blob: 30501a1301dc665d4ab768c69754d46add0d54bd (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Haddock.Backends.Xhtml.Specialize
( specialize, specialize'
, specializeTyVarBndrs
, sugar
) where
import Haddock.Syb
import GHC
import Name
import Data.Data
specialize :: (Eq name, Typeable name)
=> Data a
=> name -> HsType name -> a -> a
specialize name details = everywhere (mkT $ specializeStep name details)
specialize' :: (Eq name, Typeable name)
=> Data a
=> [(name, HsType name)] -> a -> a
specialize' = flip $ foldr (uncurry specialize)
specializeStep :: Eq name => name -> HsType name -> HsType name -> HsType name
specializeStep name details (HsTyVar name') | name == name' = details
specializeStep _ _ typ = typ
specializeTyVarBndrs :: (Eq name, Typeable name, DataId name)
=> LHsTyVarBndrs name -> [HsType name]
-> HsType name -> HsType name
specializeTyVarBndrs bndrs typs =
specialize' $ zip bndrs' typs
where
bndrs' = map (bname . unLoc) . hsq_tvs $ bndrs
bname (UserTyVar name) = name
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)
sugarListsStep :: NamedThing name => HsType name -> HsType name
sugarListsStep (HsAppTy (L _ (HsTyVar name)) ltyp)
| isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
where
name' = getName name
strName = occNameString . nameOccName $ name'
sugarListsStep typ = typ
sugarTuples :: HsType name -> HsType name
sugarTuples = id
|
