0d1f3de · rowtype-yoga/purescript-native

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

on golang help sign in

Do not search superclass implementations when looking for a superclass dictionary

0d1f3dePhil Freeman13 years ago

examples/passing/Superclasses.purs+1−2

compare with golang

unifiedsplit

@@ -15,5 +15,4 @@ instance clNumber :: Cl Number where

15test :: forall a. (Cl a) => a -> a

16test a = su (cl a a)

18−main = let n = test 10 in

18+main = Debug.Trace.print $ test 10

19− Debug.Trace.trace "Done"

src/Language/PureScript/CodeGen/JS.hs+1−1

@@ -144,7 +144,7 @@ valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntim

144valueToJs _ m _ (Var ident) = varToJs m ident

145valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val

146valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val

147−valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

147+valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"

148valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

149

150-- |

src/Language/PureScript/Declarations.hs+3−2

@@ -329,10 +329,11 @@ data Value

329 -- |

330 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

331 -- placeholders will be replaced with actual expressions representing type classes dictionaries which

332− -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and

332+ -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look

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

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

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

334 --

335 --

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

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

336 -- |

337 -- |

337 -- A value with source position information

338 -- A value with source position information

338 --

339 --

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

@@ -73,7 +73,7 @@ literals = mkPattern' match

73 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

74 , currentIndent

75 ]

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

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

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

78 match (PositionedValue _ val) = prettyPrintValue' val

79 match _ = mzero

src/Language/PureScript/Sugar/TypeClasses.hs+4−2

@@ -129,8 +129,10 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

129 M.lookup (qualify mn className) m

130 let instanceTys = map memberToNameAndType tyDecls

131

132− let superclasses = TypedValue False (ArrayLiteral [ TypeClassDictionary (superclass, tyArgs) Nothing

132+ let superclasses = TypedValue False (ArrayLiteral [ TypeClassDictionary False (superclass, tyArgs) Nothing

133+ | (superclass, suTyArgs) <- implies

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

133− | (superclass, tyArgs) <- implies ]) (TypeApp tyArray unit)

135+ ]) (TypeApp tyArray unit)

134

136

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

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

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

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

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

@@ -261,10 +261,10 @@ overTypes f = everywhere (mkT f)

261replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value

262replaceTypeClassDictionaries mn = everywhereM' (mkM go)

263 where

264− go (TypeClassDictionary constraint dicts) = do

264+ go (TypeClassDictionary trySuperclasses constraint dicts) = do

265 env <- getEnv

266 let dicts' = fromMaybe (typeClassDictionaries env) dicts

267− entails env mn dicts' constraint

267+ entails env mn dicts' constraint trySuperclasses

268 go other = return other

269

270-- |

@@ -294,7 +294,7 @@ data DictionaryValue

294-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

295-- return a type class dictionary reference.

296--

297−entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Check Value

297+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Value

298entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))

299 where

300 sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]

@@ -306,13 +306,14 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

306 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True

307 filterModule _ = False

308

309− solve context' goal@(className, tys) =

309+ solve context' (className, tys) trySuperclasses =

310− case go goal of

310+ case go className tys of

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

312 (dict : _) -> return (dictionaryValueToValue dict)

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

314 where

315− go (className', tys') =

315+ go className' tys' =

316+ -- Look for regular type instances

316 [ mkDictionary (canonicalizeDictionary tcd) args

317 [ mkDictionary (canonicalizeDictionary tcd) args

317 | tcd <- context'

318 | tcd <- context'

318 -- Make sure the type class name matches the one we are trying to satisfy

319 -- Make sure the type class name matches the one we are trying to satisfy

@@ -324,16 +325,17 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

324

325

325 -- Look for implementations via superclasses

326 -- Look for implementations via superclasses

326 [ SubclassDictionaryValue suDict index

327 [ SubclassDictionaryValue suDict index

328+ | trySuperclasses

327− | tcd <- context'

329+ , tcd <- context'

328 , let (_, _, implies) = fromMaybe (error "Type class was not defined") $ M.lookup (tcdClassName tcd) (typeClasses env)

330 , let (_, _, implies) = fromMaybe (error "Type class was not defined") $ M.lookup (tcdClassName tcd) (typeClasses env)

329 -- Try each superclass

331 -- Try each superclass

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

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

331− -- Make sure the types unify with the types in the superclass implication

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

333 -- Make sure the type class name matches the superclass name

334 , className' == superclass

335+ -- Make sure the types unify with the types in the superclass implication

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

335 -- Finally, satisfy the subclass constraint

337 -- Finally, satisfy the subclass constraint

336− , suDict <- go (tcdClassName tcd, map (applySubst subst) tys') ]

338+ , suDict <- go (tcdClassName tcd) (map (applySubst subst) (tcdInstanceTypes tcd)) ]

337

339

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

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

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

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

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

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

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

342 solveSubgoals _ Nothing = return Nothing

344 solveSubgoals _ Nothing = return Nothing

343 solveSubgoals subst (Just subgoals) = do

345 solveSubgoals subst (Just subgoals) = do

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

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

345 return $ Just dict

347 return $ Just dict

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

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

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

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

@@ -483,7 +485,7 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do

483instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

485instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

484 dicts <- getTypeClassDictionaries

486 dicts <- getTypeClassDictionaries

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

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

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

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

487instantiatePolyTypeWithUnknowns val ty = return (val, ty)

489instantiatePolyTypeWithUnknowns val ty = return (val, ty)

488

490

489-- |

491-- |

@@ -607,7 +609,7 @@ infer' (Var var) = do

607 case ty of

609 case ty of

608 ConstrainedType constraints ty' -> do

610 ConstrainedType constraints ty' -> do

609 dicts <- getTypeClassDictionaries

611 dicts <- getTypeClassDictionaries

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

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

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

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

612infer' v@(Constructor c) = do

614infer' v@(Constructor c) = do

613 env <- getEnv

615 env <- getEnv

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

973 checkFunctionApplication fn ty arg ret

975 checkFunctionApplication fn ty arg ret

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

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

975 dicts <- getTypeClassDictionaries

977 dicts <- getTypeClassDictionaries

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

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

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

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

978 ++ prettyPrintType fnTy

980 ++ prettyPrintType fnTy

979 ++ " to argument " ++ prettyPrintValue arg

981 ++ " to argument " ++ prettyPrintValue arg

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

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

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

1017 dicts <- getTypeClassDictionaries

1019 dicts <- getTypeClassDictionaries

1018 _ <- subsumes' Nothing ty1 ty2

1020 _ <- subsumes' Nothing ty1 ty2

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

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

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

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

1021 let

1023 let

1022 (ts1, r1') = rowToList r1

1024 (ts1, r1') = rowToList r1