{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module NLP.Aura.Test.CgmMacroExpansion where

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

import NLP.GenI.FeatureStructure
import NLP.GenI.GeniShow
import NLP.GenI.GeniVal
import NLP.GenI.Semantics
import NLP.GenI.Morphology ( LemmaPlus(..) )
import NLP.GenI.Pretty
import qualified NLP.GenI.Pretty as Pretty
import GHC.Exts ( IsString(..) )
import TestUtil

import NLP.Aura.CgmMacros
import NLP.Aura.CgmMacroExpansion
import NLP.Aura.Test.CgmMacros ( fancyMacro )

suite :: Test.Framework.Test
suite = testGroup "NLP.Aura.CgmMacroExpansion"
  [ tExpand
  , tNiceVars
  ]

tExpand :: Test.Framework.Test
tExpand = testGroup "expand"
  [ testCase "simple expansion"
     $ assertEqual "" (Just fancyExpansion) (expand fancyMacro input)
  -- TODO: gah! this fails
  , testProperty "idempotent"            prop_expand_idempotent
  ]
 where
  input = mkFeatStruct [AvPair "rel" "walk"]

fancyExpansion :: Expansion
fancyExpansion = Expansion
             [lit1,lit2,lit3]
             (mkFeatStruct [avRel, avArg1, avArg2, avAgr2, avKb1, avKb2, avPl])
 where
  avRel  = AvPair "rel"  "walk"
  avArg1 = AvPair "arg1" (mkGVarNone "B")
  avArg2 = AvPair "arg2" (mkGVarNone "C")
  avAgr2 = AvPair "agr2" (mkGVarNone "D")
  avKb1  = AvPair "kbclass1"  (mkGVarNone "F")
  avKb2  = AvPair "kbclass2"  (mkGVarNone "E")
  avPl   = AvPair "predlabel" (mkGVarNone "A")
  lit1   = Literal mkGAnon   "instance-of" (map mkGVarNone ["C", "E"])
  lit2   = Literal mkGAnon   "instance-of" (map mkGVarNone ["B", "F"])
  lit3   = Literal (mkGVarNone "A") "walk" (map mkGVarNone ["B", "C", "D"])

-- Expanding a macro twice (ie. converting the first expansion
-- back into a macro) with the same parameters
-- leads to the same expansion
--
-- (assuming you can convert an expansion back to a macro)
--
-- TODO: Does this really tell us anything useful?
prop_expand_idempotent m vals =
    isJust mexp
  ==>
    whenFail (putStrLn . intercalate "\n--\n\n" . map show $ [exp, (fromJust mexp2)]) $
    isJust mexp2 && Just exp == mexp2
  where
    p    = zipParams m vals
    mexp  = expandSubst m  p -- basically expand, but we need to grab the subst
    mexp2 = expand m2 p
    (exp, subst) = fromJust mexp
    m2   = m { mSemantics = eSemantics exp 
             , mInterface = eInterface exp
             , mParams    = replace subst (mParams m) -- (finaliseVars "m" (mParams m))
             }
  
instance Pretty Expansion where
    pretty x = T.intercalate "\n"
        [  " " <> geniKeyword "interface" (pretty . eInterface $ x)
        ,  " " <> geniKeyword "semantics" (Pretty.squares . pretty . eSemantics $ x)
        ]

instance Show Expansion where
    show = prettyStr


-- | QC helper: given a macro and list of values, produce
--   a parameters FS with some attributes instantiated.
--
--   The idea is to explore a tighter search space than just
--   grabbing any arbtirary parameter list, which I think
--   would just pointlessly explore a lot of nothing
zipParams :: Macro -> [GeniVal] -> FeatStruct GeniVal
zipParams m vals = Map.fromList $ zip (Map.keys (mParams m)) vals

-- quickcheck: an expansion subsumes its macro
-- A expansion in macro form

-- ----------------------------------------------------------------------
-- niceVars
-- ----------------------------------------------------------------------

tNiceVars :: Test.Framework.Test
tNiceVars = testGroup "niceVars"
    [ tc "single var" (mkGVarNone "A")
                      (mkGVarNone "X")
    , tc "multi var"  [mkGVarNone "B", mkGVarNone "A"]
                      [mkGVarNone "Y", mkGVarNone "X"]
    , testProperty "idempotent"
          (prop_niceVars_idempotent :: [GeniVal] -> Bool)
    , testProperty "unify x (niceVar x)"
          prop_niceVars_selfUnify
    ]
 where
    tc :: (Show a, Eq a, DescendGeniVal a, Collectable a)
       => String
       -> a -> a
       -> Test.Framework.Test
    tc str res inp = testCase str $ assertEqual "" res (niceVars inp)

prop_niceVars_idempotent :: (Show a, Eq a, DescendGeniVal a, Collectable a) => a -> Bool
prop_niceVars_idempotent x =
    nx == niceVars nx
  where
    nx = niceVars x

prop_niceVars_selfUnify :: [GeniVal] -> Bool
prop_niceVars_selfUnify x_ = isJust $
    unify (finaliseVars "x" nx) (finaliseVars "y" x)
  where
    nx = niceVars x
    -- don't bother with multiple occurences of the same var because they
    -- have conflicting constraints
    x = nubBy ((==) `on` gLabel) x_