module NLP.GenI.Lexicon.Internal where
import Data.Binary
import Data.FullList
import Data.Function
import Data.List ( sortBy )
import Data.Generics (Data)
import Data.Text ( Text )
import Data.Typeable (Typeable)
import qualified Data.Text as T
import NLP.GenI.FeatureStructure
import NLP.GenI.GeniShow
import NLP.GenI.GeniVal
import NLP.GenI.Pretty
import NLP.GenI.Semantics
import NLP.GenI.Polarity.Types (SemPols)
import Control.DeepSeq
type Lexicon = [LexEntry]
data LexEntry = LexEntry
{
iword :: FullList Text
, ifamname :: Text
, iparams :: [GeniVal]
, iinterface :: Flist GeniVal
, ifilters :: Flist GeniVal
, iequations :: Flist GeniVal
, isemantics :: Sem
, isempols :: [SemPols] }
deriving (Eq, Data, Typeable)
mkLexEntry :: FullList Text
-> Text
-> [GeniVal]
-> Flist GeniVal
-> Flist GeniVal
-> Flist GeniVal
-> Sem
-> LexEntry
mkLexEntry word famname params interface filters equations sem =
mkFullLexEntry word famname params interface filters equations
sem (map noSemPols sem)
where
noSemPols l = replicate (length (lArgs l)) 0
mkFullLexEntry :: FullList Text
-> Text
-> [GeniVal]
-> Flist GeniVal
-> Flist GeniVal
-> Flist GeniVal
-> Sem
-> [SemPols]
-> LexEntry
mkFullLexEntry word famname params interface filters equations sem sempols =
LexEntry
(sortNub word)
famname
params
(sortFlist interface)
(sortFlist filters)
(sortFlist equations)
sem2
sempols2
where
(sem2, sempols2) = unzip $ sortBy (compareOnLiteral `on` fst) (zip sem sempols)
instance DescendGeniVal LexEntry where
descendGeniVal s i =
i { iinterface = descendGeniVal s (iinterface i)
, iequations = descendGeniVal s (iequations i)
, isemantics = descendGeniVal s (isemantics i)
, iparams = descendGeniVal s (iparams i) }
instance Collectable LexEntry where
collect l = (collect $ iinterface l) . (collect $ iparams l) .
(collect $ ifilters l) . (collect $ iequations l) .
(collect $ isemantics l)
type PolValue = (GeniVal, Int)
fromLexSem :: [Literal PolValue] -> (Sem, [SemPols])
fromLexSem = unzip . map fromLexLiteral
fromLexLiteral :: Literal PolValue -> (Literal GeniVal, SemPols)
fromLexLiteral (Literal h pr vs) =
(lit, pols)
where
lit = Literal (fst h) (fst pr) (map fst vs)
pols = snd h : map snd vs
instance GeniShow LexEntry where
geniShowText l = T.intercalate "\n"
[ T.unwords
[ geniShowText . mkGConst $ iword l
, ifamname l
, paramT
]
, geniKeyword "equations" $ geniShowText (iequations l)
, geniKeyword "filters" $ geniShowText (ifilters l)
, geniKeyword "semantics" $ geniShowText (isemantics l)
]
where
paramT = parens . T.unwords . concat $
[ map geniShowText (iparams l)
, ["!"]
, map geniShowText (iinterface l)
]
instance GeniShow [LexEntry] where
geniShowText = T.intercalate "\n\n" . map geniShowText
instance Pretty LexEntry where
pretty = geniShowText
instance Binary LexEntry where
put (LexEntry x1 x2 x3 x4 x5 x6 x7 x8)
= do put x1
put x2
put x3
put x4
put x5
put x6
put x7
put x8
get
= do x1 <- get
x2 <- get
x3 <- get
x4 <- get
x5 <- get
x6 <- get
x7 <- get
x8 <- get
return (LexEntry x1 x2 x3 x4 x5 x6 x7 x8)
instance NFData LexEntry where
rnf (LexEntry x1 x2 x3 x4 x5 x6 x7 x8)
= rnf x1 `seq`
rnf x2 `seq`
rnf x3 `seq`
rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` ()