@@ -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. MapMaybe ModuleName ) (M. MapQualified ProperName ) (M. MapQualified Ident ) TypeClassDictionaryInScope )) -> Constraint -> Bool -> Check Expr
48+ entails :: Environment -> ModuleName -> M. MapMaybe ModuleName ) (M. MapQualified ProperName ) (M. MapQualified 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 className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'
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 tcds | pairwise overlapping (map snd tcds) = throwError . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd ) tcds)
82+ | otherwise = return (minimumBy (compare `on` length . tcdPath . snd ) tcds)
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
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
0 commit comments