forked from purescript/purescript
-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathConvert.hs
More file actions
215 lines (186 loc) · 6.14 KB
/
Convert.hs
File metadata and controls
215 lines (186 loc) · 6.14 KB
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
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
-- | Functions for converting PureScript ASTs into values of the data types
-- from Language.PureScript.Docs.
module Language.PureScript.Docs.Convert
( convertModules
, convertModulesWithEnv
, convertModulesInPackage
, convertModulesInPackageWithEnv
) where
import Protolude hiding (check)
import Control.Arrow ((&&&))
import Control.Category ((>>>))
import Control.Monad.Writer.Strict (runWriterT)
import qualified Data.Map as Map
import Data.String (String)
import Language.PureScript.Docs.Convert.ReExports (updateReExports)
import Language.PureScript.Docs.Convert.Single (convertSingleModule)
import Language.PureScript.Docs.Types
import qualified Language.PureScript as P
import qualified Language.PureScript.Constants as C
import Web.Bower.PackageMeta (PackageName)
import Text.Parsec (eof)
-- |
-- Like convertModules, except that it takes a list of modules, together with
-- their dependency status, and discards dependency modules in the resulting
-- documentation.
--
convertModulesInPackage ::
(MonadError P.MultipleErrors m) =>
[P.Module] ->
Map P.ModuleName PackageName ->
m [Module]
convertModulesInPackage modules modulesDeps =
fmap fst (convertModulesInPackageWithEnv modules modulesDeps)
convertModulesInPackageWithEnv ::
(MonadError P.MultipleErrors m) =>
[P.Module] ->
Map P.ModuleName PackageName ->
m ([Module], P.Env)
convertModulesInPackageWithEnv modules modulesDeps =
go modules
where
go =
convertModulesWithEnv withPackage
>>> fmap (first (filter (isLocal . modName)))
withPackage :: P.ModuleName -> InPackage P.ModuleName
withPackage mn =
case Map.lookup mn modulesDeps of
Just pkgName -> FromDep pkgName mn
Nothing -> Local mn
isLocal :: P.ModuleName -> Bool
isLocal = not . flip Map.member modulesDeps
-- |
-- Convert a group of modules to the intermediate format, designed for
-- producing documentation from.
--
-- Note that the whole module dependency graph must be included in the list; if
-- some modules import things from other modules, then those modules must also
-- be included.
--
-- For value declarations, if explicit type signatures are omitted, or a
-- wildcard type is used, then we typecheck the modules and use the inferred
-- types.
--
convertModules ::
(MonadError P.MultipleErrors m) =>
(P.ModuleName -> InPackage P.ModuleName) ->
[P.Module] ->
m [Module]
convertModules withPackage =
fmap fst . convertModulesWithEnv withPackage
convertModulesWithEnv ::
(MonadError P.MultipleErrors m) =>
(P.ModuleName -> InPackage P.ModuleName) ->
[P.Module] ->
m ([Module], P.Env)
convertModulesWithEnv withPackage =
P.sortModules
>>> fmap (fst >>> map importPrim)
>=> convertSorted withPackage
importPrim :: P.Module -> P.Module
importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
-- |
-- Convert a sorted list of modules, returning both the list of converted
-- modules and the Env produced during desugaring.
--
convertSorted ::
(MonadError P.MultipleErrors m) =>
(P.ModuleName -> InPackage P.ModuleName) ->
[P.Module] ->
m ([Module], P.Env)
convertSorted withPackage modules = do
(env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules
modulesWithTypes <- typeCheckIfNecessary modules convertedModules
let moduleMap = Map.fromList (map (modName &&& identity) modulesWithTypes)
let traversalOrder = map P.getModuleName modules
pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap), env)
-- |
-- If any exported value declarations have either wildcard type signatures, or
-- none at all, then typecheck in order to fill them in with the inferred
-- types.
--
typeCheckIfNecessary ::
(MonadError P.MultipleErrors m) =>
[P.Module] ->
[Module] ->
m [Module]
typeCheckIfNecessary modules convertedModules =
if any hasWildcards convertedModules
then go
else pure convertedModules
where
hasWildcards = any (isWild . declInfo) . modDeclarations
isWild (ValueDeclaration P.TypeWildcard{}) = True
isWild _ = False
go = do
checkEnv <- snd <$> typeCheck modules
pure (map (insertValueTypes checkEnv) convertedModules)
-- |
-- Typechecks all the modules together. Also returns the final 'P.Environment',
-- which is useful for adding in inferred types where explicit declarations
-- were not provided.
--
typeCheck ::
(MonadError P.MultipleErrors m) =>
[P.Module] ->
m ([P.Module], P.Environment)
typeCheck =
(P.desugar [] >=> check)
>>> fmap (second P.checkEnv)
>>> P.evalSupplyT 0
>>> ignoreWarnings
where
check ms =
runStateT
(traverse P.typeCheckModule ms)
(P.emptyCheckState P.initEnvironment)
ignoreWarnings =
fmap fst . runWriterT
-- |
-- Updates all the types of the ValueDeclarations inside the module based on
-- their types inside the given Environment.
--
insertValueTypes ::
P.Environment -> Module -> Module
insertValueTypes env m =
m { modDeclarations = map go (modDeclarations m) }
where
go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} }) =
let
ident = parseIdent (declTitle d)
ty = lookupName ident
in
d { declInfo = ValueDeclaration ty }
go other =
other
parseIdent =
either (err . ("failed to parse Ident: " ++)) identity . runParser P.parseIdent
lookupName name =
let key = P.Qualified (Just (modName m)) name
in case Map.lookup key (P.names env) of
Just (ty, _, _) ->
ty
Nothing ->
err ("name not found: " ++ show key)
err msg =
P.internalError ("Docs.Convert.insertValueTypes: " ++ msg)
runParser :: P.TokenParser a -> Text -> Either String a
runParser p s = either (Left . show) Right $ do
ts <- P.lex "" s
P.runTokenParser "" (p <* eof) ts
-- |
-- Partially desugar modules so that they are suitable for extracting
-- documentation information from.
--
partiallyDesugar ::
(MonadError P.MultipleErrors m) =>
[P.Module]
-> m (P.Env, [P.Module])
partiallyDesugar = P.evalSupplyT 0 . desugar'
where
desugar' =
traverse P.desugarDoModule
>=> traverse P.desugarCasesModule
>=> traverse P.desugarTypeDeclarationsModule
>=> ignoreWarnings . P.desugarImportsWithEnv []
ignoreWarnings = fmap fst . runWriterT