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