{-# LANGUAGE FlexibleInstances, StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module NLP.Aura.Test.CgmMacros where

import NLP.Aura.CgmMacros

import NLP.GenI.GeniVal
import NLP.GenI.FeatureStructure
import NLP.GenI.Semantics
import NLP.GenI.Morphology ( LemmaPlus(..) )
import NLP.GenI.General ( quoteText )
import NLP.GenI.GeniShow
import NLP.GenI.Pretty
import NLP.GenI.Test.GeniVal
import NLP.GenI.Test.General -- for Data.Text instance
import NLP.GenI.Test.FeatureStructure
import NLP.GenI.Test.Semantics
import GHC.Exts ( IsString(..) )
import ParsecTestUtil
import TestUtil
import qualified NLP.GenI.Pretty as Pretty

import Control.Applicative
import Control.Monad.Trans.State
import Data.Char ( isPunctuation, isAlpha )
import Data.List
import Data.Function
import Data.Text ( Text )
import qualified Data.Map  as Map
import qualified Data.Text as T
import Test.QuickCheck
import Test.QuickCheck.Arbitrary
import Test.HUnit
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.Framework
import Text.ParserCombinators.Parsec
-- import Test.SmallCheck.Series
 
import Debug.Trace

suite :: Test.Framework.Test
suite = testGroup "NLP.Aura.CgmMacros"
  [ tValue
  , tAv
  , tFeatStruct
  , tLiteral
  , tSemantics
  , tMacro
  , tParseRoundtrip
  ]

-- Round-trip
tParseRoundtrip = testProperty "roundtrip" prop_parse_roundtrip

prop_parse_roundtrip :: Macro -> Bool
prop_parse_roundtrip x = 
   case reads (show x) of
       [(x2,"")] -> x == x2
       _         -> False


tMacro :: Test.Framework.Test
tMacro = testCaseP cgmMacro "macro" (Just fancyMacro) fancyMacroString

tParse :: Test.Framework.Test
tParse = testCaseP cgmMacro "macro" (Just fancyMacro) fancyMacroString

fancyMacro :: Macro
fancyMacro = Macro "spatialRel"
             (mkFeatStruct [avRel])
             [lit1,lit2,lit3]
             (mkFeatStruct [avRel, avArg1, avArg2, avAgr2, avKb1, avKb2, avPl])
 where
  avRel  = AvPair "rel"  (mkGVarNone "B0")
  avArg1 = AvPair "arg1" (mkGVarNone "C0")
  avArg2 = AvPair "arg2" (mkGVarNone "D0")
  avAgr2 = AvPair "agr2" (mkGVarNone "E0")
  avKb1  = AvPair "kbclass1"  (mkGVarNone "I0")
  avKb2  = AvPair "kbclass2"  (mkGVarNone "G0")
  avPl   = AvPair "predlabel" (mkGVarNone "A0")
  lit1   = Literal (mkGVarNone "F0") (mkGConstNone "instance-of") (map mkGVarNone ["D0", "G0"])
  lit2   = Literal (mkGVarNone "H0") (mkGConstNone "instance-of") (map mkGVarNone ["C0", "I0"])
  lit3   = Literal (mkGVarNone "A0") (mkGVarNone "B0") (map mkGVarNone ["C0", "D0", "E0"])

fancyMacroString :: String
fancyMacroString = intercalate "\n"
  [ "spatialRel[rel=?B0]"
  , "\tsemantics:[?A0:?B0(?C0,?D0,?E0) ?F0:instance-of(?D0,?G0) ?H0:instance-of(?C0,?I0) ]"
  , "\tinterface:[agr2=?E0,arg1=?C0,arg2=?D0,kbclass1=?I0,kbclass2=?G0,predlabel=?A0,rel=?B0]"
  ]

tSemantics :: Test.Framework.Test
tSemantics = testGroup "semantics"
  [ tc "nolits"     (Just [])       ""
  , tc "one lit"    (Just [a])      "?L:foo(x)"
  , tc "two lits a" (Just [b,a])    "?L:foo(x) ?L:bar(y,z)"
  , tc "two lits b" (Just [b,a])    "?L:bar(y,z) ?L:foo(x)"
  , tc "there lits" (Just [b,c,a])  "?L:foo(x) ?L:bar(y,z) ?L:baz(a,b)"
  ]
 where
  tc = testCaseP cgmSemantics
  a = Literal (mkGVarNone "L") "foo" ["x"]
  b = Literal (mkGVarNone "L") "bar" ["y","z"]
  c = Literal (mkGVarNone "L") "baz" ["a","b"]

tLiteral :: Test.Framework.Test
tLiteral = testGroup "literal"
  [ tc "no args"    (Just (Literal "l" "foo" []))               "l:foo()"
  , tc "one arg"    (Just (Literal "l" "foo" ["x"]))            "l:foo(x)"
  , tc "two args"   (Just (Literal "l" "foo" ["x","y"]))       "l:foo(x,y)"
  , tc "two args'"  (Just (Literal "l" "foo" ["x","y"]))       "l:foo(x, y)"
  , tc "var label"  (Just (Literal (mkGVarNone "l") "foo" []))  "?l:foo()"
  , tc "var arg"    (Just (Literal "l" "foo" [mkGVarNone "x"])) "l:foo(?x)"
  ]
 where
  tc = testCaseP cgmLiteral
  a = AvPair "foo" (mkGVar "X" Nothing)
  b = AvPair "bar" (mkGVar "Y" Nothing)
  c = AvPair "baz" (mkGVar "Z" Nothing)
 
tFeatStruct :: Test.Framework.Test
tFeatStruct = testGroup "feature structure"
  [ tc "empty" (Just emptyFeatStruct)      ""
  , tc "one"   (Just $ mkFeatStruct [a])   "foo=?X"
  , tc "two a" (Just $ mkFeatStruct [a,b]) "foo=?X, bar=?Y"
  , tc "two b" (Just $ mkFeatStruct [a,b]) "bar=?Y, foo=?X"
  , tc "two c" (Just $ mkFeatStruct [a,b]) "foo=?X,bar=?Y"
  , tc "reject dup" Nothing                "foo=?X, foo=?Y"
  , tc "three" (Just $ mkFeatStruct [a,b,c]) "foo=?X, bar=?Y, baz=?Z"
  ]
 where
  tc = testCaseP cgmFeats
  a = AvPair "foo" (mkGVarNone "X")
  b = AvPair "bar" (mkGVarNone "Y")
  c = AvPair "baz" (mkGVarNone "Z")

tAv :: Test.Framework.Test
tAv = testGroup "attribute/value pair"
  [ tc "const" (Just $ AvPair "foo" "bar")             "foo=bar"
  , tc "var"   (Just $ AvPair "foo" (mkGVarNone "XY")) "foo=?XY"
  , tc "reject var att"   Nothing                      "?foo=bar"
  ]
 where
  tc = testCaseP cgmAttVal 

tValue :: Test.Framework.Test
tValue = testGroup "value"
  [ tc "constant"  (Just   "foo")          "foo"
  , tc "constant2" (Just   "X")            "X"
  , tc "variable"  (Just $ mkGVarNone "X") "?X"
  , tc "anon1"     (Just   mkGAnon)        "_"
  , tc "anon2"     (Just   mkGAnon)        "?_"
  ]
 where
  tc = testCaseP cgmValue

testCaseP :: (Eq a, Show a) => Parser a -> String -> Maybe a -> String -> Test.Framework.Test
testCaseP p = testCaseP' (tillEof p)

instance Pretty Macro where
  pretty m = T.intercalate "\n"
    [ quoteText (mName m) <> prettyCgmFeats (mParams m)
    ,  " " <> geniKeyword "semantics" (prettyCgmSem $ mSemantics m)
    ,  " " <> geniKeyword "interface" (prettyCgmFeats $ mInterface m)
    ]

prettyCgmSem = Pretty.squares
             . T.unwords
             . map prettyCgmLiteral

prettyCgmLiteral (Literal h p args) =
    pretty h <> ":" <> pretty p <> Pretty.parens (T.intercalate "," $ map pretty args)

prettyCgmFeats :: FeatStruct GeniVal -> Text
prettyCgmFeats = Pretty.squares
               . T.intercalate ","      
               . map prettyCgmAvPair
               . sortFlist
               . fromFeatStruct

prettyCgmAvPair :: AvPair GeniVal -> Text
prettyCgmAvPair (AvPair a v) = a <> "=" <> pretty v

instance Show Macro where
    show = prettyStr

instance Read Macro where
    readsPrec _ s = 
        case parse (tillEof cgmMacro) "" s of
            Left _  -> []
            Right x -> [(x,"")]

-- ----------------------------------------------------------------------
-- QuickCheck instances
-- ----------------------------------------------------------------------

instance Arbitrary Macro where
  arbitrary = do
    iface  <- mkFeatStruct . nubBy ((==) `on` avAtt) <$> arbitrary
    params <- case Map.toList iface of
                [] -> return Map.empty
                xs -> Map.fromList <$> listOf (elements xs)
    Macro <$> (fromGTestString <$> arbitrary)
          <*> pure params
          <*> (sortSem . take 5 <$> arbitrary)
          <*> pure iface

-- ----------------------------------------------------------------------
--
-- ----------------------------------------------------------------------

{-
instance Serial (Map.Map T.Text GeniVal) where
        series = cons1 Map.fromList

instance Serial Macro where
        series = cons4 Macro
        coseries rs d
          = [\ t ->
               case t of
                   Macro x1 x2 x3 x4 -> t0 x1 x2 x3 x4
             | t0 <- alts4 rs d]
-}