git.iko.soy/rowtype-yoga/purescript-native
on 0e7c936 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Types.hs
357 lines 12 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE TemplateHaskell #-}
4-- |
5-- Data types for types
6--
7module Language.PureScript.Types where
9import Prelude ()
10import Prelude.Compat
12import Data.List (nub)
13import Data.Maybe (fromMaybe)
14import qualified Data.Aeson as A
15import qualified Data.Aeson.TH as A
17import Control.Monad ((<=<))
19import Language.PureScript.Names
20import Language.PureScript.Kinds
21import Language.PureScript.AST.SourcePos
23-- |
24-- An identifier for the scope of a skolem variable
25--
26newtype SkolemScope = SkolemScope { runSkolemScope :: Int }
27 deriving (Show, Read, Eq, Ord, A.ToJSON, A.FromJSON)
29-- |
30-- The type of types
31--
32data Type
33 -- |
34 -- A unification variable of type Type
35 --
36 = TUnknown Int
37 -- |
38 -- A named type variable
39 --
40 | TypeVar String
41 -- |
42 -- A type wildcard, as would appear in a partial type synonym
43 --
44 | TypeWildcard (SourceSpan)
45 -- |
46 -- A type constructor
47 --
48 | TypeConstructor (Qualified (ProperName 'TypeName))
49 -- |
50 -- A type operator. This will be desugared into a type constructor during the
51 -- "operators" phase of desugaring.
52 --
53 | TypeOp (Qualified Ident)
54 -- |
55 -- A type application
56 --
57 | TypeApp Type Type
58 -- |
59 -- Forall quantifier
60 --
61 | ForAll String Type (Maybe SkolemScope)
62 -- |
63 -- A type with a set of type class constraints
64 --
65 | ConstrainedType [Constraint] Type
66 -- |
67 -- A skolem constant
68 --
69 | Skolem String Int SkolemScope (Maybe SourceSpan)
70 -- |
71 -- An empty row
72 --
73 | REmpty
74 -- |
75 -- A non-empty row
76 --
77 | RCons String Type Type
78 -- |
79 -- A type with a kind annotation
80 --
81 | KindedType Type Kind
82 --
83 -- |
84 -- A placeholder used in pretty printing
85 --
86 | PrettyPrintFunction Type Type
87 -- |
88 -- A placeholder used in pretty printing
89 --
90 | PrettyPrintObject Type
91 -- |
92 -- A placeholder used in pretty printing
93 --
94 | PrettyPrintForAll [String] Type
95 -- |
96 -- Binary operator application. During the rebracketing phase of desugaring,
97 -- this data constructor will be removed.
98 --
99 | BinaryNoParensType Type Type Type
100 -- |
101 -- Explicit parentheses. During the rebracketing phase of desugaring, this
102 -- data constructor will be removed.
103 --
104 -- Note: although it seems this constructor is not used, it _is_ useful,
105 -- since it prevents certain traversals from matching.
106 --
107 | ParensInType Type
108 deriving (Show, Read, Eq, Ord)
110-- | Additional data relevant to type class constraints
111data ConstraintData
112 = PartialConstraintData [[String]] Bool
113 -- ^ Data to accompany a Partial constraint generated by the exhaustivity checker.
114 -- It contains (rendered) binder information for those binders which were
115 -- not matched, and a flag indicating whether the list was truncated or not.
116 -- Note: we use 'String' here because using 'Binder' would introduce a cyclic
117 -- dependency in the module graph.
118 deriving (Show, Read, Eq, Ord)
120-- | A typeclass constraint
121data Constraint = Constraint
122 { constraintClass :: Qualified (ProperName 'ClassName)
123 -- ^ constraint class name
124 , constraintArgs :: [Type]
125 -- ^ type arguments
126 , constraintData :: Maybe ConstraintData
127 -- ^ additional data relevant to this constraint
128 } deriving (Show, Read, Eq, Ord)
130mapConstraintArgs :: ([Type] -> [Type]) -> Constraint -> Constraint
131mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) }
133overConstraintArgs :: Functor f => ([Type] -> f [Type]) -> Constraint -> f Constraint
134overConstraintArgs f c = (\args -> c { constraintArgs = args }) <$> f (constraintArgs c)
136$(A.deriveJSON A.defaultOptions ''Type)
137$(A.deriveJSON A.defaultOptions ''Constraint)
138$(A.deriveJSON A.defaultOptions ''ConstraintData)
140-- |
141-- Convert a row to a list of pairs of labels and types
142--
143rowToList :: Type -> ([(String, Type)], Type)
144rowToList (RCons name ty row) = let (tys, rest) = rowToList row
145 in ((name, ty):tys, rest)
146rowToList r = ([], r)
148-- |
149-- Convert a list of labels and types to a row
150--
151rowFromList :: ([(String, Type)], Type) -> Type
152rowFromList ([], r) = r
153rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
155-- |
156-- Check whether a type is a monotype
157--
158isMonoType :: Type -> Bool
159isMonoType ForAll{} = False
160isMonoType _ = True
162-- |
163-- Universally quantify a type
164--
165mkForAll :: [String] -> Type -> Type
166mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args
168-- |
169-- Replace a type variable, taking into account variable shadowing
170--
171replaceTypeVars :: String -> Type -> Type -> Type
172replaceTypeVars v r = replaceAllTypeVars [(v, r)]
174-- |
175-- Replace named type variables with types
176--
177replaceAllTypeVars :: [(String, Type)] -> Type -> Type
178replaceAllTypeVars = go []
179 where
181 go :: [String] -> [(String, Type)] -> Type -> Type
182 go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m)
183 go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)
184 go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f
185 | v `elem` usedVars =
186 let v' = genName v (keys ++ bs ++ usedVars)
187 t' = go bs [(v, TypeVar v')] t
188 in ForAll v' (go (v' : bs) m t') sco
189 | otherwise = ForAll v (go (v : bs) m t) sco
190 where
191 keys = map fst m
192 usedVars = concatMap (usedTypeVariables . snd) m
193 go bs m (ConstrainedType cs t) = ConstrainedType (map (mapConstraintArgs (map (go bs m))) cs) (go bs m t)
194 go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)
195 go bs m (KindedType t k) = KindedType (go bs m t) k
196 go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3)
197 go bs m (ParensInType t) = ParensInType (go bs m t)
198 go _ _ ty = ty
200 genName orig inUse = try 0
201 where
202 try :: Integer -> String
203 try n | (orig ++ show n) `elem` inUse = try (n + 1)
204 | otherwise = orig ++ show n
206-- |
207-- Collect all type variables appearing in a type
208--
209usedTypeVariables :: Type -> [String]
210usedTypeVariables = nub . everythingOnTypes (++) go
211 where
212 go (TypeVar v) = [v]
213 go _ = []
215-- |
216-- Collect all free type variables appearing in a type
217--
218freeTypeVariables :: Type -> [String]
219freeTypeVariables = nub . go []
220 where
221 go :: [String] -> Type -> [String]
222 go bound (TypeVar v) | v `notElem` bound = [v]
223 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
224 go bound (ForAll v t _) = go (v : bound) t
225 go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . constraintArgs) cs ++ go bound t
226 go bound (RCons _ t r) = go bound t ++ go bound r
227 go bound (KindedType t _) = go bound t
228 go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3
229 go bound (ParensInType t) = go bound t
230 go _ _ = []
232-- |
233-- Universally quantify over all type variables appearing free in a type
234--
235quantify :: Type -> Type
236quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty
238-- |
239-- Move all universal quantifiers to the front of a type
240--
241moveQuantifiersToFront :: Type -> Type
242moveQuantifiersToFront = go [] []
243 where
244 go qs cs (ForAll q ty sco) = go ((q, sco) : qs) cs ty
245 go qs cs (ConstrainedType cs' ty) = go qs (cs ++ cs') ty
246 go qs cs ty =
247 let constrained = case cs of
248 [] -> ty
249 cs' -> ConstrainedType cs' ty
250 in case qs of
251 [] -> constrained
252 qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs'
254-- |
255-- Check if a type contains wildcards
256--
257containsWildcards :: Type -> Bool
258containsWildcards = everythingOnTypes (||) go
259 where
260 go :: Type -> Bool
261 go TypeWildcard{} = True
262 go _ = False
264--
265-- Traversals
266--
268everywhereOnTypes :: (Type -> Type) -> Type -> Type
269everywhereOnTypes f = go
270 where
271 go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))
272 go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)
273 go (ConstrainedType cs ty) = f (ConstrainedType (map (mapConstraintArgs (map go)) cs) (go ty))
274 go (RCons name ty rest) = f (RCons name (go ty) (go rest))
275 go (KindedType ty k) = f (KindedType (go ty) k)
276 go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))
277 go (PrettyPrintObject t) = f (PrettyPrintObject (go t))
278 go (PrettyPrintForAll args t) = f (PrettyPrintForAll args (go t))
279 go (BinaryNoParensType t1 t2 t3) = f (BinaryNoParensType (go t1) (go t2) (go t3))
280 go (ParensInType t) = f (ParensInType (go t))
281 go other = f other
283everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type
284everywhereOnTypesTopDown f = go . f
285 where
286 go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))
287 go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco
288 go (ConstrainedType cs ty) = ConstrainedType (map (mapConstraintArgs (map (go . f))) cs) (go (f ty))
289 go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))
290 go (KindedType ty k) = KindedType (go (f ty)) k
291 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))
292 go (PrettyPrintObject t) = PrettyPrintObject (go (f t))
293 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))
294 go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (f (go t1)) (f (go t2)) (f (go t3))
295 go (ParensInType t) = ParensInType (f (go t))
296 go other = f other
298everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type
299everywhereOnTypesM f = go
300 where
301 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
302 go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f
303 go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (overConstraintArgs (mapM go)) cs <*> go ty) >>= f
304 go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f
305 go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f
306 go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f
307 go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f
308 go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f
309 go (BinaryNoParensType t1 t2 t3) = (BinaryNoParensType <$> go t1 <*> go t2 <*> go t3) >>= f
310 go (ParensInType t) = (ParensInType <$> go t) >>= f
311 go other = f other
313everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type
314everywhereOnTypesTopDownM f = go <=< f
315 where
316 go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
317 go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco
318 go (ConstrainedType cs ty) = ConstrainedType <$> mapM (overConstraintArgs (mapM (go <=< f))) cs <*> (f ty >>= go)
319 go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)
320 go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k
321 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)
322 go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)
323 go (PrettyPrintForAll args t) = PrettyPrintForAll args <$> (f t >>= go)
324 go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType <$> (f t1 >>= go) <*> (f t2 >>= go) <*> (f t3 >>= go)
325 go (ParensInType t) = ParensInType <$> (f t >>= go)
326 go other = f other
328everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r
329everythingOnTypes (<>) f = go
330 where
331 go t@(TypeApp t1 t2) = f t <> go t1 <> go t2
332 go t@(ForAll _ ty _) = f t <> go ty
333 go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap constraintArgs cs) <> go ty
334 go t@(RCons _ ty rest) = f t <> go ty <> go rest
335 go t@(KindedType ty _) = f t <> go ty
336 go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2
337 go t@(PrettyPrintObject t1) = f t <> go t1
338 go t@(PrettyPrintForAll _ t1) = f t <> go t1
339 go t@(BinaryNoParensType t1 t2 t3) = f t <> go t1 <> go t2 <> go t3
340 go t@(ParensInType t1) = f t <> go t1
341 go other = f other
343everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r
344everythingWithContextOnTypes s0 r0 (<>) f = go' s0
345 where
346 go' s t = let (s', r) = f s t in r <> go s' t
347 go s (TypeApp t1 t2) = go' s t1 <> go' s t2
348 go s (ForAll _ ty _) = go' s ty
349 go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap constraintArgs cs) <> go' s ty
350 go s (RCons _ ty rest) = go' s ty <> go' s rest
351 go s (KindedType ty _) = go' s ty
352 go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2
353 go s (PrettyPrintObject t1) = go' s t1
354 go s (PrettyPrintForAll _ t1) = go' s t1
355 go s (BinaryNoParensType t1 t2 t3) = go' s t1 <> go' s t2 <> go' s t3
356 go s (ParensInType t1) = go' s t1
357 go _ _ = r0