{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
module Main where

import Data.Generics.Is.TH
import qualified Data.Generics.Is.Generic as G
import qualified Data.Generics.Is.Data    as D
import Language.Haskell.TH
import Control.Monad
import Control.Applicative
import System.Exit
import GHC.Generics (Generic)
import Data.Data (Typeable, Data)

data TheType a b = A
                 | B String Double ()
                 | Int :+: Int
                 | (:-:) Double
                 | () `C` ()
                 | D { field1 :: a, field2 :: b }
                   deriving (Generic, Typeable, Data)

$(makePredicates ''TheType) ; $(makePredicatesNot ''TheType)

newtype OtherType a = E Int
$(makePredicatesAll ''OtherType)

pattern Sum a b = a :+: b

data E a where
  Plus :: E Int -> E Int -> E Int
  And  :: E Bool -> E Bool -> E Bool
  Lit  :: a -> E a
  Showable :: (Show a) => a -> E String
  (:*:) :: (Num a) => E a -> E a -> E a
  F     :: forall g. g -> E ()

$(makePredicatesAll ''E)

pattern a :&: b = And a b

assertEq :: String -> Bool -> Bool -> IO ()
assertEq _ a b | a == b = return ()
assertEq a_str a b = do
  putStrLn $ a_str ++ " /= " ++ show b
  exitFailure

main :: IO ()
main = $(
  let
    -- Test cases: pattern, expression, pattern matches expression
    testCasesPat :: [(Q Pat, Q Exp, Bool)]
    testCasesPat =
        [ ([p| Just _ |]  , [e| Just "a" |] , True)
        , ([p| [_,_,_] |] , [e| [1,2,3] |] , True)
        , ([p| [_,_] |] , [e| [1,2,3] |] , False)
        , ([p| Left{} |] , [e| Left 3 |] , True)
        ]

    -- Test cases: pattern, expression, constructor matches expression
    testCasesName :: [(Name, Q Exp, Bool)]
    testCasesName =
        [ ('Just , [e| Just 'b' |] , True)
        , ('(:) , [e| [] |] , False)
        , ('[]  , [e| [] |] , True)
        , ('(:) , [e| [1,2,3] |] , True)
        , ('(,,,) , [e| (1,2,3,4) |] , True)
        , ('(:*:) , [e| Lit 3 :*: Lit 4 |] , True)
        , ('(:&:) , [e| Lit True :&: Lit False |] , True)
        , ('(:*:) , [e| Lit True :&: Lit False |] , False)
        , ('F, [e| F "a" |], True)
        , ('A, [e| A |], True)
        , ('D, [e| D 1 "a" |], True)
        , ('C, [e| D 1 "a" |], False)
        , ('Lit, [e| Lit 3 |], True)
        , ('Showable, [e| Showable () |], True)
        ]

    testCasesGeneric :: [(Name, Q Exp, Bool)]
    testCasesGeneric =
        [ ('Just , [e| Just 'b' |] , True)
        , ('(:) , [e| [] |] , False)
        , ('[]  , [e| [] |] , True)
        , ('(:) , [e| [1,2,3] |] , True)
        , ('(,,,) , [e| (1,2,3,4) |] , True)
        , ('Sum , [e| 3 :+: 2 |] , True)
        , ('A, [e| A |], True)
        , ('D, [e| D 1 "a" |], True)
        , ('C, [e| D 1 "a" |], False)
        , ('(:+:) , [e| 3 :+: 4 |] , True)
        , ('(:-:) , [e| (:-:) 3 |] , True)
        ]

    testCasesTypeable :: [(Name, Q Exp, Bool)]
    testCasesTypeable =
        [ ('Just , [e| Just 'b' |] , True)
        , ('(:) , [e| [] :: [()] |] , False)
        , ('[]  , [e| [] :: [()] |] , True)
        , ('(:) , [e| [1,2,3] :: [Int] |] , True)
        , ('(,,,) , [e| (1,2,3,4) :: (Int,Int,Int,Int) |] , True)
        , ('Sum , [e| 3 :+: 2 :: TheType () () |] , True)
        , ('A, [e| A :: TheType () () |], True)
        , ('D, [e| D '1' "a" |], True)
        , ('C, [e| D '1' "a" |], False)
        , ('(:+:) , [e| 3 :+: 4 :: TheType () () |] , True)
        , ('(:-:) , [e| (:-:) 3 :: TheType () () |] , True)
        ]

    testCasesFun :: [(Name, Q Exp, Bool)]
    testCasesFun =
        [ ('isA, [e| A |], True)
        , ('isD, [e| D 1 "a" |], True)
        , ('isC, [e| D 1 "a" |], False)
        , ('isNotF, [e| F "a" |], False)
        , ('isLit, [e| Lit 3 |], True)
        , ('isAnd, [e| Lit "Foo" |], False)
        , ('isNotShowable, [e| Showable () |], False)
        ]

    -- Utility functions
    assertEqTH :: Bool -> Exp -> Exp -> Exp
    assertEqTH b f e = assertEqExpr (AppE f e) b

    boolExp :: Bool -> Exp
    boolExp b = if b then ConE 'True else ConE 'False

    andThen :: Exp -> Exp -> Exp
    x `andThen` y = AppE (AppE (VarE '(>>)) x) y

    assertEqExpr :: Exp -> Bool -> Exp
    assertEqExpr e b = AppE (AppE (AppE (VarE 'assertEq) (LitE (StringL (pprint e)))) e) (boolExp b)
  in do
    es1 <- forM testCasesPat $ \(p, e, b) ->
      andThen <$> (assertEqTH b <$> isP p <*> e)
              <*> (assertEqTH (not b) <$> isNotP p <*> e)

    es2 <- forM testCasesName $ \(n, e, b) ->
      andThen <$> (assertEqTH b <$> is n <*> e)
              <*> (assertEqTH (not b) <$> isNot n <*> e)

    es3 <- forM testCasesFun $ \(f, e, b) ->
      assertEqTH b (VarE f) <$> e

    es4 <- forM testCasesGeneric $ \(n, e, b) ->
      andThen <$> (assertEqTH b       (AppE (VarE 'G.is)    (ConE n)) <$> e)
              <*> (assertEqTH (not b) (AppE (VarE 'G.isNot) (ConE n)) <$> e)

    es5 <- forM testCasesTypeable $ \(n, e, b) ->
      andThen <$> (assertEqTH b       (AppE (VarE 'D.is)    (ConE n)) <$> e)
              <*> (assertEqTH (not b) (AppE (VarE 'D.isNot) (ConE n)) <$> e)

    return $ foldl1 andThen $ es1 ++ es2 ++ es3 ++ es4 ++ es5

  )