git.iko.soy/rowtype-yoga/purescript-native
on fca3655 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Environment.hs
371 lines 12 kB history raw
1{-# LANGUAGE TemplateHaskell #-}
3module Language.PureScript.Environment where
5import Prelude.Compat
7import Data.Aeson.TH
8import qualified Data.Aeson as A
9import qualified Data.Map as M
10import qualified Data.Set as S
11import Data.Maybe (fromMaybe)
12import Data.Text (Text)
13import qualified Data.Text as T
14import Data.List (nub)
15import qualified Data.Graph as G
17import Language.PureScript.Crash
18import Language.PureScript.Kinds
19import Language.PureScript.Names
20import Language.PureScript.TypeClassDictionaries
21import Language.PureScript.Types
22import qualified Language.PureScript.Constants as C
24-- | The @Environment@ defines all values and types which are currently in scope:
25data Environment = Environment
26 { names :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
27 -- ^ Values currently in scope
28 , types :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
29 -- ^ Type names currently in scope
30 , dataConstructors :: M.Map (Qualified (ProperName 'ConstructorName)) (DataDeclType, ProperName 'TypeName, Type, [Ident])
31 -- ^ Data constructors currently in scope, along with their associated type
32 -- constructor name, argument types and return type.
33 , typeSynonyms :: M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type)
34 -- ^ Type synonyms currently in scope
35 , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified (ProperName 'ClassName)) (M.Map (Qualified Ident) NamedDict))
36 -- ^ Available type class dictionaries
37 , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
38 -- ^ Type classes
39 , kinds :: S.Set (Qualified (ProperName 'KindName))
40 -- ^ Kinds in scope
41 } deriving Show
43-- | Information about a type class
44data TypeClassData = TypeClassData
45 { typeClassArguments :: [(Text, Maybe Kind)]
46 -- ^ A list of type argument names, and their kinds, where kind annotations
47 -- were provided.
48 , typeClassMembers :: [(Ident, Type)]
49 -- ^ A list of type class members and their types. Type arguments listed above
50 -- are considered bound in these types.
51 , typeClassSuperclasses :: [Constraint]
52 -- ^ A list of superclasses of this type class. Type arguments listed above
53 -- are considered bound in the types appearing in these constraints.
54 , typeClassDependencies :: [FunctionalDependency]
55 -- ^ A list of functional dependencies for the type arguments of this class.
56 , typeClassDeterminedArguments :: S.Set Int
57 -- ^ A set of indexes of type argument that are fully determined by other
58 -- arguments via functional dependencies. This can be computed from both
59 -- typeClassArguments and typeClassDependencies.
60 } deriving Show
62-- | A functional dependency indicates a relationship between two sets of
63-- type arguments in a class declaration.
64data FunctionalDependency = FunctionalDependency
65 { fdDeterminers :: [Int]
66 -- ^ the type arguments which determine the determined type arguments
67 , fdDetermined :: [Int]
68 -- ^ the determined type arguments
69 } deriving Show
71-- |
72-- The initial environment with no values and only the default javascript types defined
73--
74initEnvironment :: Environment
75initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds
77-- |
78-- A constructor for TypeClassData that computes which type class arguments are fully determined.
79-- Fully determined means that this argument cannot be used when selecting a type class instance.
80--
81-- An example of the difference between determined and fully determined would be with the class:
82-- ```class C a b c | a -> b, b -> a, b -> c```
83-- In this case, `a` must differ when `b` differs, and vice versa - each is determined by the other.
84-- Both `a` and `b` can be used in selecting a type class instance. However, `c` cannot - it is
85-- fully determined by `a` and `b`.
86--
87-- Define a graph of type class arguments with edges being fundep determiners to determined.
88-- An argument is fully determined if doesn't appear at the start of a path of strongly connected components.
89-- An argument is not fully determined otherwise.
90--
91-- The way we compute this is by saying: an argument X is fully determined if there are arguments that
92-- determine X that X does not determine. This is the same thing: everything X determines includes everything
93-- in its SCC, and everything determining X is either before it in an SCC path, or in the same SCC.
94makeTypeClassData
95 :: [(Text, Maybe Kind)]
96 -> [(Ident, Type)]
97 -> [Constraint]
98 -> [FunctionalDependency]
99 -> TypeClassData
100makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs
101 where
102 -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined
103 contributingDeps = M.fromListWith (++) $ do
104 fd <- deps
105 src <- fdDeterminers fd
106 (src, fdDetermined fd) : map (, []) (fdDetermined fd)
108 -- here we build a graph of which arguments determine other arguments
109 (depGraph, _, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)
111 -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to
112 isFunDepDetermined arg = case fromKey arg of
113 Nothing -> False -- not mentioned in fundeps
114 Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v
115 varContributesTo = G.reachable depGraph v
116 in any (\r -> not (r `elem` varContributesTo)) contributesToVar
118 -- find all the arguments that are determined
119 determinedArgs = S.fromList $ filter isFunDepDetermined [0 .. length args - 1]
121-- |
122-- The visibility of a name in scope
123--
124data NameVisibility
125 -- |
126 -- The name is defined in the current binding group, but is not visible
127 --
128 = Undefined
129 -- |
130 -- The name is defined in the another binding group, or has been made visible by a function binder
131 --
132 | Defined deriving (Show, Eq)
134-- |
135-- A flag for whether a name is for an private or public value - only public values will be
136-- included in a generated externs file.
137--
138data NameKind
139 -- |
140 -- A private value introduced as an artifact of code generation (class instances, class member
141 -- accessors, etc.)
142 --
143 = Private
144 -- |
145 -- A public value for a module member or foreing import declaration
146 --
147 | Public
148 -- |
149 -- A name for member introduced by foreign import
150 --
151 | External
152 deriving (Show, Eq)
154-- |
155-- The kinds of a type
156--
157data TypeKind
158 -- |
159 -- Data type
160 --
161 = DataType [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
162 -- |
163 -- Type synonym
164 --
165 | TypeSynonym
166 -- |
167 -- Foreign data
168 --
169 | ExternData
170 -- |
171 -- A local type variable
172 --
173 | LocalTypeVariable
174 -- |
175 -- A scoped type variable
176 --
177 | ScopedTypeVar
178 deriving (Show, Eq)
180-- |
181-- The type ('data' or 'newtype') of a data type declaration
182--
183data DataDeclType
184 -- |
185 -- A standard data constructor
186 --
187 = Data
188 -- |
189 -- A newtype constructor
190 --
191 | Newtype
192 deriving (Show, Eq, Ord)
194showDataDeclType :: DataDeclType -> Text
195showDataDeclType Data = "data"
196showDataDeclType Newtype = "newtype"
198instance A.ToJSON DataDeclType where
199 toJSON = A.toJSON . showDataDeclType
201instance A.FromJSON DataDeclType where
202 parseJSON = A.withText "DataDeclType" $ \str ->
203 case str of
204 "data" -> return Data
205 "newtype" -> return Newtype
206 other -> fail $ "invalid type: '" ++ T.unpack other ++ "'"
208-- |
209-- Construct a ProperName in the Prim module
210--
211primName :: Text -> Qualified (ProperName a)
212primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
214primKind :: Text -> Kind
215primKind = NamedKind . primName
217-- |
218-- Kinds in prim
219--
220kindType :: Kind
221kindType = primKind C.typ
223kindEffect :: Kind
224kindEffect = primKind C.effect
226kindSymbol :: Kind
227kindSymbol = primKind C.symbol
229-- |
230-- Construct a type in the Prim module
231--
232primTy :: Text -> Type
233primTy = TypeConstructor . primName
235-- |
236-- Type constructor for functions
237--
238tyFunction :: Type
239tyFunction = primTy "Function"
241-- |
242-- Type constructor for strings
243--
244tyString :: Type
245tyString = primTy "String"
247-- |
248-- Type constructor for strings
249--
250tyChar :: Type
251tyChar = primTy "Char"
253-- |
254-- Type constructor for numbers
255--
256tyNumber :: Type
257tyNumber = primTy "Number"
259-- |
260-- Type constructor for integers
261--
262tyInt :: Type
263tyInt = primTy "Int"
265-- |
266-- Type constructor for booleans
267--
268tyBoolean :: Type
269tyBoolean = primTy "Boolean"
271-- |
272-- Type constructor for arrays
273--
274tyArray :: Type
275tyArray = primTy "Array"
277-- |
278-- Type constructor for records
279--
280tyRecord :: Type
281tyRecord = primTy "Record"
283-- |
284-- Check whether a type is a record
285--
286isObject :: Type -> Bool
287isObject = isTypeOrApplied tyRecord
289-- |
290-- Check whether a type is a function
291--
292isFunction :: Type -> Bool
293isFunction = isTypeOrApplied tyFunction
295isTypeOrApplied :: Type -> Type -> Bool
296isTypeOrApplied t1 (TypeApp t2 _) = t1 == t2
297isTypeOrApplied t1 t2 = t1 == t2
299-- |
300-- Smart constructor for function types
301--
302function :: Type -> Type -> Type
303function t1 = TypeApp (TypeApp tyFunction t1)
305-- |
306-- The primitive kinds
307primKinds :: S.Set (Qualified (ProperName 'KindName))
308primKinds =
309 S.fromList
310 [ primName C.typ
311 , primName C.effect
312 , primName C.symbol
313 ]
315-- |
316-- The primitive types in the external javascript environment with their
317-- associated kinds. There are also pseudo `Fail` and `Partial` types
318-- that correspond to the classes with the same names.
319--
320primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
321primTypes =
322 M.fromList
323 [ (primName "Function", (FunKind kindType (FunKind kindType kindType), ExternData))
324 , (primName "Array", (FunKind kindType kindType, ExternData))
325 , (primName "Record", (FunKind (Row kindType) kindType, ExternData))
326 , (primName "String", (kindType, ExternData))
327 , (primName "Char", (kindType, ExternData))
328 , (primName "Number", (kindType, ExternData))
329 , (primName "Int", (kindType, ExternData))
330 , (primName "Boolean", (kindType, ExternData))
331 , (primName "Partial", (kindType, ExternData))
332 , (primName "Fail", (FunKind kindSymbol kindType, ExternData))
333 , (primName "TypeString", (FunKind kindType kindSymbol, ExternData))
334 , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))
335 ]
337-- |
338-- The primitive class map. This just contains the `Fail` and `Partial`
339-- classes. `Partial` is used as a kind of magic constraint for partial
340-- functions. `Fail` is used for user-defined type errors.
341--
342primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
343primClasses =
344 M.fromList
345 [ (primName "Partial", (makeTypeClassData [] [] [] []))
346 , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))
347 ]
349-- |
350-- Finds information about data constructors from the current environment.
351--
352lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident])
353lookupConstructor env ctor =
354 fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env
356-- |
357-- Checks whether a data constructor is for a newtype.
358--
359isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool
360isNewtypeConstructor e ctor = case lookupConstructor e ctor of
361 (Newtype, _, _, _) -> True
362 (Data, _, _, _) -> False
364-- |
365-- Finds information about values from the current environment.
366--
367lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)
368lookupValue env ident = ident `M.lookup` names env
370$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)
371$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FunctionalDependency)