@@ -41,13 +41,11 @@ import Language.PureScript.TypeClassDictionaries
41import Language.PureScript.Types
41import Language.PureScript.Types
42import qualified Language.PureScript.Constants as C
42import qualified Language.PureScript.Constants as C
44−newtype Work = Work Integer deriving (Show, Eq, Ord, Num)
47-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
45-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
48-- return a type class dictionary reference.
46-- return a type class dictionary reference.
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
51entails env moduleName context = solve
49entails env moduleName context = solve
53 forClassName :: Qualified ProperName -> [TypeClassDictionaryInScope]
51 forClassName :: Qualified ProperName -> [TypeClassDictionaryInScope]
@@ -56,56 +54,57 @@ entails env moduleName context = solve
56 findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]
54 findDicts :: Qualified ProperName -> Maybe ModuleName -> [TypeClassDictionaryInScope]
57 findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context
55 findDicts cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup context
59− solve :: Constraint -> Bool -> Check Expr
57+ solve :: Constraint -> Check Expr
60− solve (className, tys) trySuperclasses = do
58+ solve (className, tys) = do
61− let dicts = flip evalStateT (Work 0) $ go trySuperclasses className tys
59+ dict <- go 0 className tys
62− checkOverlaps dicts
60+ return $ dictionaryValueToValue dict
64− go :: Bool -> Qualified ProperName -> [Type] -> StateT Work [] DictionaryValue
62+ go :: Int -> Qualified ProperName -> [Type] -> Check DictionaryValue
65− go trySuperclasses' className' tys' = do
63+ go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
66− workDone <- get
64+ go work className' tys' = do
67− guard $ workDone < 1000
65+ let instances = do
68− modify (1 +)
66+ tcd <- forClassName className'
69− directInstances <|> superclassInstances
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)
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)
71− directInstances :: StateT Work [] DictionaryValue
77+
72− directInstances = do
78+ unique :: [(a, TypeClassDictionaryInScope)] -> Check (a, TypeClassDictionaryInScope)
73− tcd <- lift $ forClassName className'
79+ unique [] = throwError . errorMessage $ NoInstanceFound className' tys'
74− -- Make sure the type unifies with the type in the type instance definition
80+ unique [a] = return a
75− subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
81+ unique tcds | pairwise overlapping (map snd tcds) = throwError . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds)
76− -- Solve any necessary subgoals
82+ | otherwise = return (minimumBy (compare `on` length . tcdPath . snd) tcds)
77− args <- solveSubgoals subst (tcdDependencies tcd)
78− return $ mkDictionary (canonicalizeDictionary tcd) args
80− superclassInstances :: StateT Work [] DictionaryValue
84+ -- |
81− superclassInstances = do
85+ -- Check if two dictionaries are overlapping
82− guard trySuperclasses'
86+ --
83− (subclassName, (args, _, implies)) <- lift $ M.toList (typeClasses env)
87+ -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
84− -- Try each superclass
88+ -- been caught when constructing superclass dictionaries.
85− (index, (superclass, suTyArgs)) <- lift $ zip [0..] implies
89+ overlapping :: TypeClassDictionaryInScope -> TypeClassDictionaryInScope -> Bool
86− -- Make sure the type class name matches the superclass name
90+ overlapping TypeClassDictionaryInScope{ tcdPath = _ : _ } _ = False
87− guard $ className' == superclass
91+ overlapping _ TypeClassDictionaryInScope{ tcdPath = _ : _ } = False
88− -- Make sure the types unify with the types in the superclass implication
92+ overlapping tcd1 tcd2 = tcdName tcd1 /= tcdName tcd2
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
95− -- Create dictionaries for subgoals which still need to be solved by calling go recursively
94+ -- 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
95+ -- 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.
96+ -- 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])
97+ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> Check (Maybe [DictionaryValue])
99− solveSubgoals _ Nothing = return Nothing
98+ solveSubgoals _ Nothing = return Nothing
100− solveSubgoals subst (Just subgoals) = do
99+ solveSubgoals subst (Just subgoals) = do
101− dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
100+ dict <- mapM (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals
102− return $ Just dict
101+ return $ Just dict
104− -- Make a dictionary from subgoal dictionaries by applying the correct function
103+ -- Make a dictionary from subgoal dictionaries by applying the correct function
105− mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
104+ mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
106− mkDictionary fnName Nothing = LocalDictionaryValue fnName
105+ mkDictionary fnName Nothing = LocalDictionaryValue fnName
107− mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
106+ mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
108− mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
107+ mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
110 -- Turn a DictionaryValue into a Expr
109 -- Turn a DictionaryValue into a Expr
111 dictionaryValueToValue :: DictionaryValue -> Expr
110 dictionaryValueToValue :: DictionaryValue -> Expr
@@ -122,46 +121,7 @@ entails env moduleName context = solve
122 let grps = groupBy ((==) `on` fst) subst
121 let grps = groupBy ((==) `on` fst) subst
123 guard (all (pairwise (unifiesWith env) . map snd) grps)
122 guard (all (pairwise (unifiesWith env) . map snd) grps)
124 return $ map head grps
123 return $ map head grps
126− -- Check for overlapping instances
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
147− isSimpleDictionaryValue SubclassDictionaryValue{} = False
148− isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
149− isSimpleDictionaryValue _ = True
151− -- Check if two dictionaries are overlapping
153− -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
154− -- been caught when constructing superclass dictionaries.
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
165 valUndefined :: Expr
125 valUndefined :: Expr
166 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
126 valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))