gfi linearization with flags -table -record -term

src/GF/Command/Commands.hs

@@ -12,6 +12,7 @@ module GF.Command.Commands (
 import GF.Command.AbsGFShell hiding (Tree)
 import GF.Command.PPrTree
 import GF.Command.ParGFShell
+import GF.GFCC.ShowLinearize
 import GF.GFCC.API
 import GF.GFCC.Macros
 import GF.GFCC.AbsGFCC ----
@@ -101,7 +102,8 @@ allCommands mgr = Map.fromAscList [
        _ -> commandHelpAll mgr opts)
      }),
   ("l", emptyCommandInfo {
-     exec = \opts -> return . fromStrings . map (lin opts),
+     exec = \opts -> return . fromStrings . map (optLin opts),
+     options = ["record","table","term"],
      flags = ["lang"]
      }),
   ("p", emptyCommandInfo {
@@ -113,6 +115,14 @@ allCommands mgr = Map.fromAscList [
    lin opts t = unlines [linearize mgr lang t    | lang <- optLangs opts]
    par opts s = concat  [parse mgr lang (optCat opts) s | lang <- optLangs opts]
  
+   optLin opts t = unlines [linea lang t | lang <- optLangs opts] where
+     linea lang = case opts of
+       _ | isOpt "table"  opts -> tableLinearize gr (cid lang)
+       _ | isOpt "term"   opts -> termLinearize gr (cid lang)
+       _ | isOpt "record" opts -> recordLinearize gr (cid lang)
+       _  -> linearize mgr lang
+
+
    optLangs opts = case valIdOpts "lang" "" opts of
      "" -> languages mgr
      lang -> [lang] 

src/GF/Devel/GrammarToGFCC.hs

@@ -175,16 +175,17 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
   mkPType typ = case typ of
     RecType lts -> do
       ts <- mapM (mkPType . snd) lts
-      return $ C.R ts
+      return $ C.R [ C.P (kks $ prt_ l) t | ((l,_),t) <- zip lts ts]
     Table p v -> do
       p' <- mkPType p
       v' <- mkPType v
       return $ C.S [p',v']
     Sort "Str" -> return $ C.S []
     _ -> return $ 
-      C.FV $ map (C.K . C.KS . filter showable . prt_) $ 
+      C.FV $ map (kks . filter showable . prt_) $ 
              errVal [] $ Look.allParamValues sgr typ
   showable c = not (isSpace c) ---- || (c == ' ')  -- to eliminate \n in records
+  kks = C.K . C.KS
 
 -- return just one module per language
 

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))

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
+