{-# language PackageImports, BlockArguments #-}

module Language.PureScript.Ide.Externs
  ( readExternFile
  , convertExterns
  ) where

import           Protolude hiding (to, from, (&))

import           Codec.CBOR.Term as Term
import           Control.Lens hiding (anyOf)
import           "monad-logger" Control.Monad.Logger
import           Data.Version (showVersion)
import qualified Data.Text as Text
import qualified Language.PureScript as P
import qualified Language.PureScript.Make.Monad as Make
import           Language.PureScript.Ide.Error (IdeError (..))
import           Language.PureScript.Ide.Types
import           Language.PureScript.Ide.Util (properNameT)

readExternFile
  :: (MonadIO m, MonadError IdeError m, MonadLogger m)
  => FilePath
  -> m P.ExternsFile
readExternFile :: forall (m :: * -> *).
(MonadIO m, MonadError IdeError m, MonadLogger m) =>
FilePath -> m ExternsFile
readExternFile FilePath
fp = do
  Maybe ExternsFile
externsFile <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Serialise a => FilePath -> IO (Maybe a)
Make.readCborFileIO FilePath
fp)
  case Maybe ExternsFile
externsFile of
    Just ExternsFile
externs | Text
version forall a. Eq a => a -> a -> Bool
== ExternsFile -> Text
P.efVersion ExternsFile
externs ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ExternsFile
externs
    Maybe ExternsFile
_ ->
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Serialise a => FilePath -> IO (Maybe a)
Make.readCborFileIO FilePath
fp) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (Term.TList (Term
_tag : Term.TString Text
efVersion : [Term]
_rest)) -> do
          let errMsg :: Text
errMsg =
                Text
"Version mismatch for the externs at: "
                forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS FilePath
fp
                forall a. Semigroup a => a -> a -> a
<> Text
" Expected: " forall a. Semigroup a => a -> a -> a
<> Text
version
                forall a. Semigroup a => a -> a -> a
<> Text
" Found: " forall a. Semigroup a => a -> a -> a
<> Text
efVersion
          forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN Text
errMsg
          forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> IdeError
GeneralError Text
errMsg)
        Maybe Term
_ ->
          forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> IdeError
GeneralError (Text
"Parsing the extern at: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS FilePath
fp forall a. Semigroup a => a -> a -> a
<> Text
" failed"))
    where
      version :: Text
version = forall a b. ConvertText a b => a -> b
toS (Version -> FilePath
showVersion Version
P.version)

convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.DeclarationRef)])
convertExterns :: ExternsFile
-> ([IdeDeclarationAnn], [(ModuleName, DeclarationRef)])
convertExterns ExternsFile
ef =
  ([IdeDeclarationAnn]
decls, [(ModuleName, DeclarationRef)]
exportDecls)
  where
    decls :: [IdeDeclarationAnn]
decls = IdeDeclarationAnn
moduleDecl forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map
      (Annotation -> IdeDeclaration -> IdeDeclarationAnn
IdeDeclarationAnn Annotation
emptyAnn)
      ([IdeDeclaration]
resolvedDeclarations forall a. Semigroup a => a -> a -> a
<> [IdeDeclaration]
operatorDecls forall a. Semigroup a => a -> a -> a
<> [IdeDeclaration]
tyOperatorDecls)
    exportDecls :: [(ModuleName, DeclarationRef)]
exportDecls = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DeclarationRef -> Maybe (ModuleName, DeclarationRef)
convertExport (ExternsFile -> [DeclarationRef]
P.efExports ExternsFile
ef)
    operatorDecls :: [IdeDeclaration]
operatorDecls = ExternsFixity -> IdeDeclaration
convertOperator forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExternsFile -> [ExternsFixity]
P.efFixities ExternsFile
ef
    tyOperatorDecls :: [IdeDeclaration]
tyOperatorDecls = ExternsTypeFixity -> IdeDeclaration
convertTypeOperator forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExternsFile -> [ExternsTypeFixity]
P.efTypeFixities ExternsFile
ef
    moduleDecl :: IdeDeclarationAnn
moduleDecl = Annotation -> IdeDeclaration -> IdeDeclarationAnn
IdeDeclarationAnn Annotation
emptyAnn (ModuleName -> IdeDeclaration
IdeDeclModule (ExternsFile -> ModuleName
P.efModuleName ExternsFile
ef))
    ([ToResolve]
toResolve, [IdeDeclaration]
declarations) =
      forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. [Maybe a] -> [a]
catMaybes (forall a b. [Either a b] -> ([a], [b])
partitionEithers (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ExternsDeclaration -> Either ToResolve (Maybe IdeDeclaration)
convertDecl (ExternsFile -> [ExternsDeclaration]
P.efDeclarations ExternsFile
ef)))
    resolvedDeclarations :: [IdeDeclaration]
resolvedDeclarations = [ToResolve] -> [IdeDeclaration] -> [IdeDeclaration]
resolveSynonymsAndClasses [ToResolve]
toResolve [IdeDeclaration]
declarations

resolveSynonymsAndClasses
  :: [ToResolve]
  -> [IdeDeclaration]
  -> [IdeDeclaration]
resolveSynonymsAndClasses :: [ToResolve] -> [IdeDeclaration] -> [IdeDeclaration]
resolveSynonymsAndClasses [ToResolve]
trs [IdeDeclaration]
decls = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ToResolve -> [IdeDeclaration] -> [IdeDeclaration]
go [IdeDeclaration]
decls [ToResolve]
trs
  where
    go :: ToResolve -> [IdeDeclaration] -> [IdeDeclaration]
go ToResolve
tr [IdeDeclaration]
acc = case ToResolve
tr of
      TypeClassToResolve ProperName 'ClassName
tcn ->
        case ProperName 'TypeName -> [IdeDeclaration] -> Maybe IdeType
findType (forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
P.coerceProperName ProperName 'ClassName
tcn) [IdeDeclaration]
acc of
          Maybe IdeType
Nothing ->
            [IdeDeclaration]
acc
          Just IdeType
tyDecl -> IdeTypeClass -> IdeDeclaration
IdeDeclTypeClass
            (ProperName 'ClassName
-> SourceType -> [IdeInstance] -> IdeTypeClass
IdeTypeClass ProperName 'ClassName
tcn (IdeType
tyDeclforall s a. s -> Getting a s a -> a
^.Lens' IdeType SourceType
ideTypeKind) [])
            forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf (Traversal' IdeDeclaration IdeType
_IdeDeclType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IdeType (ProperName 'TypeName)
ideTypeName) (forall a. Eq a => a -> a -> Bool
== forall (a :: ProperNameType) (b :: ProperNameType).
ProperName a -> ProperName b
P.coerceProperName ProperName 'ClassName
tcn)) [IdeDeclaration]
acc
      SynonymToResolve ProperName 'TypeName
tn SourceType
ty ->
        case ProperName 'TypeName -> [IdeDeclaration] -> Maybe IdeType
findType ProperName 'TypeName
tn [IdeDeclaration]
acc of
          Maybe IdeType
Nothing ->
            [IdeDeclaration]
acc
          Just IdeType
tyDecl ->
            IdeTypeSynonym -> IdeDeclaration
IdeDeclTypeSynonym (ProperName 'TypeName -> SourceType -> SourceType -> IdeTypeSynonym
IdeTypeSynonym ProperName 'TypeName
tn SourceType
ty (IdeType
tyDeclforall s a. s -> Getting a s a -> a
^.Lens' IdeType SourceType
ideTypeKind))
            forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. Getting Any s a -> (a -> Bool) -> s -> Bool
anyOf (Traversal' IdeDeclaration IdeType
_IdeDeclType forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' IdeType (ProperName 'TypeName)
ideTypeName) (forall a. Eq a => a -> a -> Bool
== ProperName 'TypeName
tn)) [IdeDeclaration]
acc

findType :: P.ProperName 'P.TypeName -> [IdeDeclaration] -> Maybe IdeType
findType :: ProperName 'TypeName -> [IdeDeclaration] -> Maybe IdeType
findType ProperName 'TypeName
tn [IdeDeclaration]
decls =
  [IdeDeclaration]
decls
    forall a b. a -> (a -> b) -> b
& forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Traversal' IdeDeclaration IdeType
_IdeDeclType)
    forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
(==) ProperName 'TypeName
tn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' IdeType (ProperName 'TypeName)
ideTypeName)

-- The Externs format splits information about synonyms across EDType
-- and EDTypeSynonym declarations. For type classes it split them
-- across an EDType and an EDClass . We collect these and resolve them
-- at the end of the conversion process.
data ToResolve
  = TypeClassToResolve (P.ProperName 'P.ClassName)
  | SynonymToResolve (P.ProperName 'P.TypeName) P.SourceType

convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef)
convertExport :: DeclarationRef -> Maybe (ModuleName, DeclarationRef)
convertExport (P.ReExportRef SourceSpan
_ ExportSource
src DeclarationRef
r) = forall a. a -> Maybe a
Just (ExportSource -> ModuleName
P.exportSourceDefinedIn ExportSource
src, DeclarationRef
r)
convertExport DeclarationRef
_ = forall a. Maybe a
Nothing

convertDecl :: P.ExternsDeclaration -> Either ToResolve (Maybe IdeDeclaration)
convertDecl :: ExternsDeclaration -> Either ToResolve (Maybe IdeDeclaration)
convertDecl ExternsDeclaration
ed = case ExternsDeclaration
ed of
  -- We need to filter all types and synonyms that contain a '$'
  -- because those are typechecker internal definitions that shouldn't
  -- be user facing
  P.EDType{ProperName 'TypeName
SourceType
TypeKind
edTypeDeclarationKind :: ExternsDeclaration -> TypeKind
edTypeKind :: ExternsDeclaration -> SourceType
edTypeName :: ExternsDeclaration -> ProperName 'TypeName
edTypeDeclarationKind :: TypeKind
edTypeKind :: SourceType
edTypeName :: ProperName 'TypeName
..} -> forall a b. b -> Either a b
Right do
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Maybe a -> Bool
isNothing ((Char -> Bool) -> Text -> Maybe Char
Text.find (forall a. Eq a => a -> a -> Bool
== Char
'$') (ProperName 'TypeName
edTypeNameforall s a. s -> Getting a s a -> a
^.forall r (a :: ProperNameType). Getting r (ProperName a) Text
properNameT)))
    forall a. a -> Maybe a
Just (IdeType -> IdeDeclaration
IdeDeclType (ProperName 'TypeName
-> SourceType
-> [(ProperName 'ConstructorName, SourceType)]
-> IdeType
IdeType ProperName 'TypeName
edTypeName SourceType
edTypeKind []))
  P.EDTypeSynonym{[(Text, Maybe SourceType)]
ProperName 'TypeName
SourceType
edTypeSynonymType :: ExternsDeclaration -> SourceType
edTypeSynonymArguments :: ExternsDeclaration -> [(Text, Maybe SourceType)]
edTypeSynonymName :: ExternsDeclaration -> ProperName 'TypeName
edTypeSynonymType :: SourceType
edTypeSynonymArguments :: [(Text, Maybe SourceType)]
edTypeSynonymName :: ProperName 'TypeName
..} ->
    if forall a. Maybe a -> Bool
isNothing ((Char -> Bool) -> Text -> Maybe Char
Text.find (forall a. Eq a => a -> a -> Bool
== Char
'$') (ProperName 'TypeName
edTypeSynonymNameforall s a. s -> Getting a s a -> a
^.forall r (a :: ProperNameType). Getting r (ProperName a) Text
properNameT))
      then forall a b. a -> Either a b
Left (ProperName 'TypeName -> SourceType -> ToResolve
SynonymToResolve ProperName 'TypeName
edTypeSynonymName SourceType
edTypeSynonymType)
      else forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
  P.EDDataConstructor{[Ident]
ProperName 'TypeName
ProperName 'ConstructorName
SourceType
DataDeclType
edDataCtorFields :: ExternsDeclaration -> [Ident]
edDataCtorType :: ExternsDeclaration -> SourceType
edDataCtorTypeCtor :: ExternsDeclaration -> ProperName 'TypeName
edDataCtorOrigin :: ExternsDeclaration -> DataDeclType
edDataCtorName :: ExternsDeclaration -> ProperName 'ConstructorName
edDataCtorFields :: [Ident]
edDataCtorType :: SourceType
edDataCtorTypeCtor :: ProperName 'TypeName
edDataCtorOrigin :: DataDeclType
edDataCtorName :: ProperName 'ConstructorName
..} -> forall a b. b -> Either a b
Right do
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall a. Maybe a -> Bool
isNothing ((Char -> Bool) -> Text -> Maybe Char
Text.find (forall a. Eq a => a -> a -> Bool
== Char
'$') (ProperName 'ConstructorName
edDataCtorNameforall s a. s -> Getting a s a -> a
^.forall r (a :: ProperNameType). Getting r (ProperName a) Text
properNameT)))
    forall a. a -> Maybe a
Just
      (IdeDataConstructor -> IdeDeclaration
IdeDeclDataConstructor
        (ProperName 'ConstructorName
-> ProperName 'TypeName -> SourceType -> IdeDataConstructor
IdeDataConstructor ProperName 'ConstructorName
edDataCtorName ProperName 'TypeName
edDataCtorTypeCtor SourceType
edDataCtorType))
  P.EDValue{Ident
SourceType
edValueType :: ExternsDeclaration -> SourceType
edValueName :: ExternsDeclaration -> Ident
edValueType :: SourceType
edValueName :: Ident
..} ->
    forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just (IdeValue -> IdeDeclaration
IdeDeclValue (Ident -> SourceType -> IdeValue
IdeValue Ident
edValueName SourceType
edValueType)))
  P.EDClass{Bool
[(Text, Maybe SourceType)]
[(Ident, SourceType)]
[SourceConstraint]
[FunctionalDependency]
ProperName 'ClassName
edIsEmpty :: ExternsDeclaration -> Bool
edFunctionalDependencies :: ExternsDeclaration -> [FunctionalDependency]
edClassConstraints :: ExternsDeclaration -> [SourceConstraint]
edClassMembers :: ExternsDeclaration -> [(Ident, SourceType)]
edClassTypeArguments :: ExternsDeclaration -> [(Text, Maybe SourceType)]
edClassName :: ExternsDeclaration -> ProperName 'ClassName
edIsEmpty :: Bool
edFunctionalDependencies :: [FunctionalDependency]
edClassConstraints :: [SourceConstraint]
edClassMembers :: [(Ident, SourceType)]
edClassTypeArguments :: [(Text, Maybe SourceType)]
edClassName :: ProperName 'ClassName
..} ->
    forall a b. a -> Either a b
Left (ProperName 'ClassName -> ToResolve
TypeClassToResolve ProperName 'ClassName
edClassName)
  P.EDInstance{} ->
    forall a b. b -> Either a b
Right forall a. Maybe a
Nothing

convertOperator :: P.ExternsFixity -> IdeDeclaration
convertOperator :: ExternsFixity -> IdeDeclaration
convertOperator P.ExternsFixity{Precedence
Associativity
Qualified (Either Ident (ProperName 'ConstructorName))
OpName 'ValueOpName
efAlias :: ExternsFixity
-> Qualified (Either Ident (ProperName 'ConstructorName))
efOperator :: ExternsFixity -> OpName 'ValueOpName
efPrecedence :: ExternsFixity -> Precedence
efAssociativity :: ExternsFixity -> Associativity
efAlias :: Qualified (Either Ident (ProperName 'ConstructorName))
efOperator :: OpName 'ValueOpName
efPrecedence :: Precedence
efAssociativity :: Associativity
..} =
  IdeValueOperator -> IdeDeclaration
IdeDeclValueOperator
    (OpName 'ValueOpName
-> Qualified (Either Ident (ProperName 'ConstructorName))
-> Precedence
-> Associativity
-> Maybe SourceType
-> IdeValueOperator
IdeValueOperator
      OpName 'ValueOpName
efOperator
      Qualified (Either Ident (ProperName 'ConstructorName))
efAlias
      Precedence
efPrecedence
      Associativity
efAssociativity
      forall a. Maybe a
Nothing)

convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration
convertTypeOperator :: ExternsTypeFixity -> IdeDeclaration
convertTypeOperator P.ExternsTypeFixity{Precedence
Associativity
Qualified (ProperName 'TypeName)
OpName 'TypeOpName
efTypeAlias :: ExternsTypeFixity -> Qualified (ProperName 'TypeName)
efTypeOperator :: ExternsTypeFixity -> OpName 'TypeOpName
efTypePrecedence :: ExternsTypeFixity -> Precedence
efTypeAssociativity :: ExternsTypeFixity -> Associativity
efTypeAlias :: Qualified (ProperName 'TypeName)
efTypeOperator :: OpName 'TypeOpName
efTypePrecedence :: Precedence
efTypeAssociativity :: Associativity
..} =
  IdeTypeOperator -> IdeDeclaration
IdeDeclTypeOperator
    (OpName 'TypeOpName
-> Qualified (ProperName 'TypeName)
-> Precedence
-> Associativity
-> Maybe SourceType
-> IdeTypeOperator
IdeTypeOperator
      OpName 'TypeOpName
efTypeOperator
      Qualified (ProperName 'TypeName)
efTypeAlias
      Precedence
efTypePrecedence
      Associativity
efTypeAssociativity
      forall a. Maybe a
Nothing)