From 3d7c8ade178c345eca0da5038fa55929400099a1 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Fri, 9 May 2025 18:58:27 +0200 Subject: [PATCH] a draft for the generalized control operators --- .../api/GF/Compile/Compute/Concrete.hs | 4 -- .../api/GF/Compile/Compute/Concrete2.hs | 60 ++++++++++++------- src/compiler/api/GF/Compile/Rename.hs | 19 ++---- .../api/GF/Compile/TypeCheck/ConcreteNew.hs | 52 +++++++++++----- src/compiler/api/GF/Grammar/Grammar.hs | 10 +--- src/compiler/api/GF/Grammar/JSON.hs | 24 ++------ src/compiler/api/GF/Grammar/Lexer.x | 2 - src/compiler/api/GF/Grammar/Macros.hs | 4 +- src/compiler/api/GF/Grammar/Parser.y | 12 ++-- src/compiler/api/GF/Grammar/Predef.hs | 6 ++ src/compiler/api/GF/Grammar/Printer.hs | 15 +++-- 11 files changed, 105 insertions(+), 103 deletions(-) diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute/Concrete.hs index 376cc6aec..7306fab4f 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/api/GF/Compile/Compute/Concrete.hs @@ -287,10 +287,6 @@ eval env (Markup tag as ts) [] = do as <- mapM (\(id,t) -> eval env t [] >>= \v -> return (id,v)) as vs <- mapM (\t -> eval env t []) ts return (VMarkup tag as vs) -eval env (Reset c t) [] = do let limit All = id - limit (Limit n) = fmap (genericTake n) - vs <- limit c (reset (eval env t [])) - return (VMarkup identW [] vs) eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) -> case lookup pv env of Just tnk -> return (i,(tnk,ty)) diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs index 38844dc66..6a1b1ecee 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs +++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs @@ -86,7 +86,7 @@ data Value | VAlts Value [(Value, Value)] | VStrs [Value] | VMarkup Ident [(Ident,Value)] [Value] - | VReset Control Value + | VReset Ident (Maybe Value) Value QIdent | VSymCat Int LIndex [(LIndex, (Value, Type))] | VError Doc -- These two constructors are only used internally @@ -124,7 +124,7 @@ isCanonicalForm False (VFV c vs) = all (isCanonicalForm False) (unvaria isCanonicalForm flat (VAlts d vs) = all (isCanonicalForm flat . snd) vs isCanonicalForm flat (VStrs vs) = all (isCanonicalForm flat) vs isCanonicalForm flat (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat) vs -isCanonicalForm flat (VReset ctl v) = isCanonicalForm flat v +isCanonicalForm flat (VReset ctl cv v _) = maybe True (isCanonicalForm flat) cv && isCanonicalForm flat v isCanonicalForm flat _ = False data ConstValue a @@ -324,7 +324,7 @@ eval g env c (Markup tag as ts) [] = vas = mapC (\c (id,t) -> (id,eval g env c t [])) c1 as vs = mapC (\c t -> eval g env c t []) c2 ts in (VMarkup tag vas vs) -eval g env c (Reset ctl t) [] = VReset ctl (eval g env c t []) +eval g env c (Reset ctl mb_ct t qid) [] = VReset ctl (fmap (\t -> eval g env c t []) mb_ct) (eval g env c t []) qid eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs] eval g env c t@(Opts n cs) vs = if null cs then VError ("No options in expression:" $$ ppTerm Unqualified 0 t) @@ -422,7 +422,7 @@ bubble v = snd (bubble v) let (union1,attrs') = mapAccumL descend' Map.empty attrs (union2,vs') = mapAccumL descend union1 vs in (union2, VMarkup tag attrs' vs') - bubble (VReset ctl v) = lift1 (VReset ctl) v + bubble (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v bubble (VSymCat d i0 vs) = let (union,vs') = mapAccumL descendC Map.empty vs in (union, addVariants (VSymCat d i0 vs') union) @@ -932,26 +932,42 @@ value2termM flat xs (VMarkup tag as vs) = do as <- mapM (\(id,v) -> value2termM flat xs v >>= \t -> return (id,t)) as ts <- mapM (value2termM flat xs) vs return (Markup tag as ts) -value2termM flat xs (VReset ctl v) = do +value2termM flat xs (VReset ctl mb_cv v qid) = do ts <- reset (value2termM True xs v) - case ctl of - All -> case ts of - [t] -> return t - ts -> return (Markup identW [] ts) - One -> case ts of - [] -> mzero - (t:ts) -> return t - Limit n -> case genericTake n ts of - [t] -> return t - ts -> return (Markup identW [] ts) - Coordination (Just mn) conj id -> - case ts of - [] -> mzero - [t] -> return t - ts -> do let cat = showIdent id - t <- listify mn cat ts - return (App (App (QC (mn,identS ("Conj"++cat))) (QC (mn,conj))) t) + reduce ctl mb_cv ts where + reduce ctl mb_cv ts + | ctl == cConcat = do + ts' <- case mb_cv of + Just (VInt n) -> return (genericTake n ts) + Nothing -> return ts + _ -> evalError (pp "[concat: .. | ..] requires an integer constant") + case ts of + [t] -> return t + ts -> return (Markup identW [] ts) + | ctl == cOne = + case (ts,mb_cv) of + ([] ,Nothing) -> mzero + ([] ,Just v) -> value2termM flat xs v + (t:ts,_) -> return t + | ctl == cDefault = + case (ts,mb_cv) of + ([] ,Nothing) -> mzero + ([] ,Just v) -> value2termM flat xs v + (ts,_) -> msum (map pure ts) + | ctl == cList = + case (ts,mb_cv) of + ([], _) -> mzero + ([t], _) -> return t + (ts,Just cv) -> + do let cat = showIdent (snd qid) + mn = fst qid + ct <- value2termM flat xs cv + t <- listify mn cat ts + return (App (App (QC (mn,identS ("Conj"++cat))) ct) t) + _ -> evalError (pp "[list: .. | ..] requires an argument") + | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined") + listify mn cat [t1,t2] = do return (App (App (QC (mn,identS ("Base"++cat))) t1) t2) listify mn cat (t1:ts) = do t2 <- listify mn cat ts return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2) diff --git a/src/compiler/api/GF/Compile/Rename.hs b/src/compiler/api/GF/Compile/Rename.hs index 8ea3bd1ab..6015f3a7a 100644 --- a/src/compiler/api/GF/Compile/Rename.hs +++ b/src/compiler/api/GF/Compile/Rename.hs @@ -238,21 +238,12 @@ renameTerm env vars = ren vars where (p',_) <- renpatt p return $ EPatt minp maxp p' - Reset ctl t -> do - ctl <- case ctl of - Coordination _ conj cat -> - checks [ do t <- renid' (Cn conj) - case t of - Q (mn,id) -> return (Coordination (Just mn) conj cat) - QC (mn,id) -> return (Coordination (Just mn) conj cat) - _ -> return (Coordination Nothing conj cat) - , if showIdent conj == "one" - then return One - else checkError ("Undefined control" <+> pp conj) - ] - ctl -> do return ctl + Reset ctl mb_ct t qid -> do + mv_ct <- case mb_ct of + Just ct -> liftM Just $ ren vs ct + Nothing -> return mb_ct t <- ren vs t - return (Reset ctl t) + return (Reset ctl mv_ct t qid) _ -> composOp (ren vs) trm diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs index 954908b76..92c84df83 100644 --- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs @@ -370,21 +370,43 @@ tcRho scope c (Markup tag attrs children) mb_ty = do c1 attrs res <- mapCM (\c child -> tcRho scope c child Nothing) c2 children instSigma scope c3 (Markup tag attrs (map fst res)) vtypeMarkup mb_ty -tcRho scope c (Reset ctl t) mb_ty = - let (c1,c2) = split c - in case ctl of - All -> do (t,_) <- tcRho scope c1 t Nothing - instSigma scope c2 (Reset ctl t) vtypeMarkup mb_ty - One -> do (t,ty) <- tcRho scope c t mb_ty - return (Reset ctl t,ty) - Limit n -> do (t,_) <- tcRho scope c1 t Nothing - instSigma scope c2 (Reset ctl t) vtypeMarkup mb_ty - Coordination mb_mn@(Just mn) conj _ - -> do tcRho scope c1 (QC (mn,conj)) (Just (VApp poison (mn,identS "Conj") [])) - (t,ty) <- tcRho scope c2 t mb_ty - case ty of - VApp c id [] -> return (Reset (Coordination mb_mn conj (snd id)) t, ty) - _ -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty) +tcRho scope c (Reset ctl mb_ct t qid) mb_ty + | ctl == cConcat = do + let (c1,c23) = split c + (c2,c3 ) = split c23 + (t,_) <- tcRho scope c1 t Nothing + mb_ct <- case mb_ct of + Just ct -> do (ct,_) <- tcRho scope c2 ct (Just vtypeInt) + return (Just ct) + Nothing -> return Nothing + instSigma scope c2 (Reset ctl mb_ct t qid) vtypeMarkup mb_ty + | ctl == cOne = do + let (c1,c2) = split c + (t,ty) <- tcRho scope c1 t mb_ty + mb_ct <- case mb_ct of + Just ct -> do (ct,ty) <- tcRho scope c2 ct (Just ty) + return (Just ct) + Nothing -> return Nothing + return (Reset ctl mb_ct t qid,ty) + | ctl == cDefault = do + let (c1,c2) = split c + (t,ty) <- tcRho scope c1 t mb_ty + mb_ct <- case mb_ct of + Just ct -> do (ct,ty) <- tcRho scope c2 ct (Just ty) + return (Just ct) + Nothing -> evalError (pp "[list: .. | ..] requires an argument") + return (Reset ctl mb_ct t qid,ty) + | ctl == cList = do + do let (c1,c2) = split c + mb_ct <- case mb_ct of + Just ct -> do (ct,ty) <- tcRho scope c1 ct Nothing + return (Just ct) + Nothing -> evalError (pp "[list: .. | ..] requires an argument") + (t,ty) <- tcRho scope c2 t mb_ty + case ty of + VApp c qid [] -> return (Reset ctl mb_ct t qid, ty) + _ -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty) + | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined") tcRho scope s (Opts n cs) mb_ty = do let (s1,s2,s3) = split3 s (n,_) <- tcRho scope s1 n Nothing diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs index d2a7c6487..0300b19a8 100644 --- a/src/compiler/api/GF/Grammar/Grammar.hs +++ b/src/compiler/api/GF/Grammar/Grammar.hs @@ -44,7 +44,6 @@ module GF.Grammar.Grammar ( Fun, QIdent, BindType(..), - Control(..), Patt(..), TInfo(..), Label(..), @@ -400,7 +399,7 @@ data Term = | FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@ | Markup Ident [(Ident,Term)] [Term] - | Reset Control Term + | Reset Ident (Maybe Term) Term QIdent | Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@ | Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@ @@ -408,13 +407,6 @@ data Term = | TSymVar Int Int deriving (Show, Eq, Ord) -data Control - = All - | One - | Limit Integer - | Coordination (Maybe ModuleName) Ident Ident - deriving (Show, Eq, Ord) - -- | Patterns data Patt = PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@ diff --git a/src/compiler/api/GF/Grammar/JSON.hs b/src/compiler/api/GF/Grammar/JSON.hs index 0a373e5b1..ce24559bf 100644 --- a/src/compiler/api/GF/Grammar/JSON.hs +++ b/src/compiler/api/GF/Grammar/JSON.hs @@ -129,14 +129,8 @@ term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag) , ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs)) , ("children",showJSON (map term2json children)) ] -term2json (Reset ctl t) = - let jctl = case ctl of - All -> showJSON "all" - One -> showJSON "one" - Limit n -> showJSON n - Coordination Nothing conj cat -> makeObj [("conj",showJSON conj), ("cat",showJSON cat)] - Coordination (Just mod) conj cat -> makeObj [("mod",showJSON mod), ("conj",showJSON conj), ("cat",showJSON cat)] - in makeObj [("reset",jctl), ("term",term2json t)] +term2json (Reset ctl ct t qid) = + makeObj ([("ctl",showJSON ctl)]++maybe [] (\t->[("ct",term2json t)]) ct++[("term",term2json t), ("qid",showJSON qid)]) term2json (Alts def alts) = makeObj [("def",term2json def), ("alts",showJSON (map (\(t1,t2) -> (term2json t1, term2json t2)) alts))] term2json (Strs ts) = makeObj [("strs",showJSON (map term2json ts))] term2json (EPatt _ _ p) = makeObj [("epatt",patt2json p)] @@ -186,7 +180,8 @@ json2term o = Vr <$> o!:"vr" <|> Markup <$> (o!:"tag") <*> (o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*> (o!:"children" >>= mapM json2term) - <|> Reset <$> (readJSON >=> valFromObj "reset" >=> json2ctl) o <*> o!<"term" + <|> Reset <$> o!:"ctl" <*> fmap Just (o!<"ct") <*> o!<"term" <*> o!:"qid" + <|> Reset <$> o!:"ctl" <*> pure Nothing <*> o!<"term" <*> o!:"qid" <|> Alts <$> (o!<"def") <*> (o!:"alts" >>= mapM (\(x,y) -> liftM2 (,) (json2term x) (json2term y))) <|> Strs <$> (o!:"strs" >>= mapM json2term) where @@ -202,17 +197,6 @@ json2term o = Vr <$> o!:"vr" mkC [] = Empty mkC (t:ts) = foldl C t ts - json2ctl (JSString (JSONString "all")) = return All - json2ctl (JSString (JSONString "one")) = return One - json2ctl (JSRational _ i) = return (Limit (round i)) - json2ctl (JSObject o) = do - mb_mod <- fmap Just (valFromObj "mod" o) <|> return Nothing - conj <- valFromObj "conj" o - cat <- valFromObj "cat" o - return (Coordination mb_mod conj cat) - json2ctl _ = fail "Invalid control value for reset" - - patt2json (PC id ps) = makeObj [("pc",showJSON id),("args",showJSON (map patt2json ps))] patt2json (PP (mn,id) ps) = makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map patt2json ps))] patt2json (PV id) = makeObj [("pv",showJSON id)] diff --git a/src/compiler/api/GF/Grammar/Lexer.x b/src/compiler/api/GF/Grammar/Lexer.x index 1130aa0f1..d686b25b5 100644 --- a/src/compiler/api/GF/Grammar/Lexer.x +++ b/src/compiler/api/GF/Grammar/Lexer.x @@ -116,7 +116,6 @@ data Token | T_lam | T_lamlam | T_cbrack - | T_reset | T_ocurly | T_bar | T_ccurly @@ -213,7 +212,6 @@ coreResWords = Map.fromList , b "?" T_questmark , b "[" T_obrack , b "]" T_cbrack - , b "[:" T_reset , b "\\" T_lam , b "\\\\" T_lamlam , b "{" T_ocurly diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs index edaa400ac..526969b93 100644 --- a/src/compiler/api/GF/Grammar/Macros.hs +++ b/src/compiler/api/GF/Grammar/Macros.hs @@ -418,7 +418,7 @@ composOp co trm = ELin c ty -> liftM (ELin c) (co ty) ImplArg t -> liftM ImplArg (co t) Markup t as cs -> liftM2 (Markup t) (mapAttrs co as) (mapM co cs) - Reset c t -> liftM (Reset c) (co t) + Reset ctl ct t qid->liftM2 (\mb_ct t->Reset ctl ct t qid) (maybe (pure Nothing) (fmap Just . co) ct) (co t) Typed t ty -> liftM2 Typed (co t) (co ty) _ -> return trm -- covers K, Vr, Cn, Sort, EPatt @@ -459,7 +459,7 @@ collectOp co trm = case trm of FV ts -> mconcatMap co ts Strs tt -> mconcatMap co tt Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs - Reset _ t -> co t + Reset _ ct t _-> maybe mempty co ct <> co t _ -> mempty -- covers K, Vr, Cn, Sort mconcatMap f = mconcat . map f diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y index 54b1fb755..c81724d24 100644 --- a/src/compiler/api/GF/Grammar/Parser.y +++ b/src/compiler/api/GF/Grammar/Parser.y @@ -68,7 +68,6 @@ import qualified Data.Map as Map '@' { T_at } '[' { T_obrack } ']' { T_cbrack } - '[:' { T_reset } '{' { T_ocurly } '}' { T_ccurly } '\\' { T_lam } @@ -488,8 +487,8 @@ Exp6 | '{' ListLocDef '}' {% mkR $2 } | '<' ListTupleComp '>' { R (tuple2record $2) } | '<' Exp ':' Exp '>' { Typed $2 $4 } - | '[:' Control '|' Tag ']' { Reset $2 $4 } - | '[:' Control '|' Exp ']' { Reset $2 $4 } + | '[' Control '|' Tag ']' { Reset (fst $2) (snd $2) $4 undefined } + | '[' Control '|' Exp ']' { Reset (fst $2) (snd $2) $4 undefined } | '(' Exp ')' { $2 } ListExp :: { [Term] } @@ -747,10 +746,9 @@ ListMarkup :: { [Term] } | Exp { [$1] } | Markup ListMarkup { $1 : $2 } -Control :: { Control } - : { All } - | Integer { Limit (fromIntegral $1) } - | Ident { Coordination Nothing $1 identW } +Control :: { (Ident,Maybe Term) } + : Ident { ($1, Nothing) } + | Ident ':' Exp6 { ($1, Just $3) } Attributes :: { [(Ident,Term)] } Attributes diff --git a/src/compiler/api/GF/Grammar/Predef.hs b/src/compiler/api/GF/Grammar/Predef.hs index 2bc167193..4313042fa 100644 --- a/src/compiler/api/GF/Grammar/Predef.hs +++ b/src/compiler/api/GF/Grammar/Predef.hs @@ -61,6 +61,12 @@ cToStr = identS "toStr" cMapStr = identS "mapStr" cError = identS "error" +-- * Used in the delimited continuations +cConcat = identS "concat" +cOne = identS "one" +cDefault = identS "default" +cList = identS "list" + -- * Hacks: dummy identifiers used in various places. -- Not very nice! diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs index d2048da89..3f7364bbb 100644 --- a/src/compiler/api/GF/Grammar/Printer.hs +++ b/src/compiler/api/GF/Grammar/Printer.hs @@ -256,8 +256,11 @@ ppTerm q d (Markup tag attrs children) | otherwise = pp "<" <> pp tag <+> hsep (map (ppMarkupAttr q) attrs) <> pp ">" $$ nest 3 (ppMarkupChildren q children) $$ pp " pp tag <> pp ">" -ppTerm q d (Reset ctl t) - = pp "[:" <> ppControl q ctl <+> pp "|" <> ppTerm q 0 t <> pp "]" +ppTerm q d (Reset ctl ct t _) + = pp "[" <> pp ctl <> + maybe empty (\t -> ':' <+> ppTerm q 6 t) ct <> + pp "|" <> ppTerm q 0 t <> + pp "]" ppTerm q d (TSymCat i r rs) = pp '<' <> pp i <> pp ',' <> ppLinFun (pp.fst) r rs <> pp '>' ppTerm q d (TSymVar i r) = pp '<' <> pp i <> pp ',' <> pp '$' <> pp r <> pp '>' @@ -265,12 +268,8 @@ ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e -ppControl q All = empty -ppControl q One = pp "one" -ppControl q (Limit n) = pp n -ppControl q (Coordination mb_mn n _) = ppTerm q 0 (case mb_mn of - Just mn -> QC (mn,n) - Nothing -> Cn n) +ppControl q (id,Nothing) = pp id +ppControl q (id,Just t ) = pp id <> ':' <+> ppTerm q 6 t instance Pretty Patt where pp = ppPatt Unqualified 0