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