6dd900a · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Expand type synonyms eagerly

commit6dd900ae4ef9e100077df69c5cac3bc2cc2ec399 authorPhil Freeman <paf31@cantab.net> dateSat 26 Sep 2015, 11:58 (11 years ago) parent5f4bf90

12 files changed+35−143

compare with golang

unifiedsplit

src/Language/PureScript/Docs/Convert.hs−1

@@ -166,7 +166,6 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit

166166 unQual x = let (P.Qualified _ y) = x in P.runProperName y

167167

168168 extractProperNames (P.TypeConstructor n) = [unQual n]

169− extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n]

170169 extractProperNames _ = []

171170

172171 childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)

src/Language/PureScript/Make.hs+2−2

@@ -170,11 +170,11 @@ make MakeActions{..} ms = do

170170 go :: Environment -> [(Bool, Module)] -> SupplyT m Environment

171171 go env [] = return env

172172 go env ((False, m) : ms') = do

173− (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m

173+ (_, env') <- lift . runCheck' env $ typeCheckModule m

174174 go env' ms'

175175 go env ((True, m@(Module ss coms moduleName' _ exps)) : ms') = do

176176 lift . progress $ CompilingModule moduleName'

177− (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m

177+ (checked@(Module _ _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule m

178178 checkExhaustiveModule env' checked

179179 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

180180 let mod' = Module ss coms moduleName' regrouped exps

src/Language/PureScript/Pretty/Types.hs−1

@@ -42,7 +42,6 @@ typeLiterals = mkPattern match

4242 match (TUnknown u) = Just $ '_' : show u

4343 match (Skolem name s _) = Just $ name ++ show s

4444 match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> showQualified runProperName pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty

45− match (SaturatedTypeSynonym name args) = Just $ showQualified runProperName name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"

4645 match REmpty = Just "()"

4746 match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")"

4847 match _ = Nothing

src/Language/PureScript/Sugar/Names.hs−1

@@ -171,7 +171,6 @@ renameInModule env imports (Module ss coms mn decls exps) =

171171 where

172172 updateType :: Type -> m Type

173173 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos

174− updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys

175174 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t

176175 updateType t = return t

177176

src/Language/PureScript/TypeChecker.hs+8−8

@@ -132,8 +132,8 @@ checkTypeSynonyms = void . replaceAllTypeSynonyms

132132--

133133-- * Process module imports

134134--

135−typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]

136−typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

135+typeCheckAll :: ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]

136+typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds

137137 where

138138 go :: Declaration -> Check Declaration

139139 go (DataDeclaration dtype name args dctors) = do

@@ -181,7 +181,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

181181 go (ValueDeclaration name nameKind [] (Right val)) =

182182 warnAndRethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do

183183 valueIsNotDefined moduleName name

184− [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]

184+ [(_, (val', ty))] <- typesOf moduleName [(name, val)]

185185 addValue moduleName name ty nameKind

186186 return $ ValueDeclaration name nameKind [] $ Right val'

187187 go (ValueDeclaration{}) = error "Binders were not desugared"

@@ -189,7 +189,7 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

189189 warnAndRethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

190190 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->

191191 valueIsNotDefined moduleName name

192− tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals

192+ tys <- typesOf moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals

193193 vals' <- forM [ (name, val, nameKind, ty)

194194 | (name, nameKind, _) <- vals

195195 , (name', (val, ty)) <- tys

@@ -272,11 +272,11 @@ typeCheckAll mainModuleName moduleName _ ds = mapM go ds <* mapM_ checkOrphanFix

272272-- Type check an entire module and ensure all types and classes defined within the module that are

273273-- required by exported members are also exported.

274274--

275−typeCheckModule :: Maybe ModuleName -> Module -> Check Module

276−typeCheckModule _ (Module _ _ _ _ Nothing) = error "exports should have been elaborated"

277−typeCheckModule mainModuleName (Module ss coms mn decls (Just exps)) = warnAndRethrow (onErrorMessages (ErrorInModule mn)) $ do

275+typeCheckModule :: Module -> Check Module

276+typeCheckModule (Module _ _ _ _ Nothing) = error "exports should have been elaborated"

277+typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (onErrorMessages (ErrorInModule mn)) $ do

278278 modify (\s -> s { checkCurrentModule = Just mn })

279− decls' <- typeCheckAll mainModuleName mn exps decls

279+ decls' <- typeCheckAll mn exps decls

280280 forM_ exps $ \e -> do

281281 checkTypesAreExported e

282282 checkClassMembersAreExported e

src/Language/PureScript/TypeChecker/Entailment.hs−3

@@ -145,9 +145,6 @@ typeHeadsAreEqual _ _ t (TypeVar v) = Jus

145145typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

146146typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2

147147 <*> typeHeadsAreEqual m e t1 t2

148−typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of

149− Left _ -> Nothing

150− Right t1 -> typeHeadsAreEqual m e t1 t2

151148typeHeadsAreEqual _ _ REmpty REmpty = Just []

152149typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) =

153150 let (s1, r1') = rowToList r1

src/Language/PureScript/TypeChecker/Rows.hs−1

@@ -46,7 +46,6 @@ checkDuplicateLabels =

4646 where

4747 checkDups :: Type -> Check ()

4848 checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2

49− checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts

5049 checkDups (ForAll _ t _) = checkDups t

5150 checkDups (ConstrainedType args t) = do

5251 mapM_ checkDups $ concatMap snd args

src/Language/PureScript/TypeChecker/Subsumption.hs−6

@@ -57,12 +57,6 @@ subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2)

5757 _ <- subsumes Nothing arg2 arg1

5858 _ <- subsumes Nothing ret1 ret2

5959 return val

60−subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do

61− ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

62− subsumes val ty1 ty2

63−subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do

64− ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

65− subsumes val ty1 ty2

6660subsumes' val (KindedType ty1 _) ty2 =

6761 subsumes val ty1 ty2

6862subsumes' val ty1 (KindedType ty2 _) =

src/Language/PureScript/TypeChecker/Synonyms.hs+20−66

@@ -9,22 +9,18 @@

99-- Portability :

1010--

1111-- |

12−-- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor

12+-- Functions for replacing fully applied type synonyms

1313--

1414-----------------------------------------------------------------------------

1515

1616{-# LANGUAGE FlexibleContexts #-}

1717{-# LANGUAGE MultiParamTypeClasses #-}

18+{-# LANGUAGE PatternGuards #-}

1819{-# LANGUAGE GADTs #-}

1920{-# LANGUAGE CPP #-}

2021

2122module Language.PureScript.TypeChecker.Synonyms (

22− saturateAllTypeSynonyms,

23− desaturateAllTypeSynonyms,

24− replaceAllTypeSynonyms,

25− expandAllTypeSynonyms,

26− expandTypeSynonym,

27− expandTypeSynonym'

23+ replaceAllTypeSynonyms

2824) where

2925

3026import Data.Maybe (fromMaybe)

@@ -38,73 +34,31 @@ import Control.Monad.State

3834

3935import Language.PureScript.Environment

4036import Language.PureScript.Errors

41−import Language.PureScript.Names

4237import Language.PureScript.TypeChecker.Monad

4338import Language.PureScript.Types

4439

4540-- |

46−-- Build a type substitution for a type synonym

41+-- Replace fully applied type synonyms.

4742--

48−buildTypeSubstitution :: M.Map (Qualified ProperName) Int -> Type -> Either ErrorMessage (Maybe Type)

49−buildTypeSubstitution m = go 0 []

43+replaceAllTypeSynonyms' :: Environment -> Type -> Either MultipleErrors Type

44+replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try

5045 where

51− go :: Int -> [Type] -> Type -> Either ErrorMessage (Maybe Type)

52− go c args (TypeConstructor ctor) | M.lookup ctor m == Just c = return (Just $ SaturatedTypeSynonym ctor args)

53− go c _ (TypeConstructor ctor) | M.lookup ctor m > Just c = throwError $ SimpleErrorWrapper $ PartiallyAppliedSynonym ctor

54− go c args (TypeApp f arg) = go (c + 1) (arg:args) f

55− go _ _ _ = return Nothing

56−

57−-- |

58−-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor

59−--

60−saturateAllTypeSynonyms :: M.Map (Qualified ProperName) Int -> Type -> Either ErrorMessage Type

61−saturateAllTypeSynonyms syns = everywhereOnTypesTopDownM replace

62− where

63− replace t = fromMaybe t <$> buildTypeSubstitution syns t

46+ try :: Type -> Either MultipleErrors Type

47+ try t = fromMaybe t <$> go 0 [] t

6448

65−-- |

66−-- \"Desaturate\" @SaturatedTypeSynonym@s

67−--

68−desaturateAllTypeSynonyms :: Type -> Type

69−desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym

70− where

71− replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args

72− replaceSaturatedTypeSynonym t = t

73−

74−-- |

75−-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate

76−-- better error messages during unification.

77−--

78−replaceAllTypeSynonyms' :: Environment -> Type -> Either ErrorMessage Type

79−replaceAllTypeSynonyms' env d =

80− let

81− syns = length . fst <$> typeSynonyms env

82− in

83− saturateAllTypeSynonyms syns d

49+ go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type)

50+ go c args (TypeConstructor ctor)

51+ | Just (synArgs, body) <- M.lookup ctor (typeSynonyms env)

52+ , c == length synArgs

53+ = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body

54+ in Just <$> try repl

55+ | Just (synArgs, _) <- M.lookup ctor (typeSynonyms env)

56+ , length synArgs > c

57+ = throwError . errorMessage $ PartiallyAppliedSynonym ctor

58+ go c args (TypeApp f arg) = go (c + 1) (arg : args) f

59+ go _ _ _ = return Nothing

8460

8561replaceAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

8662replaceAllTypeSynonyms d = do

8763 env <- getEnv

88− either (throwError . singleError) return $ replaceAllTypeSynonyms' env d

89−

90−-- |

91−-- Replace a type synonym and its arguments with the aliased type

92−--

93−expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either ErrorMessage Type

94−expandTypeSynonym' env name args =

95− case M.lookup name (typeSynonyms env) of

96− Just (synArgs, body) -> do

97− let repl = replaceAllTypeVars (zip (map fst synArgs) args) body

98− replaceAllTypeSynonyms' env repl

99− Nothing -> error "Type synonym was not defined"

100−

101−expandTypeSynonym :: (e ~ MultipleErrors, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type

102−expandTypeSynonym name args = do

103− env <- getEnv

104− either (throwError . singleError) return $ expandTypeSynonym' env name args

105−

106−expandAllTypeSynonyms :: (e ~ MultipleErrors, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type

107−expandAllTypeSynonyms = everywhereOnTypesTopDownM go

108− where

109− go (SaturatedTypeSynonym name args) = expandTypeSynonym name args

110− go other = return other

64+ either throwError return $ replaceAllTypeSynonyms' env d

src/Language/PureScript/TypeChecker/Types.hs+5−29

@@ -67,24 +67,17 @@ import Language.PureScript.TypeChecker.Synonyms

6767import Language.PureScript.TypeChecker.Unify

6868import Language.PureScript.TypeClassDictionaries

6969import Language.PureScript.Types

70−import qualified Language.PureScript.Constants as C

7170

7271-- |

7372-- Infer the types of multiple mutually-recursive values, and return elaborated values including

7473-- type class dictionaries and type annotations.

7574--

76−typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]

77−typesOf mainModuleName moduleName vals = do

75+typesOf :: ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]

76+typesOf moduleName vals = do

7877 tys <- fmap tidyUp . liftUnifyWarnings replace $ do

7978 (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

80− ds1 <- parU typed $ \e -> do

81− triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict

82− checkMain (fst e) ty

83− return triple

84− ds2 <- forM untyped $ \e -> do

85− triple@(_, (_, ty)) <- typeForBindingGroupElement e dict untypedDict

86− checkMain (fst e) ty

87− return triple

79+ ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict

80+ ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict

8881 return $ ds1 ++ ds2

8982

9083 forM tys $ \(ident, (val, ty)) -> do

@@ -94,21 +87,13 @@ typesOf mainModuleName moduleName vals = do

9487 skolemEscapeCheck val'

9588 -- Check rows do not contain duplicate labels

9689 checkDuplicateLabels val'

97− -- Remove type synonyms placeholders, and replace

98− -- top-level unification variables with named type variables.

99− let val'' = overTypes desaturateAllTypeSynonyms val'

100− ty' = varIfUnknown . desaturateAllTypeSynonyms $ ty

101− return (ident, (val'', ty'))

90+ return (ident, (val', varIfUnknown ty))

10291 where

10392 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

10493 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

10594 -- Replace all the wildcards types with their inferred types

10695 replace sub (SimpleErrorWrapper (WildcardInferredType ty)) = SimpleErrorWrapper $ WildcardInferredType (sub $? ty)

10796 replace _ em = em

108− -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

109− checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do

110− [eff, a] <- replicateM 2 fresh

111− ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a

11297

11398type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)

11499

@@ -346,9 +331,6 @@ inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type)

346331inferProperty (TypeApp obj row) prop | obj == tyObject = do

347332 let (props, _) = rowToList row

348333 return $ lookup prop props

349−inferProperty (SaturatedTypeSynonym name args) prop = do

350− replaced <- introduceSkolemScope <=< expandTypeSynonym name $ args

351− inferProperty replaced prop

352334inferProperty (ForAll ident ty _) prop = do

353335 replaced <- replaceVarWithUnknown ident ty

354336 inferProperty replaced prop

@@ -493,9 +475,6 @@ check' val t@(ConstrainedType constraints ty) = do

493475

494476 instantiateSuperclass :: [String] -> [Type] -> [Type] -> [Type]

495477 instantiateSuperclass args supArgs tys = map (replaceAllTypeVars (zip args tys)) supArgs

496−check' val (SaturatedTypeSynonym name args) = do

497− ty <- introduceSkolemScope <=< expandTypeSynonym name $ args

498− check val ty

499478check' val u@(TUnknown _) = do

500479 val'@(TypedValue _ _ ty) <- infer val

501480 -- Don't unify an unknown with an inferred polytype

@@ -674,9 +653,6 @@ checkFunctionApplication' fn u@(TUnknown _) arg ret = do

674653 ret' <- maybe fresh return ret

675654 u =?= function ty ret'

676655 return (ret', App fn arg')

677−checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do

678− ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs

679− checkFunctionApplication fn ty arg ret

680656checkFunctionApplication' fn (KindedType ty _) arg ret =

681657 checkFunctionApplication fn ty arg ret

682658checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do

src/Language/PureScript/TypeChecker/Unify.hs−13

@@ -69,10 +69,6 @@ unifyTypes t1 t2 = rethrow (onErrorMessages (ErrorUnifyingTypes t1 t2)) $

6969 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()

7070 unifyTypes' (TUnknown u) t = u =:= t

7171 unifyTypes' t (TUnknown u) = u =:= t

72− unifyTypes' (SaturatedTypeSynonym name args) ty = do

73− ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ args

74− ty1 `unifyTypes` ty

75− unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty

7672 unifyTypes' (ForAll ident1 ty1 sc1) (ForAll ident2 ty2 sc2) =

7773 case (sc1, sc2) of

7874 (Just sc1', Just sc2') -> do

@@ -132,10 +128,6 @@ unifyRows r1 r2 =

132128 rest <- fresh

133129 u1 =:= rowFromList (sd2, rest)

134130 u2 =:= rowFromList (sd1, rest)

135− unifyRows' sd1 (SaturatedTypeSynonym name args) sd2 r2' = do

136− r1' <- expandTypeSynonym name $ args

137− unifyRows (rowFromList (sd1, r1')) (rowFromList (sd2, r2'))

138− unifyRows' sd1 r1' sd2 r2'@(SaturatedTypeSynonym _ _) = unifyRows' sd2 r2' sd1 r1'

139131 unifyRows' [] REmpty [] REmpty = return ()

140132 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

141133 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()

@@ -150,11 +142,6 @@ unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True

150142unifiesWith _ (TypeVar v1) (TypeVar v2) | v1 == v2 = True

151143unifiesWith _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True

152144unifiesWith e (TypeApp h1 t1) (TypeApp h2 t2) = unifiesWith e h1 h2 && unifiesWith e t1 t2

153−unifiesWith e (SaturatedTypeSynonym name args) t2 =

154− case expandTypeSynonym' e name args of

155− Left _ -> False

156− Right t1 -> unifiesWith e t1 t2

157−unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1

158145unifiesWith _ REmpty REmpty = True

159146unifiesWith e r1@(RCons _ _ _) r2@(RCons _ _ _) =

160147 let (s1, r1') = rowToList r1

src/Language/PureScript/Types.hs−12

@@ -66,10 +66,6 @@ data Type

6666 --

6767 | TypeApp Type Type

6868 -- |

69− -- A type synonym which is \"saturated\", i.e. fully applied

70− --

71− | SaturatedTypeSynonym (Qualified ProperName) [Type]

72− -- |

7369 -- Forall quantifier

7470 --

7571 | ForAll String Type (Maybe SkolemScope)

@@ -161,7 +157,6 @@ replaceAllTypeVars = go []

161157 Just r -> r

162158 Nothing -> TypeVar v

163159 go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)

164− go bs m (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs m) ts

165160 go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f

166161 | v `elem` usedVars =

167162 let v' = genName v (keys ++ bs ++ usedVars)

@@ -200,7 +195,6 @@ freeTypeVariables = nub . go []

200195 go :: [String] -> Type -> [String]

201196 go bound (TypeVar v) | v `notElem` bound = [v]

202197 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2

203− go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts

204198 go bound (ForAll v t _) = go (v : bound) t

205199 go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t

206200 go bound (RCons _ t r) = go bound t ++ go bound r

@@ -247,7 +241,6 @@ everywhereOnTypes :: (Type -> Type) -> Type -> Type

247241everywhereOnTypes f = go

248242 where

249243 go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))

250− go (SaturatedTypeSynonym name tys) = f (SaturatedTypeSynonym name (map go tys))

251244 go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)

252245 go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))

253246 go (RCons name ty rest) = f (RCons name (go ty) (go rest))

@@ -261,7 +254,6 @@ everywhereOnTypesTopDown :: (Type -> Type) -> Type -> Type

261254everywhereOnTypesTopDown f = go . f

262255 where

263256 go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))

264− go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name (map (go . f) tys)

265257 go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco

266258 go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))

267259 go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))

@@ -275,7 +267,6 @@ everywhereOnTypesM :: (Functor m, Applicative m, Monad m) => (Type -> m Type) ->

275267everywhereOnTypesM f = go

276268 where

277269 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f

278− go (SaturatedTypeSynonym name tys) = (SaturatedTypeSynonym name <$> mapM go tys) >>= f

279270 go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f

280271 go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f

281272 go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f

@@ -289,7 +280,6 @@ everywhereOnTypesTopDownM :: (Functor m, Applicative m, Monad m) => (Type -> m T

289280everywhereOnTypesTopDownM f = go <=< f

290281 where

291282 go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)

292− go (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name <$> mapM (go <=< f) tys

293283 go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco

294284 go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)

295285 go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)

@@ -303,7 +293,6 @@ everythingOnTypes :: (r -> r -> r) -> (Type -> r) -> Type -> r

303293everythingOnTypes (<>) f = go

304294 where

305295 go t@(TypeApp t1 t2) = f t <> go t1 <> go t2

306− go t@(SaturatedTypeSynonym _ tys) = foldl (<>) (f t) (map go tys)

307296 go t@(ForAll _ ty _) = f t <> go ty

308297 go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty

309298 go t@(RCons _ ty rest) = f t <> go ty <> go rest

@@ -318,7 +307,6 @@ everythingWithContextOnTypes s0 r0 (<>) f = go' s0

318307 where

319308 go' s t = let (s', r) = f s t in r <> go s' t

320309 go s (TypeApp t1 t2) = go' s t1 <> go' s t2

321− go s (SaturatedTypeSynonym _ tys) = foldl (<>) r0 (map (go' s) tys)

322310 go s (ForAll _ ty _) = go' s ty

323311 go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty

324312 go s (RCons _ ty rest) = go' s ty <> go' s rest