GitHub/gf-core
1
0 Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-10-25 08:43:17 -06:00
Code Issues Packages Projects Releases Wiki Activity

generalize the filter function

Browse Source
This commit is contained in:
Krasimir Angelov committed 2026-10-15 15:09:07 +02:00
1 parent 44a7f1bf7a
commit 7b10bee627
2 files changed
+36 -21
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

src/compiler/api/GF/Compile/Compute.hs
+21 -9
View File
@@ -1037,15 +1037,21 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
select n (t:ts) = select (n-1) ts select n (t:ts) = select (n-1) ts
_ -> evalError (pp "[select: .. | ..] requires an integer constant") _ -> evalError (pp "[select: .. | ..] requires an integer constant")
| ctl == cFilter = | ctl == cFilter =
let filter [] = mzero case mb_cv of
filter (t:ts) = Nothing -> let filter [] = mzero
case t of filter (t:ts) =
R rs -> case (lookup (ident2label cp1) rs, lookup (ident2label cp2) rs) of case t of
(Just (_,t), Just (_,Q q)) R rs -> case (lookup (ident2label cp1) rs, lookup (ident2label cp2) rs) of
| q == (cPredef,cTrue) -> pure t `mplus` filter ts (Just (_,t), Just (_,Q q))
_ -> filter ts | q == (cPredef,cTrue) -> pure t `mplus` filter ts
_ -> evalError (pp "The term must be a record") _ -> filter ts
in filter ts _ -> evalError (pp "The term must be a record")
in filter ts
Just cv -> do cts <- reset (value2termM True xs cv)
case ts \\ cts of
[] -> mzero
[t] -> return t
ts -> return (FV ts)
| ctl == cDefault = | ctl == cDefault =
case (ts,mb_cv) of case (ts,mb_cv) of
([] ,Nothing) -> mzero ([] ,Nothing) -> mzero
@@ -1054,6 +1060,12 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
| ctl == cList = | ctl == cList =
case (ts,mb_cv) of case (ts,mb_cv) of
([], _) -> mzero ([], _) -> mzero
([FV ts],Just cv) ->
do let Just (mn,id) = mb_qid
cat = showIdent id
ct <- value2termM flat xs cv
t <- listify mn cat ts
return (App (App (QC (mn,identS ("Conj"++cat))) ct) t)
([t], _) -> return t ([t], _) -> return t
(ts,Just cv) -> (ts,Just cv) ->
do let Just (mn,id) = mb_qid do let Just (mn,id) = mb_qid
src/compiler/api/GF/Compile/TypeCheck.hs
+15 -12
View File
@@ -526,19 +526,22 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty
Nothing -> evalError (pp "[select: .. | ..] requires an integer argument") Nothing -> evalError (pp "[select: .. | ..] requires an integer argument")
(t,_) <- tcRho scope c1 t (Just rec_ty) (t,_) <- tcRho scope c1 t (Just rec_ty)
return (Reset ctl mb_ct t qid,ty) return (Reset ctl mb_ct t qid,ty)
| ctl == cFilter = concreteOnly "Control operators" $ do | ctl == cFilter = concreteOnly "Control operators" $
ty <- case mb_ty of
Just ty -> return ty
Nothing -> do i <- newResiduation scope
return (VMeta i [])
let rec_ty = VRecType [ (ident2label cp1, True, ty)
, (ident2label cp2, True, VApp (cPredef,cBool) [])
] False
case mb_ct of case mb_ct of
Just ct -> evalError (pp "[filter | ..] cannot take an argument") Just ct -> do
Nothing -> return () (ct,ty) <- tcRho scope c ct mb_ty
(t,_) <- tcRho scope c t (Just rec_ty) (t, ty) <- tcRho scope c t (Just ty)
return (Reset ctl mb_ct t qid,ty) return (Reset ctl (Just ct) t qid,ty)
Nothing -> do
ty <- case mb_ty of
Just ty -> return ty
Nothing -> do i <- newResiduation scope
return (VMeta i [])
let rec_ty = VRecType [ (ident2label cp1, True, ty)
, (ident2label cp2, True, VApp (cPredef,cBool) [])
] False
(t,_) <- tcRho scope c t (Just rec_ty)
return (Reset ctl mb_ct t qid,ty)
| ctl == cDefault = concreteOnly "Control operators" $ do | ctl == cDefault = concreteOnly "Control operators" $ do
let (c1,c2) = split c let (c1,c2) = split c
(t,ty) <- tcRho scope c1 t mb_ty (t,ty) <- tcRho scope c1 t mb_ty