markup

6 files changed, 58 insertions, 18 deletions

diff --git a/src/GF/Canon/AbsGFC.hs b/src/GF/Canon/AbsGFC.hs
index 78f237d38..846a570b8 100644
--- a/src/GF/Canon/AbsGFC.hs
+++ b/src/GF/Canon/AbsGFC.hs
@@ -129,6 +129,7 @@ data Term =
 
 data Tokn =
    KS String
+ | KM String
  | KP [String] [Variant]
   deriving (Eq,Ord,Show)
 
diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs
index e075821b2..45f3c9d81 100644
--- a/src/GF/Canon/CMacros.hs
+++ b/src/GF/Canon/CMacros.hs
@@ -16,37 +16,64 @@ import Monad
 -- macros for concrete syntax in GFC that do not need lookup in a grammar
 
 -- how to mark subtrees, dep. on node, position, whether focus
-type Marker = V.TrNode -> [Int] -> Bool -> (String, String)
+type JustMarker = V.TrNode -> [Int] -> Bool -> (String, String)
+
+-- also to process the text (needed for escapes e.g. in XML)
+type Marker = (JustMarker, Maybe (String -> String))
+
+defTMarker :: JustMarker -> Marker
+defTMarker = flip (curry id) Nothing
 
 markSubtree :: Marker -> V.TrNode -> [Int] -> Bool -> Term -> Term
-markSubtree mk n is = markSubterm . mk n is
+markSubtree (mk,esc) n is = markSubterm esc . mk n is
+
+escapeMkString :: Marker -> Maybe (String -> String)
+escapeMkString = snd
 
 -- if no marking is wanted, use the following
 noMark :: Marker
-noMark _ _ _ = ("","")
+noMark = defTMarker mk where
+  mk _ _ _ = ("","")
 
 -- for vanilla brackets, focus, and position, use
 markBracket :: Marker
-markBracket n p b = if b then ("[*" ++ show p,"*]") else ("[" ++ show p,"]")
+markBracket = defTMarker mk where
+  mk n p b = if b then ("[*" ++ show p,"*]") else ("[" ++ show p,"]")
 
 -- for focus only
 markFocus :: Marker
-markFocus n p b = if b then ("[*","*]") else ("","")
+markFocus = defTMarker mk where
+  mk n p b = if b then ("[*","*]") else ("","")
 
 -- for XML, use
-markXML :: Marker
-markXML n i b = 
+markJustXML :: JustMarker
+markJustXML n i b = 
   if b 
     then ("<focus"   +++ p +++ c ++ s ++ ">", "</focus>") 
     else ("<subtree" +++ p +++ c ++ s ++ ">", "</subtree>") 
    where 
      c = "type=" ++ prt (M.valNode n)
      p = "position=" ++ (show $ reverse i)
-     s = "" ---- if (null (M.constrsNode n)) then "" else " status=incorrect"
+     s = if (null (M.constrsNode n)) then "" else " status=incorrect"
+
+markXML :: Marker
+markXML = (markJustXML, Just esc) where
+  esc s = case s of
+   '\\':'<':cs  -> '\\':'<':esc cs
+   '\\':'>':cs  -> '\\':'>':esc cs
+   '\\':'\\':cs -> '\\':'\\':esc cs
+   ----- the first 3 needed because marking may revisit; needs to be fixed
+
+   '<':cs  -> '\\':'<':esc cs
+   '>':cs  -> '\\':'>':esc cs
+   '\\':cs -> '\\':'\\':esc cs
+   c  :cs  -> c     :esc cs
+   _ -> s
 
 -- for XML in JGF 1, use
 markXMLjgf :: Marker
-markXMLjgf n p b = 
+markXMLjgf = defTMarker mk where
+ mk n p b = 
   if b 
     then ("<focus" +++ c ++ ">", "</focus>") 
     else ("","")
@@ -54,19 +81,28 @@ markXMLjgf n p b =
      c = "type=" ++ prt (M.valNode n)
 
 -- the marking engine
-markSubterm :: (String,String) -> Term -> Term
-markSubterm (beg, end) t = case t of
+markSubterm :: Maybe (String -> String) -> (String,String) -> Term -> Term
+markSubterm esc (beg, end) t = case t of
   R rs -> R $ map markField rs 
   T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs]
   FV ts -> FV $ map mark ts
-  _    -> foldr1 C (tk beg ++ [t] ++ tk end)  -- t : Str guaranteed?
+  _    -> foldr1 C (tm beg ++ [mkEscIf t] ++ tm end)  -- t : Str guaranteed?
  where
-   mark = markSubterm (beg, end)
+   mark = markSubterm esc (beg, end)
    markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt
-   tk s = if null s then [] else [tK s]
-
-tK :: String -> Term
+   tm s = if null s then [] else [tM s]
+   mkEscIf t = case esc of
+     Just f -> mkEsc f t
+     _ -> t
+   mkEsc f t = case t of
+     K (KS s) -> K (KS (f s))
+     C u v    -> C (mkEsc f u) (mkEsc f v)
+     FV ts    -> FV (map (mkEsc f) ts)
+     _ -> t ---- do we need to look at other cases?
+
+tK,tM :: String -> Term
 tK = K . KS
+tM = K . KM
 
 term2patt :: Term -> Err Patt
 term2patt trm = case trm of
@@ -120,6 +156,7 @@ valTableType t = case t of
 strsFromTerm :: Term -> Err [Str]
 strsFromTerm t = case t of
   K (KS s) -> return [str s]
+  K (KM s) -> return [str s]
   K (KP d vs) -> return $ [Str [TN d [(s,v) | Var s v <- vs]]]
   C s t -> do
     s' <- strsFromTerm s
diff --git a/src/GF/Canon/GFC.cf b/src/GF/Canon/GFC.cf
index ff6af21e8..a7199af4c 100644
--- a/src/GF/Canon/GFC.cf
+++ b/src/GF/Canon/GFC.cf
@@ -115,6 +115,7 @@ E.    Term2 ::= "[" "]" ;
 
 KS.   Tokn  ::= String ;
 KP.   Tokn  ::= "[" "pre" [String] "{" [Variant] "}" "]" ;
+internal KM.   Tokn  ::= String ; -- mark-up
 
 Ass.  Assign  ::= Label "=" Term ;
 Cas.  Case    ::= [Patt] "=>" Term ;
diff --git a/src/GF/Canon/PrintGFC.hs b/src/GF/Canon/PrintGFC.hs
index 2e617c61f..3e6ddc88e 100644
--- a/src/GF/Canon/PrintGFC.hs
+++ b/src/GF/Canon/PrintGFC.hs
@@ -272,6 +272,7 @@ instance Print Term where
 instance Print Tokn where
   prt i e = case e of
    KS str -> prPrec i 0 (concatD [prt 0 str])
+   KM str -> prPrec i 0 (concatD [prt 0 str])
    KP strs variants -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "pre") , prt 0 strs , doc (showString "{") , prt 0 variants , doc (showString "}") , doc (showString "]")])
 
 
diff --git a/src/GF/Canon/Unlex.hs b/src/GF/Canon/Unlex.hs
index f665f4c85..68c3c054e 100644
--- a/src/GF/Canon/Unlex.hs
+++ b/src/GF/Canon/Unlex.hs
@@ -21,7 +21,7 @@ formatAsText = unwords . format . cap . words where
   cap [] = []
   major = flip elem (map (:[]) ".!?") 
   minor = flip elem (map (:[]) ",:;")
-  para  = (=="<p>") 
+  para  = (=="&-") 
 
 unlex :: [Str] -> String
 unlex = formatAsText . performBinds . concat . map sstr . take 1 ----
diff --git a/src/GF/Text/Text.hs b/src/GF/Text/Text.hs
index de29e9026..aff52608b 100644
--- a/src/GF/Text/Text.hs
+++ b/src/GF/Text/Text.hs
@@ -46,7 +46,7 @@ formatAsText = unwords . format . cap . words where
   cap [] = []
   major = flip elem (map singleton ".!?") 
   minor = flip elem (map singleton ",:;")
-  para  = (=="<p>") 
+  para  = (=="&-") 
 
 formatAsCode :: String -> String
 formatAsCode = rend 0 . words where