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