gfi linearization with flags -table -record -term

2 files changed, 73 insertions, 0 deletions

diff --git a/src/GF/GFCC/Macros.hs b/src/GF/GFCC/Macros.hs
index cb4727e61..dd9d594d6 100644
--- a/src/GF/GFCC/Macros.hs
+++ b/src/GF/GFCC/Macros.hs
@@ -20,6 +20,10 @@ lookLincat :: GFCC -> CId -> CId -> Term
 lookLincat gfcc lang fun = 
   lookMap TM fun $ lincats $ lookMap (error "no lang") lang $ concretes gfcc
 
+lookParamLincat :: GFCC -> CId -> CId -> Term
+lookParamLincat gfcc lang fun = 
+  lookMap TM fun $ paramlincats $ lookMap (error "no lang") lang $ concretes gfcc
+
 lookType :: GFCC -> CId -> Type
 lookType gfcc f = 
   fst $ lookMap (error $ "lookType " ++ show f) f (funs (abstract gfcc))
diff --git a/src/GF/GFCC/ShowLinearize.hs b/src/GF/GFCC/ShowLinearize.hs
new file mode 100644
index 000000000..b9fca129a
--- /dev/null
+++ b/src/GF/GFCC/ShowLinearize.hs
@@ -0,0 +1,69 @@
+module GF.GFCC.ShowLinearize (
+  tableLinearize,
+  recordLinearize,
+  termLinearize
+  ) where
+
+import GF.GFCC.Linearize
+import GF.GFCC.Macros
+import GF.GFCC.DataGFCC
+import GF.GFCC.AbsGFCC
+import GF.GFCC.PrintGFCC ----
+
+import GF.Data.Operations
+import Data.List
+
+-- printing linearizations with parameters
+
+data Record = 
+   RR   [(String,Record)]
+ | RT   [(String,Record)]
+ | RFV  [Record]
+ | RS   String
+ | RCon String
+
+prRecord :: Record -> String
+prRecord = prr where
+  prr t = case t of
+    RR fs -> concat $ 
+      "{" : 
+      (intersperse ";" (map (\ (l,v) -> unwords [l,"=", prr v]) fs)) ++ ["}"]
+    RT fs -> concat $
+      "table {" : 
+      (intersperse ";" (map (\ (l,v) -> unwords [l,"=>",prr v]) fs)) ++ ["}"]
+    RFV ts -> concat $
+      "variants {" : (intersperse ";" (map prr ts)) ++ ["}"]
+    RS s -> prQuotedString s
+    RCon s -> s
+
+mkRecord :: Term -> Term -> Record
+mkRecord typ trm = case (typ,trm) of
+  (R rs,      R ts) -> RR [(str lab, mkRecord ty t) | (P lab ty, t) <- zip rs ts]
+  (S [FV ps,ty],R ts) -> RT [(str par, mkRecord ty t) | (par,    t) <- zip ps ts]
+  (_,W s (R ts))      -> mkRecord typ (R [K (KS (s ++ u)) | K (KS u) <- ts])
+  (FV ps,       C i)  -> RCon $ str $ ps !! i
+  (S [],        _)    -> RS $ realize trm
+  _                   -> RS $ printTree trm
+ where
+   str = realize
+
+tableLinearize :: GFCC -> CId -> Exp -> String
+tableLinearize gfcc lang = unlines . branches . recLinearize gfcc lang where
+  branches r = case r of
+    RR  fs -> [lab +++ b | (lab,t) <- fs, b <- branches t]
+    RT  fs -> [lab +++ b | (lab,t) <- fs, b <- branches t]
+    RFV rs -> intersperse "|" (concatMap branches rs)
+    RS  s  -> [" : " ++ s]
+    RCon _ -> []
+
+recordLinearize :: GFCC -> CId -> Exp -> String
+recordLinearize gfcc lang = prRecord . recLinearize gfcc lang
+
+termLinearize :: GFCC -> CId -> Exp -> String
+termLinearize gfcc lang = printTree . linExp gfcc lang
+
+recLinearize :: GFCC -> CId -> Exp -> Record
+recLinearize gfcc lang exp = mkRecord typ $ linExp gfcc lang exp where
+  typ = case exp of
+    DTr _ (AC f) _ -> lookParamLincat gfcc lang $ valCat $ lookType gfcc f
+