0d1f3de · rowtype-yoga/purescript-native

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

Do not search superclass implementations when looking for a superclass dictionary

commit0d1f3de516fc7409e15e2f7e55b4d65b8ab8f5ee authorPhil Freeman <paf31@cantab.net> dateSat 5 Apr 2014, 17:58 (13 years ago) parent5626277

6 files changed+27−23

compare with golang

unifiedsplit

examples/passing/Superclasses.purs+1−2 src/Language/PureScript/CodeGen/JS.hs+1−1 src/Language/PureScript/Declarations.hs+3−2 src/Language/PureScript/Pretty/Values.hs+1−1 src/Language/PureScript/Sugar/TypeClasses.hs+4−2 src/Language/PureScript/TypeChecker/Types.hs+17−15

examples/passing/Superclasses.purs+1−2

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

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

1616test a = su (cl a a)

1717

18−main = let n = test 10 in

19− Debug.Trace.trace "Done"

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

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

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

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

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

146146valueToJs 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"

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

149149

150150-- |

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

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

329329 -- |

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

331331 -- 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

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

334335 --

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

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

336337 -- |

337338 -- A value with source position information

338339 --

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

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

7373 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

7474 , currentIndent

7575 ]

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

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

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

7878 match (PositionedValue _ val) = prettyPrintValue' val

7979 match _ = mzero

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

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

129129 M.lookup (qualify mn className) m

130130 let instanceTys = map memberToNameAndType tyDecls

131131

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

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

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

133+ | (superclass, suTyArgs) <- implies

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

135+ ]) (TypeApp tyArray unit)

134136

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

136138 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)

261261replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value

262262replaceTypeClassDictionaries mn = everywhereM' (mkM go)

263263 where

264− go (TypeClassDictionary constraint dicts) = do

264+ go (TypeClassDictionary trySuperclasses constraint dicts) = do

265265 env <- getEnv

266266 let dicts' = fromMaybe (typeClassDictionaries env) dicts

267− entails env mn dicts' constraint

267+ entails env mn dicts' constraint trySuperclasses

268268 go other = return other

269269

270270-- |

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

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

295295-- return a type class dictionary reference.

296296--

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

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

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

299299 where

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

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

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

307307 filterModule _ = False

308308

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

310− case go goal of

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

310+ case go className tys of

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

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

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

314314 where

315− go (className', tys') =

315+ go className' tys' =

316+ -- Look for regular type instances

316317 [ mkDictionary (canonicalizeDictionary tcd) args

317318 | tcd <- context'

318319 -- 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

324325

325326 -- Look for implementations via superclasses

326327 [ SubclassDictionaryValue suDict index

327− | tcd <- context'

328+ | trySuperclasses

329+ , tcd <- context'

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

329331 -- Try each superclass

330332 , (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

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

334334 , 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

335337 -- Finally, satisfy the subclass constraint

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

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

337339

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

339341 -- 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

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

342344 solveSubgoals _ Nothing = return Nothing

343345 solveSubgoals subst (Just subgoals) = do

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

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

345347 return $ Just dict

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

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

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

483485instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

484486 dicts <- getTypeClassDictionaries

485487 (_, 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')

487489instantiatePolyTypeWithUnknowns val ty = return (val, ty)

488490

489491-- |

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

607609 case ty of

608610 ConstrainedType constraints ty' -> do

609611 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'

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

612614infer' v@(Constructor c) = do

613615 env <- getEnv

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

973975 checkFunctionApplication fn ty arg ret

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

975977 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

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

978980 ++ prettyPrintType fnTy

979981 ++ " to argument " ++ prettyPrintValue arg

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

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

10171019 dicts <- getTypeClassDictionaries

10181020 _ <- 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)

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

10211023 let

10221024 (ts1, r1') = rowToList r1