4974c03 · rowtype-yoga/purescript-native

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

on golang help sign in

More tests, be explicit about missing type variable in applySubst.

4974c03Phil Freeman13 years ago

examples/passing/Superclasses3.pursnew file+38

compare with golang

unifiedsplit

@@ -0,0 +1,38 @@

1+module Main where

3+import Debug.Trace

5+import Control.Monad.Eff

7+class (Monad m) <= MonadWriter w m where

8+ tell :: w -> m {}

10+testFunctor :: forall m. (Monad m) => m Number -> m Number

11+testFunctor n = (+) 1 <$> n

12+

13+test :: forall w m. (Monad m, MonadWriter w m) => w -> m {}

14+test w = do

15+ tell w

16+ tell w

17+ tell w

18+

19+data MTrace a = MTrace (Eff (trace :: Trace) a)

20+

21+runMTrace :: forall a. MTrace a -> Eff (trace :: Trace) a

22+runMTrace (MTrace a) = a

23+

24+instance functorMTrace :: Functor MTrace where

25+ (<$>) = liftM1

26+

27+instance applicativeMTrace :: Applicative MTrace where

28+ pure = return

29+ (<*>) = ap

30+

31+instance monadMTrace :: Monad MTrace where

32+ return = MTrace <<< return

33+ (>>=) m f = MTrace (runMTrace m >>= (runMTrace <<< f))

34+

35+instance writerMTrace :: MonadWriter String MTrace where

36+ tell s = MTrace (trace s)

37+

38+main = runMTrace $ test "Done"

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

@@ -39,7 +39,7 @@ typeLiterals = mkPattern match

39 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

40 match (TypeConstructor ctor) = Just $ show ctor

41 match (TUnknown (Unknown u)) = Just $ 'u' : show u

42− match (Skolem s _) = Just $ 's' : show s

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

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

44 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"

45 match REmpty = Just "()"

src/Language/PureScript/TypeChecker/Types.hs+13−12

@@ -116,7 +116,7 @@ unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintT

116 unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do

117 t3 `unifyTypes` t5

118 t4 `unifyTypes` t6

119− unifyTypes' (Skolem s1 _) (Skolem s2 _) | s1 == s2 = return ()

119+ unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()

120 unifyTypes' r1@RCons{} r2 = unifyRows r1 r2

121 unifyTypes' r1 r2@RCons{} = unifyRows r1 r2

122 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

@@ -155,7 +155,7 @@ unifyRows r1 r2 =

155 unifyRows' row r others u'

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

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

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

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

159 unifyRows' sd3 r3 sd4 r4 = throwError . strMsg $ "Cannot unify (" ++ prettyPrintRow (rowFromList (sd3, r3)) ++ ") with (" ++ prettyPrintRow (rowFromList (sd4, r4)) ++ ")"

160

161-- |

@@ -333,7 +333,8 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

333 -- Make sure the types unify with the types in the superclass implication

334 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs

335 -- Finally, satisfy the subclass constraint

336− , suDict <- go trySuperclasses' subclassName (map (applySubst subst . TypeVar) args) ]

336+ , args' <- maybeToList $ mapM (applySubst subst . TypeVar) args

337+ , suDict <- go True subclassName args' ]

337

338

338 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

339 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

339 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

340 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

@@ -364,11 +365,11 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

364 guard (all (pairwise (unifiesWith env) . map snd) grps)

365 guard (all (pairwise (unifiesWith env) . map snd) grps)

365 return $ map head grps

366 return $ map head grps

366 -- Apply a substitution to a type

367 -- Apply a substitution to a type

367− applySubst :: [(String, Type)] -> Type -> Type

368+ applySubst :: [(String, Type)] -> Type -> Maybe Type

368− applySubst subst = everywhere (mkT replace)

369+ applySubst subst = everywhereM (mkM replace)

369 where

370 where

370− replace t@(TypeVar v) = fromMaybe t $ lookup v subst

371+ replace (TypeVar v) = lookup v subst

371− replace other = other

372+ replace other = Just other

372 -- Choose the simplest DictionaryValues from a list of candidates

373 -- Choose the simplest DictionaryValues from a list of candidates

373 -- The reason for this function is as follows:

374 -- The reason for this function is as follows:

374 -- When considering overlapping instances, we don't want to consider the same dictionary

375 -- When considering overlapping instances, we don't want to consider the same dictionary

@@ -399,7 +400,7 @@ pairwise p (x : xs) = all (p x) xs && pairwise p xs

399unifiesWith :: Environment -> Type -> Type -> Bool

400unifiesWith :: Environment -> Type -> Type -> Bool

400unifiesWith _ (TUnknown _) _ = True

401unifiesWith _ (TUnknown _) _ = True

401unifiesWith _ _ (TUnknown _) = True

402unifiesWith _ _ (TUnknown _) = True

402−unifiesWith _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = True

403+unifiesWith _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = True

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

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

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

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

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

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

@@ -415,7 +416,7 @@ unifiesWith _ _ _ = False

415-- and return a substitution from type variables to types which makes the type heads unify.

416-- and return a substitution from type variables to types which makes the type heads unify.

416--

417--

417typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]

418typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]

418−typeHeadsAreEqual _ _ (Skolem s1 _) (Skolem s2 _) | s1 == s2 = Just []

419+typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []

419typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]

420typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]

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

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

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

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

@@ -449,7 +450,7 @@ skolemEscapeCheck root@TypedValue{} =

449 collectSkolems :: Type -> [SkolemScope]

450 collectSkolems :: Type -> [SkolemScope]

450 collectSkolems = nub . everything (++) (mkQ [] collect)

451 collectSkolems = nub . everything (++) (mkQ [] collect)

451 where

452 where

452− collect (Skolem _ scope) = [scope]

453+ collect (Skolem _ _ scope) = [scope]

453 collect _ = []

454 collect _ = []

454 go _ scos = ([], scos)

455 go _ scos = ([], scos)

455 findBindingScope :: SkolemScope -> Maybe Value

456 findBindingScope :: SkolemScope -> Maybe Value

@@ -782,7 +783,7 @@ newSkolemScope = SkolemScope . runUnknown <$> fresh'

782-- Skolemize a type variable by replacing its instances with fresh skolem constants

783-- Skolemize a type variable by replacing its instances with fresh skolem constants

783--

784--

784skolemize :: String -> Int -> SkolemScope -> Type -> Type

785skolemize :: String -> Int -> SkolemScope -> Type -> Type

785−skolemize ident sko scope = replaceTypeVars ident (Skolem sko scope)

786+skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)

786

787

787-- |

788-- |

788-- This function has one purpose - to skolemize type variables appearing in a

789-- This function has one purpose - to skolemize type variables appearing in a

@@ -955,7 +956,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

955 go [] [] REmpty = return []

956 go [] [] REmpty = return []

956 go [] [] u@(TUnknown _) = do u =?= REmpty

957 go [] [] u@(TUnknown _) = do u =?= REmpty

957 return []

958 return []

958− go [] [] (Skolem _ _) | lax = return []

959+ go [] [] (Skolem _ _ _) | lax = return []

959 go [] ((p, _): _) _ | lax = return []

960 go [] ((p, _): _) _ | lax = return []

960 | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))

961 | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))

961 go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))

962 go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))

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

@@ -66,7 +66,7 @@ data Type

66 -- |

67 -- A skolem constant

68 --

69− | Skolem Int SkolemScope

69+ | Skolem String Int SkolemScope

70 -- |

71 -- An empty row

72 --