5d19bd9 · rowtype-yoga/purescript-native

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

on golang help sign in

Fix issue with type variables in super class dictionary types. Simplify desugaring somewhat, add more examples

5d19bd9Phil Freeman13 years ago

examples/failing/Superclasses2.pursnew file+9

compare with golang

unifiedsplit

@@ -0,0 +1,9 @@

1+module CycleInSuperclasses where

3+class (Foo a) <= Bar a

5+class (Bar a) <= Foo a

7+instance barString :: Bar String

9+instance fooString :: Foo String

examples/failing/Superclasses3.pursnew file+5

@@ -0,0 +1,5 @@

1+module UnknownSuperclassTypeVar where

3+class Foo a

5+class (Foo b) <= Bar a

examples/passing/EqOrd.pursnew file+14

@@ -0,0 +1,14 @@

1+module Main where

3+data Pair a b = Pair a b

5+instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where

6+ compare (Pair a1 b1) (Pair a2 b2) = case compare a1 a2 of

7+ EQ -> compare b1 b2

8+ r -> r

10+instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where

11+ (==) (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2

12+ (/=) (Pair a1 b1) (Pair a2 b2) = a1 /= a2 || b1 /= b2

13+

14+main = Debug.Trace.print $ Pair 1 2 == Pair 1 2

src/Language/PureScript/Declarations.hs+5−1

@@ -333,7 +333,11 @@ data Value

333 -- at superclass implementations when searching for a dictionary, the type class name and

334 -- instance type, and the type class dictionaries in scope.

335 --

336− | TypeClassDictionary Bool (Qualified ProperName, [Type]) (Maybe [TypeClassDictionaryInScope])

336+ | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]

337+ -- |

338+ -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking

339+ --

340+ | SuperClassDictionary (Qualified ProperName) [Type]

337 -- |

341 -- |

338 -- A value with source position information

342 -- A value with source position information

339 --

343 --

src/Language/PureScript/Pretty/Values.hs+1

@@ -74,6 +74,7 @@ literals = mkPattern' match

74 , currentIndent

75 ]

76 match (TypeClassDictionary _ _ _) = return "<<dict>>"

77+ match (SuperClassDictionary _ _) = return "<<superclass dict>>"

77 match (TypedValue _ val _) = prettyPrintValue' val

78 match (TypedValue _ val _) = prettyPrintValue' val

78 match (PositionedValue _ val) = prettyPrintValue' val

79 match (PositionedValue _ val) = prettyPrintValue' val

79 match _ = mzero

80 match _ = mzero

src/Language/PureScript/Sugar/TypeClasses.hs+30−22

@@ -98,19 +98,18 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"

98--

99-- ...

100--

101−-- subString :: {} -> { __superclasses :: [{}], sub :: String }

101+-- subString :: {} -> { __superclasses :: { "Foo": {} -> Foo String }, sub :: String }

102-- subString _ = {

103+-- __superclasses: {

103−-- __superclasses: [\<dictionary placeholder to be inserted during type checking\>]

104+-- "Foo": \_ -> <dictionary placeholder to be inserted during type checking\>

105+-- }

104-- sub: ""

106-- sub: ""

105-- }

107-- }

106--

108--

107−-- Here, the __superclasses property is not typechecked (it is not even well-typed, since its

108−-- entries might be dictionaries of different types).

109−--

110desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])

109desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])

111−desugarDecl mn d@(TypeClassDeclaration name args _ members) = do

110+desugarDecl mn d@(TypeClassDeclaration name args implies members) = do

112 modify (M.insert (mn, name) d)

111 modify (M.insert (mn, name) d)

113− return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)

112+ return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

114desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do

113desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do

115 desugared <- lift $ desugarCases members

114 desugared <- lift $ desugarCases members

116 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared

115 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared

@@ -129,9 +128,15 @@ identToProperty :: Ident -> String

129identToProperty (Ident name) = name

128identToProperty (Ident name) = name

130identToProperty (Op op) = op

129identToProperty (Op op) = op

131

130

132−typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration

131+typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration

133−typeClassDictionaryDeclaration name args members =

132+typeClassDictionaryDeclaration name args implies members =

133+ let superclassesType = TypeApp tyObject (rowFromList ([ (fieldName, function unit tySynApp)

134+ | (index, (superclass, tyArgs)) <- zip [0..] implies

135+ , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs

136+ , let fieldName = mkSuperclassDictionaryName superclass index

137+ ], REmpty))

138+

134− TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map (first identToProperty . memberToNameAndType) members, REmpty))

139+ in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList ((C.__superclasses, superclassesType) : map (first identToProperty . memberToNameAndType) members, REmpty))

135

140

136typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration

141typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration

137typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

142typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

@@ -142,6 +147,12 @@ typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

142 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

147 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

143typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

148typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

144

149

150+mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String

151+mkSuperclassDictionaryName pn index = show pn ++ "_" ++ show index

152+

153+unit :: Type

154+unit = TypeApp tyObject REmpty

155+

145typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

156typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

146typeInstanceDictionaryDeclaration name mn deps className tys decls = do

157typeInstanceDictionaryDeclaration name mn deps className tys decls = do

147 m <- get

158 m <- get

@@ -152,11 +163,6 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

152 M.lookup (qualify mn className) m

163 M.lookup (qualify mn className) m

153 let instanceTys = map memberToNameAndType tyDecls

164 let instanceTys = map memberToNameAndType tyDecls

154

165

155− let superclasses = TypedValue False (ArrayLiteral [ Abs (Left (Ident "_")) (TypeClassDictionary False (superclass, tyArgs) Nothing)

156− | (superclass, suTyArgs) <- implies

157− , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs

158− ]) (TypeApp tyArray unit)

159−

160 -- Replace the type arguments with the appropriate types in the member types

166 -- Replace the type arguments with the appropriate types in the member types

161 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys

167 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys

162 -- Create values for the type instance members

168 -- Create values for the type instance members

@@ -166,17 +172,19 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

166 -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary

172 -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary

167 -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no

173 -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no

168 -- dependencies, we introduce an unnamed function parameter.

174 -- dependencies, we introduce an unnamed function parameter.

169− let (memberTypes', memberNames') =

175+ let superclasses = ObjectLiteral

170− if null implies

176+ [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))

171− then (memberTypes, memberNames)

177+ | (index, (superclass, suTyArgs)) <- zip [0..] implies

178+ , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs

179+ , let fieldName = mkSuperclassDictionaryName superclass index

180+ ]

181+

172− else ((Ident C.__superclasses, TypeApp tyArray unit) : memberTypes, (C.__superclasses, superclasses) : memberNames)

182+ let memberNames' = (C.__superclasses, superclasses) : memberNames

173− dictTy = TypeApp tyObject (rowFromList (map (first identToProperty) memberTypes', REmpty))

183+ dictTy = foldl TypeApp (TypeConstructor className) tys

174 constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)

184 constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)

175 dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'

185 dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'

176 return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)

186 return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)

177 where

187 where

178− unit :: Type

179− unit = TypeApp tyObject REmpty

180

188

181 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)

189 memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)

182 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do

190 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do

src/Language/PureScript/TypeChecker/Types.hs+43−17

@@ -263,8 +263,7 @@ replaceTypeClassDictionaries mn = everywhereM' (mkM go)

263 where

264 go (TypeClassDictionary trySuperclasses constraint dicts) = do

265 env <- getEnv

266− let dicts' = fromMaybe (typeClassDictionaries env) dicts

267− entails env mn dicts' constraint trySuperclasses

266+ entails env mn dicts constraint trySuperclasses

268 go other = return other

267 go other = return other

269

268

270-- |

269-- |

@@ -287,7 +286,7 @@ data DictionaryValue

287 -- |

286 -- |

288 -- A subclass dictionary

287 -- A subclass dictionary

289 --

288 --

290− | SubclassDictionaryValue DictionaryValue Integer

289+ | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer

291 deriving (Show, Ord, Eq)

290 deriving (Show, Ord, Eq)

292

291

293-- |

292-- |

@@ -307,12 +306,12 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

307 filterModule _ = False

306 filterModule _ = False

308

307

309 solve context' (className, tys) trySuperclasses =

308 solve context' (className, tys) trySuperclasses =

310− case chooseSimplestDictionaries (go className tys) of

309+ case chooseSimplestDictionaries (go trySuperclasses className tys) of

311 [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)

310 [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)

312 [dict] -> return (dictionaryValueToValue dict)

311 [dict] -> return (dictionaryValueToValue dict)

313 _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)

312 _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)

314 where

313 where

315− go className' tys' =

314+ go trySuperclasses' className' tys' =

316 -- Look for regular type instances

315 -- Look for regular type instances

317 [ mkDictionary (canonicalizeDictionary tcd) args

316 [ mkDictionary (canonicalizeDictionary tcd) args

318 | tcd <- context'

317 | tcd <- context'

@@ -324,8 +323,8 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

324 , args <- solveSubgoals subst (tcdDependencies tcd) ] ++

323 , args <- solveSubgoals subst (tcdDependencies tcd) ] ++

325

324

326 -- Look for implementations via superclasses

325 -- Look for implementations via superclasses

327− [ SubclassDictionaryValue suDict index

326+ [ SubclassDictionaryValue suDict superclass index

328− | trySuperclasses

327+ | trySuperclasses'

329 , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)

328 , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)

330 -- Try each superclass

329 -- Try each superclass

331 , (index, (superclass, suTyArgs)) <- zip [0..] implies

330 , (index, (superclass, suTyArgs)) <- zip [0..] implies

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

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

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

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

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

336 -- Finally, satisfy the subclass constraint

335 -- Finally, satisfy the subclass constraint

337− , suDict <- go subclassName (map (applySubst subst . TypeVar) args) ]

336+ , suDict <- go trySuperclasses' subclassName (map (applySubst subst . TypeVar) args) ]

338

337

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

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

340 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

339 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

@@ -342,7 +341,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

342 solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]

341 solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]

343 solveSubgoals _ Nothing = return Nothing

342 solveSubgoals _ Nothing = return Nothing

344 solveSubgoals subst (Just subgoals) = do

343 solveSubgoals subst (Just subgoals) = do

345− dict <- mapM (uncurry go . second (map (replaceAllTypeVars subst))) subgoals

344+ dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals

346 return $ Just dict

345 return $ Just dict

347 -- Make a dictionary from subgoal dictionaries by applying the correct function

346 -- Make a dictionary from subgoal dictionaries by applying the correct function

348 mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue

347 mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue

@@ -354,10 +353,9 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

354 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName

353 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName

355 dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])

354 dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])

356 dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)

355 dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)

357− dictionaryValueToValue (SubclassDictionaryValue dict index) =

356+ dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =

358− App (App (App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident (C.!!))))

357+ App (Accessor (show superclassName ++ "_" ++ show index)

359 (Accessor C.__superclasses (dictionaryValueToValue dict)))

358 (Accessor C.__superclasses (dictionaryValueToValue dict)))

360− (NumericLiteral (Left index)))

361 (ObjectLiteral [])

359 (ObjectLiteral [])

362 -- Ensure that a substitution is valid

360 -- Ensure that a substitution is valid

363 verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]

361 verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]

@@ -500,7 +498,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do

500instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

498instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

501 dicts <- getTypeClassDictionaries

499 dicts <- getTypeClassDictionaries

502 (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty

500 (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty

503− return (foldl App val (map (flip (TypeClassDictionary True) (Just dicts)) constraints), ty')

501+ return (foldl App val (map (flip (TypeClassDictionary True) dicts) constraints), ty')

504instantiatePolyTypeWithUnknowns val ty = return (val, ty)

502instantiatePolyTypeWithUnknowns val ty = return (val, ty)

505

503

506-- |

504-- |

@@ -624,7 +622,7 @@ infer' (Var var) = do

624 case ty of

622 case ty of

625 ConstrainedType constraints ty' -> do

623 ConstrainedType constraints ty' -> do

626 dicts <- getTypeClassDictionaries

624 dicts <- getTypeClassDictionaries

627− return $ TypedValue True (foldl App (Var var) (map (flip (TypeClassDictionary True) (Just dicts)) constraints)) ty'

625+ return $ TypedValue True (foldl App (Var var) (map (flip (TypeClassDictionary True) dicts) constraints)) ty'

628 _ -> return $ TypedValue True (Var var) ty

626 _ -> return $ TypedValue True (Var var) ty

629infer' v@(Constructor c) = do

627infer' v@(Constructor c) = do

630 env <- getEnv

628 env <- getEnv

@@ -646,6 +644,9 @@ infer' (IfThenElse cond th el) = do

646infer' (Let ds val) = do

644infer' (Let ds val) = do

647 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer

645 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer

648 return $ TypedValue True (Let ds' val') valTy

646 return $ TypedValue True (Let ds' val') valTy

647+infer' (SuperClassDictionary className tys) = do

648+ dicts <- getTypeClassDictionaries

649+ return $ TypeClassDictionary False (className, tys) dicts

649infer' (TypedValue checkType val ty) = do

650infer' (TypedValue checkType val ty) = do

650 Just moduleName <- checkCurrentModule <$> get

651 Just moduleName <- checkCurrentModule <$> get

651 kind <- liftCheck $ kindOf moduleName ty

652 kind <- liftCheck $ kindOf moduleName ty

@@ -783,6 +784,17 @@ newSkolemScope = SkolemScope . runUnknown <$> fresh'

783skolemize :: String -> Int -> SkolemScope -> Type -> Type

784skolemize :: String -> Int -> SkolemScope -> Type -> Type

784skolemize ident sko scope = replaceTypeVars ident (Skolem sko scope)

785skolemize ident sko scope = replaceTypeVars ident (Skolem sko scope)

785

786

787+-- |

788+-- This function has one purpose - to skolemize type variables appearing in a

789+-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the

790+-- only example of scoped type variables.

791+--

792+skolemizeTypesInValue :: String -> Int -> SkolemScope -> Value -> Value

793+skolemizeTypesInValue ident sko scope = everywhere (mkT go)

794+ where

795+ go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)

796+ go other = other

797+

786-- |

798-- |

787-- Introduce skolem scope at every occurence of a ForAll

799-- Introduce skolem scope at every occurence of a ForAll

788--

800--

@@ -812,7 +824,8 @@ check' val (ForAll ident ty _) = do

812 scope <- newSkolemScope

824 scope <- newSkolemScope

813 sko <- newSkolemConstant

825 sko <- newSkolemConstant

814 let sk = skolemize ident sko scope ty

826 let sk = skolemize ident sko scope ty

827+ let skVal = skolemizeTypesInValue ident sko scope val

815− val' <- check val sk

828+ val' <- check skVal sk

816 return $ TypedValue True val' (ForAll ident ty (Just scope))

829 return $ TypedValue True val' (ForAll ident ty (Just scope))

817check' val t@(ConstrainedType constraints ty) = do

830check' val t@(ConstrainedType constraints ty) = do

818 dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do

831 dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do

@@ -858,6 +871,19 @@ check' v@(Var var) ty = do

858 case v' of

871 case v' of

859 Nothing -> throwError . strMsg $ "Unable to check type subsumption"

872 Nothing -> throwError . strMsg $ "Unable to check type subsumption"

860 Just v'' -> return $ TypedValue True v'' ty'

873 Just v'' -> return $ TypedValue True v'' ty'

874+check' (SuperClassDictionary className tys) _ = do

875+ -- |

876+ -- Here, we replace a placeholder for a superclass dictionary with a regular

877+ -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the

878+ -- correct super instance dictionaries in scope, and these are not available when the type class

879+ -- declaration gets desugared.

880+ --

881+ -- Note also that the first argument to TypeClassDictionary is False, meaning we _do not_ want

882+ -- to consider superclass instances when searching for this dictionary - doing so might lead

883+ -- to traversing a cycle in the instance graph.

884+ --

885+ dicts <- getTypeClassDictionaries

886+ return $ TypeClassDictionary False (className, tys) dicts

861check' (TypedValue checkType val ty1) ty2 = do

887check' (TypedValue checkType val ty1) ty2 = do

862 Just moduleName <- checkCurrentModule <$> get

888 Just moduleName <- checkCurrentModule <$> get

863 kind <- liftCheck $ kindOf moduleName ty1

889 kind <- liftCheck $ kindOf moduleName ty1

@@ -990,7 +1016,7 @@ checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do

990 checkFunctionApplication fn ty arg ret

1016 checkFunctionApplication fn ty arg ret

991checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do

1017checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do

992 dicts <- getTypeClassDictionaries

1018 dicts <- getTypeClassDictionaries

993− checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) (Just dicts)) constraints)) fnTy arg ret

1019+ checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret

994checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "

1020checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "

995 ++ prettyPrintType fnTy

1021 ++ prettyPrintType fnTy

996 ++ " to argument " ++ prettyPrintValue arg

1022 ++ " to argument " ++ prettyPrintValue arg

@@ -1033,7 +1059,7 @@ subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do

1033subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

1059subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do

1034 dicts <- getTypeClassDictionaries

1060 dicts <- getTypeClassDictionaries

1035 _ <- subsumes' Nothing ty1 ty2

1061 _ <- subsumes' Nothing ty1 ty2

1036− return . Just $ foldl App val (map (flip (TypeClassDictionary True) (Just dicts)) constraints)

1062+ return . Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)

1037subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do

1063subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do

1038 let

1064 let

1039 (ts1, r1') = rowToList r1

1065 (ts1, r1') = rowToList r1