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

a work in progress implementation for reset

Browse Source
This commit is contained in:
Krasimir Angelov
2024-08-26 13:47:39 +02:00
parent 428287346a
commit 676a01db2c
7 changed files with 42 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
src/compiler/api/GF/Compile/Compute/Concrete.hs
View File

@@ -134,7 +134,7 @@ showValue (VInt _) = "VInt"
showValue (VFlt _) = "VFlt"
showValue (VStr s) = "(VStr "++show s++")"
showValue VEmpty = "VEmpty"
showValue (VC _ _) = "VC"
showValue (VC v1 v2) = "(VC "++showValue v1++" "++showValue v2++")"
showValue (VGlue _ _) = "VGlue"
showValue (VPatt _ _ _) = "VPatt"
showValue (VPattType _) = "VPattType"
@@ -272,6 +272,10 @@ 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))
@@ -367,16 +371,6 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
(PString s1, VEmpty)
| null s1 -> match env ps eqs args
(PSeq min1 max1 p1 min2 max2 p2,v)
-> case value2string v of
Const s -> do let n = length s
lo = min1 `max` (n-fromMaybe n max2)
hi = (n-min2) `min` fromMaybe n max1
(ds,cs) = splitAt lo s
eqs <- matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args
patternMatch v0 eqs
RunTime -> return v0
NonExist-> patternMatch v0 eqs
(PRep minp maxp p, v)
-> case value2string v of
Const s -> let n = length s
lo = min1 `max` (n-fromMaybe n max2)
@@ -388,7 +382,13 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
else patternMatch v0 eqs
RunTime -> return v0
NonExist-> patternMatch v0 eqs
(PChar, VStr [_]) -> match env ps eqs args
(PRep minp maxp p, v)
-> case value2string v of
Const s -> do let n = length s `div` (max minp 1)
eqs <- matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args)
patternMatch v0 eqs
RunTime -> return v0
NonExist-> patternMatch v0 eqs
(PChars cs, VStr [c])
| elem c cs -> match env ps eqs args
(PInt n, VInt m)

5
src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs
View File

@@ -363,7 +363,10 @@ tcRho scope (Markup tag attrs children) mb_ty = do
(t,_) <- tcRho scope t Nothing
return (id,t)
res <- mapM (\child -> tcRho scope child Nothing) children
return (Markup tag attrs (map fst res), vtypeMarkup)
instSigma scope (Markup tag attrs (map fst res)) vtypeMarkup mb_ty
tcRho scope (Reset c t) mb_ty = do
(t,_) <- tcRho scope t Nothing
instSigma scope (Reset c t) vtypeMarkup mb_ty
tcRho scope t _ = unimplemented ("tcRho "++show t)
tcCases scope [] p_ty res_ty = return []

7
src/compiler/api/GF/Grammar/Grammar.hs
View File

@@ -44,6 +44,7 @@ module GF.Grammar.Grammar (
Fun,
QIdent,
BindType(..),
Control(..),
Patt(..),
TInfo(..),
Label(..),
@@ -396,6 +397,7 @@ data Term =
| FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@
| Markup Ident [(Ident,Term)] [Term]
| Reset Control Term
| Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
| Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@
@@ -403,6 +405,11 @@ data Term =
| TSymVar Int Int
deriving (Show, Eq, Ord)
data Control
= All
| Limit Integer
deriving (Show, Eq, Ord)
-- | Patterns
data Patt =
PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@

4
src/compiler/api/GF/Grammar/Lexer.x
View File

@@ -31,7 +31,7 @@ $i = [$l $d _ '] -- identifier character
$u = [.\n] -- universal: any character
@rsyms = -- symbols and non-identifier-like reserved words
\; | \= | \{ | \} | \( | \) | \~ | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/ | \: \= | \: \: \=
\; | \= | \{ | \} | \( | \) | \~ | \* \* | \: | \- \> | \, | \[ | \] | \[\: | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/ | \: \= | \: \: \=
@ident =
(\_ | $l)($l | $d | \_ | \')*
@@ -116,6 +116,7 @@ data Token
| T_lam
| T_lamlam
| T_cbrack
| T_reset
| T_ocurly
| T_bar
| T_ccurly
@@ -207,6 +208,7 @@ resWords = Map.fromList
, b "?" T_questmark
, b "[" T_obrack
, b "]" T_cbrack
, b "[:" T_reset
, b "\\" T_lam
, b "\\\\" T_lamlam
, b "{" T_ocurly

2
src/compiler/api/GF/Grammar/Macros.hs
View File

@@ -418,6 +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)
_ -> return trm -- covers K, Vr, Cn, Sort, EPatt
composSafePattOp op = runIdentity . composPattOp (return . op)
@@ -457,6 +458,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
_ -> mempty -- covers K, Vr, Cn, Sort
mconcatMap f = mconcat . map f

11
src/compiler/api/GF/Grammar/Parser.y
View File

@@ -68,6 +68,7 @@ import qualified Data.Map as Map
'@' { T_at }
'[' { T_obrack }
']' { T_cbrack }
'[:' { T_reset }
'{' { T_ocurly }
'}' { T_ccurly }
'\\' { T_lam }
@@ -485,6 +486,8 @@ Exp6
| '{' ListLocDef '}' {% mkR $2 }
| '<' ListTupleComp '>' { R (tuple2record $2) }
| '<' Exp ':' Exp '>' { Typed $2 $4 }
| '[:' Control '|' Tag ']' { Reset $2 $4 }
| '[:' Control '|' Exp ']' { Reset $2 $4 }
| '(' Exp ')' { $2 }
ListExp :: { [Term] }
@@ -708,8 +711,8 @@ ERHS3 :: { ERHS }
NLG :: { Map.Map Ident Info }
: ListNLGDef { Map.fromList $1 }
| Posn Tag Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 (Abs Explicit (identS "qid") $2)))) }
| Posn Exp Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 (Abs Explicit (identS "qid") $2)))) }
| Posn Tag Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 (Abs Explicit (identS "qid") (Abs Explicit (identS "lang") $2))))) }
| Posn Exp Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 (Abs Explicit (identS "qid") (Abs Explicit (identS "lang") $2))))) }
ListNLGDef :: { [(Ident,Info)] }
ListNLGDef
@@ -733,6 +736,10 @@ ListMarkup :: { [Term] }
| Exp { [$1] }
| Markup ListMarkup { $1 : $2 }
Control :: { Control }
: { All }
| Integer { Limit (fromIntegral $1) }
Attributes :: { [(Ident,Term)] }
Attributes
: { [] }

5
src/compiler/api/GF/Grammar/Printer.hs
View File

@@ -256,6 +256,8 @@ 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 c t)
= pp "[:" <> ppControl c <+> 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 '>'
@@ -263,6 +265,9 @@ 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 All = empty
ppControl (Limit n) = pp n
instance Pretty Patt where pp = ppPatt Unqualified 0
ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)