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