From 4ed287a8094f6934713c8b767867b387cff877ae Mon Sep 17 00:00:00 2001 From: krangelov Date: Thu, 16 Dec 2021 13:14:29 +0100 Subject: [PATCH] bug fix and refactoring in the cc command --- src/compiler/GF/Compile/Compute/Concrete.hs | 152 ++++++++++-------- src/compiler/GF/Compile/GeneratePMCFG.hs | 4 +- src/compiler/GF/Compile/TypeCheck/Concrete.hs | 2 +- src/compiler/GF/Grammar/Macros.hs | 21 +-- src/compiler/GF/Infra/Ident.hs | 9 +- testsuite/compiler/compute/lambda.gfs | 3 + testsuite/compiler/compute/lambda.gfs.gold | 2 + testsuite/compiler/compute/param_table.gfs | 2 +- .../compiler/compute/param_table.gfs.gold | 18 +-- testsuite/compiler/compute/predef.gfs.gold | 6 +- testsuite/compiler/compute/record.gfs.gold | 8 +- .../compiler/compute/string_matching.gfs.gold | 8 +- 12 files changed, 132 insertions(+), 103 deletions(-) create mode 100644 testsuite/compiler/compute/lambda.gfs create mode 100644 testsuite/compiler/compute/lambda.gfs.gold diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs index 3c8fa2a69..e2d49c710 100644 --- a/src/compiler/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/GF/Compile/Compute/Concrete.hs @@ -41,7 +41,7 @@ import PGF2.Transactions(LIndex) normalForm :: Grammar -> Term -> Check Term normalForm gr t = - fmap mkFV (runEvalM gr (eval [] t [] >>= value2term 0)) + fmap mkFV (runEvalM gr (eval [] t [] >>= value2term [])) where mkFV [t] = t mkFV ts = FV ts @@ -62,7 +62,7 @@ data Value s | VSusp (Thunk s) (Env s) (Value s -> EvalM s (Value s)) [Thunk s] | VGen {-# UNPACK #-} !Int [Thunk s] | VClosure (Env s) Term - | VProd BindType Ident (Value s) (Env s) Term + | VProd BindType Ident (Value s) (Value s) | VRecType [(Label, Value s)] | VR [(Label, Thunk s)] | VP (Value s) Label [Thunk s] @@ -92,7 +92,7 @@ showValue (VMeta _ _ _) = "VMeta" showValue (VSusp _ _ _ _) = "VSusp" showValue (VGen _ _) = "VGen" showValue (VClosure _ _) = "VClosure" -showValue (VProd _ _ _ _ _) = "VProd" +showValue (VProd _ _ _ _) = "VProd" showValue (VRecType _) = "VRecType" showValue (VR lbls) = "(VR {"++unwords (map (\(lbl,_) -> show lbl) lbls)++"})" showValue (VP v l _) = "(VP "++showValue v++" "++show l++")" @@ -130,7 +130,7 @@ eval env (Meta i) vs = do tnk <- newResiduation i return (VMeta tnk env vs) eval env (ImplArg t) [] = eval env t [] eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 [] - return (VProd b x v1 env t2) + return (VProd b x v1 (VClosure env t2)) eval env (Typed t ty) vs = eval env t vs eval env (RecType lbls) [] = do lbls <- mapM (\(lbl,ty) -> fmap ((,) lbl) (eval env ty [])) lbls return (VRecType lbls) @@ -165,8 +165,8 @@ eval env t@(S t1 t2) vs = do v1 <- eval env t1 [] let v0 = VS v1 tnk2 vs case v1 of VT _ env cs -> patternMatch v0 (map (\(p,t) -> (env,[p],tnk2:vs,t)) cs) - VV vty tnks -> do t2 <- force tnk2 >>= value2term (length env) - ty <- value2term (length env) vty + VV vty tnks -> do t2 <- force tnk2 >>= value2term (map fst env) + ty <- value2term (map fst env) vty ts <- getAllParamValues ty case lookup t2 (zip ts tnks) of Just tnk -> do v <- force tnk @@ -425,85 +425,107 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0 Success r -> bindInt gr k mt r s (iv+1) max | otherwise = return (Success r) -value2term i (VApp q tnks) = - foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term i)) (if fst q == cPredef then Q q else QC q) tnks -value2term i (VMeta m env tnks) = do +value2term xs (VApp q tnks) = + foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (if fst q == cPredef then Q q else QC q) tnks +value2term xs (VMeta m env tnks) = do res <- zonk m tnks case res of - Right i -> foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term i)) (Meta i) tnks - Left v -> value2term i v -value2term i (VSusp j env k vs) = do + Right i -> foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (Meta i) tnks + Left v -> value2term xs v +value2term xs (VSusp j env k vs) = do v <- k (VGen maxBound vs) - value2term i v -value2term i (VGen j tnks) = - foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term i)) (Vr (identS ('v':show j))) tnks -value2term i (VClosure env (Abs b x t)) = do - tnk <- newEvaluatedThunk (VGen i []) + value2term xs v +value2term xs (VGen j tnks) = + foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (Vr (reverse xs !! j)) tnks +value2term xs (VClosure env (Abs b x t)) = do + tnk <- newEvaluatedThunk (VGen (length xs) []) v <- eval ((x,tnk):env) t [] - t <- value2term (i+1) v - return (Abs b (identS ('v':show i)) t) -value2term i (VProd b x v1 env t2) - | x == identW = do t1 <- value2term i v1 + let x' = mkFreshVar xs x + t <- value2term (x':xs) v + return (Abs b x' t) +value2term xs (VProd b x v1 (VClosure env t2)) + | x == identW = do t1 <- value2term xs v1 v2 <- eval env t2 [] - t2 <- value2term i v2 + t2 <- value2term xs v2 return (Prod b x t1 t2) - | otherwise = do t1 <- value2term i v1 - tnk <- newEvaluatedThunk (VGen i []) + | otherwise = do t1 <- value2term xs v1 + tnk <- newEvaluatedThunk (VGen (length xs) []) v2 <- eval ((x,tnk):env) t2 [] - t2 <- value2term (i+1) v2 - return (Prod b (identS ('v':show i)) t1 t2) -value2term i (VRecType lbls) = do - lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term i v)) lbls + t2 <- value2term (x:xs) v2 + return (Prod b (mkFreshVar xs x) t1 t2) +value2term xs (VRecType lbls) = do + lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term xs v)) lbls return (RecType lbls) -value2term i (VR as) = do - as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (force tnk >>= value2term i)) as +value2term xs (VR as) = do + as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (force tnk >>= value2term xs)) as return (R as) -value2term i (VP v lbl tnks) = do - t <- value2term i v - foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term i)) (P t lbl) tnks -value2term i (VExtR v1 v2) = do - t1 <- value2term i v1 - t2 <- value2term i v2 +value2term xs (VP v lbl tnks) = do + t <- value2term xs v + foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (P t lbl) tnks +value2term xs (VExtR v1 v2) = do + t1 <- value2term xs v1 + t2 <- value2term xs v2 return (ExtR t1 t2) -value2term i (VTable v1 v2) = do - t1 <- value2term i v1 - t2 <- value2term i v2 +value2term xs (VTable v1 v2) = do + t1 <- value2term xs v1 + t2 <- value2term xs v2 return (Table t1 t2) -value2term i (VT vty _ cs)= do ty <- value2term i vty - return (T (TTyped ty) cs) -value2term i (VV vty tnks)= do ty <- value2term i vty - ts <- mapM (\tnk -> force tnk >>= value2term i) tnks - return (V ty ts) -value2term i (VS v1 tnk2 tnks) = do t1 <- value2term i v1 - t2 <- force tnk2 >>= value2term i - foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term i)) (S t1 t2) tnks -value2term i (VSort s) = return (Sort s) -value2term i (VStr tok) = return (K tok) -value2term i (VInt n) = return (EInt n) -value2term i (VFlt n) = return (EFloat n) -value2term i (VC vs) = do - ts <- mapM (value2term i) vs +value2term xs (VT vty env cs)= do + ty <- value2term xs vty + cs <- forM cs $ \(p,t) -> do + (_,xs',env') <- pattVars (length xs,xs,env) p + v <- eval env' t [] + t <- value2term xs' v + return (p,t) + return (T (TTyped ty) cs) +value2term xs (VV vty tnks)= do ty <- value2term xs vty + ts <- mapM (\tnk -> force tnk >>= value2term xs) tnks + return (V ty ts) +value2term xs (VS v1 tnk2 tnks) = do t1 <- value2term xs v1 + t2 <- force tnk2 >>= value2term xs + foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (S t1 t2) tnks +value2term xs (VSort s) = return (Sort s) +value2term xs (VStr tok) = return (K tok) +value2term xs (VInt n) = return (EInt n) +value2term xs (VFlt n) = return (EFloat n) +value2term xs (VC vs) = do + ts <- mapM (value2term xs) vs case ts of [] -> return Empty (t:ts) -> return (foldl C t ts) -value2term i (VGlue v1 v2) = do - t1 <- value2term i v1 - t2 <- value2term i v2 +value2term xs (VGlue v1 v2) = do + t1 <- value2term xs v1 + t2 <- value2term xs v2 return (Glue t1 t2) -value2term i (VPatt min max p) = return (EPatt min max p) -value2term i (VPattType v) = do t <- value2term i v - return (EPattType t) -value2term i (VAlts vd vas) = do - d <- value2term i vd +value2term xs (VPatt min max p) = return (EPatt min max p) +value2term xs (VPattType v) = do t <- value2term xs v + return (EPattType t) +value2term xs (VAlts vd vas) = do + d <- value2term xs vd as <- forM vas $ \(vt,vs) -> do - t <- value2term i vt - s <- value2term i vs + t <- value2term xs vt + s <- value2term xs vs return (t,s) return (Alts d as) -value2term i (VStrs vs) = do - ts <- mapM (value2term i) vs +value2term xs (VStrs vs) = do + ts <- mapM (value2term xs) vs return (Strs ts) +pattVars st (PP _ ps) = foldM pattVars st ps +pattVars st (PV x) = case st of + (i,xs,env) -> do tnk <- newEvaluatedThunk (VGen i []) + return (i+1,x:xs,(x,tnk):env) +pattVars st (PR as) = foldM (\st (_,p) -> pattVars st p) st as +pattVars st (PT ty p) = pattVars st p +pattVars st (PAs x p) = do st <- case st of + (i,xs,env) -> do tnk <- newEvaluatedThunk (VGen i []) + return (i+1,x:xs,(x,tnk):env) + pattVars st p +pattVars st (PImplArg p) = pattVars st p +pattVars st (PSeq _ _ p1 _ _ p2) = do st <- pattVars st p1 + pattVars st p2 +pattVars st _ = return st + data ConstValue a = Const a | RunTime diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 6708e8e9c..cf337809f 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -185,7 +185,7 @@ str2lin (VAlts def alts) = do def <- str2lin def lin <- str2lin v return (lin,[s | VStr s <- vs]) return [SymKP def alts] -str2lin v = do t <- value2term 0 v +str2lin v = do t <- value2term [] v evalError ("the string:" <+> ppTerm Unqualified 0 t $$ "cannot be evaluated at compile time.") @@ -227,7 +227,7 @@ param2int (VMeta tnk _ _) ty = do QC q -> do (_,ResParam _ (Just (_,cnt))) <- getInfo q return (0,[(1,j-1)],cnt) App q (EInt cnt) -> return (0,[(1,j-1)],fromIntegral cnt) -param2int v ty = do t <- value2term 0 v +param2int v ty = do t <- value2term [] v evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$ "cannot be evaluated at compile time.") diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs index 9cc39f7eb..fc2e3331a 100644 --- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs @@ -569,7 +569,7 @@ checkLType gr g trm typ0 = do Vr _ -> f g (\l -> P t l) _ -> if length fields == 1 then f g (\l -> P t l) - else let x = mkFreshVar (map (\(_,v,_)->v) g) + else let x = mkFreshVar (map (\(_,x,_) -> x) g) (identS "x") in Let (x, (Nothing, t)) (f ((Explicit,x,RecType fields):g) (\l -> P (Vr x) l)) rec = withProjection r' fields1 g $ \g p_r' -> diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 4501b2f3b..e045f2ced 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -297,22 +297,17 @@ defLinType :: Type defLinType = RecType [(theLinLabel, typeStr)] -- | refreshing variables -mkFreshVar :: [Ident] -> Ident -mkFreshVar olds = varX (maxVarIndex olds + 1) +mkFreshVar :: [Ident] -> Ident -> Ident +mkFreshVar olds x = + case maximum ((-1) : map (varIndex' rx) olds) + 1 of + 0 -> x + i -> identV rx i + where + rx = ident2raw x -- | trying to preserve a given symbol mkFreshVarX :: [Ident] -> Ident -> Ident -mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x - -maxVarIndex :: [Ident] -> Int -maxVarIndex = maximum . ((-1):) . map varIndex - -mkFreshVars :: Int -> [Ident] -> [Ident] -mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]] - --- | quick hack for refining with var in editor -freshAsTerm :: String -> Term -freshAsTerm s = Vr (varX (readIntArg s)) +mkFreshVarX olds x = if (elem x olds) then (varX (maximum ((-1) : (map varIndex olds)) + 1)) else x -- | create a terminal for concrete syntax string2term :: String -> Term diff --git a/src/compiler/GF/Infra/Ident.hs b/src/compiler/GF/Infra/Ident.hs index 418eac980..dac127434 100644 --- a/src/compiler/GF/Infra/Ident.hs +++ b/src/compiler/GF/Infra/Ident.hs @@ -19,7 +19,7 @@ module GF.Infra.Ident (-- ** Identifiers identS, identC, identW, -- *** Special identifiers for internal use identV, - varStr, varX, varIndex, + varStr, varX, varIndex, varIndex', -- *** Raw identifiers RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent, isPrefixOf, showRawIdent @@ -128,3 +128,10 @@ wild = pack "_" varIndex :: Ident -> Int varIndex (IV _ n) = n varIndex _ = -1 --- other than IV should not count + +varIndex' :: RawIdent -> Ident -> Int +varIndex' x (IC y) + | x == y = 0 +varIndex' x (IV y n) + | x == y = n +varIndex' _ _ = -1 --- other than IV should not count diff --git a/testsuite/compiler/compute/lambda.gfs b/testsuite/compiler/compute/lambda.gfs new file mode 100644 index 000000000..4bacafdad --- /dev/null +++ b/testsuite/compiler/compute/lambda.gfs @@ -0,0 +1,3 @@ +i -retain prelude/Predef.gfo +cc <\x,x -> x : Str -> Str -> Str> +cc <\x -> (<\y,x->y : Str -> Str -> Str>) x : Str -> Str -> Str> diff --git a/testsuite/compiler/compute/lambda.gfs.gold b/testsuite/compiler/compute/lambda.gfs.gold new file mode 100644 index 000000000..c67558bbe --- /dev/null +++ b/testsuite/compiler/compute/lambda.gfs.gold @@ -0,0 +1,2 @@ +\x,x_1 -> x_1 +\x,x_1 -> x diff --git a/testsuite/compiler/compute/param_table.gfs b/testsuite/compiler/compute/param_table.gfs index b8b935212..f14432e3c 100644 --- a/testsuite/compiler/compute/param_table.gfs +++ b/testsuite/compiler/compute/param_table.gfs @@ -14,4 +14,4 @@ cc case of { => "11"; => "12"; _ => "??"} cc case of { => "11"; => "12"; _ => "??"} cc <\x -> case x of {Q1 => "q1"; Q2 => "q2"} : Q -> Str> cc <\x -> case P2 x of {P1 => "p1"; P2 q => "p2"} : Q -> Str> -cc <\x -> case P2 x of {P1 => "p1"; P2 q => case q of {Q1 => "q1"; Q2 => "q2"}} : Q -> Str> +cc <\x -> case P2 x of {P1 => "p1"; P2 q => case q of {Q1 => "q"+"1"; Q2 => "q"+"2"}} : Q -> Str> diff --git a/testsuite/compiler/compute/param_table.gfs.gold b/testsuite/compiler/compute/param_table.gfs.gold index fce5b4043..f28ddbf2e 100644 --- a/testsuite/compiler/compute/param_table.gfs.gold +++ b/testsuite/compiler/compute/param_table.gfs.gold @@ -11,12 +11,12 @@ variants {"p2q1"; "p2q2"} "p2q1" "12" "??" -\v0 -> case of { - param_table.Q1 => "q1"; - param_table.Q2 => "q2" - } -\v0 -> "p2" -\v0 -> case of { - param_table.Q1 => "q1"; - param_table.Q2 => "q2" - } +\x -> case of { + param_table.Q1 => "q1"; + param_table.Q2 => "q2" + } +\x -> "p2" +\x -> case of { + param_table.Q1 => "q1"; + param_table.Q2 => "q2" + } diff --git a/testsuite/compiler/compute/predef.gfs.gold b/testsuite/compiler/compute/predef.gfs.gold index 778ed9a97..7f8272785 100644 --- a/testsuite/compiler/compute/predef.gfs.gold +++ b/testsuite/compiler/compute/predef.gfs.gold @@ -1,11 +1,11 @@ 4 5 Predef.length Predef.nonExist -\v0 -> Predef.length v0 +\x -> Predef.length x "ab" "cd" -"d" "abc" +"d" "ABCD" "abcd" Predef.PFalse @@ -32,5 +32,5 @@ user error "x" ++ Predef.CAPIT ++ "y" "x" ++ Predef.ALL_CAPIT ++ "y" "ab" -\v0 -> v0 + "b" +\x -> x + "b" Predef.PTrue diff --git a/testsuite/compiler/compute/record.gfs.gold b/testsuite/compiler/compute/record.gfs.gold index 297cf711d..5bf27baa9 100644 --- a/testsuite/compiler/compute/record.gfs.gold +++ b/testsuite/compiler/compute/record.gfs.gold @@ -1,9 +1,9 @@ "hello" "x" "y" -\v0 -> v0.x +\r -> r.x {x = "x"; y = "y"; z = "z"} {x = "x"; y = "y'"} -\v0 -> {y = "y'"} -\v0 -> {x = v0.x; y = "y'"} -\v0 -> {b = "b"} +\r -> {y = "y'"} +\r -> {x = r.x; y = "y'"} +\r -> {b = "b"} diff --git a/testsuite/compiler/compute/string_matching.gfs.gold b/testsuite/compiler/compute/string_matching.gfs.gold index 49606e060..e0de96fe5 100644 --- a/testsuite/compiler/compute/string_matching.gfs.gold +++ b/testsuite/compiler/compute/string_matching.gfs.gold @@ -25,8 +25,8 @@ param_table.Q2 "xy" param_table.Q1 param_table.Q2 -\v0 -> case of { - "q1" => param_table.Q1; - _ => param_table.Q2 - } +\x -> case of { + "q1" => param_table.Q1; + _ => param_table.Q2 + } pre {"в"; "във" / strs {"в"; "ф"}}