git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix #438 and #979
53359aaPhil Freeman
examples/failing/438.pursnew file+9
compare with golang
unifiedsplit
@@ -0,0 +1,9 @@
1+module Main where
2+
3+data Fix f = In (f (Fix f))
4+
5+instance eqFix :: (Eq (f (Fix f))) => Eq (Fix f) where
6+ (==) (In f) (In g) = f == g
7+ (/=) a b = not (a == b)
8+
9+example = In [] == In []
src/Language/PureScript/TypeChecker/Entailment.hs+43−26
@@ -13,6 +13,8 @@
13--
13--
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15
15
16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17+
16module Language.PureScript.TypeChecker.Entailment (
18module Language.PureScript.TypeChecker.Entailment (
17 entails
19 entails
18) where
20) where
@@ -26,6 +28,7 @@ import qualified Data.Map as M
26import Control.Applicative
28import Control.Applicative
27import Control.Arrow (Arrow(..))
29import Control.Arrow (Arrow(..))
28import Control.Monad.Except
30import Control.Monad.Except
31+import Control.Monad.State
29
32
30import Language.PureScript.AST
33import Language.PureScript.AST
31import Language.PureScript.Errors
34import Language.PureScript.Errors
@@ -38,6 +41,8 @@ import Language.PureScript.TypeClassDictionaries
38import Language.PureScript.Types
41import Language.PureScript.Types
39import qualified Language.PureScript.Constants as C
42import qualified Language.PureScript.Constants as C
40
43
44+newtype Work = Work Integer deriving (Show, Eq, Ord, Num)
45+
41-- |
46-- |
42-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
47-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
43-- return a type class dictionary reference.
48-- return a type class dictionary reference.
@@ -54,47 +59,59 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
54 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
59 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
55 filterModule _ = False
60 filterModule _ = False
56
61
62+ solve :: [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
57− solve context' (className, tys) trySuperclasses =
63+ solve context' (className, tys) trySuperclasses = do
58− checkOverlaps $ go trySuperclasses className tys
64+ let dicts = flip evalStateT (Work 0) $ go trySuperclasses className tys
65+ checkOverlaps dicts
59 where
66 where
67+ go :: Bool -> Qualified ProperName -> [Type] -> StateT Work [] DictionaryValue
60− go trySuperclasses' className' tys' =
68+ go trySuperclasses' className' tys' = do
61− -- Look for regular type instances
69+ workDone <- get
62− [ mkDictionary (canonicalizeDictionary tcd) args
70+ guard $ workDone < 1000
71+ modify (1 +)
72+ directInstances <|> superclassInstances
73+ where
74+ directInstances :: StateT Work [] DictionaryValue
75+ directInstances = do
63− | tcd <- context'
76+ tcd <- lift context'
64− -- Make sure the type class name matches the one we are trying to satisfy
77+ -- Make sure the type class name matches the one we are trying to satisfy
65− , className' == tcdClassName tcd
78+ guard $ className' == tcdClassName tcd
66− -- Make sure the type unifies with the type in the type instance definition
79+ -- Make sure the type unifies with the type in the type instance definition
67− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
80+ subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
68− -- Solve any necessary subgoals
81+ -- Solve any necessary subgoals
69− , args <- solveSubgoals subst (tcdDependencies tcd) ] ++
82+ args <- solveSubgoals subst (tcdDependencies tcd)
83+ return $ mkDictionary (canonicalizeDictionary tcd) args
70
84
71− -- Look for implementations via superclasses
85+ superclassInstances :: StateT Work [] DictionaryValue
72− [ SubclassDictionaryValue suDict superclass index
86+ superclassInstances = do
73− | trySuperclasses'
87+ guard trySuperclasses'
74− , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
88+ (subclassName, (args, _, implies)) <- lift $ M.toList (typeClasses env)
75− -- Try each superclass
89+ -- Try each superclass
76− , (index, (superclass, suTyArgs)) <- zip [0..] implies
90+ (index, (superclass, suTyArgs)) <- lift $ zip [0..] implies
77− -- Make sure the type class name matches the superclass name
91+ -- Make sure the type class name matches the superclass name
78− , className' == superclass
92+ guard $ className' == superclass
79− -- Make sure the types unify with the types in the superclass implication
93+ -- Make sure the types unify with the types in the superclass implication
80− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
94+ subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
81− -- Finally, satisfy the subclass constraint
95+ -- Finally, satisfy the subclass constraint
82− , args' <- maybeToList $ mapM ((`lookup` subst) . fst) args
96+ args' <- lift . maybeToList $ mapM ((`lookup` subst) . fst) args
83− , suDict <- go True subclassName args' ]
97+ suDict <- go True subclassName args'
98+ return $ SubclassDictionaryValue suDict superclass index
84
99
85 -- Create dictionaries for subgoals which still need to be solved by calling go recursively
100 -- Create dictionaries for subgoals which still need to be solved by calling go recursively
86 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
101 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
87 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
102 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
88− solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> [Maybe [DictionaryValue]]
103+ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Work [] (Maybe [DictionaryValue])
89 solveSubgoals _ Nothing = return Nothing
104 solveSubgoals _ Nothing = return Nothing
90 solveSubgoals subst (Just subgoals) = do
105 solveSubgoals subst (Just subgoals) = do
91 dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
106 dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
92 return $ Just dict
107 return $ Just dict
108+
93 -- Make a dictionary from subgoal dictionaries by applying the correct function
109 -- Make a dictionary from subgoal dictionaries by applying the correct function
94 mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
110 mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
95 mkDictionary fnName Nothing = LocalDictionaryValue fnName
111 mkDictionary fnName Nothing = LocalDictionaryValue fnName
96 mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
112 mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
97 mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
113 mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
114+
98 -- Turn a DictionaryValue into a Expr
115 -- Turn a DictionaryValue into a Expr
99 dictionaryValueToValue :: DictionaryValue -> Expr
116 dictionaryValueToValue :: DictionaryValue -> Expr
100 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
117 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName