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

bug fix and refactoring in the cc command

Browse Source
This commit is contained in:
krangelov
2021-12-16 13:14:29 +01:00
parent 8466692584
commit 4ed287a809
12 changed files with 132 additions and 103 deletions
Download Patch File Download Diff File Expand all files Collapse all files

152
src/compiler/GF/Compile/Compute/Concrete.hs
View File

@@ -41,7 +41,7 @@ import PGF2.Transactions(LIndex)
normalForm :: Grammar -> Term -> Check Term normalForm :: Grammar -> Term -> Check Term
normalForm gr t = normalForm gr t =
fmap mkFV (runEvalM gr (eval [] t [] >>= value2term 0)) fmap mkFV (runEvalM gr (eval [] t [] >>= value2term []))
where where
mkFV [t] = t mkFV [t] = t
mkFV ts = FV ts mkFV ts = FV ts
@@ -62,7 +62,7 @@ data Value s
| VSusp (Thunk s) (Env s) (Value s -> EvalM s (Value s)) [Thunk s] | VSusp (Thunk s) (Env s) (Value s -> EvalM s (Value s)) [Thunk s]
| VGen {-# UNPACK #-} !Int [Thunk s] | VGen {-# UNPACK #-} !Int [Thunk s]
| VClosure (Env s) Term | VClosure (Env s) Term
| VProd BindType Ident (Value s) (Env s) Term | VProd BindType Ident (Value s) (Value s)
| VRecType [(Label, Value s)] | VRecType [(Label, Value s)]
| VR [(Label, Thunk s)] | VR [(Label, Thunk s)]
| VP (Value s) Label [Thunk s] | VP (Value s) Label [Thunk s]
@@ -92,7 +92,7 @@ showValue (VMeta _ _ _) = "VMeta"
showValue (VSusp _ _ _ _) = "VSusp" showValue (VSusp _ _ _ _) = "VSusp"
showValue (VGen _ _) = "VGen" showValue (VGen _ _) = "VGen"
showValue (VClosure _ _) = "VClosure" showValue (VClosure _ _) = "VClosure"
showValue (VProd _ _ _ _ _) = "VProd" showValue (VProd _ _ _ _) = "VProd"
showValue (VRecType _) = "VRecType" showValue (VRecType _) = "VRecType"
showValue (VR lbls) = "(VR {"++unwords (map (\(lbl,_) -> show lbl) lbls)++"})" showValue (VR lbls) = "(VR {"++unwords (map (\(lbl,_) -> show lbl) lbls)++"})"
showValue (VP v l _) = "(VP "++showValue v++" "++show l++")" 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) return (VMeta tnk env vs)
eval env (ImplArg t) [] = eval env t [] eval env (ImplArg t) [] = eval env t []
eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 [] 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 (Typed t ty) vs = eval env t vs
eval env (RecType lbls) [] = do lbls <- mapM (\(lbl,ty) -> fmap ((,) lbl) (eval env ty [])) lbls eval env (RecType lbls) [] = do lbls <- mapM (\(lbl,ty) -> fmap ((,) lbl) (eval env ty [])) lbls
return (VRecType 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 let v0 = VS v1 tnk2 vs
case v1 of case v1 of
VT _ env cs -> patternMatch v0 (map (\(p,t) -> (env,[p],tnk2:vs,t)) cs) VT _ env cs -> patternMatch v0 (map (\(p,t) -> (env,[p],tnk2:vs,t)) cs)
VV vty tnks -> do t2 <- force tnk2 >>= value2term (length env) VV vty tnks -> do t2 <- force tnk2 >>= value2term (map fst env)
ty <- value2term (length env) vty ty <- value2term (map fst env) vty
ts <- getAllParamValues ty ts <- getAllParamValues ty
case lookup t2 (zip ts tnks) of case lookup t2 (zip ts tnks) of
Just tnk -> do v <- force tnk 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 Success r -> bindInt gr k mt r s (iv+1) max
| otherwise = return (Success r) | otherwise = return (Success r)
value2term i (VApp q tnks) = value2term xs (VApp q tnks) =
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term i)) (if fst q == cPredef then Q q else QC q) tnks foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (if fst q == cPredef then Q q else QC q) tnks
value2term i (VMeta m env tnks) = do value2term xs (VMeta m env tnks) = do
res <- zonk m tnks res <- zonk m tnks
case res of case res of
Right i -> foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term i)) (Meta i) tnks Right i -> foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (Meta i) tnks
Left v -> value2term i v Left v -> value2term xs v
value2term i (VSusp j env k vs) = do value2term xs (VSusp j env k vs) = do
v <- k (VGen maxBound vs) v <- k (VGen maxBound vs)
value2term i v value2term xs v
value2term i (VGen j tnks) = value2term xs (VGen j tnks) =
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term i)) (Vr (identS ('v':show j))) tnks foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (Vr (reverse xs !! j)) tnks
value2term i (VClosure env (Abs b x t)) = do value2term xs (VClosure env (Abs b x t)) = do
tnk <- newEvaluatedThunk (VGen i []) tnk <- newEvaluatedThunk (VGen (length xs) [])
v <- eval ((x,tnk):env) t [] v <- eval ((x,tnk):env) t []
t <- value2term (i+1) v let x' = mkFreshVar xs x
return (Abs b (identS ('v':show i)) t) t <- value2term (x':xs) v
value2term i (VProd b x v1 env t2) return (Abs b x' t)
| x == identW = do t1 <- value2term i v1 value2term xs (VProd b x v1 (VClosure env t2))
| x == identW = do t1 <- value2term xs v1
v2 <- eval env t2 [] v2 <- eval env t2 []
t2 <- value2term i v2 t2 <- value2term xs v2
return (Prod b x t1 t2) return (Prod b x t1 t2)
| otherwise = do t1 <- value2term i v1 | otherwise = do t1 <- value2term xs v1
tnk <- newEvaluatedThunk (VGen i []) tnk <- newEvaluatedThunk (VGen (length xs) [])
v2 <- eval ((x,tnk):env) t2 [] v2 <- eval ((x,tnk):env) t2 []
t2 <- value2term (i+1) v2 t2 <- value2term (x:xs) v2
return (Prod b (identS ('v':show i)) t1 t2) return (Prod b (mkFreshVar xs x) t1 t2)
value2term i (VRecType lbls) = do value2term xs (VRecType lbls) = do
lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term i v)) lbls lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term xs v)) lbls
return (RecType lbls) return (RecType lbls)
value2term i (VR as) = do value2term xs (VR as) = do
as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (force tnk >>= value2term i)) as as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (force tnk >>= value2term xs)) as
return (R as) return (R as)
value2term i (VP v lbl tnks) = do value2term xs (VP v lbl tnks) = do
t <- value2term i v t <- value2term xs v
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term i)) (P t lbl) tnks foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term xs)) (P t lbl) tnks
value2term i (VExtR v1 v2) = do value2term xs (VExtR v1 v2) = do
t1 <- value2term i v1 t1 <- value2term xs v1
t2 <- value2term i v2 t2 <- value2term xs v2
return (ExtR t1 t2) return (ExtR t1 t2)
value2term i (VTable v1 v2) = do value2term xs (VTable v1 v2) = do
t1 <- value2term i v1 t1 <- value2term xs v1
t2 <- value2term i v2 t2 <- value2term xs v2
return (Table t1 t2) return (Table t1 t2)
value2term i (VT vty _ cs)= do ty <- value2term i vty value2term xs (VT vty env cs)= do
return (T (TTyped ty) cs) ty <- value2term xs vty
value2term i (VV vty tnks)= do ty <- value2term i vty cs <- forM cs $ \(p,t) -> do
ts <- mapM (\tnk -> force tnk >>= value2term i) tnks (_,xs',env') <- pattVars (length xs,xs,env) p
return (V ty ts) v <- eval env' t []
value2term i (VS v1 tnk2 tnks) = do t1 <- value2term i v1 t <- value2term xs' v
t2 <- force tnk2 >>= value2term i return (p,t)
foldM (\e1 tnk -> fmap (App e1) (force tnk >>= value2term i)) (S t1 t2) tnks return (T (TTyped ty) cs)
value2term i (VSort s) = return (Sort s) value2term xs (VV vty tnks)= do ty <- value2term xs vty
value2term i (VStr tok) = return (K tok) ts <- mapM (\tnk -> force tnk >>= value2term xs) tnks
value2term i (VInt n) = return (EInt n) return (V ty ts)
value2term i (VFlt n) = return (EFloat n) value2term xs (VS v1 tnk2 tnks) = do t1 <- value2term xs v1
value2term i (VC vs) = do t2 <- force tnk2 >>= value2term xs
ts <- mapM (value2term i) vs 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 case ts of
[] -> return Empty [] -> return Empty
(t:ts) -> return (foldl C t ts) (t:ts) -> return (foldl C t ts)
value2term i (VGlue v1 v2) = do value2term xs (VGlue v1 v2) = do
t1 <- value2term i v1 t1 <- value2term xs v1
t2 <- value2term i v2 t2 <- value2term xs v2
return (Glue t1 t2) return (Glue t1 t2)
value2term i (VPatt min max p) = return (EPatt min max p) value2term xs (VPatt min max p) = return (EPatt min max p)
value2term i (VPattType v) = do t <- value2term i v value2term xs (VPattType v) = do t <- value2term xs v
return (EPattType t) return (EPattType t)
value2term i (VAlts vd vas) = do value2term xs (VAlts vd vas) = do
d <- value2term i vd d <- value2term xs vd
as <- forM vas $ \(vt,vs) -> do as <- forM vas $ \(vt,vs) -> do
t <- value2term i vt t <- value2term xs vt
s <- value2term i vs s <- value2term xs vs
return (t,s) return (t,s)
return (Alts d as) return (Alts d as)
value2term i (VStrs vs) = do value2term xs (VStrs vs) = do
ts <- mapM (value2term i) vs ts <- mapM (value2term xs) vs
return (Strs ts) 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 data ConstValue a
= Const a = Const a
| RunTime | RunTime

4
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -185,7 +185,7 @@ str2lin (VAlts def alts) = do def <- str2lin def
lin <- str2lin v lin <- str2lin v
return (lin,[s | VStr s <- vs]) return (lin,[s | VStr s <- vs])
return [SymKP def alts] return [SymKP def alts]
str2lin v = do t <- value2term 0 v str2lin v = do t <- value2term [] v
evalError ("the string:" <+> ppTerm Unqualified 0 t $$ evalError ("the string:" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.") "cannot be evaluated at compile time.")
@@ -227,7 +227,7 @@ param2int (VMeta tnk _ _) ty = do
QC q -> do (_,ResParam _ (Just (_,cnt))) <- getInfo q QC q -> do (_,ResParam _ (Just (_,cnt))) <- getInfo q
return (0,[(1,j-1)],cnt) return (0,[(1,j-1)],cnt)
App q (EInt cnt) -> return (0,[(1,j-1)],fromIntegral 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 $$ evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.") "cannot be evaluated at compile time.")

2
src/compiler/GF/Compile/TypeCheck/Concrete.hs
View File

@@ -569,7 +569,7 @@ checkLType gr g trm typ0 = do
Vr _ -> f g (\l -> P t l) Vr _ -> f g (\l -> P t l)
_ -> if length fields == 1 _ -> if length fields == 1
then f g (\l -> P t l) 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)) in Let (x, (Nothing, t)) (f ((Explicit,x,RecType fields):g) (\l -> P (Vr x) l))
rec = withProjection r' fields1 g $ \g p_r' -> rec = withProjection r' fields1 g $ \g p_r' ->

21
src/compiler/GF/Grammar/Macros.hs
View File

@@ -297,22 +297,17 @@ defLinType :: Type
defLinType = RecType [(theLinLabel, typeStr)] defLinType = RecType [(theLinLabel, typeStr)]
-- | refreshing variables -- | refreshing variables
mkFreshVar :: [Ident] -> Ident mkFreshVar :: [Ident] -> Ident -> Ident
mkFreshVar olds = varX (maxVarIndex olds + 1) 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 -- | trying to preserve a given symbol
mkFreshVarX :: [Ident] -> Ident -> Ident mkFreshVarX :: [Ident] -> Ident -> Ident
mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x mkFreshVarX olds x = if (elem x olds) then (varX (maximum ((-1) : (map varIndex 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))
-- | create a terminal for concrete syntax -- | create a terminal for concrete syntax
string2term :: String -> Term string2term :: String -> Term

9
src/compiler/GF/Infra/Ident.hs
View File

@@ -19,7 +19,7 @@ module GF.Infra.Ident (-- ** Identifiers
identS, identC, identW, identS, identC, identW,
-- *** Special identifiers for internal use -- *** Special identifiers for internal use
identV, identV,
varStr, varX, varIndex, varStr, varX, varIndex, varIndex',
-- *** Raw identifiers -- *** Raw identifiers
RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent, RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
isPrefixOf, showRawIdent isPrefixOf, showRawIdent
@@ -128,3 +128,10 @@ wild = pack "_"
varIndex :: Ident -> Int varIndex :: Ident -> Int
varIndex (IV _ n) = n varIndex (IV _ n) = n
varIndex _ = -1 --- other than IV should not count 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

3
testsuite/compiler/compute/lambda.gfs Normal file
View File

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

2
testsuite/compiler/compute/lambda.gfs.gold Normal file
View File

@@ -0,0 +1,2 @@
\x,x_1 -> x_1
\x,x_1 -> x

2
testsuite/compiler/compute/param_table.gfs
View File

@@ -14,4 +14,4 @@ cc case <Q1,Q2> of {<Q1,Q1> => "11"; <Q1,Q2> => "12"; _ => "??"}
cc case <Q2,Q2> of {<Q1,Q1> => "11"; <Q1,Q2> => "12"; _ => "??"} cc case <Q2,Q2> of {<Q1,Q1> => "11"; <Q1,Q2> => "12"; _ => "??"}
cc <\x -> case x of {Q1 => "q1"; Q2 => "q2"} : Q -> Str> 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 => "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>

18
testsuite/compiler/compute/param_table.gfs.gold
View File

@@ -11,12 +11,12 @@ variants {"p2q1"; "p2q2"}
"p2q1" "p2q1"
"12" "12"
"??" "??"
\v0 -> case <v0 : param_table.Q> of { \x -> case <x : param_table.Q> of {
param_table.Q1 => "q1"; param_table.Q1 => "q1";
param_table.Q2 => "q2" param_table.Q2 => "q2"
} }
\v0 -> "p2" \x -> "p2"
\v0 -> case <v0 : param_table.Q> of { \x -> case <x : param_table.Q> of {
param_table.Q1 => "q1"; param_table.Q1 => "q1";
param_table.Q2 => "q2" param_table.Q2 => "q2"
} }

6
testsuite/compiler/compute/predef.gfs.gold
View File

@@ -1,11 +1,11 @@
4 4
5 5
Predef.length Predef.nonExist Predef.length Predef.nonExist
\v0 -> Predef.length v0 \x -> Predef.length x
"ab" "ab"
"cd" "cd"
"d"
"abc" "abc"
"d"
"ABCD" "ABCD"
"abcd" "abcd"
Predef.PFalse Predef.PFalse
@@ -32,5 +32,5 @@ user error
"x" ++ Predef.CAPIT ++ "y" "x" ++ Predef.CAPIT ++ "y"
"x" ++ Predef.ALL_CAPIT ++ "y" "x" ++ Predef.ALL_CAPIT ++ "y"
"ab" "ab"
\v0 -> v0 + "b" \x -> x + "b"
Predef.PTrue Predef.PTrue

8
testsuite/compiler/compute/record.gfs.gold
View File

@@ -1,9 +1,9 @@
"hello" "hello"
"x" "x"
"y" "y"
\v0 -> v0.x \r -> r.x
{x = "x"; y = "y"; z = "z"} {x = "x"; y = "y"; z = "z"}
{x = "x"; y = "y'"} {x = "x"; y = "y'"}
\v0 -> {y = "y'"} \r -> {y = "y'"}
\v0 -> {x = v0.x; y = "y'"} \r -> {x = r.x; y = "y'"}
\v0 -> {b = "b"} \r -> {b = "b"}

8
testsuite/compiler/compute/string_matching.gfs.gold
View File

@@ -25,8 +25,8 @@ param_table.Q2
"xy" "xy"
param_table.Q1 param_table.Q1
param_table.Q2 param_table.Q2
\v0 -> case <v0 : Str> of { \x -> case <x : Str> of {
"q1" => param_table.Q1; "q1" => param_table.Q1;
_ => param_table.Q2 _ => param_table.Q2
} }
pre {"в"; "във" / strs {"в"; "ф"}} pre {"в"; "във" / strs {"в"; "ф"}}