module NLP.GenI.LexicalSelection.Types where
import Control.Monad.Writer
import Data.List
import Data.Poset
import Data.Text ( Text )
import qualified Data.Map as Map
import qualified Data.Text as T
import NLP.GenI.GeniVal
import NLP.GenI.Pretty
data PathEqLhs = PeqInterface Text
| PeqJust NodePathEqLhs
| PeqUnknown Text
deriving (Eq, Ord)
data NodePathEqLhs = PeqFeat Text TopBottom Text
| PeqLex Text
deriving (Eq, Ord)
data TopBottom = Top | Bottom
deriving (Eq, Ord)
type PathEqPair = (NodePathEqLhs, GeniVal)
parsePathEq :: Text -> Writer [LexCombineError] PathEqLhs
parsePathEq e =
case T.splitOn "." e of
(n:"top":r) -> return (node n Top r)
(n:"bot":r) -> return (node n Bottom r)
[n,"lex"] -> return (PeqJust (PeqLex n))
("top":r) -> return (node "anchor" Top r)
("bot":r) -> return (node "anchor" Bottom r)
("anchor":r) -> return (node "anchor" Bottom r)
("interface":r) -> return (PeqInterface (rejoin r))
("anc":r) -> parsePathEq $ rejoin ("anchor":r)
(n:r@(_:_)) -> tell [BoringError (tMsg n)] >> return (node n Top r)
_ -> tell [BoringError iMsg ] >> return (PeqUnknown e)
where
node n tb r = PeqJust $ PeqFeat n tb (rejoin r)
rejoin = T.intercalate "."
tMsg n = T.unwords
[ "Interpreting path equation"
, e
, "as applying to top of"
, n `T.snoc` '.'
]
iMsg = "Could not interpret path equation" <+> e
showPathEqLhs :: PathEqLhs -> Text
showPathEqLhs p =
case p of
PeqJust (PeqFeat n tb att) -> squish [ n, fromTb tb, att ]
PeqJust (PeqLex n) -> squish [ n, "lex" ]
PeqInterface att -> squish [ "interface", att ]
PeqUnknown e -> e
where
fromTb Top = "top"
fromTb Bottom = "bot"
squish = T.intercalate "."
data LexCombineError =
BoringError Text
| FamilyNotFoundError Text
| SchemaError [Text] LexCombineError2
deriving Eq
data LexCombineError2 = EnrichError PathEqLhs
| StringError Text
deriving (Eq, Ord)
instance Poset LexCombineError where
leq (BoringError _) _ = True
leq (SchemaError _ e1) (SchemaError _ e2) = leq e1 e2
leq (FamilyNotFoundError x1) (FamilyNotFoundError x2) = leq x1 x2
leq (FamilyNotFoundError _) (SchemaError _ _) = True
leq _ _ = False
instance Poset LexCombineError2 where
leq (EnrichError e1) (EnrichError e2) = leq e1 e2
leq (EnrichError _ ) (StringError _ ) = True
leq (StringError s1) (StringError s2) = leq s1 s2
leq _ _ = False
instance Poset PathEqLhs where
leq l1 l2 = leq (showPathEqLhs l1) (showPathEqLhs l2)
instance Poset Text where
leq l1 l2 = leq (T.unpack l1) (T.unpack l2)
instance Pretty LexCombineError where
pretty e =
body <+> suffix
where
(body, suffix) = showLexCombineError e
showLexCombineError :: LexCombineError -> (Text, Text)
showLexCombineError (SchemaError xs x) = (pretty x, prettyCount (const "") "trees" ((), length xs))
showLexCombineError (BoringError s) = (s, "")
showLexCombineError (FamilyNotFoundError f) = ("Family" <+> f <+> "not found in tree schema file", "")
instance Pretty LexCombineError2 where
pretty (EnrichError p) =
"Some trees discarded due to enrichment error on" <+> showPathEqLhs p
pretty (StringError s) = s
compressLexCombineErrors :: [LexCombineError] -> [LexCombineError]
compressLexCombineErrors errs = schema2 ++ normal
where
isSchema (SchemaError _ _) = True
isSchema _ = False
(schema, normal) = partition isSchema errs
schema2 = map (uncurry (flip SchemaError))
. Map.toList
$ Map.fromListWith (++) [ (l,ts) | SchemaError ts l <- schema ]