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.List.NonEmpty qualified as NE
import Data.Map qualified as Map
import Data.String (String)
import Data.Text qualified as T
import Language.PureScript.Docs.Convert.Single (convertSingleModule)
import Language.PureScript.Docs.Types (Declaration(..), DeclarationInfo(..), KindInfo(..), Module(..), Type')
import Language.PureScript.CST qualified as CST
import Language.PureScript.AST qualified as P
import Language.PureScript.Crash qualified as P
import Language.PureScript.Errors qualified as P
import Language.PureScript.Externs qualified as P
import Language.PureScript.Environment qualified as P
import Language.PureScript.Names qualified as P
import Language.PureScript.Roles qualified as P
import Language.PureScript.Sugar qualified as P
import Language.PureScript.Types qualified as P
import Language.PureScript.Constants.Prim qualified as Prim
import Language.PureScript.Sugar (RebracketCaller(CalledByDocs))
convertModule ::
MonadError P.MultipleErrors m =>
[P.ExternsFile] ->
P.Env ->
P.Environment ->
P.Module ->
m Module
convertModule :: forall (m :: * -> *).
MonadError MultipleErrors m =>
[ExternsFile] -> Env -> Environment -> Module -> m Module
convertModule [ExternsFile]
externs Env
env Environment
checkEnv =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Environment -> Module -> Module
insertValueTypesAndAdjustKinds Environment
checkEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Module
convertSingleModule) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadError MultipleErrors m =>
[ExternsFile] -> Env -> Module -> m Module
partiallyDesugar [ExternsFile]
externs Env
env
insertValueTypesAndAdjustKinds ::
P.Environment -> Module -> Module
insertValueTypesAndAdjustKinds :: Environment -> Module -> Module
insertValueTypesAndAdjustKinds Environment
env Module
m =
Module
m { modDeclarations :: [Declaration]
modDeclarations = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (Declaration -> Declaration
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> Declaration
insertInferredRoles forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> Declaration
convertFFIDecl) (Module -> [Declaration]
modDeclarations Module
m) }
where
convertFFIDecl :: Declaration -> Declaration
convertFFIDecl d :: Declaration
d@Declaration { declInfo :: Declaration -> DeclarationInfo
declInfo = ExternDataDeclaration Type'
kind [Role]
roles } =
Declaration
d { declInfo :: DeclarationInfo
declInfo = DataDeclType -> [(Text, Maybe Type')] -> [Role] -> DeclarationInfo
DataDeclaration DataDeclType
P.Data (Type' -> [(Text, Maybe Type')]
genTypeParams Type'
kind) [Role]
roles
, declKind :: Maybe KindInfo
declKind = forall a. a -> Maybe a
Just (KindSignatureFor -> Type' -> KindInfo
KindInfo KindSignatureFor
P.DataSig Type'
kind)
}
convertFFIDecl Declaration
other = Declaration
other
insertInferredRoles :: Declaration -> Declaration
insertInferredRoles d :: Declaration
d@Declaration { declInfo :: Declaration -> DeclarationInfo
declInfo = DataDeclaration DataDeclType
dataDeclType [(Text, Maybe Type')]
args [] } =
Declaration
d { declInfo :: DeclarationInfo
declInfo = DataDeclType -> [(Text, Maybe Type')] -> [Role] -> DeclarationInfo
DataDeclaration DataDeclType
dataDeclType [(Text, Maybe Type')]
args [Role]
inferredRoles }
where
inferredRoles :: [P.Role]
inferredRoles :: [Role]
inferredRoles = do
let key :: Qualified (ProperName 'TypeName)
key = forall a. QualifiedBy -> a -> Qualified a
P.Qualified (ModuleName -> QualifiedBy
P.ByModuleName (Module -> ModuleName
modName Module
m)) (forall (a :: ProperNameType). Text -> ProperName a
P.ProperName (Declaration -> Text
declTitle Declaration
d))
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Qualified (ProperName 'TypeName)
key (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
P.types Environment
env) of
Just (SourceType
_, TypeKind
tyKind) -> case TypeKind
tyKind of
P.DataType DataDeclType
_ [(Text, Maybe SourceType, Role)]
tySourceTyRole [(ProperName 'ConstructorName, [SourceType])]
_ ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Text
_,Maybe SourceType
_,Role
r) -> Role
r) [(Text, Maybe SourceType, Role)]
tySourceTyRole
P.ExternData [Role]
rs ->
[Role]
rs
TypeKind
_ ->
[]
Maybe (SourceType, TypeKind)
Nothing ->
forall {a}. [Char] -> a
err forall a b. (a -> b) -> a -> b
$ [Char]
"type not found: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
show Qualified (ProperName 'TypeName)
key
insertInferredRoles Declaration
other =
Declaration
other
genTypeParams :: Type' -> [(Text, Maybe Type')]
genTypeParams :: Type' -> [(Text, Maybe Type')]
genTypeParams Type'
kind = do
let n :: Int
n = Int -> Type' -> Int
countParams Int
0 Type'
kind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\(Int
i :: Int) -> (Text
"t" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a b. (Show a, StringConv [Char] b) => a -> b
show Int
i), forall a. Maybe a
Nothing)) forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
n [Int
0..]
where
countParams :: Int -> Type' -> Int
countParams :: Int -> Type' -> Int
countParams Int
acc = \case
P.ForAll ()
_ Text
_ Maybe Type'
_ Type'
rest Maybe SkolemScope
_ ->
Int -> Type' -> Int
countParams Int
acc Type'
rest
P.TypeApp ()
_ Type'
f Type'
a | Type' -> Bool
isFunctionApplication Type'
f ->
Int -> Type' -> Int
countParams (Int
acc forall a. Num a => a -> a -> a
+ Int
1) Type'
a
P.ParensInType ()
_ Type'
ty ->
Int -> Type' -> Int
countParams Int
acc Type'
ty
Type'
_ ->
Int
acc
isFunctionApplication :: Type' -> Bool
isFunctionApplication = \case
P.TypeApp ()
_ (P.TypeConstructor () Qualified (ProperName 'TypeName)
Prim.Function) Type'
_ -> Bool
True
P.ParensInType ()
_ Type'
ty -> Type' -> Bool
isFunctionApplication Type'
ty
Type'
_ -> Bool
False
go :: Declaration -> Declaration
go d :: Declaration
d@Declaration { declInfo :: Declaration -> DeclarationInfo
declInfo = ValueDeclaration P.TypeWildcard{} } =
let
ident :: Ident
ident = Text -> Ident
P.Ident forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
CST.getIdent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Name a -> a
CST.nameValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Name Ident
parseIdent forall a b. (a -> b) -> a -> b
$ Declaration -> Text
declTitle Declaration
d
ty :: SourceType
ty = Ident -> SourceType
lookupName Ident
ident
in
Declaration
d { declInfo :: DeclarationInfo
declInfo = Type' -> DeclarationInfo
ValueDeclaration (SourceType
ty forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()) }
go d :: Declaration
d@Declaration{[ChildDeclaration]
Maybe Text
Maybe SourceSpan
Maybe KindInfo
Text
DeclarationInfo
declChildren :: Declaration -> [ChildDeclaration]
declSourceSpan :: Declaration -> Maybe SourceSpan
declComments :: Declaration -> Maybe Text
declKind :: Maybe KindInfo
declInfo :: DeclarationInfo
declChildren :: [ChildDeclaration]
declSourceSpan :: Maybe SourceSpan
declComments :: Maybe Text
declTitle :: Text
declTitle :: Declaration -> Text
declKind :: Declaration -> Maybe KindInfo
declInfo :: Declaration -> DeclarationInfo
..} | Just KindSignatureFor
keyword <- DeclarationInfo -> Maybe KindSignatureFor
extractKeyword DeclarationInfo
declInfo =
case Maybe KindInfo
declKind of
Just KindInfo
ks ->
if KindSignatureFor -> Type' -> Bool
isUninteresting KindSignatureFor
keyword forall a b. (a -> b) -> a -> b
$ KindInfo -> Type'
kiKind KindInfo
ks
then Declaration
d { declKind :: Maybe KindInfo
declKind = forall a. Maybe a
Nothing }
else Declaration
d
Maybe KindInfo
Nothing ->
Declaration -> Text -> KindSignatureFor -> Declaration
insertInferredKind Declaration
d Text
declTitle KindSignatureFor
keyword
go Declaration
other =
Declaration
other
parseIdent :: Text -> Name Ident
parseIdent =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall {a}. [Char] -> a
err forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"failed to parse Ident: " forall a. [a] -> [a] -> [a]
++)) forall a. a -> a
identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Text -> Either [Char] a
runParser Parser (Name Ident)
CST.parseIdent
lookupName :: Ident -> SourceType
lookupName Ident
name =
let key :: Qualified Ident
key = forall a. QualifiedBy -> a -> Qualified a
P.Qualified (ModuleName -> QualifiedBy
P.ByModuleName (Module -> ModuleName
modName Module
m)) Ident
name
in case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Qualified Ident
key (Environment
-> Map (Qualified Ident) (SourceType, NameKind, NameVisibility)
P.names Environment
env) of
Just (SourceType
ty, NameKind
_, NameVisibility
_) ->
SourceType
ty
Maybe (SourceType, NameKind, NameVisibility)
Nothing ->
forall {a}. [Char] -> a
err ([Char]
"name not found: " forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, StringConv [Char] b) => a -> b
show Qualified Ident
key)
extractKeyword :: DeclarationInfo -> Maybe P.KindSignatureFor
extractKeyword :: DeclarationInfo -> Maybe KindSignatureFor
extractKeyword = \case
DataDeclaration DataDeclType
dataDeclType [(Text, Maybe Type')]
_ [Role]
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ case DataDeclType
dataDeclType of
DataDeclType
P.Data -> KindSignatureFor
P.DataSig
DataDeclType
P.Newtype -> KindSignatureFor
P.NewtypeSig
TypeSynonymDeclaration [(Text, Maybe Type')]
_ Type'
_ -> forall a. a -> Maybe a
Just KindSignatureFor
P.TypeSynonymSig
TypeClassDeclaration [(Text, Maybe Type')]
_ [Constraint']
_ [([Text], [Text])]
_ -> forall a. a -> Maybe a
Just KindSignatureFor
P.ClassSig
DeclarationInfo
_ -> forall a. Maybe a
Nothing
isUninteresting
:: P.KindSignatureFor -> Type' -> Bool
isUninteresting :: KindSignatureFor -> Type' -> Bool
isUninteresting KindSignatureFor
keyword = \case
P.TypeApp ()
_ Type'
f Type'
a | forall {a}. Type a -> Bool
isTypeAppFunctionType Type'
f -> KindSignatureFor -> Type' -> Bool
isUninteresting KindSignatureFor
keyword Type'
a
P.ParensInType ()
_ Type'
ty -> KindSignatureFor -> Type' -> Bool
isUninteresting KindSignatureFor
keyword Type'
ty
Type'
x -> forall {a}. Type a -> Bool
isKindPrimType Type'
x Bool -> Bool -> Bool
|| (Bool
isClassKeyword Bool -> Bool -> Bool
&& forall {a}. Type a -> Bool
isKindPrimConstraint Type'
x)
where
isClassKeyword :: Bool
isClassKeyword = case KindSignatureFor
keyword of
KindSignatureFor
P.ClassSig -> Bool
True
KindSignatureFor
_ -> Bool
False
isTypeAppFunctionType :: Type a -> Bool
isTypeAppFunctionType = \case
P.TypeApp a
_ Type a
f Type a
a -> forall {a}. Type a -> Bool
isKindFunction Type a
f Bool -> Bool -> Bool
&& forall {a}. Type a -> Bool
isKindPrimType Type a
a
P.ParensInType a
_ Type a
ty -> Type a -> Bool
isTypeAppFunctionType Type a
ty
Type a
_ -> Bool
False
isKindFunction :: Type a -> Bool
isKindFunction = forall {a}. Qualified (ProperName 'TypeName) -> Type a -> Bool
isTypeConstructor Qualified (ProperName 'TypeName)
Prim.Function
isKindPrimType :: Type a -> Bool
isKindPrimType = forall {a}. Qualified (ProperName 'TypeName) -> Type a -> Bool
isTypeConstructor Qualified (ProperName 'TypeName)
Prim.Type
isKindPrimConstraint :: Type a -> Bool
isKindPrimConstraint = forall {a}. Qualified (ProperName 'TypeName) -> Type a -> Bool
isTypeConstructor Qualified (ProperName 'TypeName)
Prim.Constraint
isTypeConstructor :: Qualified (ProperName 'TypeName) -> Type a -> Bool
isTypeConstructor Qualified (ProperName 'TypeName)
k = \case
P.TypeConstructor a
_ Qualified (ProperName 'TypeName)
k' -> Qualified (ProperName 'TypeName)
k' forall a. Eq a => a -> a -> Bool
== Qualified (ProperName 'TypeName)
k
P.ParensInType a
_ Type a
ty -> Qualified (ProperName 'TypeName) -> Type a -> Bool
isTypeConstructor Qualified (ProperName 'TypeName)
k Type a
ty
Type a
_ -> Bool
False
insertInferredKind :: Declaration -> Text -> P.KindSignatureFor -> Declaration
insertInferredKind :: Declaration -> Text -> KindSignatureFor -> Declaration
insertInferredKind Declaration
d Text
name KindSignatureFor
keyword =
let
key :: Qualified (ProperName 'TypeName)
key = forall a. QualifiedBy -> a -> Qualified a
P.Qualified (ModuleName -> QualifiedBy
P.ByModuleName (Module -> ModuleName
modName Module
m)) (forall (a :: ProperNameType). Text -> ProperName a
P.ProperName Text
name)
in case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Qualified (ProperName 'TypeName)
key (Environment
-> Map (Qualified (ProperName 'TypeName)) (SourceType, TypeKind)
P.types Environment
env) of
Just (SourceType
inferredKind, TypeKind
_) ->
if KindSignatureFor -> Type' -> Bool
isUninteresting KindSignatureFor
keyword Type'
inferredKind'
then Declaration
d
else Declaration
d { declKind :: Maybe KindInfo
declKind = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ KindInfo
{ kiKeyword :: KindSignatureFor
kiKeyword = KindSignatureFor
keyword
, kiKind :: Type'
kiKind = forall {a}. Type a -> Type a
dropTypeSortAnnotation Type'
inferredKind'
}
}
where
inferredKind' :: Type'
inferredKind' = SourceType
inferredKind forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ()
dropTypeSortAnnotation :: Type a -> Type a
dropTypeSortAnnotation = \case
P.ForAll a
sa Text
txt (Just (P.TypeConstructor a
_ Qualified (ProperName 'TypeName)
Prim.Type)) Type a
rest Maybe SkolemScope
skol ->
forall a.
a
-> Text -> Maybe (Type a) -> Type a -> Maybe SkolemScope -> Type a
P.ForAll a
sa Text
txt forall a. Maybe a
Nothing (Type a -> Type a
dropTypeSortAnnotation Type a
rest) Maybe SkolemScope
skol
Type a
rest -> Type a
rest
Maybe (SourceType, TypeKind)
Nothing ->
forall {a}. [Char] -> a
err ([Char]
"type not found: " forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, StringConv [Char] b) => a -> b
show Qualified (ProperName 'TypeName)
key)
err :: [Char] -> a
err [Char]
msg =
forall a. HasCallStack => [Char] -> a
P.internalError ([Char]
"Docs.Convert.insertValueTypes: " forall a. [a] -> [a] -> [a]
++ [Char]
msg)
runParser :: CST.Parser a -> Text -> Either String a
runParser :: forall a. Parser a -> Text -> Either [Char] a
runParser Parser a
p =
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ParserError -> [Char]
CST.prettyPrintError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head) forall a b. (a, b) -> b
snd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Parser a
-> [LexResult]
-> Either (NonEmpty ParserError) ([ParserWarning], a)
CST.runTokenParser Parser a
p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [LexResult]
CST.lex
partiallyDesugar ::
(MonadError P.MultipleErrors m) =>
[P.ExternsFile] ->
P.Env ->
P.Module ->
m P.Module
partiallyDesugar :: forall (m :: * -> *).
MonadError MultipleErrors m =>
[ExternsFile] -> Env -> Module -> m Module
partiallyDesugar [ExternsFile]
externs Env
env = forall (m :: * -> *) a. Functor m => Integer -> SupplyT m a -> m a
evalSupplyT Integer
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> SupplyT m Module
desugar'
where
desugar' :: Module -> SupplyT m Module
desugar' =
forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Module -> m Module
P.desugarDoModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Module -> m Module
P.desugarAdoModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Module -> Module
P.desugarLetPatternModule
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Module -> m Module
P.desugarCasesModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *).
MonadError MultipleErrors m =>
Module -> m Module
P.desugarTypeDeclarationsModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Env
env, forall a. Monoid a => a
mempty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadError MultipleErrors m, MonadWriter MultipleErrors m,
MonadState (Env, UsedImports) m) =>
Module -> m Module
P.desugarImports
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *).
(MonadError MultipleErrors m, MonadSupply m) =>
RebracketCaller
-> (Declaration -> Bool) -> [ExternsFile] -> Module -> m Module
P.rebracketFiltered RebracketCaller
CalledByDocs Declaration -> Bool
isInstanceDecl [ExternsFile]
externs
isInstanceDecl :: Declaration -> Bool
isInstanceDecl P.TypeInstanceDeclaration {} = Bool
True
isInstanceDecl Declaration
_ = Bool
False