module Language.PureScript.Docs.Convert
( convertModules
, convertModulesInPackage
, collectBookmarks
) where
import Prelude ()
import Prelude.Compat
import Control.Arrow ((&&&), second)
import Control.Category ((>>>))
import Control.Monad
import Control.Monad.State (runStateT)
import Control.Monad.Writer.Strict (runWriterT)
import Control.Monad.Error.Class (MonadError)
import qualified Data.Map as Map
import Text.Parsec (eof)
import qualified Language.PureScript as P
import qualified Language.PureScript.Constants as C
import Language.PureScript.Docs.Types
import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks)
import Language.PureScript.Docs.Convert.ReExports (updateReExports)
convertModulesInPackage ::
(Functor m, Applicative m, MonadError P.MultipleErrors m) =>
[InPackage P.Module] ->
m [Module]
convertModulesInPackage modules =
go modules
where
localNames =
map P.getModuleName (takeLocals modules)
go =
map ignorePackage
>>> convertModules
>>> fmap (filter ((`elem` localNames) . modName))
convertModules ::
(Functor m, Applicative m, MonadError P.MultipleErrors m) =>
[P.Module] ->
m [Module]
convertModules =
P.sortModules
>>> fmap (fst >>> map importPrim)
>=> convertSorted
importPrim :: P.Module -> P.Module
importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim])
convertSorted ::
(Functor m, Applicative m, MonadError P.MultipleErrors m) =>
[P.Module] ->
m [Module]
convertSorted 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 moduleMap))
typeCheckIfNecessary ::
(Functor m, Applicative m, MonadError P.MultipleErrors m) =>
[P.Module] ->
[Module] ->
m [Module]
typeCheckIfNecessary modules convertedModules =
if any hasWildcards convertedModules
then go
else pure convertedModules
where
hasWildcards =
any ((==) (ValueDeclaration P.TypeWildcard) . declInfo) . modDeclarations
go = do
checkEnv <- snd <$> typeCheck modules
pure (map (insertValueTypes checkEnv) convertedModules)
typeCheck ::
(Functor m, 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 = (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 -> String -> Either String a
runParser p s = either (Left . show) Right $ do
ts <- P.lex "" s
P.runTokenParser "" (p <* eof) ts
partiallyDesugar ::
(Functor m, Applicative m, MonadError P.MultipleErrors m) =>
[P.Module]
-> m (P.Env, [P.Module])
partiallyDesugar = P.evalSupplyT 0 . desugar'
where
desugar' =
traverse P.desugarDoModule
>=> P.desugarCasesModule
>=> P.desugarTypeDeclarationsModule
>=> ignoreWarnings . P.desugarImportsWithEnv []
ignoreWarnings = fmap fst . runWriterT