git.iko.soy/rowtype-yoga/purescript-native
on c84d2fd help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Externs.hs
217 lines 8.7 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript.Externs
4-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
5-- License : MIT (http://opensource.org/licenses/MIT)
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
13--
14-----------------------------------------------------------------------------
16{-# LANGUAGE CPP #-}
17{-# LANGUAGE RecordWildCards #-}
18{-# LANGUAGE PatternGuards #-}
19{-# LANGUAGE TemplateHaskell #-}
21module Language.PureScript.Externs
22 ( ExternsFile(..)
23 , ExternsImport(..)
24 , ExternsFixity(..)
25 , ExternsDeclaration(..)
26 , moduleToExternsFile
27 , applyExternsFileToEnvironment
28 ) where
30import Data.List (find, foldl')
31import Data.Maybe (mapMaybe, maybeToList, fromMaybe)
32import Data.Foldable (fold)
33import Data.Version (showVersion)
34#if __GLASGOW_HASKELL__ < 710
35import Data.Monoid
36#endif
37import Data.Aeson.TH
39import qualified Data.Map as M
41import Language.PureScript.Crash
42import Language.PureScript.AST
43import Language.PureScript.Environment
44import Language.PureScript.Names
45import Language.PureScript.Types
46import Language.PureScript.Kinds
47import Language.PureScript.TypeClassDictionaries
49import Paths_purescript as Paths
51-- | The data which will be serialized to an externs file
52data ExternsFile = ExternsFile
53 {
54 -- | The externs version
55 efVersion :: String
56 -- | Module name
57 , efModuleName :: ModuleName
58 -- | List of module exports
59 , efExports :: [DeclarationRef]
60 -- | List of module imports
61 , efImports :: [ExternsImport]
62 -- | List of operators and their fixities
63 , efFixities :: [ExternsFixity]
64 -- | List of type and value declaration
65 , efDeclarations :: [ExternsDeclaration]
66 } deriving (Show, Read)
68-- | A module import in an externs file
69data ExternsImport = ExternsImport
70 {
71 -- | The imported module
72 eiModule :: ModuleName
73 -- | The import type: regular, qualified or hiding
74 , eiImportType :: ImportDeclarationType
75 -- | The imported-as name, for qualified imports
76 , eiImportedAs :: Maybe ModuleName
77 } deriving (Show, Read)
79-- | A fixity declaration in an externs file
80data ExternsFixity = ExternsFixity
81 {
82 -- | The associativity of the operator
83 efAssociativity :: Associativity
84 -- | The precedence level of the operator
85 , efPrecedence :: Precedence
86 -- | The operator symbol
87 , efOperator :: String
88 } deriving (Show, Read)
90-- | A type or value declaration appearing in an externs file
91data ExternsDeclaration =
92 -- | A type declaration
93 EDType
94 { edTypeName :: ProperName
95 , edTypeKind :: Kind
96 , edTypeDeclarationKind :: TypeKind
97 }
98 -- | A type synonym
99 | EDTypeSynonym
100 { edTypeSynonymName :: ProperName
101 , edTypeSynonymArguments :: [(String, Maybe Kind)]
102 , edTypeSynonymType :: Type
103 }
104 -- | A data construtor
105 | EDDataConstructor
106 { edDataCtorName :: ProperName
107 , edDataCtorOrigin :: DataDeclType
108 , edDataCtorTypeCtor :: ProperName
109 , edDataCtorType :: Type
110 , edDataCtorFields :: [Ident]
111 }
112 -- | A value declaration
113 | EDValue
114 { edValueName :: Ident
115 , edValueType :: Type
116 }
117 -- | A type class declaration
118 | EDClass
119 { edClassName :: ProperName
120 , edClassTypeArguments :: [(String, Maybe Kind)]
121 , edClassMembers :: [(Ident, Type)]
122 , edClassConstraints :: [Constraint]
123 }
124 -- | An instance declaration
125 | EDInstance
126 { edInstanceClassName :: Qualified ProperName
127 , edInstanceName :: Ident
128 , edInstanceTypes :: [Type]
129 , edInstanceConstraints :: Maybe [Constraint]
130 }
131 deriving (Show, Read)
133-- | Convert an externs file back into a module
134applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
135applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations
136 where
137 applyDecl :: Environment -> ExternsDeclaration -> Environment
138 applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }
139 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
140 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
141 applyDecl env (EDValue ident ty) = env { names = M.insert (efModuleName, ident) (ty, External, Defined) (names env) }
142 applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) }
143 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }
144 where
145 dict :: TypeClassDictionaryInScope
146 dict = TypeClassDictionaryInScope (qual ident) [] className tys cs
148 updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a
149 updateMap f = M.alter (Just . f . fold)
151 qual :: a -> Qualified a
152 qual = Qualified (Just efModuleName)
154-- | Generate an externs file for all declarations in a module
155moduleToExternsFile :: Module -> Environment -> ExternsFile
156moduleToExternsFile (Module _ _ _ _ Nothing) _ = internalError "moduleToExternsFile: module exports were not elaborated"
157moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
158 where
159 efVersion = showVersion Paths.version
160 efModuleName = mn
161 efExports = exps
162 efImports = mapMaybe importDecl ds
163 efFixities = mapMaybe fixityDecl ds
164 efDeclarations = concatMap toExternsDeclaration efExports
166 fixityDecl :: Declaration -> Maybe ExternsFixity
167 fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (ExternsFixity assoc prec op)) (find exportsOp exps)
168 where
169 exportsOp :: DeclarationRef -> Bool
170 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
171 exportsOp (ValueRef ident') = ident' == Op op
172 exportsOp _ = False
173 fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d
174 fixityDecl _ = Nothing
176 importDecl :: Declaration -> Maybe ExternsImport
177 importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn)
178 importDecl (PositionedDeclaration _ _ d) = importDecl d
179 importDecl _ = Nothing
181 toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration]
182 toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r
183 toExternsDeclaration (TypeRef pn dctors) =
184 case Qualified (Just mn) pn `M.lookup` types env of
185 Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration"
186 Just (kind, TypeSynonym)
187 | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]
188 Just (kind, ExternData) -> [ EDType pn kind ExternData ]
189 Just (kind, tk@(DataType _ tys)) ->
190 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args
191 | dctor <- fromMaybe (map fst tys) dctors
192 , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))
193 ]
194 _ -> internalError "toExternsDeclaration: Invalid input"
195 toExternsDeclaration (ValueRef ident)
196 | Just (ty, _, _) <- (mn, ident) `M.lookup` names env
197 = [ EDValue ident ty ]
198 toExternsDeclaration (TypeClassRef className)
199 | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env
200 , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env)
201 , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env
202 = [ EDType className kind TypeSynonym
203 , EDTypeSynonym className args synTy
204 , EDClass className args members implies
205 ]
206 toExternsDeclaration (TypeInstanceRef ident)
207 = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies
208 | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env))
209 , m2 <- M.elems m1
210 , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2)
211 ]
212 toExternsDeclaration _ = []
214$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport)
215$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity)
216$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration)
217$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile)