git.iko.soy/rowtype-yoga/purescript-native
on 88fdcee help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Externs.hs
238 lines 10 kB history raw
1{-# LANGUAGE TemplateHaskell #-}
3-- |
4-- This module generates code for \"externs\" files, i.e. files containing only
5-- foreign import declarations.
6--
7module Language.PureScript.Externs
8 ( ExternsFile(..)
9 , ExternsImport(..)
10 , ExternsFixity(..)
11 , ExternsTypeFixity(..)
12 , ExternsDeclaration(..)
13 , moduleToExternsFile
14 , applyExternsFileToEnvironment
15 ) where
17import Prelude.Compat
19import Data.Aeson.TH
20import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
21import Data.List (foldl', find)
22import Data.Foldable (fold)
23import Data.Text (Text)
24import qualified Data.Text as T
25import Data.Version (showVersion)
26import qualified Data.Map as M
27import qualified Data.Set as S
29import Language.PureScript.AST
30import Language.PureScript.Crash
31import Language.PureScript.Environment
32import Language.PureScript.Kinds
33import Language.PureScript.Names
34import Language.PureScript.TypeClassDictionaries
35import Language.PureScript.Types
37import Paths_purescript as Paths
39-- | The data which will be serialized to an externs file
40data ExternsFile = ExternsFile
41 {
42 -- | The externs version
43 efVersion :: Text
44 -- | Module name
45 , efModuleName :: ModuleName
46 -- | List of module exports
47 , efExports :: [DeclarationRef]
48 -- | List of module imports
49 , efImports :: [ExternsImport]
50 -- | List of operators and their fixities
51 , efFixities :: [ExternsFixity]
52 -- | List of type operators and their fixities
53 , efTypeFixities :: [ExternsTypeFixity]
54 -- | List of type and value declaration
55 , efDeclarations :: [ExternsDeclaration]
56 } deriving (Show)
58-- | A module import in an externs file
59data ExternsImport = ExternsImport
60 {
61 -- | The imported module
62 eiModule :: ModuleName
63 -- | The import type: regular, qualified or hiding
64 , eiImportType :: ImportDeclarationType
65 -- | The imported-as name, for qualified imports
66 , eiImportedAs :: Maybe ModuleName
67 } deriving (Show)
69-- | A fixity declaration in an externs file
70data ExternsFixity = ExternsFixity
71 {
72 -- | The associativity of the operator
73 efAssociativity :: Associativity
74 -- | The precedence level of the operator
75 , efPrecedence :: Precedence
76 -- | The operator symbol
77 , efOperator :: OpName 'ValueOpName
78 -- | The value the operator is an alias for
79 , efAlias :: Qualified (Either Ident (ProperName 'ConstructorName))
80 } deriving (Show)
82-- | A type fixity declaration in an externs file
83data ExternsTypeFixity = ExternsTypeFixity
84 {
85 -- | The associativity of the operator
86 efTypeAssociativity :: Associativity
87 -- | The precedence level of the operator
88 , efTypePrecedence :: Precedence
89 -- | The operator symbol
90 , efTypeOperator :: OpName 'TypeOpName
91 -- | The value the operator is an alias for
92 , efTypeAlias :: Qualified (ProperName 'TypeName)
93 } deriving (Show)
95-- | A type or value declaration appearing in an externs file
96data ExternsDeclaration =
97 -- | A type declaration
98 EDType
99 { edTypeName :: ProperName 'TypeName
100 , edTypeKind :: Kind
101 , edTypeDeclarationKind :: TypeKind
102 }
103 -- | A type synonym
104 | EDTypeSynonym
105 { edTypeSynonymName :: ProperName 'TypeName
106 , edTypeSynonymArguments :: [(Text, Maybe Kind)]
107 , edTypeSynonymType :: Type
108 }
109 -- | A data construtor
110 | EDDataConstructor
111 { edDataCtorName :: ProperName 'ConstructorName
112 , edDataCtorOrigin :: DataDeclType
113 , edDataCtorTypeCtor :: ProperName 'TypeName
114 , edDataCtorType :: Type
115 , edDataCtorFields :: [Ident]
116 }
117 -- | A value declaration
118 | EDValue
119 { edValueName :: Ident
120 , edValueType :: Type
121 }
122 -- | A type class declaration
123 | EDClass
124 { edClassName :: ProperName 'ClassName
125 , edClassTypeArguments :: [(Text, Maybe Kind)]
126 , edClassMembers :: [(Ident, Type)]
127 , edClassConstraints :: [Constraint]
128 , edFunctionalDependencies :: [FunctionalDependency]
129 }
130 -- | An instance declaration
131 | EDInstance
132 { edInstanceClassName :: Qualified (ProperName 'ClassName)
133 , edInstanceName :: Ident
134 , edInstanceTypes :: [Type]
135 , edInstanceConstraints :: Maybe [Constraint]
136 }
137 -- | A kind declaration
138 | EDKind
139 { edKindName :: ProperName 'KindName
140 }
141 deriving Show
143-- | Convert an externs file back into a module
144applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
145applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations
146 where
147 applyDecl :: Environment -> ExternsDeclaration -> Environment
148 applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }
149 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
150 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
151 applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }
152 applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) }
153 applyDecl env (EDKind pn) = env { kinds = S.insert (qual pn) (kinds env) }
154 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }
155 where
156 dict :: NamedDict
157 dict = TypeClassDictionaryInScope (qual ident) [] className tys cs
159 updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a
160 updateMap f = M.alter (Just . f . fold)
162 qual :: a -> Qualified a
163 qual = Qualified (Just efModuleName)
165-- | Generate an externs file for all declarations in a module
166moduleToExternsFile :: Module -> Environment -> ExternsFile
167moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated"
168moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
169 where
170 efVersion = T.pack (showVersion Paths.version)
171 efModuleName = mn
172 efExports = exps
173 efImports = mapMaybe importDecl ds
174 efFixities = mapMaybe fixityDecl ds
175 efTypeFixities = mapMaybe typeFixityDecl ds
176 efDeclarations = concatMap toExternsDeclaration efExports
178 fixityDecl :: Declaration -> Maybe ExternsFixity
179 fixityDecl (ValueFixityDeclaration (Fixity assoc prec) name op) =
180 fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps)
181 fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d
182 fixityDecl _ = Nothing
184 typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity
185 typeFixityDecl (TypeFixityDeclaration (Fixity assoc prec) name op) =
186 fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps)
187 typeFixityDecl (PositionedDeclaration _ _ d) = typeFixityDecl d
188 typeFixityDecl _ = Nothing
190 findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool
191 findOp g op = maybe False (== op) . g
193 importDecl :: Declaration -> Maybe ExternsImport
194 importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn)
195 importDecl (PositionedDeclaration _ _ d) = importDecl d
196 importDecl _ = Nothing
198 toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration]
199 toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r
200 toExternsDeclaration (TypeRef pn dctors) =
201 case Qualified (Just mn) pn `M.lookup` types env of
202 Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration"
203 Just (kind, TypeSynonym)
204 | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]
205 Just (kind, ExternData) -> [ EDType pn kind ExternData ]
206 Just (kind, tk@(DataType _ tys)) ->
207 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args
208 | dctor <- fromMaybe (map fst tys) dctors
209 , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env)
210 ]
211 _ -> internalError "toExternsDeclaration: Invalid input"
212 toExternsDeclaration (ValueRef ident)
213 | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env
214 = [ EDValue ident ty ]
215 toExternsDeclaration (TypeClassRef className)
216 | Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env
217 , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env
218 , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env
219 = [ EDType (coerceProperName className) kind TypeSynonym
220 , EDTypeSynonym (coerceProperName className) typeClassArguments synTy
221 , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies
222 ]
223 toExternsDeclaration (TypeInstanceRef ident)
224 = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies
225 | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env))
226 , m2 <- M.elems m1
227 , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2)
228 ]
229 toExternsDeclaration (KindRef pn)
230 | Qualified (Just mn) pn `S.member` kinds env
231 = [ EDKind pn ]
232 toExternsDeclaration _ = []
234$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport)
235$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity)
236$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsTypeFixity)
237$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration)
238$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile)