From b9939318207f0986193163607d5974db58b26c82 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 10 Jun 2025 17:27:30 +0000 Subject: [PATCH 1/2] change the semantics of bubbling and add the len construction --- .../api/GF/Compile/Compute/Concrete2.hs | 19 ++++++++++++++++--- .../api/GF/Compile/TypeCheck/ConcreteNew.hs | 11 +++++++++++ src/compiler/api/GF/Grammar/Predef.hs | 1 + 3 files changed, 28 insertions(+), 3 deletions(-) diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs index 7acb76e9d..1799264ce 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs +++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs @@ -24,6 +24,7 @@ import GF.Grammar.Predef import GF.Grammar.Printer hiding (ppValue) import GF.Grammar.Lockfield(lockLabel) import GF.Text.Pretty hiding (empty) +import qualified GF.Text.Pretty as PP import Control.Monad import Control.Applicative hiding (Const) import qualified Control.Applicative as A @@ -411,18 +412,20 @@ bubble v = snd (bubble v) bubble v@(VFV c (VarFree vs)) | null vs = (Map.empty, v) | otherwise = let (union,vs') = mapAccumL descend Map.empty vs - in (Map.insert c (BubbleFree (length vs),1) union, addVariants (VFV c (VarFree vs')) union) + in (Map.insert c (BubbleFree (length vs),1) union, VFV c (VarFree vs')) bubble v@(VFV c (VarOpts n os)) | null os = (Map.empty, v) | otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty os - in (Map.insert c (BubbleOpts n (fst <$> os),1) union, addVariants (VFV c (VarOpts n os')) union) + in (Map.insert c (BubbleOpts n (fst <$> os),1) union, VFV c (VarOpts n os')) bubble (VAlts v vs) = lift1L2 VAlts v vs bubble (VStrs vs) = liftL VStrs vs bubble (VMarkup tag attrs vs) = let (union1,attrs') = mapAccumL descend' Map.empty attrs (union2,vs') = mapAccumL descend union1 vs in (union2, VMarkup tag attrs' vs') - bubble (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v + bubble (VReset ctl mb_cv v id) = + let (union,v') = bubble v + in (Map.empty,VReset ctl mb_cv v' id) bubble (VSymCat d i0 vs) = let (union,vs') = mapAccumL descendC Map.empty vs in (union, addVariants (VSymCat d i0 vs') union) @@ -972,6 +975,11 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do t <- listify mn cat ts return (App (App (QC (mn,identS ("Conj"++cat))) ct) t) _ -> evalError (pp "[list: .. | ..] requires an argument") + | ctl == cLen = + case mb_cv of + Just cv -> do g <- globals + value2termM True xs (apply g cv [VInt (genericLength ts)]) + Nothing -> return (EInt (genericLength ts)) | 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) @@ -999,6 +1007,7 @@ pattVars st (PSeq _ _ p1 _ _ p2) = pattVars (pattVars st p1) p2 pattVars st _ = st + ppValue q d (VApp c f vs) = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs)) ppValue q d (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs)) ppValue q d (VSusp i k vs) = prec d 4 (hsep (pp "#susp" : (if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs)) @@ -1030,6 +1039,10 @@ ppValue q d (VFV i vs) = prec d 4 ("variants" <+> pp i <+> braces (fsep (punctua ppValue q d (VAlts e xs) = prec d 4 ("pre" <+> braces (ppValue q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs)))) ppValue q d (VStrs _) = pp "VStrs" ppValue q d (VMarkup _ _ _) = pp "VMarkup" +ppValue q d (VReset ctl ct t _) = pp "[" <> pp ctl <> + maybe PP.empty (\v -> pp ':' <+> ppValue q 6 v) ct <> + pp "|" <> ppValue q 0 t <> + pp "]" ppValue q d (VSymCat i r rs) = pp '<' <> pp i <> pp ',' <> pp r <> pp '>' ppValue q d (VError msg) = prec d 4 (pp "error" <+> ppTerm q 5 (K (show msg))) ppValue q d (VCRecType ass) = pp "VCRecType" diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs index 74c20f2ab..0aa5a444d 100644 --- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs @@ -414,6 +414,17 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty case ty of VApp c qid [] -> return (Reset ctl mb_ct t (Just qid), ty) _ -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty) + | ctl == cLen = do + do let (c1,c2) = split c + (t,_) <- tcRho scope c1 t Nothing + case mb_ct of + Just ct -> do res_ty <- case mb_ty of + Just ty -> return ty + Nothing -> do i <- newResiduation scope + return (VMeta i []) + (ct,_) <- tcRho scope c2 ct (Just (VProd Explicit identW vtypeInt res_ty)) + return (Reset ctl (Just ct) t Nothing, res_ty) + Nothing -> instSigma scope c2 (Reset ctl Nothing t Nothing) vtypeInt mb_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 diff --git a/src/compiler/api/GF/Grammar/Predef.hs b/src/compiler/api/GF/Grammar/Predef.hs index 5f561303e..ca4ea545b 100644 --- a/src/compiler/api/GF/Grammar/Predef.hs +++ b/src/compiler/api/GF/Grammar/Predef.hs @@ -67,6 +67,7 @@ cConcat' = identS "concat'" cOne = identS "one" cDefault = identS "default" cList = identS "list" +cLen = identS "len" -- * Hacks: dummy identifiers used in various places. -- Not very nice! From 4c8549d6ddf34f85fcb357cabbb09fb3404c17ac Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Wed, 11 Jun 2025 08:48:04 +0000 Subject: [PATCH 2/2] a simple selection operation --- .../api/GF/Compile/Compute/Concrete2.hs | 21 +++++++++++++++++++ .../api/GF/Compile/TypeCheck/ConcreteNew.hs | 15 +++++++++++++ src/compiler/api/GF/Grammar/Predef.hs | 4 ++++ 3 files changed, 40 insertions(+) diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs index 1799264ce..aad10371f 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs +++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs @@ -959,6 +959,22 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do ([] ,Nothing) -> mzero ([] ,Just v) -> value2termM flat xs v (t:ts,_) -> return t + | ctl == cSelect = + case mb_cv of + Just (VInt n) | n >= 0 -> select n ts' + | otherwise -> select (-n-1) (reverse ts') + where + ts' = sortBy compareKey ts + + select _ [] = mzero + select 0 (t:ts) = + case t of + R rs -> case lookup (ident2label cp1) rs of + Just (_,t) -> return t + Nothing -> evalError (pp "Missing label p1") + _ -> evalError (pp "The term must be a record") + select n (t:ts) = select (n-1) ts + _ -> evalError (pp "[select: .. | ..] requires an integer constant") | ctl == cDefault = case (ts,mb_cv) of ([] ,Nothing) -> mzero @@ -985,6 +1001,11 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do 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) + + compareKey (R rs1) (R rs2) = + case (lookup (ident2label cp2) rs1, lookup (ident2label cp2) rs2) of + (Just (_,K s1), Just (_,K s2)) -> compare s1 s2 + value2termM flat xs (VError msg) = evalError msg value2termM flat xs (VCRecType lbls) = do lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs index 0aa5a444d..99d85dd67 100644 --- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs @@ -396,6 +396,21 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty return (Just ct,ty) Nothing -> return (Nothing,ty) return (Reset ctl mb_ct t qid,ty) + | ctl == cSelect = do + let (c1,c2) = split c + ty <- case mb_ty of + Just ty -> return ty + Nothing -> do i <- newResiduation scope + return (VMeta i []) + let rec_ty = VRecType [ (ident2label cp1, ty) + , (ident2label cp2, VSort cStr) + ] + mb_ct <- case mb_ct of + Just ct -> do (ct,_) <- tcRho scope c2 ct (Just vtypeInt) + return (Just ct) + Nothing -> evalError (pp "[select: .. | ..] requires an integer argument") + (t,_) <- tcRho scope c1 t (Just rec_ty) + return (Reset ctl mb_ct t qid,ty) | ctl == cDefault = do let (c1,c2) = split c (t,ty) <- tcRho scope c1 t mb_ty diff --git a/src/compiler/api/GF/Grammar/Predef.hs b/src/compiler/api/GF/Grammar/Predef.hs index ca4ea545b..f807d762a 100644 --- a/src/compiler/api/GF/Grammar/Predef.hs +++ b/src/compiler/api/GF/Grammar/Predef.hs @@ -65,10 +65,14 @@ cError = identS "error" cConcat = identS "concat" cConcat' = identS "concat'" cOne = identS "one" +cSelect = identS "select" cDefault = identS "default" cList = identS "list" cLen = identS "len" +cp1 = identS "p1" +cp2 = identS "p2" + -- * Hacks: dummy identifiers used in various places. -- Not very nice!