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