module Language.PureScript.Docs.Convert
( convertModules
, convertModulesInPackage
, collectBookmarks
) where
import Prelude.Compat
import Control.Arrow ((&&&), second)
import Control.Category ((>>>))
import Control.Monad
import Control.Monad.Error.Class (MonadError)
import Control.Monad.State (runStateT)
import Control.Monad.Writer.Strict (runWriterT)
import Data.List (find)
import qualified Data.Map as Map
import Data.Text (Text)
import Language.PureScript.Docs.Convert.ReExports (updateReExports)
import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)
import Language.PureScript.Docs.Types
import qualified Language.PureScript as P
import qualified Language.PureScript.Constants as C
import Text.Parsec (eof)
convertModulesInPackage ::
(MonadError P.MultipleErrors m) =>
[InPackage P.Module] ->
m [Module]
convertModulesInPackage modules =
go modules
where
localNames =
map P.getModuleName (takeLocals modules)
go =
map ignorePackage
>>> convertModules withPackage
>>> fmap (filter ((`elem` localNames) . modName))
withPackage :: P.ModuleName -> InPackage P.ModuleName
withPackage mn =
case find ((== mn) . P.getModuleName . ignorePackage) modules of
Just m ->
fmap P.getModuleName m
Nothing ->
P.internalError $ "withPackage: missing module:" ++
show (P.runModuleName mn)
convertModules ::
(MonadError P.MultipleErrors m) =>
(P.ModuleName -> InPackage P.ModuleName) ->
[P.Module] ->
m [Module]
convertModules withPackage =
P.sortModules
>>> fmap (fst >>> map importPrim)
>=> convertSorted withPackage
importPrim :: P.Module -> P.Module
importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
convertSorted ::
(MonadError P.MultipleErrors m) =>
(P.ModuleName -> InPackage P.ModuleName) ->
[P.Module] ->
m [Module]
convertSorted withPackage modules = do
(env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules
modulesWithTypes <- typeCheckIfNecessary modules convertedModules
let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes)
let traversalOrder = map P.getModuleName modules
pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap))
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)
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
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: " ++)) id . 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
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