git.iko.soy/rowtype-yoga/purescript-native
on 72ce900 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Externs.hs
163 lines 7.2 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 , ExternsDeclaration(..)
24 , moduleToExternsFile
25 , applyExternsFileToEnvironment
26 ) where
28import Data.List (find, foldl')
29import Data.Maybe (mapMaybe, maybeToList, fromMaybe)
30import Data.Foldable (fold)
31import Data.Version (showVersion)
32#if __GLASGOW_HASKELL__ < 710
33import Data.Monoid
34#endif
35import Data.Aeson.TH
37import qualified Data.Map as M
39import Language.PureScript.AST
40import Language.PureScript.Environment
41import Language.PureScript.Names
42import Language.PureScript.Types
43import Language.PureScript.Kinds
44import Language.PureScript.TypeClassDictionaries
46import Paths_purescript as Paths
48-- | The data which will be serialized to an externs file
49data ExternsFile = ExternsFile
50 {
51 -- ^ The externs version
52 efVersion :: String
53 -- ^ Module name
54 , efModuleName :: ModuleName
55 -- ^ List of module exports
56 , efExports :: [DeclarationRef]
57 -- ^ List of module imports
58 , efImports :: [(ModuleName, ImportDeclarationType, Maybe ModuleName)]
59 -- ^ List of operators and their fixities
60 , efFixities :: [(Associativity, Precedence, String)]
61 -- ^ List of type and value declaration
62 , efDeclarations :: [ExternsDeclaration]
63 } deriving (Show, Read)
65-- | A type or value declaration appearing in an externs file
66data ExternsDeclaration =
67 -- ^ A type declaration
68 EDType ProperName Kind TypeKind
69 -- ^ A type synonym
70 | EDTypeSynonym ProperName [(String, Maybe Kind)] Type
71 -- ^ A data construtor
72 | EDDataConstructor ProperName DataDeclType ProperName Type [Ident]
73 -- ^ A value declaration
74 | EDValue Ident Type
75 -- ^ A type class declaration
76 | EDClass ProperName [(String, Maybe Kind)] [(Ident, Type)] [Constraint]
77 -- ^ An instance declaration
78 | EDInstance (Qualified ProperName) Ident [Type] (Maybe [Constraint])
79 deriving (Show, Read)
81-- | Convert an externs file back into a module
82applyExternsFileToEnvironment :: ExternsFile -> Environment -> Environment
83applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclarations
84 where
85 applyDecl :: Environment -> ExternsDeclaration -> Environment
86 applyDecl env (EDType pn kind tyKind) = env { types = M.insert (qual pn) (kind, tyKind) (types env) }
87 applyDecl env (EDTypeSynonym pn args ty) = env { typeSynonyms = M.insert (qual pn) (args, ty) (typeSynonyms env) }
88 applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) }
89 applyDecl env (EDValue ident ty) = env { names = M.insert (efModuleName, ident) (ty, External, Defined) (names env) }
90 applyDecl env (EDClass pn args members cs) = env { typeClasses = M.insert (qual pn) (args, members, cs) (typeClasses env) }
91 applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) }
92 where
93 dict :: TypeClassDictionaryInScope
94 dict = TypeClassDictionaryInScope (qual ident) [] className tys cs
96 updateMap :: (Ord k, Monoid a) => (a -> a) -> k -> M.Map k a -> M.Map k a
97 updateMap f = M.alter (Just . f . fold)
99 qual :: a -> Qualified a
100 qual = Qualified (Just efModuleName)
102-- | Generate an externs file for all declarations in a module
103moduleToExternsFile :: Module -> Environment -> ExternsFile
104moduleToExternsFile (Module _ _ _ _ Nothing) _ = error "moduleToExternsFile: module exports were not elaborated"
105moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
106 where
107 efVersion = showVersion Paths.version
108 efModuleName = mn
109 efExports = exps
110 efImports = mapMaybe importDecl ds
111 efFixities = mapMaybe fixityDecl ds
112 efDeclarations = concatMap toExternsDeclaration efExports
114 fixityDecl :: Declaration -> Maybe (Associativity, Precedence, String)
115 fixityDecl (FixityDeclaration (Fixity assoc prec) op) = fmap (const (assoc, prec, op)) (find exportsOp exps)
116 where
117 exportsOp :: DeclarationRef -> Bool
118 exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
119 exportsOp (ValueRef ident') = ident' == Op op
120 exportsOp _ = False
121 fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d
122 fixityDecl _ = Nothing
124 importDecl :: Declaration -> Maybe (ModuleName, ImportDeclarationType, Maybe ModuleName)
125 importDecl (ImportDeclaration m mt qmn) = Just (m, mt, qmn)
126 importDecl (PositionedDeclaration _ _ d) = importDecl d
127 importDecl _ = Nothing
129 toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration]
130 toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r
131 toExternsDeclaration (TypeRef pn dctors) =
132 case Qualified (Just mn) pn `M.lookup` types env of
133 Nothing -> error "toExternsDeclaration: no kind in toExternsDeclaration"
134 Just (kind, TypeSynonym)
135 | Just (args, synTy) <- Qualified (Just mn) pn `M.lookup` typeSynonyms env -> [ EDType pn kind TypeSynonym, EDTypeSynonym pn args synTy ]
136 Just (kind, ExternData) -> [ EDType pn kind ExternData ]
137 Just (kind, tk@(DataType _ tys)) ->
138 EDType pn kind tk : [ EDDataConstructor dctor dty pn ty args
139 | dctor <- fromMaybe (map fst tys) dctors
140 , (dty, _, ty, args) <- maybeToList (M.lookup (Qualified (Just mn) dctor) (dataConstructors env))
141 ]
142 _ -> error "toExternsDeclaration: Invalid input"
143 toExternsDeclaration (ValueRef ident)
144 | Just (ty, _, _) <- (mn, ident) `M.lookup` names env
145 = [ EDValue ident ty ]
146 toExternsDeclaration (TypeClassRef className)
147 | Just (args, members, implies) <- Qualified (Just mn) className `M.lookup` typeClasses env
148 , Just (kind, TypeSynonym) <- M.lookup (Qualified (Just mn) className) (types env)
149 , Just (_, synTy) <- Qualified (Just mn) className `M.lookup` typeSynonyms env
150 = [ EDType className kind TypeSynonym
151 , EDTypeSynonym className args synTy
152 , EDClass className args members implies
153 ]
154 toExternsDeclaration (TypeInstanceRef ident)
155 = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies
156 | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env))
157 , m2 <- M.elems m1
158 , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2)
159 ]
160 toExternsDeclaration _ = []
162$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration)
163$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile)