git.iko.soy/rowtype-yoga/purescript-native
on d167155 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Externs.hs
207 lines 8.5 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE PatternGuards #-}
3{-# LANGUAGE TemplateHaskell #-}
5-- |
6-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
7--
8module Language.PureScript.Externs
9 ( ExternsFile(..)
10 , ExternsImport(..)
11 , ExternsFixity(..)
12 , ExternsDeclaration(..)
13 , moduleToExternsFile
14 , applyExternsFileToEnvironment
15 ) where
17import Prelude ()
18import Prelude.Compat
20import Data.List (find, foldl')
21import Data.Maybe (mapMaybe, maybeToList, fromMaybe)
22import Data.Foldable (fold)
23import Data.Version (showVersion)
24import Data.Aeson.TH
26import qualified Data.Map as M
28import Language.PureScript.Crash
29import Language.PureScript.AST
30import Language.PureScript.Environment
31import Language.PureScript.Names
32import Language.PureScript.Types
33import Language.PureScript.Kinds
34import Language.PureScript.TypeClassDictionaries
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 :: String
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 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 :: String
75 -- | The value the operator is an alias for
76 , efAlias :: Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName)))
77 } deriving (Show, Read)
79-- | A type or value declaration appearing in an externs file
80data ExternsDeclaration =
81 -- | A type declaration
82 EDType
83 { edTypeName :: ProperName 'TypeName
84 , edTypeKind :: Kind
85 , edTypeDeclarationKind :: TypeKind
86 }
87 -- | A type synonym
88 | EDTypeSynonym
89 { edTypeSynonymName :: ProperName 'TypeName
90 , edTypeSynonymArguments :: [(String, Maybe Kind)]
91 , edTypeSynonymType :: Type
92 }
93 -- | A data construtor
94 | EDDataConstructor
95 { edDataCtorName :: ProperName 'ConstructorName
96 , edDataCtorOrigin :: DataDeclType
97 , edDataCtorTypeCtor :: ProperName 'TypeName
98 , edDataCtorType :: Type
99 , edDataCtorFields :: [Ident]
100 }
101 -- | A value declaration
102 | EDValue
103 { edValueName :: Ident
104 , edValueType :: Type
105 }
106 -- | A type class declaration
107 | EDClass
108 { edClassName :: ProperName 'ClassName
109 , edClassTypeArguments :: [(String, Maybe Kind)]
110 , edClassMembers :: [(Ident, Type)]
111 , edClassConstraints :: [Constraint]
112 }
113 -- | An instance declaration
114 | EDInstance
115 { edInstanceClassName :: Qualified (ProperName 'ClassName)
116 , edInstanceName :: Ident
117 , edInstanceTypes :: [Type]
118 , edInstanceConstraints :: Maybe [Constraint]
119 }
120 deriving (Show, Read)
122-- | Convert an externs file back into a module
123applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
124applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations
125 where
126 applyDecl :: Environment -> ExternsDeclaration -> Environment
127 applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }
128 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
129 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
130 applyDecl env (EDValue ident ty) = env { names = M.insert (efModuleName, ident) (ty, External, Defined) (names env) }
131 applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) }
132 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }
133 where
134 dict :: TypeClassDictionaryInScope
135 dict = TypeClassDictionaryInScope (qual ident) [] className tys cs
137 updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a
138 updateMap f = M.alter (Just . f . fold)
140 qual :: a -> Qualified a
141 qual = Qualified (Just efModuleName)
143-- | Generate an externs file for all declarations in a module
144moduleToExternsFile :: Module -> Environment -> ExternsFile
145moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated"
146moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
147 where
148 efVersion = showVersion Paths.version
149 efModuleName = mn
150 efExports = exps
151 efImports = mapMaybe importDecl ds
152 efFixities = mapMaybe fixityDecl ds
153 efDeclarations = concatMap toExternsDeclaration efExports
155 fixityDecl :: Declaration -> Maybe ExternsFixity
156 fixityDecl (FixityDeclaration (Fixity assoc prec) op alias) =
157 fmap (const (ExternsFixity assoc prec op alias)) (find exportsOp exps)
158 where
159 exportsOp :: DeclarationRef -> Bool
160 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
161 exportsOp (ValueRef ident') = ident' == Op op
162 exportsOp _ = False
163 fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d
164 fixityDecl _ = Nothing
166 importDecl :: Declaration -> Maybe ExternsImport
167 importDecl (ImportDeclaration m mt qmn _) = Just (ExternsImport m mt qmn)
168 importDecl (PositionedDeclaration _ _ d) = importDecl d
169 importDecl _ = Nothing
171 toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration]
172 toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r
173 toExternsDeclaration (TypeRef pn dctors) =
174 case Qualified (Just mn) pn `M.lookup` types env of
175 Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration"
176 Just (kind, TypeSynonym)
177 | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]
178 Just (kind, ExternData) -> [ EDType pn kind ExternData ]
179 Just (kind, tk@(DataType _ tys)) ->
180 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args
181 | dctor <- fromMaybe (map fst tys) dctors
182 , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env)
183 ]
184 _ -> internalError "toExternsDeclaration: Invalid input"
185 toExternsDeclaration (ValueRef ident)
186 | Just (ty, _, _) <- (mn, ident) `M.lookup` names env
187 = [ EDValue ident ty ]
188 toExternsDeclaration (TypeClassRef className)
189 | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env
190 , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env
191 , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env
192 = [ EDType (coerceProperName className) kind TypeSynonym
193 , EDTypeSynonym (coerceProperName className) args synTy
194 , EDClass className args members implies
195 ]
196 toExternsDeclaration (TypeInstanceRef ident)
197 = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies
198 | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env))
199 , m2 <- M.elems m1
200 , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2)
201 ]
202 toExternsDeclaration _ = []
204$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport)
205$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity)
206$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration)
207$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile)