Finish implementing the annotation-building process for WebAnno + add a lot of...

Finish implementing the annotation-building process for WebAnno + add a lot of unit and regression tests

test/Unit/Text/TEIWA/Annotation/Context.hs

+{-# LANGUAGE NamedFieldPuns, OverloadedStrings #-}
+module Unit.Text.TEIWA.Annotation.Context (
+    ofHeaderTest
+  ) where
+
+import Control.Monad.Except (runExceptT)
+import Control.Monad.Reader (runReaderT)
+import Data.Text.Lazy (Text)
+import Distribution.TestSuite (Test(..))
+import Mock.Text.TEIWA (
+    customHeaderConfig, defaultHeader, newFormConfig, otherFormConfig, otherHeader
+  )
+import Mock.WebAnno as WebAnno (context)
+import Text.TEIWA (Config, Error(..), defaultConfig)
+import Text.TEIWA.Annotation.Context (Context(..), ofHeader)
+import Text.TEIWA.Source.Common (Header)
+import Utils (monadicTest)
+
+type TestableContext = (Int, Text, Header)
+type TestCase = (String, (Header, Config), Either Error TestableContext)
+
+simpleHeaderDefaultConfig :: TestCase
+simpleHeaderDefaultConfig = (
+      "simple header with default config"
+    , (defaultHeader, defaultConfig)
+    , Right (0, "form", drop 1 defaultHeader)
+  )
+
+replacingForm :: TestCase
+replacingForm = (
+      "replacing form"
+    , (otherHeader, newFormConfig)
+    , Right (0, "Test", drop 1 otherHeader)
+  )
+
+anotherColumn :: TestCase
+anotherColumn = (
+      "using another column"
+    , (defaultHeader, otherFormConfig)
+    , Right (1, "lemma", ["form", "pos"])
+  )
+
+customHeaderCustomColumn :: TestCase
+customHeaderCustomColumn = (
+      "custom header with custom column"
+    , (defaultHeader, customHeaderConfig)
+    , Right (0, "Test", drop 1 otherHeader)
+  )
+
+noForm :: TestCase
+noForm = (
+      "no form"
+    , (otherHeader, defaultConfig)
+    , Left NoFormColumn
+  )
+
+noSuchColumn :: TestCase
+noSuchColumn = (
+      "no such column"
+    , (defaultHeader, newFormConfig)
+    , Left $ NoSuchColumn "Test"
+  )
+
+webAnno :: TestCase
+webAnno = (
+      "web anno"
+    , (["ID", "SPAN", "FORM", "LEMMA", "enc_tags"], defaultConfig)
+    , Right (columnIndex, columnName, header)
+  )
+  where
+    Context {columnIndex, columnName, header} = WebAnno.context
+
+ofHeaderTest :: Test
+ofHeaderTest = Group {
+      groupName = "ofHeader"
+    , concurrently = True
+    , groupTests = monadicTest evaluator <$> [
+            simpleHeaderDefaultConfig
+          , replacingForm
+          , anotherColumn
+          , customHeaderCustomColumn
+          , noForm
+          , noSuchColumn
+          , webAnno
+        ]
+  }
+  where
+    evaluator (h, config) =
+      fmap dropTagger <$> runExceptT (runReaderT (ofHeader h) config)
+    dropTagger (Context {columnIndex, columnName, header}) =
+      (columnIndex, columnName, header)

test/Unit/Text/TEIWA/Source/WebAnno/Annotator.hs

+{-# LANGUAGE OverloadedStrings #-}
+module Unit.Text.TEIWA.Source.WebAnno.Annotator (
+    annotationsTree
+  ) where
+
+import Control.Monad.Except (runExceptT)
+import Control.Monad.Reader (runReaderT)
+import Distribution.TestSuite (Test(..))
+import Mock.Annotation (node)
+import Mock.WebAnno (
+      anotherGreen, blue, context, dbStep0, dbStep1, dbStep2, dbStep3, emptyDB
+    , green, greenUC, linesDB, multiRowStep0, multiRowStep1, multiRowStep2
+    , multiRowStep3, numberedRows, red
+  )
+import Text.TEIWA (Error(..), defaultConfig)
+import Text.TEIWA.Annotation.Context (Context(..))
+import Text.TEIWA.Source.Common (Range(..))
+import Text.TEIWA.Source.WebAnno.Annotator (buildTree, index, indexCell, splitDB)
+import Text.TEIWA.Source.WebAnno.Data (AnnotationDB(..))
+import Utils (monadicTest, pureTest)
+
+indexCellTest :: Test
+indexCellTest = Group {
+      groupName = "indexCell"
+    , concurrently = True
+    , groupTests = pureTest (uncurry3 indexCell) <$> [
+            ("empty cell",
+              (undefined, (multiRowStep0, []), ("enc_tags", [])),
+              (multiRowStep0, [Nothing]))
+          , ("empty cell on non-empty fields",
+              (undefined, (multiRowStep0, [Just "test"]), ("enc_tags", [])),
+              (multiRowStep0, [Nothing, Just "test"]))
+          , ("one single-line annotation",
+              (undefined, (multiRowStep0, []), (undefined, [blue])),
+              (multiRowStep0, [Just "BLUE"]))
+          , ("two single-line annotations",
+              (undefined, (multiRowStep0, []), (undefined, [blue, red])),
+              (multiRowStep0, [Just "BLUE+RED"]))
+          , ("one multiline annotation",
+              (7, (multiRowStep0, []), ("enc_tags", [green])),
+              (multiRowStep1, [Nothing]))
+          , ("both single-line and multiline annotations",
+              (7, (multiRowStep0, []), ("enc_tags", [green, blue])),
+              (multiRowStep1, [Just "BLUE"]))
+          , ("expanding a multiline annotation",
+              (8, (multiRowStep1, [Just "TEST"]), ("enc_tags", [green])),
+              (multiRowStep2, [Nothing, Just "TEST"]))
+          , ("mixing several single-line and multiline annotations",
+              (9, (multiRowStep2, [Nothing]), ("enc_tags", [red, anotherGreen, blue])),
+              (multiRowStep3, [Just "RED+BLUE", Nothing]))
+        ]
+  }
+  where
+    uncurry3 f (a, b, c) = f a b c
+
+indexTest :: Test
+indexTest = Group {
+      groupName = "index"
+    , concurrently = True
+    , groupTests = pureTest (uncurry index) <$> [
+            ("no line", (context, []), emptyDB)
+          , ("after 1st line", (context, [take 1 numberedRows]), dbStep0)
+          , ("after 2 lines", (context, [take 2 numberedRows]), dbStep1)
+          , ("after 3 lines", (context, [take 3 numberedRows]), dbStep2)
+          , ("with all lines", (context, [numberedRows]), dbStep3)
+        ]
+  }
+
+splitDBTest :: Test
+splitDBTest = Group {
+      groupName = "splitDB"
+    , concurrently = True
+    , groupTests = monadicTest (runExceptT . uncurry splitDB) <$> [
+            ("1st split from whole DB",
+              ((greenUC 0, Range 7 8), dbStep3),
+              Right (
+                    emptyDB {lineFields = linesDB 6 6}
+                  , emptyDB {lineFields = linesDB 7 8}
+                  , emptyDB {lineFields = linesDB 9 9}
+                ))
+          , ("overlapping annotations in DB",
+              ((greenUC 1, Range 6 7), dbStep3),
+              Left (OverlappingAnnotation (6, show $ greenUC 1) (7, show $ greenUC 0)))
+        ]
+  }
+
+buildTreeTest :: Test
+buildTreeTest = Group {
+      groupName = "buildTree"
+    , concurrently = True
+    , groupTests = monadicTest evaluator <$> [
+          ("1st line only",
+            (context, dbStep0),
+            Right [node (header context) ("This", "w") ["1-1", "0-4", "this", "BLUE"]])
+        ]
+  }
+  where
+    evaluator = runExceptT . flip runReaderT defaultConfig . uncurry buildTree
+
+annotationsTree :: Test
+annotationsTree = Group {
+      groupName = "annotations"
+    , concurrently = True
+    , groupTests = [indexCellTest, indexTest, splitDBTest, buildTreeTest]
+  }

test/Utils.hs

 {-# LANGUAGE NamedFieldPuns #-}
 module Utils (
-    simpleTest
+      diff
+    , monadicTest
+    , pureTest
+    , simpleTest
   ) where
 
-import Distribution.TestSuite (Progress, Test(..), TestInstance(..))
+import Distribution.TestSuite (Progress(..), Result(..), Test(..), TestInstance(..))
+import Text.Printf (printf)
 
 simpleTest :: String -> IO Progress -> Test
 simpleTest name run = Test $ TestInstance {
@@ -13,3 +17,17 @@ simpleTest name run = Test $ TestInstance {
     , options = []
     , setOption = \_ _ -> Left "Options not supported for simpleTest"
   }
+
+diff :: Show a => a -> a -> String
+diff a = printf "Result differs from expectations: %s vs %s" (show a) . show
+
+pureTest :: (Eq b, Show b) => (a -> b) -> (String, a, b) -> Test
+pureTest f = monadicTest (pure . f)
+
+monadicTest :: (Eq b, Show b) => (a -> IO b) -> (String, a, b) -> Test
+monadicTest f (name, input, expected) = simpleTest name $ do
+  actual <- f input
+  pure . Finished $
+    if actual == expected
+    then Pass
+    else Fail $ diff actual expected

test/source/hey bulldog.webanno.tsv

 #FORMAT=WebAnno TSV 3.2
 #T_SP=webanno.custom.LEMMA|LEMMA
 #T_SP=webanno.custom.POS|POS
+#T_SP=webanno.custom.SYNTAX|SYNTAX
 
 #Text=You can talk to me.
-1-1	0-3	You	you	PRON	
-1-2	4-7	can	can	AUX	
-1-3	8-12	talk	talk	VERB	
-1-4	13-15	to	to	ADP	
-1-5	16-18	me	I	PRON	
-1-6	18-19	.	.	PUNCT	
+1-1	0-3	You	you	PRON	_	
+1-2	4-7	can	can	AUX	_	
+1-3	8-12	talk	talk	VERB	_	
+1-4	13-15	to	to	ADP	_	
+1-5	16-18	me	I	PRON	_	
+1-6	18-19	.	.	PUNCT	_	
 
 #Text=If you're lonely you can talk to me.
-2-1	0-2	If	if	SCONJ	
-2-2	3-6	you	you	PRON	
-2-3	6-9	're	be	AUX	
-2-4	10-16	lonely	lonely	ADJ	
-2-5	17-20	you	you	PRON	
-2-6	21-24	can	can	AUX	
-2-7	25-29	talk	talk	VERB	
-2-8	30-32	to	to	ADP	
-2-9	32-34	me	I	PRON	
-2-10	34-35	.	.	PUNCT	
+2-1	0-2	If	if	SCONJ	CONDITION[0]	
+2-2	3-6	you	you	PRON	CONDITION[0]|HYPOTHESIS[1]	
+2-3	6-9	're	be	AUX	CONDITION[0]|HYPOTHESIS[1]	
+2-4	10-16	lonely	lonely	ADJ	CONDITION[0]|HYPOTHESIS[1]	
+2-5	17-20	you	you	PRON	CONDITION[0]|CONCLUSION[2]	
+2-6	21-24	can	can	AUX	CONDITION[0]|CONCLUSION[2]	
+2-7	25-29	talk	talk	VERB	CONDITION[0]|CONCLUSION[2]	
+2-8	30-32	to	to	ADP	CONDITION[0]|CONCLUSION[2]	
+2-9	32-34	me	I	PRON	CONDITION[0]|CONCLUSION[2]	
+2-10	34-35	.	.	PUNCT	_