6dd900a · rowtype-yoga/purescript-native

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

compare with golang

unifiedsplit

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

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

167

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

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

170 extractProperNames _ = []

169 extractProperNames _ = []

171

170

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

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

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

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

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

171 go env [] = return env

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

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

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

174 go env' ms'

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

176 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

178 checkExhaustiveModule env' checked

179 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

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

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

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

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

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

44 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) ++ ">"

46 match REmpty = Just "()"

45 match REmpty = Just "()"

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

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

48 match _ = Nothing

47 match _ = Nothing

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

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

171 where

172 updateType :: Type -> m Type

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

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

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

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

176 updateType t = return t

175 updateType t = return t

177

176

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

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

132--

133-- * Process module imports

134--

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

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

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

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

137 where

138 go :: Declaration -> Check Declaration

139 go (DataDeclaration dtype name args dctors) = do

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

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

182 warnAndRethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do

183 valueIsNotDefined moduleName name

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

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

185 addValue moduleName name ty nameKind

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

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

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

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

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

191 valueIsNotDefined moduleName name

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

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

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

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

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

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

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

273-- required by exported members are also exported.

274--

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

275+typeCheckModule :: Module -> Check Module

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

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

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

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

279− decls' <- typeCheckAll mainModuleName mn exps decls

279+ decls' <- typeCheckAll mn exps decls

280 forM_ exps $ \e -> do

281 checkTypesAreExported e

282 checkClassMembersAreExported e

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

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

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

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

147 <*> 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

151typeHeadsAreEqual _ _ REmpty REmpty = Just []

148typeHeadsAreEqual _ _ REmpty REmpty = Just []

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

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

153 let (s1, r1') = rowToList r1

150 let (s1, r1') = rowToList r1

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

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

46 where

47 checkDups :: Type -> Check ()

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

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

50 checkDups (ForAll _ t _) = checkDups t

49 checkDups (ForAll _ t _) = checkDups t

51 checkDups (ConstrainedType args t) = do

50 checkDups (ConstrainedType args t) = do

52 mapM_ checkDups $ concatMap snd args

51 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)

57 _ <- subsumes Nothing arg2 arg1

58 _ <- subsumes Nothing ret1 ret2

59 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

66subsumes' val (KindedType ty1 _) ty2 =

60subsumes' val (KindedType ty1 _) ty2 =

67 subsumes val ty1 ty2

61 subsumes val ty1 ty2

68subsumes' val ty1 (KindedType ty2 _) =

62subsumes' val ty1 (KindedType ty2 _) =

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

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

9-- Portability :

10--

11-- |

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

12+-- Functions for replacing fully applied type synonyms

13--

14-----------------------------------------------------------------------------

15

16{-# LANGUAGE FlexibleContexts #-}

17{-# LANGUAGE MultiParamTypeClasses #-}

18+{-# LANGUAGE PatternGuards #-}

18{-# LANGUAGE GADTs #-}

19{-# LANGUAGE GADTs #-}

19{-# LANGUAGE CPP #-}

20{-# LANGUAGE CPP #-}

20

21

21module Language.PureScript.TypeChecker.Synonyms (

22module Language.PureScript.TypeChecker.Synonyms (

22− saturateAllTypeSynonyms,

23− desaturateAllTypeSynonyms,

24− replaceAllTypeSynonyms,

23+ replaceAllTypeSynonyms

25− expandAllTypeSynonyms,

26− expandTypeSynonym,

27− expandTypeSynonym'

28) where

24) where

29

25

30import Data.Maybe (fromMaybe)

26import Data.Maybe (fromMaybe)

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

38

34

39import Language.PureScript.Environment

35import Language.PureScript.Environment

40import Language.PureScript.Errors

36import Language.PureScript.Errors

41−import Language.PureScript.Names

42import Language.PureScript.TypeChecker.Monad

37import Language.PureScript.TypeChecker.Monad

43import Language.PureScript.Types

38import Language.PureScript.Types

44

39

45-- |

40-- |

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

41+-- Replace fully applied type synonyms.

47--

42--

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

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

49−buildTypeSubstitution m = go 0 []

44+replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try

50 where

45 where

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

46+ try :: Type -> Either MultipleErrors Type

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

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

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

64

48

65−-- |

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

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

50+ go c args (TypeConstructor ctor)

67−--

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

68−desaturateAllTypeSynonyms :: Type -> Type

52+ , c == length synArgs

69−desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym

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

70− where

54+ in Just <$> try repl

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

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

82− in

56+ , length synArgs > c

83− saturateAllTypeSynonyms syns d

57+ = throwError . errorMessage $ PartiallyAppliedSynonym ctor

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

59+ go _ _ _ = return Nothing

84

60

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

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

86replaceAllTypeSynonyms d = do

62replaceAllTypeSynonyms d = do

87 env <- getEnv

63 env <- getEnv

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

64+ either throwError 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

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

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

67import Language.PureScript.TypeChecker.Unify

68import Language.PureScript.TypeClassDictionaries

69import Language.PureScript.Types

70−import qualified Language.PureScript.Constants as C

71

70

72-- |

71-- |

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

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

74-- type class dictionaries and type annotations.

73-- type class dictionaries and type annotations.

75--

74--

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

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

77−typesOf mainModuleName moduleName vals = do

76+typesOf moduleName vals = do

78 tys <- fmap tidyUp . liftUnifyWarnings replace $ do

77 tys <- fmap tidyUp . liftUnifyWarnings replace $ do

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

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

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

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

79+ ds1 <- parU typed $ \e -> 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

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

86− checkMain (fst e) ty

87− return triple

88 return $ ds1 ++ ds2

81 return $ ds1 ++ ds2

89

82

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

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

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

94 skolemEscapeCheck val'

87 skolemEscapeCheck val'

95 -- Check rows do not contain duplicate labels

88 -- Check rows do not contain duplicate labels

96 checkDuplicateLabels val'

89 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))

102 where

91 where

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

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

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

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

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

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

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

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

107 replace _ em = em

96 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

112

97

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

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

114

99

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

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

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

347 let (props, _) = rowToList row

332 let (props, _) = rowToList row

348 return $ lookup prop props

333 return $ lookup prop props

349−inferProperty (SaturatedTypeSynonym name args) prop = do

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

351− inferProperty replaced prop

352inferProperty (ForAll ident ty _) prop = do

334inferProperty (ForAll ident ty _) prop = do

353 replaced <- replaceVarWithUnknown ident ty

335 replaced <- replaceVarWithUnknown ident ty

354 inferProperty replaced prop

336 inferProperty replaced prop

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

493

475

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

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

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

477 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

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

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

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

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

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

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

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

674 ret' <- maybe fresh return ret

653 ret' <- maybe fresh return ret

675 u =?= function ty ret'

654 u =?= function ty ret'

676 return (ret', App fn arg')

655 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

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

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

681 checkFunctionApplication fn ty arg ret

657 checkFunctionApplication fn ty arg ret

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

658checkFunctionApplication' 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)) $

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

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

71 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

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

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

77 case (sc1, sc2) of

73 case (sc1, sc2) of

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

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

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

132 rest <- fresh

128 rest <- fresh

133 u1 =:= rowFromList (sd2, rest)

129 u1 =:= rowFromList (sd2, rest)

134 u2 =:= rowFromList (sd1, rest)

130 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'

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

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

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

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

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

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

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

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

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

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

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

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

144unifiesWith 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

158unifiesWith _ REmpty REmpty = True

145unifiesWith _ REmpty REmpty = True

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

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

160 let (s1, r1') = rowToList r1

147 let (s1, r1') = rowToList r1

src/Language/PureScript/Types.hs−12

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

66 --

67 | TypeApp Type Type

68 -- |

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

70− --

71− | SaturatedTypeSynonym (Qualified ProperName) [Type]

72− -- |

73 -- Forall quantifier

69 -- Forall quantifier

74 --

70 --

75 | ForAll String Type (Maybe SkolemScope)

71 | ForAll String Type (Maybe SkolemScope)

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

161 Just r -> r

157 Just r -> r

162 Nothing -> TypeVar v

158 Nothing -> TypeVar v

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

159 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

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

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

166 | v `elem` usedVars =

161 | v `elem` usedVars =

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

247everywhereOnTypes f = go

241everywhereOnTypes f = go

248 where

242 where

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

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

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

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

244 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))

245 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))

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

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

261everywhereOnTypesTopDown f = go . f

254everywhereOnTypesTopDown f = go . f

262 where

255 where

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

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

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

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

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

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

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

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

259 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) ->

275everywhereOnTypesM f = go

267everywhereOnTypesM f = go

276 where

268 where

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

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

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

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

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

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

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

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

272 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

289everywhereOnTypesTopDownM f = go <=< f

280everywhereOnTypesTopDownM f = go <=< f

290 where

281 where

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

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

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

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

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

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

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

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

285 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

303everythingOnTypes (<>) f = go

293everythingOnTypes (<>) f = go

304 where

294 where

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

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

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

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

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

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

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

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

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

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

318 where

307 where

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

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

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

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

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

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

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

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

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

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

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