@@ -0,0 +1,216 @@
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+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE CPP #-}
17+{-# LANGUAGE RecordWildCards #-}
18+{-# LANGUAGE PatternGuards #-}
19+{-# LANGUAGE TemplateHaskell #-}
20+
21+module Language.PureScript.Externs
22+ ( ExternsFile(..)
23+ , ExternsImport(..)
24+ , ExternsFixity(..)
25+ , ExternsDeclaration(..)
26+ , moduleToExternsFile
27+ , applyExternsFileToEnvironment
28+ ) where
29+
30+import Data.List (find, foldl')
31+import Data.Maybe (mapMaybe, maybeToList, fromMaybe)
32+import Data.Foldable (fold)
33+import Data.Version (showVersion)
34+#if __GLASGOW_HASKELL__ < 710
35+import Data.Monoid
36+#endif
37+import Data.Aeson.TH
38+
39+import qualified Data.Map as M
40+
41+import Language.PureScript.AST
42+import Language.PureScript.Environment
43+import Language.PureScript.Names
44+import Language.PureScript.Types
45+import Language.PureScript.Kinds
46+import Language.PureScript.TypeClassDictionaries
47+
48+import Paths_purescript as Paths
49+
50+-- | The data which will be serialized to an externs file
51+data 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)
66+
67+-- | A module import in an externs file
68+data 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)
77+
78+-- | A fixity declaration in an externs file
79+data 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)
88+
89+-- | A type or value declaration appearing in an externs file
90+data 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)
131+
132+-- | Convert an externs file back into a module
133+applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
134+applyExternsFileToEnvironment 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
146+
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)
149+
150+ qual :: a -> Qualified a
151+ qual = Qualified (Just efModuleName)
152+
153+-- | Generate an externs file for all declarations in a module
154+moduleToExternsFile :: Module -> Environment -> ExternsFile
155+moduleToExternsFile (Module _ _ _ _ Nothing) _ = error "moduleToExternsFile: module exports were not elaborated"
156+moduleToExternsFile (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
164+
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
174+
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
179+
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 _ = []
212+
213+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport)
214+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFixity)
215+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration)
216+$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile)