{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}
module Context where

import Control.DeepSeq
import Control.Lens (view)
import Control.Monad.State (evalStateT, runStateT)
import Data.Array.IArray
import Data.Array.Unboxed
import Data.Bits
import Data.Default (def)
import Data.List as List (map)
import Data.Logic.ATP (Failing(..), unify)
import Data.Logic.ATP.TH ({- Unify instance for template haskell -})
import Data.Map as Map (Map, empty, map, mapKeys, toList, fromList)
import Data.Set as Set (fromList, map, Set)
import Language.Haskell.TH
import Language.Haskell.TH.Context (reifyInstancesWithContext)
-- import Language.Haskell.TH.Context.S (S(S), instMap)
-- import Language.Haskell.TH.Context.Simple (missingInstances, simpleMissingInstanceTest)
import Language.Haskell.TH.Desugar (withLocalDeclarations)
import Language.Haskell.TH.Syntax (Lift(lift), Quasi(qReifyInstances))
import Language.Haskell.TH.Expand (E(_unE), unE, ExpandMap, expandType, pprint1)
import System.Exit (ExitCode)
import Test.Hspec hiding (runIO)
import Test.Hspec.Core.Spec (SpecM)

import Common
import Values

tests :: SpecM () ()
tests = do
  it "can run the Q monad" $ do
     typ <- runQ [t|Int|]
     typ `shouldBe` ConT ''Int

  -- String becomes [Char], Maybe String becomes Maybe [Char], Maybe (Maybe String) becomes Maybe (Maybe [Char])
  it "expands types as expected" $ do
     (expected :: [Type]) <- runQ (sequence [ [t| [Char] |], [t|Maybe [Char] |], [t|Maybe (Maybe [Char])|] ])
     let actual = $(withLocalDeclarations [] $ flip evalStateT (Map.empty :: ExpandMap) $
                    do (types :: [Type]) <- runQ (sequence [ [t|String|], [t|Maybe String|], [t|Maybe (Maybe String)|] ]) >>= mapM expandType >>= return . List.map (view unE)
                       runQ . lift $ types)
     actual `shouldBe` expected

  -- Test the behavior of th-reify-many
  it "can tell that there is an instance NFData Char" $
     $(do insts <- qReifyInstances ''NFData [ConT ''Char]
          lift $ List.map pprint1 insts) `shouldBe` (["instance NFData Char"] :: [String])

  it "can tell that there is no instance NFData ExitCode" $
     $(do insts <- qReifyInstances ''NFData [ConT ''ExitCode]
          lift $ List.map pprint1 insts) `shouldBe` ([] :: [String])
{-
  it "can tell that an instance hasn't been declared" $
     $(missingInstances simpleMissingInstanceTest [d|instance NFData ExitCode|] >>= lift . List.null)
          `shouldBe` False

  it "can tell that an instance has been declared" $
     $(missingInstances simpleMissingInstanceTest [d|instance NFData Char|] >>= lift . List.null)
          `shouldBe` True
-}
-- GHCs older than 7.10 that haven't been specially patched cannot deal with
-- the unbound type variable a.
  -- Doesn't actually use any th-context functions, but it tests
  -- for trac 9262.
  it "Is using a ghc without bug https://ghc.haskell.org/trac/ghc/ticket/9262 (i.e. either 7.10 or a custom patched ghc)" $ do
     $(do _insts <- qReifyInstances ''Eq [ListT `AppT` VarT (mkName "a")]
          -- runIO $ putStrLn (pprint insts)
          lift "ok")
         `shouldBe` "ok"

  it "can find all the Bits instances" $ do
     (setDifferences
        (Set.fromList
           $(do insts <- qReifyInstances ''Bits [VarT (mkName "a")]
                lift (List.map pprintDec insts)))
        bitsInstances)
      `shouldBe` noDifferences
{-
  it "can match all the Enum instances" $ do
     (\ (insts, _pairs) -> (setDifferences (Set.fromList insts) enumInstances))
             $(do (insts, mp) <- runContext (reifyInstancesWithContext ''Enum [VarT (mkName "a")])
                  lift (List.map pprintDec insts, Map.toList (Map.map (List.map pprintDec) (Map.mapKeys pprintPred mp))))
          `shouldBe` noDifferences
-}

  it "knows variables with different names unify" $ do
     let a = mkName "a"
         b = mkName "b"
     unify (AppT (AppT EqualityT (VarT a)) (VarT b)) mempty `shouldBe` Success (Map.fromList [(VarT a, VarT b)])
{-
  it "knows variables are not Eq with other types" $ do
     (E (VarT (mkName "a")) == E (AppT (VarT (mkName "b")) (VarT (mkName "c")))) `shouldBe` False

  it "knows different types are not Eq" $ do
     (E (ConT (mkName "a")) == E (ConT (mkName "b"))) `shouldBe` False
-}

  it "can handle multi param class IArray" $ do
     (\ (insts, pairs) -> (setDifferences (Set.fromList insts) arrayInstances,
                           Map.map Set.fromList (Map.fromList pairs)))
             -- Unquote the template haskell Q monad expression
             $(do -- Run instances and save the result and the state monad result
                  (insts, s) <- runStateT (reifyInstancesWithContext ''IArray [ConT ''UArray, VarT (mkName "a")]) def
                  -- Convert to lists of text so we can lift out of Q
                  lift (List.map pprintDec insts, Map.toList (Map.map (List.map pprintDec') (Map.mapKeys (pprintPred . _unE) (view instMap s)))))
          `shouldBe` (noDifferences,
                      -- I don't think this is right
                      Map.fromList [("IArray UArray a", Set.map (\ x -> "Declared (" ++ x ++ ")") arrayInstances)] :: Map String (Set String))

  it "handles a wrapper instance" $
     $(do (insts, s) <- runStateT (reifyInstancesWithContext ''MyClass [AppT (ConT ''Wrapper) (ConT ''Int)]) def
          lift (List.map pprintDec insts, Map.toList (Map.map (List.map pprintDec') (Map.mapKeys (pprintPred . _unE) (view instMap s)))))
          `shouldBe` (["instance MyClass a => MyClass (Wrapper a)"],
                      [("MyClass (Wrapper Int)",["Declared (instance MyClass a => MyClass (Wrapper a))"]),
                       ("MyClass Int",["Declared (instance MyClass Int)"])])
  it "handles a multi param wrapper instance" $
     $(do (insts, s) <- runStateT (reifyInstancesWithContext ''MyMPClass [VarT (mkName "a"), AppT (ConT ''Wrapper) (ConT ''Int)]) def
          lift (List.map pprintDec insts, Map.toList (Map.map (List.map pprintDec') (Map.mapKeys (pprintPred . _unE) (view instMap s)))))
          `shouldBe` (["instance MyMPClass a b => MyMPClass a (Wrapper b)"],
                      [("MyMPClass a (Wrapper Int)",["Declared (instance MyMPClass a b => MyMPClass a (Wrapper b))"]),
                       ("MyMPClass a Int",["Declared (instance MyMPClass a Int)"])])