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