@@ -41,13 +41,11 @@ import Language.PureScript.TypeClassDictionaries
4141import Language.PureScript.Types
4242import qualified Language.PureScript.Constants as C
4343
44−newtype Work = Work Integer deriving (Show, Eq, Ord, Num)
45−
4644-- |
4745-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
4846-- return a type class dictionary reference.
4947--
50−entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Bool -> Check Expr
48+entails :: Environment -> ModuleName -> M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)) -> Constraint -> Check Expr
5149entails env moduleName context = solve
5250 where
5351 forClassName :: Qualified ProperName -> [TypeClassDictionaryInScope]
@@ -56,56 +54,57 @@ entails env moduleName context = solve
5654 findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]
5755 findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context
5856
59− solve :: Constraint -> Bool -> Check Expr
60− solve (className, tys) trySuperclasses = do
61− let dicts = flip evalStateT (Work 0) $ go trySuperclasses className tys
62− checkOverlaps dicts
57+ solve :: Constraint -> Check Expr
58+ solve (className, tys) = do
59+ dict <- go 0 className tys
60+ return $ dictionaryValueToValue dict
6361 where
64− go :: Bool -> Qualified ProperName -> [Type] -> StateT Work [] DictionaryValue
65− go trySuperclasses' className' tys' = do
66− workDone <- get
67− guard $ workDone < 1000
68− modify (1 +)
69− directInstances <|> superclassInstances
62+ go :: Int -> Qualified ProperName -> [Type] -> Check DictionaryValue
63+ go work _ _ | work > 1000 = error "Overworked!"
64+ go work className' tys' = do
65+ let instances = do
66+ tcd <- forClassName className'
67+ -- Make sure the type unifies with the type in the type instance definition
68+ subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
69+ return (subst, tcd)
70+ (subst, tcd) <- unique instances
71+ -- Solve any necessary subgoals
72+ args <- solveSubgoals subst (tcdDependencies tcd)
73+ return $ foldr (\(superclassName, index) dict -> SubclassDictionaryValue dict superclassName index)
74+ (mkDictionary (canonicalizeDictionary tcd) args)
75+ (tcdPath tcd)
7076 where
71− directInstances :: StateT Work [] DictionaryValue
72− directInstances = do
73− tcd <- lift $ forClassName className'
74− -- Make sure the type unifies with the type in the type instance definition
75− subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
76− -- Solve any necessary subgoals
77− args <- solveSubgoals subst (tcdDependencies tcd)
78− return $ mkDictionary (canonicalizeDictionary tcd) args
77+
78+ unique :: [(a, TypeClassDictionaryInScope)] -> Check (a, TypeClassDictionaryInScope)
79+ unique [] = throwError . errorMessage $ NoInstanceFound className' tys'
80+ unique [a] = return a
81+ unique xs@(x : _) | pairwise overlapping (map snd xs) = throwError . errorMessage $ OverlappingInstances className' tys' [] -- include overlaps in error, use simplest instance
82+ | otherwise = return x
7983
80− superclassInstances :: StateT Work [] DictionaryValue
81− superclassInstances = do
82− guard trySuperclasses'
83− (subclassName, (args, _, implies)) <- lift $ M.toList (typeClasses env)
84− -- Try each superclass
85− (index, (superclass, suTyArgs)) <- lift $ zip [0..] implies
86− -- Make sure the type class name matches the superclass name
87− guard $ className' == superclass
88− -- Make sure the types unify with the types in the superclass implication
89− subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
90− -- Finally, satisfy the subclass constraint
91− args' <- lift . maybeToList $ mapM ((`lookup` subst) . fst) args
92− suDict <- go True subclassName args'
93− return $ SubclassDictionaryValue suDict superclass index
84+ -- |
85+ -- Check if two dictionaries are overlapping
86+ --
87+ -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
88+ -- been caught when constructing superclass dictionaries.
89+ overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool
90+ overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False
91+ overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False
92+ overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2
9493
95− -- Create dictionaries for subgoals which still need to be solved by calling go recursively
96− -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
97− -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
98− solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Work [] (Maybe [DictionaryValue])
99− solveSubgoals _ Nothing = return Nothing
100− solveSubgoals subst (Just subgoals) = do
101− dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
102− return $ Just dict
94+ -- Create dictionaries for subgoals which still need to be solved by calling go recursively
95+ -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
96+ -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
97+ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> Check (Maybe [DictionaryValue])
98+ solveSubgoals _ Nothing = return Nothing
99+ solveSubgoals subst (Just subgoals) = do
100+ dict <- mapM (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals
101+ return $ Just dict
103102
104− -- Make a dictionary from subgoal dictionaries by applying the correct function
105− mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
106− mkDictionary fnName Nothing = LocalDictionaryValue fnName
107− mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
108− mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
103+ -- Make a dictionary from subgoal dictionaries by applying the correct function
104+ mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
105+ mkDictionary fnName Nothing = LocalDictionaryValue fnName
106+ mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
107+ mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
109108
110109 -- Turn a DictionaryValue into a Expr
111110 dictionaryValueToValue :: DictionaryValue -> Expr
@@ -122,46 +121,7 @@ entails env moduleName context = solve
122121 let grps = groupBy ((==) `on` fst) subst
123122 guard (all (pairwise (unifiesWith env) . map snd) grps)
124123 return $ map head grps
125− -- |
126− -- Check for overlapping instances
127− --
128− checkOverlaps :: [DictionaryValue] -> Check Expr
129− checkOverlaps dicts =
130− case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of
131− ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys $ nub (map fst ds)
132− _ -> case chooseSimplestDictionaries dicts of
133− [] -> throwError . errorMessage $ NoInstanceFound className tys
134− d : _ -> return $ dictionaryValueToValue d
135− -- Choose the simplest DictionaryValues from a list of candidates
136− -- The reason for this function is as follows:
137− -- When considering overlapping instances, we don't want to consider the same dictionary
138− -- to be an overlap of itself when obtained as a superclass of another class.
139− -- Observing that we probably don't want to select a superclass instance when an instance
140− -- is available directly, and that there is no way for a superclass instance to actually
141− -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
142− -- obtained as superclass instances if there are simpler instances available.
143− chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
144− chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
145− [] -> ds
146− simple -> simple
147− isSimpleDictionaryValue SubclassDictionaryValue{} = False
148− isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
149− isSimpleDictionaryValue _ = True
150− -- |
151− -- Check if two dictionaries are overlapping
152− --
153− -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
154− -- been caught when constructing superclass dictionaries.
155− --
156− overlapping :: DictionaryValue -> DictionaryValue -> Bool
157− overlapping (LocalDictionaryValue nm1) (LocalDictionaryValue nm2) | nm1 == nm2 = False
158− overlapping (GlobalDictionaryValue nm1) (GlobalDictionaryValue nm2) | nm1 == nm2 = False
159− overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2)
160− | nm1 == nm2 = or $ zipWith overlapping ds1 ds2
161− overlapping SubclassDictionaryValue{} _ = False
162− overlapping _ SubclassDictionaryValue{} = False
163− overlapping _ _ = True
164−
124+
165125 valUndefined :: Expr
166126 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
167127