git.iko.soy/rowtype-yoga/purescript-native
on a22bde5 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Externs.hs
227 lines 9.8 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)
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)
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)
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)
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 , edFunctionalDependencies :: [FunctionalDependency]
126 }
127 -- | An instance declaration
128 | EDInstance
129 { edInstanceClassName :: Qualified (ProperName 'ClassName)
130 , edInstanceName :: Ident
131 , edInstanceTypes :: [Type]
132 , edInstanceConstraints :: Maybe [Constraint]
133 }
134 deriving Show
136-- | Convert an externs file back into a module
137applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
138applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations
139 where
140 applyDecl :: Environment -> ExternsDeclaration -> Environment
141 applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }
142 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
143 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
144 applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) }
145 applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (TypeClassData args members cs deps) (typeClasses env) }
146 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }
147 where
148 dict :: TypeClassDictionaryInScope
149 dict = TypeClassDictionaryInScope (qual ident) [] className tys cs
151 updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a
152 updateMap f = M.alter (Just . f . fold)
154 qual :: a -> Qualified a
155 qual = Qualified (Just efModuleName)
157-- | Generate an externs file for all declarations in a module
158moduleToExternsFile :: Module -> Environment -> ExternsFile
159moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated"
160moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
161 where
162 efVersion = showVersion Paths.version
163 efModuleName = mn
164 efExports = exps
165 efImports = mapMaybe importDecl ds
166 efFixities = mapMaybe fixityDecl ds
167 efTypeFixities = mapMaybe typeFixityDecl ds
168 efDeclarations = concatMap toExternsDeclaration efExports
170 fixityDecl :: Declaration -> Maybe ExternsFixity
171 fixityDecl (ValueFixityDeclaration (Fixity assoc prec) name op) =
172 fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps)
173 fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d
174 fixityDecl _ = Nothing
176 typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity
177 typeFixityDecl (TypeFixityDeclaration (Fixity assoc prec) name op) =
178 fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps)
179 typeFixityDecl (PositionedDeclaration _ _ d) = typeFixityDecl d
180 typeFixityDecl _ = Nothing
182 findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool
183 findOp get op = maybe False (== op) . get
185 importDecl :: Declaration -> Maybe ExternsImport
186 importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn)
187 importDecl (PositionedDeclaration _ _ d) = importDecl d
188 importDecl _ = Nothing
190 toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration]
191 toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r
192 toExternsDeclaration (TypeRef pn dctors) =
193 case Qualified (Just mn) pn `M.lookup` types env of
194 Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration"
195 Just (kind, TypeSynonym)
196 | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]
197 Just (kind, ExternData) -> [ EDType pn kind ExternData ]
198 Just (kind, tk@(DataType _ tys)) ->
199 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args
200 | dctor <- fromMaybe (map fst tys) dctors
201 , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env)
202 ]
203 _ -> internalError "toExternsDeclaration: Invalid input"
204 toExternsDeclaration (ValueRef ident)
205 | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env
206 = [ EDValue ident ty ]
207 toExternsDeclaration (TypeClassRef className)
208 | Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env
209 , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env
210 , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env
211 = [ EDType (coerceProperName className) kind TypeSynonym
212 , EDTypeSynonym (coerceProperName className) typeClassArguments synTy
213 , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies
214 ]
215 toExternsDeclaration (TypeInstanceRef ident)
216 = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies
217 | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env))
218 , m2 <- M.elems m1
219 , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2)
220 ]
221 toExternsDeclaration _ = []
223$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport)
224$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity)
225$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsTypeFixity)
226$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration)
227$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile)