aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock
diff options
context:
space:
mode:
authorƁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-07-15 20:31:48 +0200
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2015-08-21 18:22:30 +0100
commit6be6ca76e9163569ad3bed1441cb9fcfa7df0cec (patch)
treeb39d655b86cf58c652822056fffb41ba4ca43be1 /haddock-api/src/Haddock
parent060b986c641cd496395b2d13dc316fc84462a7a4 (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.hs30
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