git.iko.soy/rowtype-yoga/purescript-native
on 4af7f4a help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Environment.hs
344 lines 11 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 } deriving Show
41-- | Information about a type class
42data TypeClassData = TypeClassData
43 { typeClassArguments :: [(Text, Maybe Kind)]
44 -- ^ A list of type argument names, and their kinds, where kind annotations
45 -- were provided.
46 , typeClassMembers :: [(Ident, Type)]
47 -- ^ A list of type class members and their types. Type arguments listed above
48 -- are considered bound in these types.
49 , typeClassSuperclasses :: [Constraint]
50 -- ^ A list of superclasses of this type class. Type arguments listed above
51 -- are considered bound in the types appearing in these constraints.
52 , typeClassDependencies :: [FunctionalDependency]
53 -- ^ A list of functional dependencies for the type arguments of this class.
54 , typeClassDeterminedArguments :: S.Set Int
55 -- ^ A set of indexes of type argument that are fully determined by other
56 -- arguments via functional dependencies. This can be computed from both
57 -- typeClassArguments and typeClassDependencies.
58 } deriving Show
60-- | A functional dependency indicates a relationship between two sets of
61-- type arguments in a class declaration.
62data FunctionalDependency = FunctionalDependency
63 { fdDeterminers :: [Int]
64 -- ^ the type arguments which determine the determined type arguments
65 , fdDetermined :: [Int]
66 -- ^ the determined type arguments
67 } deriving Show
69-- |
70-- The initial environment with no values and only the default javascript types defined
71--
72initEnvironment :: Environment
73initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses
75-- |
76-- A constructor for TypeClassData that computes which type class arguments are fully determined.
77-- Fully determined means that this argument cannot be used when selecting a type class instance.
78--
79-- An example of the difference between determined and fully determined would be with the class:
80-- ```class C a b c | a -> b, b -> a, b -> c```
81-- In this case, `a` must differ when `b` differs, and vice versa - each is determined by the other.
82-- Both `a` and `b` can be used in selecting a type class instance. However, `c` cannot - it is
83-- fully determined by `a` and `b`.
84--
85-- Define a graph of type class arguments with edges being fundep determiners to determined.
86-- An argument is fully determined if doesn't appear at the start of a path of strongly connected components.
87-- An argument is not fully determined otherwise.
88--
89-- The way we compute this is by saying: an argument X is fully determined if there are arguments that
90-- determine X that X does not determine. This is the same thing: everything X determines includes everything
91-- in its SCC, and everything determining X is either before it in an SCC path, or in the same SCC.
92makeTypeClassData
93 :: [(Text, Maybe Kind)]
94 -> [(Ident, Type)]
95 -> [Constraint]
96 -> [FunctionalDependency]
97 -> TypeClassData
98makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs
99 where
100 -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined
101 contributingDeps = M.fromListWith (++) $ do
102 fd <- deps
103 src <- fdDeterminers fd
104 (src, fdDetermined fd) : map (, []) (fdDetermined fd)
106 -- here we build a graph of which arguments determine other arguments
107 (depGraph, _, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps)
109 -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to
110 isFunDepDetermined arg = case fromKey arg of
111 Nothing -> False -- not mentioned in fundeps
112 Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v
113 varContributesTo = G.reachable depGraph v
114 in any (\r -> not (r `elem` varContributesTo)) contributesToVar
116 -- find all the arguments that are determined
117 determinedArgs = S.fromList $ filter isFunDepDetermined [0 .. length args - 1]
119-- |
120-- The visibility of a name in scope
121--
122data NameVisibility
123 -- |
124 -- The name is defined in the current binding group, but is not visible
125 --
126 = Undefined
127 -- |
128 -- The name is defined in the another binding group, or has been made visible by a function binder
129 --
130 | Defined deriving (Show, Eq)
132-- |
133-- A flag for whether a name is for an private or public value - only public values will be
134-- included in a generated externs file.
135--
136data NameKind
137 -- |
138 -- A private value introduced as an artifact of code generation (class instances, class member
139 -- accessors, etc.)
140 --
141 = Private
142 -- |
143 -- A public value for a module member or foreing import declaration
144 --
145 | Public
146 -- |
147 -- A name for member introduced by foreign import
148 --
149 | External
150 deriving (Show, Eq)
152-- |
153-- The kinds of a type
154--
155data TypeKind
156 -- |
157 -- Data type
158 --
159 = DataType [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])]
160 -- |
161 -- Type synonym
162 --
163 | TypeSynonym
164 -- |
165 -- Foreign data
166 --
167 | ExternData
168 -- |
169 -- A local type variable
170 --
171 | LocalTypeVariable
172 -- |
173 -- A scoped type variable
174 --
175 | ScopedTypeVar
176 deriving (Show, Eq)
178-- |
179-- The type ('data' or 'newtype') of a data type declaration
180--
181data DataDeclType
182 -- |
183 -- A standard data constructor
184 --
185 = Data
186 -- |
187 -- A newtype constructor
188 --
189 | Newtype
190 deriving (Show, Eq, Ord)
192showDataDeclType :: DataDeclType -> Text
193showDataDeclType Data = "data"
194showDataDeclType Newtype = "newtype"
196instance A.ToJSON DataDeclType where
197 toJSON = A.toJSON . showDataDeclType
199instance A.FromJSON DataDeclType where
200 parseJSON = A.withText "DataDeclType" $ \str ->
201 case str of
202 "data" -> return Data
203 "newtype" -> return Newtype
204 other -> fail $ "invalid type: '" ++ T.unpack other ++ "'"
206-- |
207-- Construct a ProperName in the Prim module
208--
209primName :: Text -> Qualified (ProperName a)
210primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
212-- |
213-- Construct a type in the Prim module
214--
215primTy :: Text -> Type
216primTy = TypeConstructor . primName
218-- |
219-- Type constructor for functions
220--
221tyFunction :: Type
222tyFunction = primTy "Function"
224-- |
225-- Type constructor for strings
226--
227tyString :: Type
228tyString = primTy "String"
230-- |
231-- Type constructor for strings
232--
233tyChar :: Type
234tyChar = primTy "Char"
236-- |
237-- Type constructor for numbers
238--
239tyNumber :: Type
240tyNumber = primTy "Number"
242-- |
243-- Type constructor for integers
244--
245tyInt :: Type
246tyInt = primTy "Int"
248-- |
249-- Type constructor for booleans
250--
251tyBoolean :: Type
252tyBoolean = primTy "Boolean"
254-- |
255-- Type constructor for arrays
256--
257tyArray :: Type
258tyArray = primTy "Array"
260-- |
261-- Type constructor for records
262--
263tyRecord :: Type
264tyRecord = primTy "Record"
266-- |
267-- Check whether a type is a record
268--
269isObject :: Type -> Bool
270isObject = isTypeOrApplied tyRecord
272-- |
273-- Check whether a type is a function
274--
275isFunction :: Type -> Bool
276isFunction = isTypeOrApplied tyFunction
278isTypeOrApplied :: Type -> Type -> Bool
279isTypeOrApplied t1 (TypeApp t2 _) = t1 == t2
280isTypeOrApplied t1 t2 = t1 == t2
282-- |
283-- Smart constructor for function types
284--
285function :: Type -> Type -> Type
286function t1 = TypeApp (TypeApp tyFunction t1)
288-- |
289-- The primitive types in the external javascript environment with their
290-- associated kinds. There are also pseudo `Fail` and `Partial` types
291-- that correspond to the classes with the same names.
292--
293primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
294primTypes =
295 M.fromList
296 [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))
297 , (primName "Array", (FunKind Star Star, ExternData))
298 , (primName "Record", (FunKind (Row Star) Star, ExternData))
299 , (primName "String", (Star, ExternData))
300 , (primName "Char", (Star, ExternData))
301 , (primName "Number", (Star, ExternData))
302 , (primName "Int", (Star, ExternData))
303 , (primName "Boolean", (Star, ExternData))
304 , (primName "Partial", (Star, ExternData))
305 , (primName "Fail", (FunKind Symbol Star, ExternData))
306 , (primName "TypeString", (FunKind Star Symbol, ExternData))
307 , (primName "TypeConcat", (FunKind Symbol (FunKind Symbol Symbol), ExternData))
308 ]
310-- |
311-- The primitive class map. This just contains the `Fail` and `Partial`
312-- classes. `Partial` is used as a kind of magic constraint for partial
313-- functions. `Fail` is used for user-defined type errors.
314--
315primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
316primClasses =
317 M.fromList
318 [ (primName "Partial", (makeTypeClassData [] [] [] []))
319 , (primName "Fail", (makeTypeClassData [("message", Just Symbol)] [] [] []))
320 ]
322-- |
323-- Finds information about data constructors from the current environment.
324--
325lookupConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> (DataDeclType, ProperName 'TypeName, Type, [Ident])
326lookupConstructor env ctor =
327 fromMaybe (internalError "Data constructor not found") $ ctor `M.lookup` dataConstructors env
329-- |
330-- Checks whether a data constructor is for a newtype.
331--
332isNewtypeConstructor :: Environment -> Qualified (ProperName 'ConstructorName) -> Bool
333isNewtypeConstructor e ctor = case lookupConstructor e ctor of
334 (Newtype, _, _, _) -> True
335 (Data, _, _, _) -> False
337-- |
338-- Finds information about values from the current environment.
339--
340lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)
341lookupValue env ident = ident `M.lookup` names env
343$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''TypeKind)
344$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FunctionalDependency)