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