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

strings computed from a predefined operation should be tokenized

Browse Source
This commit is contained in:
krangelov
2021-10-05 11:50:59 +02:00
parent 26be741dea
commit 557cdb82a7
1 changed files with 18 additions and 18 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -139,23 +139,23 @@ apply (VClosure env (Abs b x t)) (v:vs) = eval ((x,v):env) t vs
evalPredef id [v] evalPredef id [v]
| id == cLength = return (fmap VInt (liftM genericLength (value2string v))) | id == cLength = return (fmap VInt (liftM genericLength (value2string v)))
evalPredef id [v1,v2] evalPredef id [v1,v2]
| id == cTake = return (fmap VStr (liftM2 genericTake (value2int v1) (value2string v2))) | id == cTake = return (fmap string2value (liftM2 genericTake (value2int v1) (value2string v2)))
evalPredef id [v1,v2] evalPredef id [v1,v2]
| id == cDrop = return (fmap VStr (liftM2 genericDrop (value2int v1) (value2string v2))) | id == cDrop = return (fmap string2value (liftM2 genericDrop (value2int v1) (value2string v2)))
evalPredef id [v1,v2] evalPredef id [v1,v2]
| id == cTk = return (fmap VStr (liftM2 genericTk (value2int v1) (value2string v2))) | id == cTk = return (fmap string2value (liftM2 genericTk (value2int v1) (value2string v2)))
where where
genericTk n = reverse . genericTake n . reverse genericTk n = reverse . genericTake n . reverse
evalPredef id [v1,v2] evalPredef id [v1,v2]
| id == cDp = return (fmap VStr (liftM2 genericDp (value2int v1) (value2string v2))) | id == cDp = return (fmap string2value (liftM2 genericDp (value2int v1) (value2string v2)))
where where
genericDp n = reverse . genericDrop n . reverse genericDp n = reverse . genericDrop n . reverse
evalPredef id [v]
| id == cIsUpper= return (fmap toPBool (liftM (all isUpper) (value2string v)))
evalPredef id [v] evalPredef id [v]
| id == cToUpper= return (fmap VStr (liftM (map toUpper) (value2string v))) | id == cToUpper= return (fmap VStr (liftM (map toUpper) (value2string v)))
evalPredef id [v] evalPredef id [v]
| id == cToLower= return (fmap VStr (liftM (map toLower) (value2string v))) | id == cToLower= return (fmap VStr (liftM (map toLower) (value2string v)))
evalPredef id [v]
| id == cIsUpper= return (fmap toPBool (liftM (all isUpper) (value2string v)))
evalPredef id [v1,v2] evalPredef id [v1,v2]
| id == cEqStr = return (fmap toPBool (liftM2 (==) (value2string v1) (value2string v2))) | id == cEqStr = return (fmap toPBool (liftM2 (==) (value2string v1) (value2string v2)))
evalPredef id [v1,v2] evalPredef id [v1,v2]
@@ -247,16 +247,16 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
Nothing -> evalError ("Missing value for label" <+> pp lbl) Nothing -> evalError ("Missing value for label" <+> pp lbl)
matchStr env ps eqs i ds [] args = do matchStr env ps eqs i ds [] args = do
arg1 <- newEvaluatedThunk (vc (reverse ds)) arg1 <- newEvaluatedThunk (string2value (reverse ds))
arg2 <- newEvaluatedThunk (vc []) arg2 <- newEvaluatedThunk (string2value [])
return ((env,ps,arg1:arg2:args,t) : eqs) return ((env,ps,arg1:arg2:args,t) : eqs)
matchStr env ps eqs 0 ds cs args = do matchStr env ps eqs 0 ds cs args = do
arg1 <- newEvaluatedThunk (vc (reverse ds)) arg1 <- newEvaluatedThunk (string2value (reverse ds))
arg2 <- newEvaluatedThunk (vc cs) arg2 <- newEvaluatedThunk (string2value cs)
return ((env,ps,arg1:arg2:args,t) : eqs) return ((env,ps,arg1:arg2:args,t) : eqs)
matchStr env ps eqs i ds (c:cs) args = do matchStr env ps eqs i ds (c:cs) args = do
arg1 <- newEvaluatedThunk (vc (reverse ds)) arg1 <- newEvaluatedThunk (string2value (reverse ds))
arg2 <- newEvaluatedThunk (vc (c:cs)) arg2 <- newEvaluatedThunk (string2value (c:cs))
eqs <- matchStr env ps eqs (i-1 :: Int) (c:ds) cs args eqs <- matchStr env ps eqs (i-1 :: Int) (c:ds) cs args
return ((env,ps,arg1:arg2:args,t) : eqs) return ((env,ps,arg1:arg2:args,t) : eqs)
@@ -265,12 +265,6 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
matchRep env n minp maxp p minq maxq q ps eqs args = do matchRep env n minp maxp p minq maxq q ps eqs args = do
matchRep env (n-1) minp maxp p (minp+minq) (liftM2 (+) maxp maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args matchRep env (n-1) minp maxp p (minp+minq) (liftM2 (+) maxp maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args
vc s =
case words s of
[] -> VC []
[w] -> VStr w
ws -> VC (map VStr ws)
value2term i (VApp q tnks) = value2term i (VApp q tnks) =
foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (QC q) tnks foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (QC q) tnks
value2term i (VMeta m env tnks) = do value2term i (VMeta m env tnks) = do
@@ -322,6 +316,12 @@ value2string (VStr s) = Just s
value2string (VC vs) = fmap unwords (mapM value2string vs) value2string (VC vs) = fmap unwords (mapM value2string vs)
value2string _ = Nothing value2string _ = Nothing
string2value s =
case words s of
[] -> VC []
[w] -> VStr w
ws -> VC (map VStr ws)
value2int (VInt n) = Just n value2int (VInt n) = Just n
value2int _ = Nothing value2int _ = Nothing