GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-01 07:12:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

more general and simpler implementation for gluing

Browse Source
This commit is contained in:
Krasimir Angelov
2023-12-16 12:29:13 +01:00
parent 9313b45a4f
commit 4c701e68e2
1 changed files with 21 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -202,32 +202,31 @@ eval env (QC q) vs = return (VApp q vs)
eval env (C t1 t2) [] = do v1 <- eval env t1 [] eval env (C t1 t2) [] = do v1 <- eval env t1 []
v2 <- eval env t2 [] v2 <- eval env t2 []
case (v1,v2) of case (v1,v2) of
(VEmpty,VEmpty) -> return VEmpty
(v1, VEmpty) -> return v1 (v1, VEmpty) -> return v1
(VEmpty,v2 ) -> return v2 (VEmpty,v2 ) -> return v2
_ -> return (VC v1 v2) _ -> return (VC v1 v2)
eval env t@(Glue t1 t2) [] = do v1 <- eval env t1 [] eval env t@(Glue t1 t2) [] = do v1 <- eval env t1 []
v2 <- eval env t2 [] v2 <- eval env t2 []
let glue v = let glue VEmpty v = v
case value2string' v False [] [] of glue (VC v1 v2) v = VC v1 (glue v2 v)
Const (b,ws,qs) -> let b' = case v1 of glue (VApp q []) v
VEmpty -> b | q == (cPredef,cNonExist) = VApp q []
_ -> True glue v VEmpty = v
in case value2string' v1 b' ws qs of glue v (VC v1 v2) = VC (glue v v1) v2
Const (b,ws,qs) -> Just (bind b ws (foldl (\v q->VC v (VApp q [])) (string2value' ws) qs)) glue v (VApp q [])
NonExist -> Just (VApp (cPredef,cNonExist) []) | q == (cPredef,cNonExist) = VApp q []
RunTime -> Nothing glue (VStr s1) (VStr s2) = VStr (s1++s2)
NonExist -> Just (VApp (cPredef,cNonExist) []) glue v (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas]
RunTime -> Nothing glue (VAlts d vas) (VStr s) = pre d vas s
bind True (_:_) v = VC (VApp (cPredef,cBIND) []) v glue (VAlts d vas) v = glue d v
bind _ _ v = v glue v1 v2 = VGlue v1 v2
case (case v2 of
(VAlts d vas) -> do d <- glue d pre vd [] s = glue vd (VStr s)
vas <- mapM (\(v,ss) -> glue v >>= \v -> return (v,ss)) vas pre vd ((v,VStrs ss):vas) s
return (VAlts d vas) | or [startsWith s' s | VStr s' <- ss] = glue v (VStr s)
_ -> do glue v2) of | otherwise = pre vd vas s
Just v -> return v
Nothing -> return (VGlue v1 v2) return (glue v1 v2)
eval env (EPatt min max p) [] = return (VPatt min max p) eval env (EPatt min max p) [] = return (VPatt min max p)
eval env (EPattType t) [] = do v <- eval env t [] eval env (EPattType t) [] = do v <- eval env t []
return (VPattType v) return (VPattType v)
@@ -606,6 +605,7 @@ value2term xs (VCInts Nothing (Just j)) = return (App (Q (cPredef,cInts)) (EInt
value2term xs (VCRecType lctrs) = do value2term xs (VCRecType lctrs) = do
ltys <- mapM (\(l,o,ctr) -> value2term xs ctr >>= \ty -> return (l,ty)) lctrs ltys <- mapM (\(l,o,ctr) -> value2term xs ctr >>= \ty -> return (l,ty)) lctrs
return (RecType ltys) return (RecType ltys)
value2term xs (VSymCat d r rs) = return (TSymCat d r [(i,(identW,ty)) | (i,(_,ty)) <- rs])
value2term xs v = error (showValue v) value2term xs v = error (showValue v)
pattVars st (PP _ ps) = foldM pattVars st ps pattVars st (PP _ ps) = foldM pattVars st ps