Added CFGM format (pm -printer=cfgm) and utf8 conversion for pm.

3 files changed, 126 insertions, 5 deletions

diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs
index 37693efa5..4643b1494 100644
--- a/src/GF/Canon/CMacros.hs
+++ b/src/GF/Canon/CMacros.hs
@@ -178,3 +178,56 @@ wordsInTerm trm = filter (not . null) $ case trm of
    P t _   -> wo t --- not needed ?
    _       -> []
  where wo = wordsInTerm
+
+onTokens :: (String -> String) -> Term -> Term
+onTokens f t = case t of
+   K (KS s) -> K (KS (f s))
+   K (KP ss vs) -> K (KP (map f ss) [Var (map f x) (map f y) | Var x y <- vs])
+   _ -> composSafeOp (onTokens f) t
+
+
+-- to define compositional term functions
+
+composSafeOp :: (Term -> Term) -> Term -> Term
+composSafeOp op trm = case composOp (mkMonadic op) trm of
+  Ok t -> t
+  _ -> error "the operation is safe isn't it ?"
+ where
+ mkMonadic f = return . f
+
+composOp :: Monad m => (Term -> m Term) -> Term -> m Term
+composOp co trm = 
+ case trm of
+  Con x as ->
+      do
+      as' <- mapM co as
+      return (Con x as')
+  R as -> 
+      do
+      let onAss (Ass l t) = liftM (Ass l) (co t)
+      as' <- mapM onAss as
+      return (R as')
+  P a x ->
+      do
+      a' <- co a
+      return (P a' x)
+  T x as ->
+      do
+      let onCas (Cas ps t) = liftM (Cas ps) (co t)
+      as' <- mapM onCas as
+      return (T x as')
+  S a b ->
+      do
+      a' <- co a
+      b' <- co b
+      return (S a' b')
+  C a b ->
+      do
+      a' <- co a
+      b' <- co b
+      return (C a' b')
+  FV as -> 
+      do
+      as' <- mapM co as
+      return (FV as')
+  _ -> return trm -- covers Arg, I, LI, K, E
diff --git a/src/GF/Canon/GFC.hs b/src/GF/Canon/GFC.hs
index 48c77dfe3..c5af14785 100644
--- a/src/GF/Canon/GFC.hs
+++ b/src/GF/Canon/GFC.hs
@@ -47,3 +47,70 @@ prCanonModInfo = printTree . info2mod
 prGrammar :: CanonGrammar -> String
 prGrammar = printTree . grammar2canon
 -}
+
+{-
+-- apply a function to all concrete terms in a grammar
+mapConcreteTerms :: (Term -> Term) -> CanonGrammar -> CanonGrammar
+mapConcreteTerms f (M.MGrammar xs) = M.MGrammar $ map (onSnd (onModule f)) xs
+    where
+    onModule :: (Term -> Term) -> M.ModInfo i f Info -> M.ModInfo i f Info
+    onModule f m = case m of
+       M.ModMod (m@M.Module{M.jments=js}) -> 
+	   M.ModMod (m{ M.jments = mapTree (onSnd (onInfo f)) js })
+       _ -> m
+
+
+
+
+
+    -- if -utf8 was given, convert from language specific coding
+    encode = if oElem useUTF8 opts then setUTF8Flag . canonUTF8 else id
+    canonUTF8 = mapConcreteTerms (onTokens (anyCodingToUTF8 opts))
+    setUTF8Flag = setFlag "coding" "utf8"
+
+moduleToUTF8 :: Module Ident Flag Info -> Module Ident Flag Info
+moduleToUTF8 m = m{ jments = mapTree (onSnd }
+    where 
+    code = anyCodingToUTF8 (moduleOpts m)
+    moduleOpts = okError . mapM redFlag . flags
+
+data MGrammar i f a = MGrammar {modules :: [(i,ModInfo i f a)]}
+  deriving Show
+
+data ModInfo i f a =
+    ModMainGrammar (MainGrammar i)
+  | ModMod  (Module i f a)
+  | ModWith (ModuleType i) ModuleStatus i [OpenSpec i]
+  deriving Show
+
+data Module i f a = Module {
+    mtype   :: ModuleType i ,
+    mstatus :: ModuleStatus ,
+    flags   :: [f] ,
+    extends :: Maybe i ,
+    opens   :: [OpenSpec i] ,
+    jments  :: BinTree (i,a)
+  }
+  deriving Show
+
+
+
+-- Set a flag in all modules in a grammar
+setFlag :: String -> String -> CanonGrammar -> CanonGrammar
+setFlag n v (M.MGrammar ms) = M.MGrammar $ map (onSnd setFlagMod) ms
+    where
+    setFlagMod m = case m of
+      M.ModMod (m@M.Module{M.flags=fs}) -> M.ModMod $ m{ M.flags = fs' }
+	  where fs' = Flg (IC n) (IC v):[f | f@(Flg (IC n') _) <- fs, n' /= n]
+      _ -> m
+-}
+	      
+mapInfoTerms :: (Term -> Term) -> Info -> Info
+mapInfoTerms f i = case i of 
+         ResOper x a -> ResOper x (f a)
+	 CncCat  x a y -> CncCat x (f a) y
+	 CncFun  x y a z -> CncFun x y (f a) z
+	 _ -> i
+
+setFlag :: String -> String -> [Flag] -> [Flag]
+setFlag n v fs = Flg (IC n) (IC v):[f | f@(Flg (IC n') _) <- fs, n' /= n]
\ No newline at end of file
diff --git a/src/GF/Canon/PrintGFC.hs b/src/GF/Canon/PrintGFC.hs
index 77e60c75d..e2b6e057a 100644
--- a/src/GF/Canon/PrintGFC.hs
+++ b/src/GF/Canon/PrintGFC.hs
@@ -69,12 +69,13 @@ instance Print Double where
   prt _ x = doc (shows x)
 
 instance Print Char where
-  prt _ s = doc (showChar '\'' . mkEsc s . showChar '\'')
-  prtList s = doc (showChar '"' . concatS (map mkEsc s) . showChar '"')
+  prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
+  prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
 
-mkEsc :: Char -> ShowS
-mkEsc s = case s of
-  _ | elem s "\\\"'" -> showChar '\\' . showChar s
+mkEsc :: Char -> Char -> ShowS
+mkEsc q s = case s of
+  _ | s == q -> showChar '\\' . showChar s
+  '\\'-> showString "\\\\"
   '\n' -> showString "\\n"
   '\t' -> showString "\\t"
   _ -> showChar s