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

retain source location for the children of a Markup

Browse Source
This commit is contained in:
Krasimir Angelov
2025-10-19 14:41:29 +00:00
parent 6e529e74d9
commit bd26b24aed
10 changed files with 51 additions and 30 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/compiler/api/GF/Compile/Compute/Concrete.hs
+2 -2
View File
@@ -285,7 +285,7 @@ eval env (Strs ts) [] = do vs <- mapM (\t -> eval env t []) ts
return (VStrs vs)
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
vs <- mapM (\t -> eval env (unLoc t) []) ts
return (VMarkup tag as vs)
eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) ->
case lookup pv env of
@@ -638,7 +638,7 @@ value2term flat xs (VStrs vs) = do
value2term flat xs (VMarkup tag as vs) = do
as <- mapM (\(id,v) -> value2term flat xs v >>= \t -> return (id,t)) as
ts <- mapM (value2term flat xs) vs
return (Markup tag as ts)
return (Markup tag as (map noLoc ts))
value2term flat xs (VCInts (Just i) Nothing) = return (App (Q (cPredef,cInts)) (EInt i))
value2term flat xs (VCInts Nothing (Just j)) = return (App (Q (cPredef,cInts)) (EInt j))
value2term flat xs (VCRecType lctrs) = do
src/compiler/api/GF/Compile/Compute/Concrete2.hs
+11 -7
View File
@@ -87,7 +87,7 @@ data Value
| VFV Choice (Variants Value)
| VAlts Value [(Value, Value)]
| VStrs [Value]
| VMarkup Ident [(Ident,Value)] [Value]
| VMarkup Ident [(Ident,Value)] [L Value]
| VReset Ident (Maybe Value) Value (Maybe QIdent)
| VSymCat Int LIndex [(LIndex, (Value, Type))]
| VError Doc
@@ -126,7 +126,7 @@ isCanonicalForm True (VFV {}) = False
isCanonicalForm False (VFV c vs) = all (isCanonicalForm False) (unvariants vs)
isCanonicalForm flat (VAlts d vs) = all (isCanonicalForm flat . snd) vs
isCanonicalForm flat (VStrs vs) = all (isCanonicalForm flat) vs
isCanonicalForm flat (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat) vs
isCanonicalForm flat (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat . unLoc) vs
isCanonicalForm flat (VReset ctl cv v _) = maybe True (isCanonicalForm flat) cv && isCanonicalForm flat v
isCanonicalForm flat _ = False
@@ -308,7 +308,7 @@ eval g env c (Strs ts) [] = VStrs (mapC (\c t -> eval g env c t []) c ts)
eval g env c (Markup tag as ts) [] =
let (c1,c2) = split c
vas = mapC (\c (id,t) -> (id,eval g env c t [])) c1 as
vs = mapC (\c t -> eval g env c t []) c2 ts
vs = mapC (\c (L loc t) -> L loc (eval g env c t [])) c2 ts
in (VMarkup tag vas vs)
eval g env c (Reset ctl mb_ct t qid) [] = VReset ctl (fmap (\t -> eval g env c t []) mb_ct) (eval g env c t []) qid
eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs]
@@ -410,7 +410,7 @@ bubble v = snd (bubble v)
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
(union2,vs') = mapAccumL descendL union1 vs
in (union2, VMarkup tag attrs' vs')
bubble (VReset ctl mb_cv v id) =
let (union,v') = bubble v
@@ -481,6 +481,10 @@ bubble v = snd (bubble v)
let (choices,v') = bubble v
in (mergeChoices1 union choices,(i,(v',ty)))
descendL union (L loc v) =
let (choices,v') = bubble v
in (mergeChoices1 union choices,L loc v')
descendR union (l,b,v) =
let (choices,v') = bubble v
in (mergeChoices1 union choices,(l,b,v'))
@@ -928,7 +932,7 @@ value2termM flat xs (VStrs vs) = do
return (Strs ts)
value2termM flat xs (VMarkup tag as vs) = do
as <- mapM (\(id,v) -> value2termM flat xs v >>= \t -> return (id,t)) as
ts <- mapM (value2termM flat xs) vs
ts <- mapM (mapM (value2termM flat xs)) vs
return (Markup tag as ts)
value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
ts <- reset (value2termM True xs v)
@@ -942,7 +946,7 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
_ -> evalError (pp "[concat: .. | ..] requires an integer constant")
case ts of
[t] -> return t
ts -> return (Markup identW [] ts)
ts -> return (Markup identW [] (map noLoc ts))
| ctl == cConcat' = do
ts <- case mb_cv of
Just (VInt n) -> return (genericTake n ts)
@@ -951,7 +955,7 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
case ts of
[] -> mzero
[t] -> return t
ts -> return (Markup identW [] ts)
ts -> return (Markup identW [] (map noLoc ts))
| ctl == cOne =
case (ts,mb_cv) of
([] ,Nothing) -> mzero
src/compiler/api/GF/Compile/TypeCheck/Concrete.hs
+2 -2
View File
@@ -452,8 +452,8 @@ tcRho scope c (Markup tag attrs children) mb_ty = do
(t,_) <- tcRho scope c t Nothing
return (id,t))
c1 attrs
res <- mapCM (\c child -> tcRho scope c child Nothing) c2 children
instSigma scope c3 (Markup tag attrs (map fst res)) vtypeMarkup mb_ty
res <- mapCM (\c (L loc child) -> fmap (L loc . fst) (tcRho scope c child Nothing)) c2 children
instSigma scope c3 (Markup tag attrs res) vtypeMarkup mb_ty
tcRho scope c (Reset ctl mb_ct t qid) mb_ty
| ctl == cConcat || ctl == cConcat' = do
let (c1,c23) = split c
src/compiler/api/GF/Data/XML.hs
+12 -1
View File
@@ -4,7 +4,7 @@
--
-- Utilities for creating XML documents.
----------------------------------------------------------------------
module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML, parseXML) where
module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, showsNospaceXML, bottomUpXML, parseXML) where
import Data.Char(isSpace)
import Numeric (readHex)
@@ -38,6 +38,17 @@ showsXML = showsX 0 where
(Empty) -> id
ind i = showString ("\n" ++ replicate (2*i) ' ')
showsNospaceXML :: XML -> ShowS
showsNospaceXML x = case x of
(Data s) -> showString (escape s)
(ETag t as) -> showChar '<' . showString t . showsAttrs as . showString "/>"
(Tag t as cs) ->
showChar '<' . showString t . showsAttrs as . showChar '>' .
concatS (map showsNospaceXML cs) .
showString "</" . showString t . showChar '>'
(Comment c) -> showString "<!-- " . showString c . showString " -->"
(Empty) -> id
showsAttrs :: [Attr] -> ShowS
showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
src/compiler/api/GF/Grammar/Grammar.hs
+1 -1
View File
@@ -396,7 +396,7 @@ data Term =
| FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@
| Markup Ident [(Ident,Term)] [Term]
| Markup Ident [(Ident,Term)] [L Term]
| Reset Ident (Maybe Term) Term (Maybe QIdent)
| Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
src/compiler/api/GF/Grammar/JSON.hs
+2 -2
View File
@@ -126,7 +126,7 @@ term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)]
term2json (FV ts) = makeObj [("variants",showJSON (map term2json ts))]
term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
, ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
, ("children",showJSON (map term2json children))
, ("children",showJSON (map (term2json . unLoc) children))
]
term2json (Reset ctl ct t qid) =
makeObj ([("ctl",showJSON ctl)]++maybe [] (\t->[("ct",term2json t)]) ct++[("term",term2json t), ("qid",showJSON qid)])
@@ -177,7 +177,7 @@ json2term o = Vr <$> o!:"vr"
<|> FV <$> (o!:"variants" >>= mapM json2term)
<|> Markup <$> (o!:"tag") <*>
(o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*>
(o!:"children" >>= mapM json2term)
(o!:"children" >>= mapM (fmap noLoc . json2term))
<|> Reset <$> o!:"ctl" <*> fmap Just (o!<"ct") <*> o!<"term" <*> o!:"qid"
<|> Reset <$> o!:"ctl" <*> pure Nothing <*> o!<"term" <*> o!:"qid"
<|> Alts <$> (o!<"def") <*> (o!:"alts" >>= mapM (\(x,y) -> liftM2 (,) (json2term x) (json2term y)))
src/compiler/api/GF/Grammar/Macros.hs
+2 -2
View File
@@ -418,7 +418,7 @@ composOp co trm =
ELincat c ty -> liftM (ELincat c) (co ty)
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)
Markup t as cs -> liftM2 (Markup t) (mapAttrs co as) (mapM (mapM co) cs)
Reset ctl ct t qid->liftM2 (\mb_ct t->Reset ctl ct t qid) (maybe (pure Nothing) (fmap Just . co) ct) (co t)
Typed t ty -> liftM2 Typed (co t) (co ty)
_ -> return trm -- covers K, Vr, Cn, Sort, EPatt
@@ -466,7 +466,7 @@ collectOp co trm = case trm of
Strs tt -> mconcatMap co tt
ELincat _ t -> co t
ELin _ t -> co t
Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs
Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap (co . unLoc) cs
Reset _ ct t _-> maybe mempty co ct <> co t
_ -> mempty -- covers K, Vr, Cn, Sort
src/compiler/api/GF/Grammar/Parser.y
+12 -10
View File
@@ -714,9 +714,11 @@ ERHS3 :: { ERHS }
| '(' ERHS0 ')' { $2 }
NLG :: { Map.Map Ident Info }
: ListNLGDef { Map.fromList $1 }
| Posn Exp Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
| Posn ListMarkup2 Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 (mkMarkup $2)))) }
: ListNLGDef { Map.fromList $1 }
| Posn Exp Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
| ListMarkup2 { case (head $1,last $1) of
(L (Local l1 _) _, L (Local _ l2) _) -> Map.singleton (identS "main") (ResOper Nothing (Just (L (Local l1 l2) (mkMarkup $1))))
}
ListNLGDef :: { [(Ident,Info)] }
ListNLGDef
@@ -730,10 +732,10 @@ NLGDef
| Posn LhsName ListArg '=' ListMarkup2 Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing (Just (mkL $1 $6 (mkAbs $3 (mkMarkup $5))))] }
| Posn LhsNames ':' Exp '=' ListMarkup2 Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 (mkMarkup $6)))] }
Markup :: { Term }
Markup :: { L Term }
Markup
: Tag { $1 }
| Exp ';' { $1 }
: Posn Tag Posn { mkL $1 $3 $2 }
| Posn Exp Posn ';' { mkL $1 $3 $2 }
Tag :: { Term }
Tag
@@ -742,12 +744,12 @@ Tag
else fail ("Unmatched closing tag " ++ showIdent $1) }
| '<tag' Attributes '/' '>' { Markup $1 $2 [] }
ListMarkup :: { [Term] }
ListMarkup :: { [L Term] }
: { [] }
| Exp { [$1] }
| Posn Exp Posn { [mkL $1 $3 $2] }
| Markup ListMarkup { $1 : $2 }
ListMarkup2 :: { [Term] }
ListMarkup2 :: { [L Term] }
: Markup { [$1] }
| Markup ListMarkup2 { $1 : $2 }
@@ -889,7 +891,7 @@ mkAlts cs = case cs of
mkL :: Posn -> Posn -> x -> L x
mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
mkMarkup [t] = t
mkMarkup [t] = unLoc t
mkMarkup ts = Markup identW [] ts
}
src/compiler/api/GF/Grammar/Printer.hs
+2 -2
View File
@@ -365,8 +365,8 @@ ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
ppMarkupAttr q (id,e) =
id <> pp '=' <> ppTerm q 5 e
ppMarkupChildren q [t] = ppTerm q 0 t
ppMarkupChildren q (t:ts) =
ppMarkupChildren q [L _ t] = ppTerm q 0 t
ppMarkupChildren q (L _ t:ts) =
(case t of
Markup {} -> ppTerm q 0 t
_ -> ppTerm q 0 t <> ';') $$
src/compiler/api/GF/Infra/Location.hs
+5 -1
View File
@@ -14,10 +14,14 @@ data Location
deriving (Show,Eq,Ord)
-- | Attaching location information
data L a = L Location a deriving Show
data L a = L Location a deriving (Show, Eq, Ord)
instance Functor L where fmap f (L loc x) = L loc (f x)
instance Foldable L where foldr f b (L loc x) = f x b
instance Traversable L where traverse f (L loc x) = pure (L loc) <*> f x
unLoc :: L a -> a
unLoc (L _ x) = x