Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where

import Data.Text (Text)
import qualified Data.Text as T

import Test.HUnit      ( (@=?) )
import Test.Tasty.QuickCheck (testProperty)
import Test.Tasty.HUnit (testCase)
import Test.Tasty ( TestTree, defaultIngredients, defaultMainWithIngredients
                  , testGroup )
import Test.Tasty.Ingredients (Ingredient )
import Test.Tasty.Runners.AntXML ( antXMLRunner )

import NLP.Types (Tag(..), parseTag, RawTag(..), POSTagger(..))
import NLP.POS (tagText, train)
import NLP.Corpora.Parsing (readPOS)

import qualified AvgPerceptronTests as APT
import qualified BackoffTaggerTests as Backoff
import qualified Data.DefaultMapTests as DefMap
import qualified IntegrationTests as IT
import qualified NLP.Corpora.BrownTests as Brown
import qualified NLP.Corpora.ConllTests as Conll
import qualified NLP.Extraction.ParsecTests as Parsec
import qualified NLP.POS.AvgPerceptronTagger as APT
import qualified NLP.POS.UnambiguousTaggerTests as UT
import qualified NLP.POS.LiteralTaggerTests as LT
import qualified NLP.POSTests as POS
import qualified NLP.Similarity.VectorSimTests as Vec
import qualified NLP.TypesTests as TypeTests
import qualified NLP.Types.IOBTests as IOB
import qualified NLP.Types.TreeTests as Tree
import qualified NLP.Chunk.AvgPerceptronChunkerTests as APC

import Corpora

main :: IO ()
main = defaultMainWithIngredients ingredients tests

ingredients :: [Ingredient]
ingredients = antXMLRunner : defaultIngredients


tests :: TestTree
tests = testGroup "Tests"
        [ testGroup "parseTag" $
          [ testProperty "basic tag parsing" prop_parseTag]
        , testGroup "Train and tag"
          [ testGroup "miniCorpora1" $
            map (trainAndTagTest miniCorpora1)
             [ ("the dog jumped .", "the/DT dog/NN jumped/VB ./.") ]
          , testGroup "miniCorpora2" $
            map (trainAndTagTest miniCorpora1)
             [ ("the dog jumped .", "the/DT dog/NN jumped/VB ./.") ]
          , testGroup "miniCorpora1 - POSTagger train" $
            map (trainAndTagTestVTrainer miniCorpora1)
             [ ("the dog jumped .", "the/DT dog/NN jumped/VB ./.") ]
          , testGroup "miniCorpora2 - POSTagger train" $
            map (trainAndTagTestVTrainer miniCorpora1)
             [ ("the dog jumped .", "the/DT dog/NN jumped/VB ./.") ]
          ]
        , APT.tests
        , Backoff.tests
        , Vec.tests
        , POS.tests
        , UT.tests
        , LT.tests
        , TypeTests.tests
        , DefMap.tests
        , Parsec.tests
        , IT.tests
        , Brown.tests
        , Conll.tests
        , IOB.tests
        , APC.tests
        , Tree.tests
        ]

trainAndTagTestIO :: IO Text -> (Text, Text) -> TestTree
trainAndTagTestIO corpora (input, oracle) = testCase (T.unpack input) $ do
  let parser :: Text -> RawTag
      parser = parseTag
  perceptron <- APT.trainNew parser =<< corpora
  let tagger :: POSTagger RawTag
      tagger = (APT.mkTagger perceptron Nothing)
  oracle @=? tagText tagger input

trainAndTagTest :: Text -> (Text, Text) -> TestTree
trainAndTagTest corpora (input, oracle) = testCase (T.unpack input) $ do
  let parser :: Text -> RawTag
      parser = parseTag
  perceptron <- APT.trainNew parser corpora
  let tagger :: POSTagger RawTag
      tagger = (APT.mkTagger perceptron Nothing)
  oracle @=? tagText tagger input

trainAndTagTestVTrainer :: Text -> (Text, Text) -> TestTree
trainAndTagTestVTrainer corpora (input, oracle) = testCase (T.unpack input) $ do
  let newTagger :: POSTagger RawTag
      newTagger = APT.mkTagger APT.emptyPerceptron Nothing
      examples = map readPOS $ T.lines corpora
  posTgr <- train newTagger examples

  oracle @=? tagText posTgr input

prop_parseTag :: Text -> Bool
prop_parseTag txt = parseTag txt == RawTag txt

genTest :: (Show a, Show b, Eq b) => (a -> b) -> (String, a, b) -> TestTree
genTest fn (descr, input, oracle) =
    testCase (descr++" input: "++show input) assert
        where assert = oracle @=? fn input