git.iko.soy/rowtype-yoga/purescript-native
on 06e4332 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Types.hs
336 lines 11 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.Arrow (second)
18import Control.Monad ((<=<))
20import Language.PureScript.Names
21import Language.PureScript.Kinds
22import Language.PureScript.Traversals
23import Language.PureScript.AST.SourcePos
25-- |
26-- An identifier for the scope of a skolem variable
27--
28newtype SkolemScope = SkolemScope { runSkolemScope :: Int }
29 deriving (Show, Read, Eq, Ord, A.ToJSON, A.FromJSON)
31-- |
32-- The type of types
33--
34data Type
35 -- |
36 -- A unification variable of type Type
37 --
38 = TUnknown Int
39 -- |
40 -- A named type variable
41 --
42 | TypeVar String
43 -- |
44 -- A type wildcard, as would appear in a partial type synonym
45 --
46 | TypeWildcard
47 -- |
48 -- A type constructor
49 --
50 | TypeConstructor (Qualified (ProperName 'TypeName))
51 -- |
52 -- A type operator. This will be desugared into a type constructor during the
53 -- "operators" phase of desugaring.
54 --
55 | TypeOp (Qualified Ident)
56 -- |
57 -- A type application
58 --
59 | TypeApp Type Type
60 -- |
61 -- Forall quantifier
62 --
63 | ForAll String Type (Maybe SkolemScope)
64 -- |
65 -- A type with a set of type class constraints
66 --
67 | ConstrainedType [Constraint] Type
68 -- |
69 -- A skolem constant
70 --
71 | Skolem String Int SkolemScope (Maybe SourceSpan)
72 -- |
73 -- An empty row
74 --
75 | REmpty
76 -- |
77 -- A non-empty row
78 --
79 | RCons String Type Type
80 -- |
81 -- A type with a kind annotation
82 --
83 | KindedType Type Kind
84 --
85 -- |
86 -- A placeholder used in pretty printing
87 --
88 | PrettyPrintFunction Type Type
89 -- |
90 -- A placeholder used in pretty printing
91 --
92 | PrettyPrintObject Type
93 -- |
94 -- A placeholder used in pretty printing
95 --
96 | PrettyPrintForAll [String] Type
97 -- |
98 -- Binary operator application. During the rebracketing phase of desugaring,
99 -- this data constructor will be removed.
100 --
101 | BinaryNoParensType Type Type Type
102 -- |
103 -- Explicit parentheses. During the rebracketing phase of desugaring, this
104 -- data constructor will be removed.
105 --
106 -- Note: although it seems this constructor is not used, it _is_ useful,
107 -- since it prevents certain traversals from matching.
108 --
109 | ParensInType Type
110 deriving (Show, Read, Eq, Ord)
112-- |
113-- A typeclass constraint
114--
115type Constraint = (Qualified (ProperName 'ClassName), [Type])
117$(A.deriveJSON A.defaultOptions ''Type)
119-- |
120-- Convert a row to a list of pairs of labels and types
121--
122rowToList :: Type -> ([(String, Type)], Type)
123rowToList (RCons name ty row) = let (tys, rest) = rowToList row
124 in ((name, ty):tys, rest)
125rowToList r = ([], r)
127-- |
128-- Convert a list of labels and types to a row
129--
130rowFromList :: ([(String, Type)], Type) -> Type
131rowFromList ([], r) = r
132rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
134-- |
135-- Check whether a type is a monotype
136--
137isMonoType :: Type -> Bool
138isMonoType ForAll{} = False
139isMonoType _ = True
141-- |
142-- Universally quantify a type
143--
144mkForAll :: [String] -> Type -> Type
145mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args
147-- |
148-- Replace a type variable, taking into account variable shadowing
149--
150replaceTypeVars :: String -> Type -> Type -> Type
151replaceTypeVars v r = replaceAllTypeVars [(v, r)]
153-- |
154-- Replace named type variables with types
155--
156replaceAllTypeVars :: [(String, Type)] -> Type -> Type
157replaceAllTypeVars = go []
158 where
160 go :: [String] -> [(String, Type)] -> Type -> Type
161 go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m)
162 go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)
163 go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f
164 | v `elem` usedVars =
165 let v' = genName v (keys ++ bs ++ usedVars)
166 t' = go bs [(v, TypeVar v')] t
167 in ForAll v' (go (v' : bs) m t') sco
168 | otherwise = ForAll v (go (v : bs) m t) sco
169 where
170 keys = map fst m
171 usedVars = concatMap (usedTypeVariables . snd) m
172 go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t)
173 go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)
174 go bs m (KindedType t k) = KindedType (go bs m t) k
175 go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3)
176 go bs m (ParensInType t) = ParensInType (go bs m t)
177 go _ _ ty = ty
179 genName orig inUse = try 0
180 where
181 try :: Integer -> String
182 try n | (orig ++ show n) `elem` inUse = try (n + 1)
183 | otherwise = orig ++ show n
185-- |
186-- Collect all type variables appearing in a type
187--
188usedTypeVariables :: Type -> [String]
189usedTypeVariables = nub . everythingOnTypes (++) go
190 where
191 go (TypeVar v) = [v]
192 go _ = []
194-- |
195-- Collect all free type variables appearing in a type
196--
197freeTypeVariables :: Type -> [String]
198freeTypeVariables = nub . go []
199 where
200 go :: [String] -> Type -> [String]
201 go bound (TypeVar v) | v `notElem` bound = [v]
202 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
203 go bound (ForAll v t _) = go (v : bound) t
204 go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t
205 go bound (RCons _ t r) = go bound t ++ go bound r
206 go bound (KindedType t _) = go bound t
207 go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3
208 go bound (ParensInType t) = go bound t
209 go _ _ = []
211-- |
212-- Universally quantify over all type variables appearing free in a type
213--
214quantify :: Type -> Type
215quantify ty = foldr (\arg t -> ForAll arg t Nothing) ty $ freeTypeVariables ty
217-- |
218-- Move all universal quantifiers to the front of a type
219--
220moveQuantifiersToFront :: Type -> Type
221moveQuantifiersToFront = go [] []
222 where
223 go qs cs (ForAll q ty sco) = go ((q, sco) : qs) cs ty
224 go qs cs (ConstrainedType cs' ty) = go qs (cs ++ cs') ty
225 go qs cs ty =
226 let constrained = case cs of
227 [] -> ty
228 cs' -> ConstrainedType cs' ty
229 in case qs of
230 [] -> constrained
231 qs' -> foldl (\ty' (q, sco) -> ForAll q ty' sco) constrained qs'
233-- |
234-- Check if a type contains wildcards
235--
236containsWildcards :: Type -> Bool
237containsWildcards = everythingOnTypes (||) go
238 where
239 go :: Type -> Bool
240 go TypeWildcard = True
241 go _ = False
243--
244-- Traversals
245--
247everywhereOnTypes :: (Type -> Type) -> Type -> Type
248everywhereOnTypes f = go
249 where
250 go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))
251 go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)
252 go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))
253 go (RCons name ty rest) = f (RCons name (go ty) (go rest))
254 go (KindedType ty k) = f (KindedType (go ty) k)
255 go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))
256 go (PrettyPrintObject t) = f (PrettyPrintObject (go t))
257 go (PrettyPrintForAll args t) = f (PrettyPrintForAll args (go t))
258 go (BinaryNoParensType t1 t2 t3) = f (BinaryNoParensType (go t1) (go t2) (go t3))
259 go (ParensInType t) = f (ParensInType (go t))
260 go other = f other
262everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type
263everywhereOnTypesTopDown f = go . f
264 where
265 go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))
266 go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco
267 go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))
268 go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))
269 go (KindedType ty k) = KindedType (go (f ty)) k
270 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))
271 go (PrettyPrintObject t) = PrettyPrintObject (go (f t))
272 go (PrettyPrintForAll args t) = PrettyPrintForAll args (go (f t))
273 go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (f (go t1)) (f (go t2)) (f (go t3))
274 go (ParensInType t) = ParensInType (f (go t))
275 go other = f other
277everywhereOnTypesM :: Monad m => (Type -> m Type) -> Type -> m Type
278everywhereOnTypesM f = go
279 where
280 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f
281 go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f
282 go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f
283 go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f
284 go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f
285 go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f
286 go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f
287 go (PrettyPrintForAll args t) = (PrettyPrintForAll args <$> go t) >>= f
288 go (BinaryNoParensType t1 t2 t3) = (BinaryNoParensType <$> go t1 <*> go t2 <*> go t3) >>= f
289 go (ParensInType t) = (ParensInType <$> go t) >>= f
290 go other = f other
292everywhereOnTypesTopDownM :: Monad m => (Type -> m Type) -> Type -> m Type
293everywhereOnTypesTopDownM f = go <=< f
294 where
295 go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)
296 go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco
297 go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)
298 go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)
299 go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k
300 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)
301 go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)
302 go (PrettyPrintForAll args t) = PrettyPrintForAll args <$> (f t >>= go)
303 go (BinaryNoParensType t1 t2 t3) = BinaryNoParensType <$> (f t1 >>= go) <*> (f t2 >>= go) <*> (f t3 >>= go)
304 go (ParensInType t) = ParensInType <$> (f t >>= go)
305 go other = f other
307everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r
308everythingOnTypes (<>) f = go
309 where
310 go t@(TypeApp t1 t2) = f t <> go t1 <> go t2
311 go t@(ForAll _ ty _) = f t <> go ty
312 go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty
313 go t@(RCons _ ty rest) = f t <> go ty <> go rest
314 go t@(KindedType ty _) = f t <> go ty
315 go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2
316 go t@(PrettyPrintObject t1) = f t <> go t1
317 go t@(PrettyPrintForAll _ t1) = f t <> go t1
318 go t@(BinaryNoParensType t1 t2 t3) = f t <> go t1 <> go t2 <> go t3
319 go t@(ParensInType t1) = f t <> go t1
320 go other = f other
322everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type -> (s, r)) -> Type -> r
323everythingWithContextOnTypes s0 r0 (<>) f = go' s0
324 where
325 go' s t = let (s', r) = f s t in r <> go s' t
326 go s (TypeApp t1 t2) = go' s t1 <> go' s t2
327 go s (ForAll _ ty _) = go' s ty
328 go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty
329 go s (RCons _ ty rest) = go' s ty <> go' s rest
330 go s (KindedType ty _) = go' s ty
331 go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2
332 go s (PrettyPrintObject t1) = go' s t1
333 go s (PrettyPrintForAll _ t1) = go' s t1
334 go s (BinaryNoParensType t1 t2 t3) = go' s t1 <> go' s t2 <> go' s t3
335 go s (ParensInType t1) = go' s t1
336 go _ _ = r0