module Language.PureScript.Docs.Convert
( convertModule
) where
import Protolude hiding (check)
import Control.Category ((>>>))
import Control.Monad.Writer.Strict (runWriterT)
import Control.Monad.Supply (evalSupplyT)
import Data.Functor (($>))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.String (String)
import Language.PureScript.Docs.Convert.Single (convertSingleModule)
import Language.PureScript.Docs.Types
import qualified Language.PureScript.CST as CST
import qualified Language.PureScript.AST as P
import qualified Language.PureScript.Crash as P
import qualified Language.PureScript.Errors as P
import qualified Language.PureScript.Externs as P
import qualified Language.PureScript.Environment as P
import qualified Language.PureScript.Names as P
import qualified Language.PureScript.Sugar as P
import qualified Language.PureScript.Types as P
convertModule ::
MonadError P.MultipleErrors m =>
[P.ExternsFile] ->
P.Environment ->
P.Module ->
m Module
convertModule externs checkEnv m =
partiallyDesugar externs [m] >>= \case
[m'] -> pure (insertValueTypes checkEnv (convertSingleModule m'))
_ -> P.internalError "partiallyDesugar did not return a singleton"
insertValueTypes ::
P.Environment -> Module -> Module
insertValueTypes env m =
m { modDeclarations = map go (modDeclarations m) }
where
go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} }) =
let
ident = P.Ident . CST.getIdent . CST.nameValue . parseIdent $ declTitle d
ty = lookupName ident
in
d { declInfo = ValueDeclaration (ty $> ()) }
go other =
other
parseIdent =
either (err . ("failed to parse Ident: " ++)) identity . runParser CST.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 :: CST.Parser a -> Text -> Either String a
runParser p =
first (CST.prettyPrintError . NE.head)
. CST.runTokenParser p
. CST.lex
partiallyDesugar ::
(MonadError P.MultipleErrors m) =>
[P.ExternsFile] ->
[P.Module] ->
m [P.Module]
partiallyDesugar externs = evalSupplyT 0 . desugar'
where
desugar' =
traverse P.desugarDoModule
>=> traverse P.desugarAdoModule
>=> map P.desugarLetPatternModule
>>> traverse P.desugarCasesModule
>=> traverse P.desugarTypeDeclarationsModule
>=> ignoreWarnings . P.desugarImports externs
>=> P.rebracketFiltered isInstanceDecl externs
ignoreWarnings = fmap fst . runWriterT
isInstanceDecl (P.TypeInstanceDeclaration {}) = True
isInstanceDecl _ = False