GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 03:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

Nondeterministic overload resolution in new type checker

Browse Source
This commit is contained in:
Eve
2025-02-04 13:14:54 +01:00
parent 41cdf5e56a
commit 4750ccfb7e
1 changed files with 77 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files

107
src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -1,4 +1,4 @@
{-# LANGUAGE RankNTypes, CPP #-} {-# LANGUAGE RankNTypes, CPP, TupleSections #-}
module GF.Compile.TypeCheck.ConcreteNew( checkLType, checkLType', inferLType, inferLType' ) where module GF.Compile.TypeCheck.ConcreteNew( checkLType, checkLType', inferLType, inferLType' ) where
-- The code here is based on the paper: -- The code here is based on the paper:
@@ -12,15 +12,16 @@ import GF.Grammar.Predef
import GF.Grammar.Lockfield import GF.Grammar.Lockfield
import GF.Compile.Compute.Concrete import GF.Compile.Compute.Concrete
import GF.Infra.CheckM import GF.Infra.CheckM
import GF.Data.Operations import GF.Data.ErrM ( Err(Ok, Bad) )
import Control.Applicative(Applicative(..)) import Control.Applicative(Applicative(..))
import Control.Monad(ap,liftM,mplus,foldM,zipWithM,forM) import Control.Monad(ap,liftM,mplus,foldM,zipWithM,forM,filterM,when)
import Control.Monad.ST import Control.Monad.ST
import GF.Text.Pretty import GF.Text.Pretty
import Data.STRef import Data.STRef
import Data.List (nub, (\\), tails) import Data.List (nub, (\\), tails)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe(fromMaybe,isNothing) import Data.Maybe(fromMaybe,isNothing,mapMaybe)
import Data.Functor((<&>))
import qualified Control.Monad.Fail as Fail import qualified Control.Monad.Fail as Fail
checkLType :: Globals -> Term -> Type -> Check (Term, Type) checkLType :: Globals -> Term -> Type -> Check (Term, Type)
@@ -70,13 +71,13 @@ tcRho scope t@(Vr v) mb_ty = do -- VAR
Just v_sigma -> instSigma scope t v_sigma mb_ty Just v_sigma -> instSigma scope t v_sigma mb_ty
Nothing -> evalError ("Unknown variable" <+> v) Nothing -> evalError ("Unknown variable" <+> v)
tcRho scope t@(Q id) mb_ty = do tcRho scope t@(Q id) mb_ty = do
(t,ty) <- tcApp scope t t (t,ty) <- tcApp scope t t []
instSigma scope t ty mb_ty instSigma scope t ty mb_ty
tcRho scope t@(QC id) mb_ty = do tcRho scope t@(QC id) mb_ty = do
(t,ty) <- tcApp scope t t (t,ty) <- tcApp scope t t []
instSigma scope t ty mb_ty instSigma scope t ty mb_ty
tcRho scope t@(App fun arg) mb_ty = do tcRho scope t@(App fun arg) mb_ty = do
(t,ty) <- tcApp scope t t (t,ty) <- tcApp scope t t []
instSigma scope t ty mb_ty instSigma scope t ty mb_ty
tcRho scope (Abs bt var body) Nothing = do -- ABS1 tcRho scope (Abs bt var body) Nothing = do -- ABS1
(i,tnk) <- newResiduation scope (i,tnk) <- newResiduation scope
@@ -381,21 +382,28 @@ tcCases scope ((p,t):cs) p_ty res_ty = do
cs <- tcCases scope cs p_ty res_ty cs <- tcCases scope cs p_ty res_ty
return ((p,t):cs) return ((p,t):cs)
tcApp scope t0 t@(App fun (ImplArg arg)) = do -- APP1 tcApp scope t0 (App fun (ImplArg arg)) args = tcApp scope t0 fun ((arg,False):args) -- APP1
(fun,fun_ty) <- tcApp scope t0 fun tcApp scope t0 (App fun arg) args = tcApp scope t0 fun ((arg,True):args) -- APP2
tcApp scope t0 (Q id) args = resolveOverloads scope t0 id args -- VAR (global)
tcApp scope t0 (QC id) args = resolveOverloads scope t0 id args -- VAR (global)
tcApp scope t0 t args = do
(t,ty) <- tcRho scope t Nothing
reapply scope t ty args
reapply :: Scope s -> Term -> Constraint s -> [(Term,Bool)] -> EvalM s (Term,Rho s)
reapply scope fun fun_ty [] = return (fun,fun_ty)
reapply scope fun fun_ty ((arg,False):args) = do
(bt, x, arg_ty, res_ty) <- unifyFun scope fun_ty (bt, x, arg_ty, res_ty) <- unifyFun scope fun_ty
if (bt == Implicit) when (bt == Implicit) $ evalError (ppTerm Unqualified 0 (App fun (ImplArg arg)) <+>
then return () "is an implicit argument application, but no implicit argument is expected")
else evalError (ppTerm Unqualified 0 t <+> "is an implicit argument application, but no implicit argument is expected")
(arg,_) <- tcRho scope arg (Just arg_ty) (arg,_) <- tcRho scope arg (Just arg_ty)
res_ty <- case res_ty of res_ty <- case res_ty of
VClosure res_env res_ty -> do env <- scopeEnv scope VClosure res_env res_ty -> do env <- scopeEnv scope
tnk <- newThunk env arg tnk <- newThunk env arg
eval ((x,tnk):res_env) res_ty [] eval ((x,tnk):res_env) res_ty []
res_ty -> return res_ty res_ty -> return res_ty
return (App fun (ImplArg arg), res_ty) reapply scope (App fun (ImplArg arg)) res_ty args
tcApp scope t0 (App fun arg) = do -- APP2 reapply scope fun fun_ty ((arg,True):args) = do
(fun,fun_ty) <- tcApp scope t0 fun
(fun,fun_ty) <- instantiate scope fun fun_ty (fun,fun_ty) <- instantiate scope fun fun_ty
(_, x, arg_ty, res_ty) <- unifyFun scope fun_ty (_, x, arg_ty, res_ty) <- unifyFun scope fun_ty
(arg,_) <- tcRho scope arg (Just arg_ty) (arg,_) <- tcRho scope arg (Just arg_ty)
@@ -404,22 +412,61 @@ tcApp scope t0 (App fun arg) = do -- APP2
tnk <- newThunk env arg tnk <- newThunk env arg
eval ((x,tnk):res_env) res_ty [] eval ((x,tnk):res_env) res_ty []
res_ty -> return res_ty res_ty -> return res_ty
return (App fun arg, res_ty) reapply scope (App fun arg) res_ty args
tcApp scope t0 (Q id) = do -- VAR (global)
(t,ty) <- getOverload t0 id
vty <- eval [] ty []
return (t,vty)
tcApp scope t0 (QC id) = do -- VAR (global)
(t,ty) <- getOverload t0 id
vty <- eval [] ty []
return (t,vty)
tcApp scope t0 t = tcRho scope t Nothing
tcOverloadFailed t ttys = resolveOverloads :: Scope s -> Term -> QIdent -> [(Term,Bool)] -> EvalM s (Term,Rho s)
evalError ("Overload resolution failed" $$ resolveOverloads scope t q args = EvalM $ \gl@(Gl gr _) k mt d r msgs ->
"of term " <+> pp t $$ case lookupOverloadTypes gr q of
"with types" <+> vcat [ppTerm Terse 0 ty | (_,ty) <- ttys]) Bad msg -> return $ Fail (pp msg) msgs
Ok [tty] -> try tty gl k mt d r msgs -- skip overload resolution if there's only one overload
Ok ttys -> do rs <- mapM (\tty -> (tty,) <$> try tty gl k mt d r msgs) ttys
let successes = mapMaybe isSuccess rs
r <- case successes of
[] -> return $ Fail mempty msgs
[(_,r,msgs)] -> return $ Success r msgs
_ -> case unifyOverloads (successes <&> \(tty,_,_) -> tty) of
EvalM f -> f gl k mt d r msgs
return $ case r of
s@(Success _ _) -> s
Fail err msgs -> let h = "Overload resolution failed" $$
"of term " <+> pp t $$
"with types" <+> vcat [ppTerm Terse 0 ty | (_,ty) <- ttys]
in Fail (h $+$ err) msgs
where
try (t,ty) = case eval [] ty [] >>= \vty -> reapply scope t vty args of EvalM f -> f
isSuccess (tty, Success r msg) = Just (tty,r,msg)
isSuccess (_, Fail _ _) = Nothing
unifyOverloads ttys = do
ttys <- forM ttys $ \(t,ty) -> do
vty <- eval [] ty []
(t,vty) <- papply scope t vty args
return (t,vty)
(_,tnk) <- newResiduation scope
let mv = VMeta tnk []
mapM_ (\(_,vty) -> unify scope vty mv) ttys
fvty <- force tnk
return (FV (fst <$> ttys), fvty)
papply scope fun fun_ty [] = return (fun,fun_ty)
papply scope fun (VProd Implicit x arg_ty res_ty) ((arg,False):args) = do
(arg,_) <- tcRho scope arg (Just arg_ty)
res_ty <- case res_ty of
VClosure res_env res_ty -> do env <- scopeEnv scope
tnk <- newThunk env arg
eval ((x,tnk):res_env) res_ty []
res_ty -> return res_ty
papply scope (App fun (ImplArg arg)) res_ty args
papply scope fun fun_ty ((arg,True):args) = do
(fun,VProd Explicit x arg_ty res_ty) <- instantiate scope fun fun_ty
(arg,_) <- tcRho scope arg (Just arg_ty)
res_ty <- case res_ty of
VClosure res_env res_ty -> do env <- scopeEnv scope
tnk <- newThunk env arg
eval ((x,tnk):res_env) res_ty []
res_ty -> return res_ty
papply scope (App fun arg) res_ty args
tcPatt scope PW ty0 = tcPatt scope PW ty0 =
return scope return scope