@@ -16,12 +16,17 @@ module Language.PureScript.Docs.Convert
1616import Prelude ()
1717import Prelude.Compat
1818
19−import Control.Monad.Error.Class (MonadError)
20−import Control.Arrow ((&&&))
19+import Control.Arrow ((&&&), second)
2120import Control.Category ((>>>))
21+import Control.Monad
22+import Control.Monad.State (runStateT)
23+import Control.Monad.Writer.Strict (runWriterT)
24+import Control.Monad.Error.Class (MonadError)
2225import qualified Data.Map as Map
2326
27+import Text.Parsec (eof)
2428import qualified Language.PureScript as P
29+import qualified Language.PureScript.Constants as C
2530
2631import Language.PureScript.Docs.Types
2732import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)
@@ -33,18 +38,17 @@ import Language.PureScript.Docs.Convert.ReExports (updateReExports)
3338-- documentation.
3439--
3540convertModulesInPackage ::
36− (Functor m, MonadError P.MultipleErrors m) =>
37− P.Env ->
41+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
3842 [InPackage P.Module] ->
3943 m [Module]
40−convertModulesInPackage env modules =
44+convertModulesInPackage modules =
4145 go modules
4246 where
4347 localNames =
44− map (P.runModuleName . P.getModuleName) (takeLocals modules)
48+ map P.getModuleName (takeLocals modules)
4549 go =
4650 map ignorePackage
47− >>> convertModules env
51+ >>> convertModules
4852 >>> fmap (filter ((`elem` localNames) . modName))
4953
5054-- |
@@ -53,35 +57,140 @@ convertModulesInPackage env modules =
5357-- imports/exports information about the list of modules, which is needed for
5458-- documenting re-exports.
5559--
56−-- Preconditions:
60+-- Note that the whole module dependency graph must be included in the list; if
61+-- some modules import things from other modules, then those modules must also
62+-- be included.
5763--
58−-- * If any module in the list re-exports documentation from other
59−-- modules, those modules must also be included in the list.
60−-- * The modules passed must have had names desugared and re-exports
61−-- elaborated first.
62−--
63−-- If either of these are not satisfied, an internal error will be thrown. To
64−-- avoid this, it is recommended to use
65−-- Language.PureScript.Docs.ParseAndDesugar to construct the inputs to this
66−-- function.
64+-- For value declarations, if explicit type signatures are omitted, or a
65+-- wildcard type is used, then we typecheck the modules and use the inferred
66+-- types.
6767--
6868convertModules ::
69− (Functor m, MonadError P.MultipleErrors m) =>
70− P.Env ->
69+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
7170 [P.Module] ->
7271 m [Module]
73−convertModules env =
74− P.sortModules >>> fmap (convertSorted env . fst)
72+convertModules =
73+ P.sortModules
74+ >>> fmap (fst >>> map importPrim)
75+ >=> convertSorted
76+
77+importPrim :: P.Module -> P.Module
78+importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
7579
7680-- |
7781-- Convert a sorted list of modules.
7882--
79−convertSorted :: P.Env -> [P.Module] -> [Module]
80−convertSorted env modules =
81− let
82− traversalOrder =
83− map P.getModuleName modules
84− moduleMap =
85− Map.fromList $ map (P.getModuleName &&& convertSingleModule) modules
86− in
87− Map.elems (updateReExports env traversalOrder moduleMap)
83+convertSorted ::
84+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
85+ [P.Module] ->
86+ m [Module]
87+convertSorted modules = do
88+ (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules
89+
90+ modulesWithTypes <- typeCheckIfNecessary modules convertedModules
91+ let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)
92+
93+ let traversalOrder = map P.getModuleName modules
94+ pure (Map.elems (updateReExports env traversalOrder moduleMap))
95+
96+-- |
97+-- If any exported value declarations have either wildcard type signatures, or
98+-- none at all, then typecheck in order to fill them in with the inferred
99+-- types.
100+--
101+typeCheckIfNecessary ::
102+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
103+ [P.Module] ->
104+ [Module] ->
105+ m [Module]
106+typeCheckIfNecessary modules convertedModules =
107+ if any hasWildcards convertedModules
108+ then go
109+ else pure convertedModules
110+
111+ where
112+ hasWildcards =
113+ any ((==) (ValueDeclaration P.TypeWildcard) . declInfo) . modDeclarations
114+
115+ go = do
116+ checkEnv <- snd <$> typeCheck modules
117+ pure (map (insertValueTypes checkEnv) convertedModules)
118+
119+-- |
120+-- Typechecks all the modules together. Also returns the final 'P.Environment',
121+-- which is useful for adding in inferred types where explicit declarations
122+-- were not provided.
123+--
124+typeCheck ::
125+ (Functor m, MonadError P.MultipleErrors m) =>
126+ [P.Module] ->
127+ m ([P.Module], P.Environment)
128+typeCheck =
129+ (P.desugar [] >=> check)
130+ >>> fmap (second P.checkEnv)
131+ >>> P.evalSupplyT 0
132+ >>> ignoreWarnings
133+
134+ where
135+ check ms =
136+ runStateT
137+ (traverse P.typeCheckModule ms)
138+ (P.emptyCheckState P.initEnvironment)
139+
140+ ignoreWarnings =
141+ fmap fst . runWriterT
142+
143+-- |
144+-- Updates all the types of the ValueDeclarations inside the module based on
145+-- their types inside the given Environment.
146+--
147+insertValueTypes ::
148+ P.Environment -> Module -> Module
149+insertValueTypes env m =
150+ m { modDeclarations = map go (modDeclarations m) }
151+ where
152+ go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard }) =
153+ let
154+ ident = parseIdent (declTitle d)
155+ ty = lookupName ident
156+ in
157+ d { declInfo = ValueDeclaration ty }
158+ go other =
159+ other
160+
161+ parseIdent =
162+ either (err . ("failed to parse Ident: " ++)) id . runParser P.parseIdent
163+
164+ lookupName name =
165+ let key = (modName m, name)
166+ in case Map.lookup key (P.names env) of
167+ Just (ty, _, _) ->
168+ ty
169+ Nothing ->
170+ err ("name not found: " ++ show key)
171+
172+ err msg =
173+ P.internalError ("Docs.Convert.insertValueTypes: " ++ msg)
174+
175+runParser :: P.TokenParser a -> String -> Either String a
176+runParser p s = either (Left . show) Right $ do
177+ ts <- P.lex "" s
178+ P.runTokenParser "" (p <* eof) ts
179+
180+-- |
181+-- Partially desugar modules so that they are suitable for extracting
182+-- documentation information from.
183+--
184+partiallyDesugar ::
185+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>
186+ [P.Module]
187+ -> m (P.Env, [P.Module])
188+partiallyDesugar = P.evalSupplyT 0 . desugar'
189+ where
190+ desugar' =
191+ traverse P.desugarDoModule
192+ >=> P.desugarCasesModule
193+ >=> P.desugarTypeDeclarationsModule
194+ >=> ignoreWarnings . P.desugarImportsWithEnv []
195+
196+ ignoreWarnings = fmap fst . runWriterT