5626277 · rowtype-yoga/purescript-native

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

Qualifying superclass names, more work on instance search.

commit562627733da3c2a1ad5e830a31eb032e0dea707a authorPhil Freeman <paf31@cantab.net> dateSat 5 Apr 2014, 17:32 (13 years ago) parent1fbdd2a

4 files changed+22−12

compare with golang

unifiedsplit

src/Language/PureScript/Declarations.hs+1−1 src/Language/PureScript/Sugar/Names.hs+2 src/Language/PureScript/Sugar/TypeClasses.hs+2−1 src/Language/PureScript/TypeChecker/Types.hs+17−10

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

@@ -332,7 +332,7 @@ data Value

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

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

334334 --

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

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

336336 -- |

337337 -- A value with source position information

338338 --

src/Language/PureScript/Sugar/Names.hs+2

@@ -185,6 +185,8 @@ renameInModule imports exports (Module mn decls exps) =

185185 go (TypeSynonymDeclaration name ps ty) =

186186 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $

187187 TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty

188+ go (TypeClassDeclaration className args implies ds) =

189+ TypeClassDeclaration className args <$> updateConstraints Nothing implies <*> mapM go ds

188190 go (TypeInstanceDeclaration name cs cn ts ds) =

189191 TypeInstanceDeclaration name <$> updateConstraints Nothing cs <*> updateClassName cn Nothing <*> updateType' ts <*> mapM go ds

190192 go (ExternInstanceDeclaration name cs cn ts) =

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

@@ -129,7 +129,8 @@ 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) [] | (superclass, tyArgs) <- implies ]) (TypeApp tyArray unit)

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

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

133134

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

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

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

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

263263 where

264264 go (TypeClassDictionary constraint dicts) = do

265265 env <- getEnv

266− entails env mn dicts constraint

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

267+ entails env mn dicts' constraint

267268 go other = return other

268269

269270-- |

@@ -308,8 +309,8 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

308309 solve context' goal@(className, tys) =

309310 case go goal of

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

311− [dict] -> return (dictionaryValueToValue dict)

312− _ -> throwError . strMsg $ "Overlapping instances 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)

313314 where

314315 go (className', tys') =

315316 [ mkDictionary (canonicalizeDictionary tcd) args

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

324325 -- Look for implementations via superclasses

325326 [ SubclassDictionaryValue suDict index

326327 | tcd <- context'

327− , (_, _, implies) <- maybeToList $ M.lookup (tcdClassName tcd) (typeClasses env)

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

328329 -- Try each superclass

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

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

331− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) suTyArgs (tcdInstanceTypes tcd)

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

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

333334 , className' == superclass

334335 -- Finally, satisfy the subclass constraint

335− , suDict <- go (tcdClassName tcd, tys') ]

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

336337

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

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

@@ -362,6 +363,12 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

362363 let grps = groupBy ((==) `on` fst) subst

363364 guard (all (pairwise (unifiesWith env) . map snd) grps)

364365 return $ map head grps

366+ -- Apply a substitution to a type

367+ applySubst :: [(String, Type)] -> Type -> Type

368+ applySubst subst = everywhere (mkT replace)

369+ where

370+ replace t@(TypeVar v) = fromMaybe t $ lookup v subst

371+ replace other = other

365372

366373-- |

367374-- Check all values in a list pairwise match a predicate

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

476483instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do

477484 dicts <- getTypeClassDictionaries

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

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

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

480487instantiatePolyTypeWithUnknowns val ty = return (val, ty)

481488

482489-- |

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

600607 case ty of

601608 ConstrainedType constraints ty' -> do

602609 dicts <- getTypeClassDictionaries

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

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

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

605612infer' v@(Constructor c) = do

606613 env <- getEnv

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

966973 checkFunctionApplication fn ty arg ret

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

968975 dicts <- getTypeClassDictionaries

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

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

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

971978 ++ prettyPrintType fnTy

972979 ++ " to argument " ++ prettyPrintValue arg

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

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

10101017 dicts <- getTypeClassDictionaries

10111018 _ <- subsumes' Nothing ty1 ty2

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

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

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

10141021 let

10151022 (ts1, r1') = rowToList r1