content: {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE OverloadedStrings #-}
  module NLP.Types.Tags
  where
  
  import Data.Serialize (Serialize)
  import Data.Serialize.Text ()
  import Data.Text (Text)
  import qualified Data.Text as T
  import GHC.Generics
  import Text.Read (readEither)
  
  
  import Test.QuickCheck (Arbitrary(..), NonEmptyList(..))
  import Test.QuickCheck.Instances ()
  
  import NLP.Types.General (Error, toEitherErr)
  
  -- | The class of named entity sets.  This typeclass can be defined
  -- entirely in terms of the required class constraints.
  class (Ord a, Eq a, Read a, Show a, Generic a, Serialize a) => NERTag a where
    fromNERTag :: a -> Text
    fromNERTag = T.pack . show
  
    parseNERTag :: Text -> Either Error a
    parseNERTag txt = toEitherErr $ readEither $ T.unpack txt
  
  -- | The class of things that can be regarded as 'chunks'; Chunk tags
  -- are much like POS tags, but should not be confused. Generally,
  -- chunks distinguish between different phrasal categories (e.g.; Noun
  -- Phrases, Verb Phrases, Prepositional Phrases, etc..)
  class (Ord a, Eq a, Read a, Show a, Generic a, Serialize a) => ChunkTag a where
    fromChunk :: a -> Text
    parseChunk :: Text -> Either Error a
    notChunk :: a
  
  -- | The class of POS Tags.
  --
  -- We use a typeclass here because POS tags just need a few things in
  -- excess of equality (they also need to be serializable and human
  -- readable).  Passing around all the constraints everywhere becomes a
  -- hassle, and it's handy to have a uniform interface to the diferent
  -- kinds of tag types.
  --
  -- This typeclass also allows for corpus-specific tags to be
  -- distinguished; They have different semantics, so they should not be
  -- merged.  That said, if you wish to create a unifying POS Tag set,
  -- and mappings into that set, you can use the type system to ensure
  -- that that is done correctly.
  --
  -- This /may/ get renamed to POSTag at some later date.
  class (Ord a, Eq a, Read a, Show a, Generic a, Serialize a) => Tag a where
    fromTag :: a -> Text
    parseTag :: Text -> a
    tagUNK :: a
    tagTerm :: a -> Text
    startTag :: a
    endTag :: a
    -- | Check if a tag is a determiner tag.
    isDt :: a -> Bool
  
  -- | A fall-back 'ChunkTag' instance, analogous to 'RawTag'
  newtype RawChunk = RawChunk Text
    deriving (Ord, Eq, Read, Show, Generic)
  
  instance Serialize RawChunk
  
  instance ChunkTag RawChunk where
    fromChunk (RawChunk ch) = ch
    parseChunk txt = Right (RawChunk txt)
    notChunk = RawChunk "O"
  
  -- | A fallback POS tag instance.
  newtype RawTag = RawTag Text
    deriving (Ord, Eq, Read, Show, Generic)
  
  instance Serialize RawTag
  
  -- | Tag instance for unknown tagsets.
  instance Tag RawTag where
    fromTag (RawTag t) = t
  
    parseTag t = RawTag t
  
    -- | Constant tag for "unknown"
    tagUNK = RawTag "Unk"
  
    tagTerm (RawTag t) = t
  
    startTag = RawTag "-START-"
    endTag = RawTag "-END-"
  
    isDt (RawTag tg) = tg == "DT"
  
  instance Arbitrary RawTag where
    arbitrary = do
      NonEmpty str <- arbitrary
      return $ RawTag $ T.pack str
  