module NLP.GenI.GeniShow
where
import Data.Tree
import Data.List(intersperse, isPrefixOf)
import qualified Data.Map as Map
import NLP.GenI.Tags
( TagElem, idname,
tsemantics, ttree, tinterface, ttype, ttreename,
)
import NLP.GenI.Btypes (GeniVal(GConst), AvPair(..), Ptype(..),
Ttree(params, pidname, pfamily, pinterface, ptype, tree, psemantics, ptrace),
GNode(..), GType(..),
SemInput, Pred,
TestCase(..),
)
class GeniShow a where
geniShow :: a -> String
instance GeniShow Ptype where
geniShow Initial = "initial"
geniShow Auxiliar = "auxiliary"
geniShow _ = ""
instance GeniShow AvPair where
geniShow (AvPair a v) = a ++ ":" ++ geniShow v
instance GeniShow GeniVal where
geniShow (GConst xs) = concat $ intersperse "|" xs
geniShow x = show x
instance GeniShow Pred where
geniShow (h, p, l) =
showh ++ geniShow p ++ "(" ++ unwords (map geniShow l) ++ ")"
where
hideh (GConst [x]) = "genihandle" `isPrefixOf` x
hideh _ = False
showh = if hideh h then "" else geniShow h ++ ":"
instance GeniShow GNode where
geniShow x =
let gaconstrstr = case (gaconstr x, gtype x) of
(True, Other) -> "aconstr:noadj"
_ -> ""
gtypestr n = case (gtype n) of
Subs -> "type:subst"
Foot -> "type:foot"
Lex -> if ganchor n && (null.glexeme) n
then "type:anchor" else "type:lex"
_ -> ""
glexstr n =
if null ls then ""
else concat $ intersperse "|" $ map quote ls
where quote s = "\"" ++ s ++ "\""
ls = glexeme n
tbFeats n = (geniShow $ gup n) ++ "!" ++ (geniShow $ gdown n)
in unwords $ filter (not.null) $ [ gnname x, gaconstrstr, gtypestr x, glexstr x, tbFeats x ]
instance (GeniShow a) => GeniShow [a] where
geniShow = squares . unwords . (map geniShow)
instance (GeniShow a) => GeniShow (Tree a) where
geniShow t =
let treestr i (Node a l) =
spaces i ++ geniShow a ++
case (l,i) of
([], 0) -> "{}"
([], _) -> ""
(_, _) -> "{\n" ++ (unlines $ map next l) ++ spaces i ++ "}"
where next = treestr (i+1)
spaces i = take i $ repeat ' '
in treestr 0 t
instance GeniShow TagElem where
geniShow te =
"\n% ------------------------- " ++ idname te
++ "\n" ++ (ttreename te) ++ ":" ++ (idname te)
++ " " ++ (geniShow.tinterface $ te)
++ " " ++ (geniShow.ttype $ te)
++ "\n" ++ (geniShow.ttree $ te)
++ "\n" ++ geniShowKeyword "semantics" "" ++ (geniShow.tsemantics $ te)
instance (GeniShow a) => GeniShow (Ttree a) where
geniShow tt =
"\n% ------------------------- " ++ pidname tt
++ "\n" ++ (pfamily tt) ++ ":" ++ (pidname tt)
++ " " ++ (parens $ (unwords $ map geniShow $ params tt)
++ " ! "
++ (unwords $ map geniShow $ pinterface tt))
++ " " ++ (geniShow.ptype $ tt)
++ "\n" ++ (geniShow.tree $ tt)
++ (case psemantics tt of
Nothing -> ""
Just psem -> "\n" ++ geniShowKeyword "semantics" (geniShow psem))
++ "\n" ++ geniShowKeyword "trace" (squares.unwords.ptrace $ tt)
instance GeniShow TestCase where
geniShow (TestCase { tcName = name
, tcExpected = sentences
, tcOutputs = outputs
, tcSemString = semStr
, tcSem = sem }) =
unlines $ [ name, semS ]
++ map (geniShowKeyword "sentence" . squares) sentences
++ (concat.prettify.map outStuff $ outputs)
where
semS = if null semStr then geniShowSemInput sem "" else semStr
prettify = if all (Map.null . snd) outputs then id else map ("":)
gshowTrace ((k1,k2),ts) =
geniShowKeyword "trace" . squares . showString (k1 ++ " " ++ k2 ++ " ! " ++ unwords ts) $ ""
outStuff (o,ds) =
[ geniShowKeyword "output" . squares $ o ]
++ (map gshowTrace $ Map.toList ds)
parens, squares :: String -> String
parens s = "(" ++ s ++ ")"
squares s = "[" ++ s ++ "]"
geniShowKeyword :: String -> ShowS
geniShowKeyword k = showString k . showChar ':'
geniShowSemInput :: SemInput -> ShowS
geniShowSemInput (sem,icons,lcons) =
let withConstraints lit =
case concat [ cs | (p,cs) <- lcons, p == lit ] of
[] -> geniShow lit
cs -> geniShow lit ++ (squares . unwords $ cs)
semStuff = geniShowKeyword "semantics" . squares
. (showString . unwords . map withConstraints $ sem)
idxStuff = geniShowKeyword "idxconstraints"
. (showString . geniShow $ icons) . squares
in semStuff . (if null icons then id else showChar '\n' . idxStuff)