4974c03 · rowtype-yoga/purescript-native

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

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

commit4974c03e31098f873722205640eac6c050c36519 authorPhil Freeman <paf31@cantab.net> dateSun 6 Apr 2014, 13:15 (13 years ago) parent5d19bd9

4 files changed+53−14

compare with golang

unifiedsplit

examples/passing/Superclasses3.purs+38 src/Language/PureScript/Pretty/Types.hs+1−1 src/Language/PureScript/TypeChecker/Types.hs+13−12 src/Language/PureScript/Types.hs+1−1

examples/passing/Superclasses3.pursnew file+38

@@ -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

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

4040 match (TypeConstructor ctor) = Just $ show ctor

4141 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

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

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

4545 match REmpty = Just "()"

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

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

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

117117 t3 `unifyTypes` t5

118118 t4 `unifyTypes` t6

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

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

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

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

122122 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

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

155155 unifyRows' row r others u'

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

157157 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 ()

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

160160

161161-- |

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

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

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

335335 -- 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' ]

337338

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

339340 -- 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

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

365366 return $ map head grps

366367 -- Apply a substitution to a type

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

368− applySubst subst = everywhere (mkT replace)

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

369+ applySubst subst = everywhereM (mkM replace)

369370 where

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

371− replace other = other

371+ replace (TypeVar v) = lookup v subst

372+ replace other = Just other

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

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

374375 -- 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

399400unifiesWith :: Environment -> Type -> Type -> Bool

400401unifiesWith _ (TUnknown _) _ = True

401402unifiesWith _ _ (TUnknown _) = True

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

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

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

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

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

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

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

416417--

417418typeHeadsAreEqual :: 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 []

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

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

421422typeHeadsAreEqual 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{} =

449450 collectSkolems :: Type -> [SkolemScope]

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

451452 where

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

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

453454 collect _ = []

454455 go _ scos = ([], scos)

455456 findBindingScope :: SkolemScope -> Maybe Value

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

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

783784--

784785skolemize :: 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)

786787

787788-- |

788789-- 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

955956 go [] [] REmpty = return []

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

957958 return []

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

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

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

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

961962 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

6666 -- |

6767 -- A skolem constant

6868 --

69− | Skolem Int SkolemScope

69+ | Skolem String Int SkolemScope

7070 -- |

7171 -- An empty row

7272 --