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
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) The University of Glasgow 2001-2002
-- (c) Simon Marlow 2002
--
module HaddockUtil (
-- * Misc utilities
nameOfQName, collectNames, declBinders, declMainBinder, splitTyConApp,
restrictTo,
-- * Filename utilities
basename, dirname, splitFilename3,
isPathSeparator, pathSeparator,
-- * Miscellaneous utilities
die, dieMsg, mapSnd, mapMaybeM
) where
import HsSyn
import List ( intersect )
import IO ( hPutStr, stderr )
import System
-- -----------------------------------------------------------------------------
-- Some Utilities
nameOfQName (Qual _ n) = n
nameOfQName (UnQual n) = n
collectNames :: [HsDecl] -> [HsName]
collectNames ds = concat (map declBinders ds)
declMainBinder :: HsDecl -> Maybe HsName
declMainBinder d =
case d of
HsTypeDecl _ n _ _ -> Just n
HsDataDecl _ _ n _ cons _ -> Just n
HsNewTypeDecl _ _ n _ _ _ -> Just n
HsClassDecl _ qt decls -> Just (exQtNm qt)
HsTypeSig _ [n] _ -> Just n
HsTypeSig _ ns _ -> error "declMainBinder"
HsForeignImport _ _ _ _ n _ -> Just n
_ -> Nothing
declBinders :: HsDecl -> [HsName]
declBinders d =
case d of
HsTypeDecl _ n _ _ -> [n]
HsDataDecl _ _ n _ cons _ -> n : concat (map conDeclBinders cons)
HsNewTypeDecl _ _ n _ _ _ -> [n]
HsClassDecl _ qt decls -> exQtNm qt : collectNames decls
HsTypeSig _ ns _ -> ns
HsForeignImport _ _ _ _ n _ -> [n]
_ -> []
conDeclBinders (HsConDecl _ n _ _) = [n]
conDeclBinders (HsRecDecl _ n fields _) = n : concat (map fieldDeclBinders fields)
fieldDeclBinders (HsFieldDecl ns _ _) = ns
exQtNm (HsForAllType _ _ t) = nameOfQName (fst (splitTyConApp t))
exQtNm t = nameOfQName (fst (splitTyConApp t))
splitTyConApp :: HsType -> (HsQName,[HsType])
splitTyConApp t = split t []
where
split :: HsType -> [HsType] -> (HsQName,[HsType])
split (HsTyApp t u) ts = split t (u:ts)
split (HsTyCon t) ts = (t,ts)
split _ _ = error "splitTyConApp"
-- ---------------------------------------------------------------------------
-- Making abstract declarations
restrictTo :: [HsName] -> HsDecl -> HsDecl
restrictTo names decl = case decl of
HsDataDecl loc ctxt n xs cons drv ->
HsDataDecl loc ctxt n xs (restrictCons names cons) drv
HsNewTypeDecl loc ctxt n xs con drv ->
HsDataDecl loc ctxt n xs (restrictCons names [con]) drv
HsClassDecl loc qt decls ->
HsClassDecl loc qt (restrictDecls names decls)
_ -> decl
restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl]
restrictCons names decls = filter keep decls
where keep (HsConDecl _ n _ _) = n `elem` names
keep (HsRecDecl _ n _ _) = n `elem` names
-- ToDo: records not right
restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl]
restrictDecls names decls = filter keep decls
where keep d = not (null (declBinders d `intersect` names))
-- ToDo: not really correct
-- -----------------------------------------------------------------------------
-- Filename mangling functions stolen from GHC's main/DriverUtil.lhs.
type Suffix = String
splitFilename :: String -> (String,Suffix)
splitFilename f = split_longest_prefix f (=='.')
basename :: String -> String
basename f = base where (_dir, base, _suff) = splitFilename3 f
dirname :: String -> String
dirname f = dir where (dir, _base, _suff) = splitFilename3 f
-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
splitFilename3 :: String -> (String,String,Suffix)
splitFilename3 str
= let (dir, rest) = split_longest_prefix str isPathSeparator
(name, ext) = splitFilename rest
real_dir | null dir = "."
| otherwise = dir
in (real_dir, name, ext)
split_longest_prefix :: String -> (Char -> Bool) -> (String,String)
split_longest_prefix s pred
= case pre of
[] -> ([], reverse suf)
(_:pre) -> (reverse pre, reverse suf)
where (suf,pre) = break pred (reverse s)
pathSeparator :: Char
#ifdef __WIN32__
pathSeparator = '\\'
#else
pathSeparator = '/'
#endif
isPathSeparator :: Char -> Bool
isPathSeparator ch =
#ifdef mingw32_TARGET_OS
ch == '/' || ch == '\\'
#else
ch == '/'
#endif
-----------------------------------------------------------------------------
-- misc.
die :: String -> IO a
die s = hPutStr stderr s >> exitWith (ExitFailure 1)
dieMsg :: String -> IO a
dieMsg s = getProgName >>= \prog -> die (prog ++ ": " ++ s)
mapSnd f [] = []
mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs
mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
mapMaybeM f Nothing = return Nothing
mapMaybeM f (Just a) = f a >>= return . Just
|
