-- | Functions for converting PureScript ASTs into values of the data types
-- from Language.PureScript.Docs.

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 qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.String (String)
import qualified Data.Text as T

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.Roles as P
import qualified Language.PureScript.Sugar as P
import qualified Language.PureScript.Types as P
import qualified Language.PureScript.Constants.Prim as Prim
import Language.PureScript.Sugar (RebracketCaller(CalledByDocs))

-- |
-- Convert a single module to a Docs.Module, making use of a pre-existing
-- type-checking environment in order to fill in any missing types. Note that
-- re-exports will not be included.
--
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

-- |
-- Convert FFI declarations into `DataDeclaration` so that the declaration's
-- roles (if any) can annotate the generated type parameter names.
--
-- Inserts all data declarations inferred roles if none were specified
-- explicitly.
--
-- Updates all the types of the ValueDeclarations inside the module based on
-- their types inside the given Environment.
--
-- Removes explicit kind signatures if they are "uninteresting."
--
-- Inserts inferred kind signatures into the corresponding declarations
-- if no kind signature was declared explicitly and the kind
-- signature is "interesting."
--
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
  -- |
  -- Convert FFI declarations into data declaration
  -- by generating the type parameters' names based on its kind signature.
  -- Note: `Prim` modules' docs don't go through this conversion process
  -- so `ExternDataDeclaration` values will still exist beyond this point.
  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

  -- |
  -- Given an FFI declaration like this
  -- ```
  -- foreign import data Foo
  --    :: forall a b c d
  --     . MyKind a b
  --    -> OtherKind c d
  --    -> Symbol
  --    -> (Type -> Type)
  --    -> (Type) -- unneeded parens a developer typo
  --    -> Type
  -- ```
  -- Return a list of values, one for each implicit type parameter
  -- of `(tX, Nothing)` where `X` refers to the index of he parameter
  -- in that list, matching the values expected by `Render.toTypeVar`
  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

  -- insert value types
  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 ->
        -- hide explicit kind signatures that are "uninteresting"
        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 ->
        -- insert inferred kinds so long as they are "interesting"
        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)

  -- |
  -- Extracts the keyword for a declaration (if there is one)
  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

  -- |
  -- Returns True if the kind signature is "uninteresting", which
  -- is a kind that follows this form:
  -- - `Type`
  -- - `Constraint` (class declaration only)
  -- - `Type -> K` where `K` is an "uninteresting" kind
  isUninteresting
    :: P.KindSignatureFor -> Type' -> Bool
  isUninteresting :: KindSignatureFor -> Type' -> Bool
isUninteresting KindSignatureFor
keyword = \case
    -- `Type -> ...`
    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
$> ()

          -- Note: the below change to the final kind used is intentionally
          -- NOT being done for explicit kind signatures:
          --
          -- changes `forall (k :: Type). k -> ...`
          -- to      `forall k          . k -> ...`
          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

-- |
-- Partially desugar modules so that they are suitable for extracting
-- documentation information from.
--
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