diff options
| author | Ćukasz Hanuszczak <lukasz.hanuszczak@gmail.com> | 2015-07-15 20:31:48 +0200 | 
|---|---|---|
| committer | Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk> | 2015-08-21 18:22:30 +0100 | 
| commit | 6be6ca76e9163569ad3bed1441cb9fcfa7df0cec (patch) | |
| tree | b39d655b86cf58c652822056fffb41ba4ca43be1 /haddock-api/src/Haddock | |
| parent | 060b986c641cd496395b2d13dc316fc84462a7a4 (diff) | |
Get rid of code duplication in type specialization module.
Diffstat (limited to 'haddock-api/src/Haddock')
| -rw-r--r-- | haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs | 30 | 
1 files changed, 12 insertions, 18 deletions
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs index a2cb8799..50cce3d5 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs @@ -47,32 +47,26 @@ specializeTyVarBndrs bndrs typs =      bname (KindedTyVar (L _ name) _) = name -sugar :: (NamedThing name, DataId name) => HsType name -> HsType name -sugar = sugarTuples . sugarLists - - -sugarLists :: forall name. (NamedThing name, DataId name) -           => HsType name -> HsType name -sugarLists = everywhere $ mkT (sugarListsStep :: HsType name -> HsType name) +sugar :: forall name. (NamedThing name, DataId name) +      => HsType name -> HsType name +sugar = +    everywhere $ mkT step +  where +    step :: HsType name -> HsType name +    step = sugarTuples . sugarLists -sugarListsStep :: NamedThing name => HsType name -> HsType name -sugarListsStep (HsAppTy (L _ (HsTyVar name)) ltyp) +sugarLists :: NamedThing name => HsType name -> HsType name +sugarLists (HsAppTy (L _ (HsTyVar name)) ltyp)      | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp    where      name' = getName name      strName = occNameString . nameOccName $ name' -sugarListsStep typ = typ - - -sugarTuples :: forall name. (NamedThing name, DataId name) -            => HsType name -> HsType name -sugarTuples = everywhere $ -    mkT (sugarTuplesStep :: HsType name -> HsType name) +sugarLists typ = typ -sugarTuplesStep :: NamedThing name => HsType name -> HsType name -sugarTuplesStep typ = +sugarTuples :: NamedThing name => HsType name -> HsType name +sugarTuples typ =      aux [] typ    where      aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp  | 
