1{-# language PackageImports, BlockArguments #-}
2
3module Language.PureScript.Ide.Externs
4  ( readExternFile
5  , convertExterns
6  ) where
7
8import           Protolude hiding (to, from, (&))
9
10import           Codec.CBOR.Term as Term
11import           "monad-logger" Control.Monad.Logger
12import           Data.Version (showVersion)
13import qualified Data.Text as Text
14import qualified Language.PureScript as P
15import qualified Language.PureScript.Make.Monad as Make
16import           Language.PureScript.Ide.Error (IdeError (..))
17import           Language.PureScript.Ide.Types
18import           Language.PureScript.Ide.Util (properNameT)
19import           Lens.Micro.Platform
20
21readExternFile
22  :: (MonadIO m, MonadError IdeError m, MonadLogger m)
23  => FilePath
24  -> m P.ExternsFile
25readExternFile fp = do
26  externsFile <- liftIO (Make.readCborFileIO fp)
27  case externsFile of
28    Just externs | version == P.efVersion externs ->
29      pure externs
30    _ ->
31      liftIO (Make.readCborFileIO fp) >>= \case
32        Just (Term.TList (_tag : Term.TString efVersion : _rest)) -> do
33          let errMsg =
34                "Version mismatch for the externs at: "
35                <> toS fp
36                <> " Expected: " <> version
37                <> " Found: " <> efVersion
38          logErrorN errMsg
39          throwError (GeneralError errMsg)
40        _ ->
41          throwError (GeneralError ("Parsing the extern at: " <> toS fp <> " failed"))
42    where
43      version = toS (showVersion P.version)
44
45convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.DeclarationRef)])
46convertExterns ef =
47  (decls, exportDecls)
48  where
49    decls = moduleDecl : map
50      (IdeDeclarationAnn emptyAnn)
51      (resolvedDeclarations <> operatorDecls <> tyOperatorDecls)
52    exportDecls = mapMaybe convertExport (P.efExports ef)
53    operatorDecls = convertOperator <$> P.efFixities ef
54    tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef
55    moduleDecl = IdeDeclarationAnn emptyAnn (IdeDeclModule (P.efModuleName ef))
56    (toResolve, declarations) =
57      second catMaybes (partitionEithers (map convertDecl (P.efDeclarations ef)))
58    resolvedDeclarations = resolveSynonymsAndClasses toResolve declarations
59
60resolveSynonymsAndClasses
61  :: [ToResolve]
62  -> [IdeDeclaration]
63  -> [IdeDeclaration]
64resolveSynonymsAndClasses trs decls = foldr go decls trs
65  where
66    go tr acc = case tr of
67      TypeClassToResolve tcn ->
68        case findType (P.coerceProperName tcn) acc of
69          Nothing ->
70            acc
71          Just tyDecl -> IdeDeclTypeClass
72            (IdeTypeClass tcn (tyDecl^.ideTypeKind) [])
73            : filter (not . anyOf (_IdeDeclType.ideTypeName) (== P.coerceProperName tcn)) acc
74      SynonymToResolve tn ty ->
75        case findType tn acc of
76          Nothing ->
77            acc
78          Just tyDecl ->
79            IdeDeclTypeSynonym (IdeTypeSynonym tn ty (tyDecl^.ideTypeKind))
80            : filter (not . anyOf (_IdeDeclType.ideTypeName) (== tn)) acc
81
82findType :: P.ProperName 'P.TypeName -> [IdeDeclaration] -> Maybe IdeType
83findType tn decls =
84  decls
85    & mapMaybe (preview _IdeDeclType)
86    & find ((==) tn . view ideTypeName)
87
88-- The Externs format splits information about synonyms across EDType
89-- and EDTypeSynonym declarations. For type classes it split them
90-- across an EDType and an EDClass . We collect these and resolve them
91-- at the end of the conversion process.
92data ToResolve
93  = TypeClassToResolve (P.ProperName 'P.ClassName)
94  | SynonymToResolve (P.ProperName 'P.TypeName) P.SourceType
95
96convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef)
97convertExport (P.ReExportRef _ src r) = Just (P.exportSourceDefinedIn src, r)
98convertExport _ = Nothing
99
100convertDecl :: P.ExternsDeclaration -> Either ToResolve (Maybe IdeDeclaration)
101convertDecl ed = case ed of
102  -- We need to filter all types and synonyms that contain a '$'
103  -- because those are typechecker internal definitions that shouldn't
104  -- be user facing
105  P.EDType{..} -> Right do
106    guard (isNothing (Text.find (== '$') (edTypeName^.properNameT)))
107    Just (IdeDeclType (IdeType edTypeName edTypeKind []))
108  P.EDTypeSynonym{..} ->
109    if isNothing (Text.find (== '$') (edTypeSynonymName^.properNameT))
110      then Left (SynonymToResolve edTypeSynonymName edTypeSynonymType)
111      else Right Nothing
112  P.EDDataConstructor{..} -> Right do
113    guard (isNothing (Text.find (== '$') (edDataCtorName^.properNameT)))
114    Just
115      (IdeDeclDataConstructor
116        (IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType))
117  P.EDValue{..} ->
118    Right (Just (IdeDeclValue (IdeValue edValueName edValueType)))
119  P.EDClass{..} ->
120    Left (TypeClassToResolve edClassName)
121  P.EDInstance{} ->
122    Right Nothing
123
124convertOperator :: P.ExternsFixity -> IdeDeclaration
125convertOperator P.ExternsFixity{..} =
126  IdeDeclValueOperator
127    (IdeValueOperator
128      efOperator
129      efAlias
130      efPrecedence
131      efAssociativity
132      Nothing)
133
134convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration
135convertTypeOperator P.ExternsTypeFixity{..} =
136  IdeDeclTypeOperator
137    (IdeTypeOperator
138      efTypeOperator
139      efTypeAlias
140      efTypePrecedence
141      efTypeAssociativity
142      Nothing)
143