1-- |
2-- This module generates code for \"externs\" files, i.e. files containing only
3-- foreign import declarations.
4--
5module Language.PureScript.Externs
6  ( ExternsFile(..)
7  , ExternsImport(..)
8  , ExternsFixity(..)
9  , ExternsTypeFixity(..)
10  , ExternsDeclaration(..)
11  , externsIsCurrentVersion
12  , moduleToExternsFile
13  , applyExternsFileToEnvironment
14  , externsFileName
15  ) where
16
17import Prelude.Compat
18
19import Codec.Serialise (Serialise)
20import Control.Monad (join)
21import GHC.Generics (Generic)
22import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
23import Data.List (foldl', find)
24import Data.Foldable (fold)
25import Data.Text (Text)
26import qualified Data.Text as T
27import Data.Version (showVersion)
28import qualified Data.Map as M
29import qualified Data.List.NonEmpty as NEL
30
31import Language.PureScript.AST
32import Language.PureScript.AST.Declarations.ChainId (ChainId)
33import Language.PureScript.Crash
34import Language.PureScript.Environment
35import Language.PureScript.Names
36import Language.PureScript.TypeClassDictionaries
37import Language.PureScript.Types
38
39import Paths_purescript as Paths
40
41-- | The data which will be serialized to an externs file
42data ExternsFile = ExternsFile
43  -- NOTE: Make sure to keep `efVersion` as the first field in this
44  -- record, so the derived Serialise instance produces CBOR that can
45  -- be checked for its version independent of the remaining format
46  { efVersion :: Text
47  -- ^ The externs version
48  , efModuleName :: ModuleName
49  -- ^ Module name
50  , efExports :: [DeclarationRef]
51  -- ^ List of module exports
52  , efImports :: [ExternsImport]
53  -- ^ List of module imports
54  , efFixities :: [ExternsFixity]
55  -- ^ List of operators and their fixities
56  , efTypeFixities :: [ExternsTypeFixity]
57  -- ^ List of type operators and their fixities
58  , efDeclarations :: [ExternsDeclaration]
59  -- ^ List of type and value declaration
60  , efSourceSpan :: SourceSpan
61  -- ^ Source span for error reporting
62  } deriving (Show, Generic)
63
64instance Serialise ExternsFile
65
66-- | A module import in an externs file
67data ExternsImport = ExternsImport
68  {
69  -- | The imported module
70    eiModule :: ModuleName
71  -- | The import type: regular, qualified or hiding
72  , eiImportType :: ImportDeclarationType
73  -- | The imported-as name, for qualified imports
74  , eiImportedAs :: Maybe ModuleName
75  } deriving (Show, Generic)
76
77instance Serialise ExternsImport
78
79-- | A fixity declaration in an externs file
80data ExternsFixity = ExternsFixity
81  {
82  -- | The associativity of the operator
83    efAssociativity :: Associativity
84  -- | The precedence level of the operator
85  , efPrecedence :: Precedence
86  -- | The operator symbol
87  , efOperator :: OpName 'ValueOpName
88  -- | The value the operator is an alias for
89  , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName))
90  } deriving (Show, Generic)
91
92instance Serialise ExternsFixity
93
94-- | A type fixity declaration in an externs file
95data ExternsTypeFixity = ExternsTypeFixity
96  {
97  -- | The associativity of the operator
98    efTypeAssociativity :: Associativity
99  -- | The precedence level of the operator
100  , efTypePrecedence :: Precedence
101  -- | The operator symbol
102  , efTypeOperator :: OpName 'TypeOpName
103  -- | The value the operator is an alias for
104  , efTypeAlias :: Qualified (ProperName 'TypeName)
105  } deriving (Show, Generic)
106
107instance Serialise ExternsTypeFixity
108
109-- | A type or value declaration appearing in an externs file
110data ExternsDeclaration =
111  -- | A type declaration
112    EDType
113      { edTypeName                :: ProperName 'TypeName
114      , edTypeKind                :: SourceType
115      , edTypeDeclarationKind     :: TypeKind
116      }
117  -- | A type synonym
118  | EDTypeSynonym
119      { edTypeSynonymName         :: ProperName 'TypeName
120      , edTypeSynonymArguments    :: [(Text, Maybe SourceType)]
121      , edTypeSynonymType         :: SourceType
122      }
123  -- | A data constructor
124  | EDDataConstructor
125      { edDataCtorName            :: ProperName 'ConstructorName
126      , edDataCtorOrigin          :: DataDeclType
127      , edDataCtorTypeCtor        :: ProperName 'TypeName
128      , edDataCtorType            :: SourceType
129      , edDataCtorFields          :: [Ident]
130      }
131  -- | A value declaration
132  | EDValue
133      { edValueName               :: Ident
134      , edValueType               :: SourceType
135      }
136  -- | A type class declaration
137  | EDClass
138      { edClassName               :: ProperName 'ClassName
139      , edClassTypeArguments      :: [(Text, Maybe SourceType)]
140      , edClassMembers            :: [(Ident, SourceType)]
141      , edClassConstraints        :: [SourceConstraint]
142      , edFunctionalDependencies  :: [FunctionalDependency]
143      , edIsEmpty                 :: Bool
144      }
145  -- | An instance declaration
146  | EDInstance
147      { edInstanceClassName       :: Qualified (ProperName 'ClassName)
148      , edInstanceName            :: Ident
149      , edInstanceForAll          :: [(Text, SourceType)]
150      , edInstanceKinds           :: [SourceType]
151      , edInstanceTypes           :: [SourceType]
152      , edInstanceConstraints     :: Maybe [SourceConstraint]
153      , edInstanceChain           :: Maybe ChainId
154      , edInstanceChainIndex      :: Integer
155      , edInstanceNameSource      :: NameSource
156      , edInstanceSourceSpan      :: SourceSpan
157      }
158  deriving (Show, Generic)
159
160instance Serialise ExternsDeclaration
161
162-- | Check whether the version in an externs file matches the currently running
163-- version.
164externsIsCurrentVersion :: ExternsFile -> Bool
165externsIsCurrentVersion ef =
166  T.unpack (efVersion ef) == showVersion Paths.version
167
168-- | Convert an externs file back into a module
169applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
170applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations
171  where
172  applyDecl :: Environment -> ExternsDeclaration -> Environment
173  applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }
174  applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
175  applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
176  applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }
177  applyDecl env (EDClass pn args members cs deps tcIsEmpty) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps tcIsEmpty) (typeClasses env) }
178  applyDecl env (EDInstance className ident vars kinds tys cs ch idx ns ss) =
179    env { typeClassDictionaries =
180            updateMap
181              (updateMap (M.insertWith (<>) (qual ident) (pure dict)) className)
182              (Just efModuleName) (typeClassDictionaries env) }
183    where
184    dict :: NamedDict
185    dict = TypeClassDictionaryInScope ch idx (qual ident) [] className vars kinds tys cs instTy
186
187    updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a
188    updateMap f = M.alter (Just . f . fold)
189
190    instTy :: Maybe SourceType
191    instTy = case ns of
192      CompilerNamed -> Just $ srcInstanceType ss vars className tys
193      UserNamed -> Nothing
194
195  qual :: a -> Qualified a
196  qual = Qualified (Just efModuleName)
197
198-- | Generate an externs file for all declarations in a module.
199--
200-- The `Map Ident Ident` argument should contain any top-level `GenIdent`s that
201-- were rewritten to `Ident`s when the module was compiled; this rewrite only
202-- happens in the CoreFn, not the original module AST, so it needs to be
203-- applied to the exported names here also. (The appropriate map is returned by
204-- `L.P.Renamer.renameInModule`.)
205moduleToExternsFile :: Module -> Environment -> M.Map Ident Ident -> ExternsFile
206moduleToExternsFile (Module _ _ _ _ Nothing) _ _ = internalError "moduleToExternsFile: module exports were not elaborated"
207moduleToExternsFile (Module ss _ mn ds (Just exps)) env renamedIdents = ExternsFile{..}
208  where
209  efVersion       = T.pack (showVersion Paths.version)
210  efModuleName    = mn
211  efExports       = map renameRef exps
212  efImports       = mapMaybe importDecl ds
213  efFixities      = mapMaybe fixityDecl ds
214  efTypeFixities  = mapMaybe typeFixityDecl ds
215  efDeclarations  = concatMap toExternsDeclaration exps
216  efSourceSpan    = ss
217
218  fixityDecl :: Declaration -> Maybe ExternsFixity
219  fixityDecl (ValueFixityDeclaration _ (Fixity assoc prec) name op) =
220    fmap (const (ExternsFixity assoc prec op name)) (find ((== Just op) . getValueOpRef) exps)
221  fixityDecl _ = Nothing
222
223  typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity
224  typeFixityDecl (TypeFixityDeclaration _ (Fixity assoc prec) name op) =
225    fmap (const (ExternsTypeFixity assoc prec op name)) (find ((== Just op) . getTypeOpRef) exps)
226  typeFixityDecl _ = Nothing
227
228  importDecl :: Declaration -> Maybe ExternsImport
229  importDecl (ImportDeclaration _ m mt qmn) = Just (ExternsImport m mt qmn)
230  importDecl _ = Nothing
231
232  toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration]
233  toExternsDeclaration (TypeRef _ pn dctors) =
234    case Qualified (Just mn) pn `M.lookup` types env of
235      Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration"
236      Just (kind, TypeSynonym)
237        | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]
238      Just (kind, ExternData rs) -> [ EDType pn kind (ExternData rs) ]
239      Just (kind, tk@(DataType _ _ tys)) ->
240        EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args
241                            | dctor <- fromMaybe (map fst tys) dctors
242                            , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env)
243                            ]
244      _ -> internalError "toExternsDeclaration: Invalid input"
245  toExternsDeclaration (ValueRef _ ident)
246    | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env
247    = [ EDValue (lookupRenamedIdent ident) ty ]
248  toExternsDeclaration (TypeClassRef _ className)
249    | let dictName = dictTypeName . coerceProperName $ className
250    , Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env
251    , Just (kind, tk) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env
252    , Just (dictKind, dictData@(DataType _ _ [(dctor, _)])) <- Qualified (Just mn) dictName `M.lookup` types env
253    , Just (dty, _, ty, args) <- Qualified (Just mn) dctor `M.lookup` dataConstructors env
254    = [ EDType (coerceProperName className) kind tk
255      , EDType dictName dictKind dictData
256      , EDDataConstructor dctor dty dictName ty args
257      , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies typeClassIsEmpty
258      ]
259  toExternsDeclaration (TypeInstanceRef ss' ident ns)
260    = [ EDInstance tcdClassName (lookupRenamedIdent ident) tcdForAll tcdInstanceKinds tcdInstanceTypes tcdDependencies tcdChain tcdIndex ns ss'
261      | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env))
262      , m2 <- M.elems m1
263      , nel <- maybeToList (M.lookup (Qualified (Just mn) ident) m2)
264      , TypeClassDictionaryInScope{..} <- NEL.toList nel
265      ]
266  toExternsDeclaration _ = []
267
268  renameRef :: DeclarationRef -> DeclarationRef
269  renameRef = \case
270    ValueRef ss' ident -> ValueRef ss' $ lookupRenamedIdent ident
271    TypeInstanceRef ss' ident _ | not $ isPlainIdent ident -> TypeInstanceRef ss' (lookupRenamedIdent ident) CompilerNamed
272    other -> other
273
274  lookupRenamedIdent :: Ident -> Ident
275  lookupRenamedIdent = flip (join M.findWithDefault) renamedIdents
276
277externsFileName :: FilePath
278externsFileName = "externs.cbor"
279