diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs index 79e28865f..8dcefece9 100644 --- a/src/GF/Command/Commands.hs +++ b/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] diff --git a/src/GF/Devel/GrammarToGFCC.hs b/src/GF/Devel/GrammarToGFCC.hs index 66b238267..9c052b35c 100644 --- a/src/GF/Devel/GrammarToGFCC.hs +++ b/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 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 +