{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
-- | Tests for forms.
module FormTest where

#include "ghc_modules.h"

-- base
import           Control.Applicative          (Alternative (..))
import           Data.Char                    (toUpper)
import           Data.Complex
import           Data.Data
import qualified Data.Fixed                   as Fixed
import           Data.Functor.Compose
import           Data.Functor.Const
import           Data.Functor.Identity
import qualified Data.Functor.Product         as Product
import qualified Data.Functor.Sum             as Sum
import           Data.Int
import           Data.List                    (isPrefixOf, isSubsequenceOf)
import           Data.List.NonEmpty           (NonEmpty (..))
import           Data.Monoid
import           Data.Ratio
import qualified Data.Semigroup               as Semigroup
import           Data.Version
import           Data.Word
import           GHC.Generics                 (Generic (..))
import           Numeric.Natural
import           Text.Show.Functions          ()

#if !MIN_VERSION_ghc(8,4,0)
import           Data.Monoid                  ((<>))
#endif

-- binary
import           Data.Binary                  (decode, encode)

-- deepseq
import           Control.DeepSeq

-- ghc
import           GHC_Data_FastString          (fsLit, unpackFS)
import           GHC_Data_StringBuffer        (stringToStringBuffer)
import           GHC_Driver_Session           (HasDynFlags (..))
import           GHC_Types_SrcLoc             (GenLocated (..), SrcSpan (..),
                                               noSrcSpan)
import           GHC_Driver_Ppr               (showPpr)

#if MIN_VERSION_ghc(9,0,0)
import           GHC_Types_SrcLoc             (UnhelpfulSpanReason (..))
#endif

-- transformers
import           Control.Monad.Trans.State

-- hspec
import           Test.Hspec

-- QuickCheck
import           Test.QuickCheck

-- finkel-kernel
import           Language.Finkel.Fnk
import           Language.Finkel.Form
import           Language.Finkel.Homoiconic
import qualified Language.Finkel.Homoiconic   as Homoiconic
import           Language.Finkel.Lexer
import           Language.Finkel.Reader
import           Language.Finkel.SpecialForms

-- Internal
import           Orphan                       ()

formTests :: Spec
formTests = do
  mapM_ readShow
    [ "foo", "#'a", "12345", "6.789", "0.001"
    , "(foo bar buzz)"
    , "(#'a #'\\SP #'\\ \"bcd\")"
    , "[#'\\BEL #'\\BS #'\\FF #'\\LF #'\\CR #'\\HT #'\\VT]"
    , "[()]"
    , "(1 -2 345 6.789 0.001)" ]

  readUnicodeStringProp
  readShowFormProp

  dataInstanceTests
  qFunctionTests

  fracTest 1.23
  fracTest (-1.23)
  fracTest 0
  fracTest 1e-9

  showTest
  pprTest
  functorTest "(a \"foo\" \\x [True False])"
  applicativeTest
  monadTest
  foldableTest
  traversableTest
  binaryTest

  eqTest "(a \"bcd\" \\e [f g] (h i))"
  eqPropTest

  locationTest Nothing "foo"
  locationTest (Just "locationTest") "foo"
  asLocOfTest

  lengthTest 3 "(a b c)"
  lengthTest 5 "(a (b (c)) d e)"
  lengthTest 1 "()"
  lengthTest 8 "[a (b (c d e) [f g]) h]"
  lengthTest 1 "foo"

  homoiconicTests
  rnfTest
  listTest
  numTest
  fractionalTest
  monoidTest
  alternativeTest

  fromCodeTest
  fromCodeErrorTest

  dataToCodeTest
  genericHomoiconicTest

  unquoteSpliceTest

readShow :: String -> Spec
readShow str =
  describe ("read and show `" ++ str ++ "'") $
    it "should match the input" $
      show (parseE str) `shouldBe` str

readUnicodeStringProp :: Spec
readUnicodeStringProp =
  describe "read and show unicode string" $
    it "should return itself" $
      property (\uni ->
                  let str = getUnicodeString uni
                  in  parseE (show str) == toCode (aString NoSourceText str))

readShowFormProp :: Spec
readShowFormProp =
  describe "read and show form property" $
    it "should match the input" $
      property (\form ->
                  form == form && parseE (show form) `eqForm` form)

dataInstanceTests :: Spec
dataInstanceTests = do
  let gfoldl_self atom =
        gfoldl (\mb_f x -> case mb_f of
                   Just f -> pure (f x)
                   _ -> error "should not happen")
               return atom
      t_gfoldl_self x = gfoldl_self x `shouldBe` Just x
      t_show_constr x y = show (toConstr x) `shouldBe` y
  describe "Data instance for Atom" $ do
    let aunit = AUnit
        asym = ASymbol (fsLit "foo")
        achar = AChar NoSourceText 'a'
        astr = AString NoSourceText (fsLit "string")
        aint = AInteger (mkIntegralLit (42 :: Int))
        afrac = aFractional (1.23 :: Double)
    it "should return Just self with simple gfoldl" $ do
      t_gfoldl_self aunit
      t_gfoldl_self asym
      t_gfoldl_self achar
      t_gfoldl_self astr
      t_gfoldl_self aint
      t_gfoldl_self afrac
    it "should show itself with toConstr" $ do
      t_show_constr aunit "AUnit"
      t_show_constr asym "ASymbol"
      t_show_constr achar "AChar"
      t_show_constr astr "AString"
      t_show_constr aint "AInteger"
      t_show_constr afrac "AFractional"
    it "should return AUnit with simple gunfold" $ do
      gunfold (const Nothing) Just (toConstr AUnit) `shouldBe` Just AUnit
    it "should return AUnit constr" $ do
      let dtype = dataTypeOf AUnit
          cnstr = toConstr AUnit
      readConstr dtype "AUnit" `shouldBe` Just cnstr
  describe "Data instance for Form" $ do
    let fatom = Atom AUnit
        qc c = qChar c "" 0 0 0 0
        flist = List [qc 'a', qc 'b']
        fhslist = HsList [qc 'a', qc 'b']
        ftend :: Form Atom
        ftend = TEnd
    it "should return Just self with simple gfoldl" $ do
      t_gfoldl_self fatom
      t_gfoldl_self flist
      t_gfoldl_self fhslist
      t_gfoldl_self ftend
    it "should show itself with toConstr" $ do
      t_show_constr fatom "Atom"
      t_show_constr flist "List"
      t_show_constr fhslist "HsList"
      t_show_constr ftend "TEnd"
    it "should return TEnd with simple gunfold" $
      gunfold (const Nothing) Just (toConstr ftend) `shouldBe` Just ftend
    it "should return Atom constr" $ do
      let dtype = dataTypeOf fatom
          cnstr = toConstr fatom
      readConstr dtype "Atom" `shouldBe` Just cnstr
    it "should return same result from dataCast1 and gcast1" $ do
      (dataCast1 [TEnd] :: Maybe [Form Atom]) `shouldBe` Just [TEnd]
  describe "Data instance for LForm" $ do
    let qc = qChar 'x' "" 0 0 0 0
        d1, d2, d3 :: Data a => a
        d1 = fromConstr (toConstr noSrcSpan)
        d2 = fromConstrB (fromConstr (toConstr AUnit))
                         (toConstr (Atom AUnit))
        d3 = evalState m 0
          where
            m = fromConstrM act (toConstr (L noSrcSpan (Atom AUnit)))
            act :: Data d => State Int d
            act = do
              i <- get
              modify succ
              case i of
                0 -> return d1
                1 -> return d2
                _ -> error ("index " ++ show i ++ " for LForm")
        d4 = fromConstrB d3 (toConstr qu)
        gc1 :: Data a => Maybe [LForm a]
        gc1 =
          let a :: Data a => a
              a = fromConstr (toConstr AUnit)
          in  dataCast1 [LForm (L noSrcSpan (Atom a))]
        qu = qUnit "" 0 0 0 0
    it "should return Just self with simple gfoldl" $ do
      t_gfoldl_self qc
    it "should show itself with toConstr" $ do
      t_show_constr qc "LForm"
    it "should return LForm constr" $ do
      let dtype = dataTypeOf qc
          cnstr = toConstr qc
      readConstr dtype "LForm" `shouldBe` Just cnstr
    it "should construct qUnit from constructors" $ do
      d4 `shouldBe` qu
    it "should return qUnit from dataCast1" $
      gc1 `shouldBe` Just [qu]

qFunctionTests :: Spec
qFunctionTests = do
  describe "qSymbol function" $
    it "should equal to quoted symbol" $
      qSymbol "foo" "" 0 0 0 0 `shouldBe` toCode (ASymbol (fsLit "foo"))
  describe "qChar function" $
    it "should equal to quoted char" $
      qChar 'x' "" 0 0 0 0 `shouldBe` toCode 'x'
  describe "qString function" $
    it "should equal to quoted string" $
      qString "foo" "" 0 0 0 0 `shouldBe` toCode "foo"
  describe "qInteger function" $
    it "should equal to quoted integer" $
      qInteger 42 "" 0 0 0 0 `shouldBe` toCode (42 :: Integer)
  describe "qFractional function" $
    it "should equal to quoted fractional" $
      qFractional (1.23 :: Double) "" 0 0 0 0
        `shouldBe` toCode (1.23 :: Double)
  describe "qUnit function" $
    it "should equal to quoted unit" $
      qUnit "" 0 0 0 0 `shouldBe` toCode ()

  let qc x = qChar x "" 0 0 0 0
  describe "qList function" $
    it "should equal to quoted codes" $
      let xs = [qc 'a', qc 'b']
      in qList xs "" 0 0 0 0 `shouldBe` toCode (List xs)
  describe "qHsList function" $
    it "should equal to quoted haskell list" $
      let xs = [qc 'a', qc 'b']
      in  qHsList xs "" 0 0 0 0 `shouldBe` toCode (HsList xs)

fracTest :: Double -> Spec
fracTest x =
  describe ("read and show a fractional number `" ++ show x ++ "'") $
    it "should match the input" $
       show (aFractional x) `shouldBe` show x

showTest :: Spec
showTest =
  describe "showing TEnd" $
    it "should be \"TEnd\"" $
      show (TEnd :: Form Atom) `shouldBe` "TEnd"

functorTest :: String -> Spec
functorTest str = do
  describe ("Functor instance of Code `" ++ str ++ "'") $
    it "should obey the Functor law" $
       let c = parseE str
       in  fmap id c `shouldBe` c
  describe "fmap to TEnd" $
    it "should be TEnd" $ do
      let te :: Form Atom
          te = TEnd
          f :: Atom -> Atom
          f _ = AUnit
      fmap f te `shouldBe` te

applicativeTest :: Spec
applicativeTest = do
  let atom_a = AChar NoSourceText 'a'
      char_a = toCode atom_a
      al2 = qList [char_a, char_a] "" 0 0 0 0
      ahl2 = qHsList [char_a, char_a] "" 0 0 0 0
      unit = toCode ()
      f1 a b = (a,b)
      a_pair = lf (Atom (atom_a, atom_a))
      a_pair_ls = mk_a_pairs List 2 -- lf (List [a_pair, a_pair])
      a_pair_hls = mk_a_pairs HsList 2 -- lf (HsList [a_pair, a_pair])
      mk_a_pairs f n = lf (f (replicate n a_pair))
      lf = LForm . genSrc
      tend :: Form Atom
      tend = TEnd

  describe "pure" $
    it "should result in atom" $
      toCode (pure AUnit :: Form Atom) `shouldBe` unit

  describe "<*>" $ do
    it "should apply f1 to atom and atom" $
      f1 <$> char_a <*> char_a `shouldBe` a_pair
    it "should apply f1 to atom and list" $
      f1 <$> char_a <*> al2 `shouldBe` a_pair_ls
    it "should apply f1 to atom and hslist" $
      f1 <$> char_a <*> ahl2 `shouldBe` a_pair_hls
    it "should aply f1 to list and atom" $
      f1 <$> al2 <*> char_a `shouldBe` a_pair_ls
    it "should apply f1 to list and list" $
      f1 <$> al2 <*> al2 `shouldBe` mk_a_pairs List 4
    it "should apply f1 to list and hslist" $
      f1 <$> al2 <*> ahl2 `shouldBe` mk_a_pairs List 4
    it "should aply f1 to list and atom" $
      f1 <$> ahl2 <*> char_a `shouldBe` a_pair_hls
    it "should apply f1 to list and list" $
      f1 <$> ahl2 <*> al2 `shouldBe` mk_a_pairs HsList 4
    it "should apply f1 to list and list" $
      f1 <$> ahl2 <*> ahl2 `shouldBe` mk_a_pairs HsList 4
    it "should result in TEnd" $ do
      f1 <$> char_a <*> lf tend `shouldBe` lf TEnd
      f1 <$> lf tend <*> char_a `shouldBe` lf TEnd

monadTest :: Spec
monadTest = do
  let f1 x = case x of
               AChar st c -> AChar st (toUpper c)
               _          -> x
      qh x = qHsList x "" 0 0 0 0
      ql x = qList x "" 0 0 0 0
  describe "bind" $ do
    it "should apply f1 to atom" $
      do {x <- toCode 'x'; return (f1 x)} `shouldBe` toCode 'X'
    it "should apply f1 to list" $
      do {x <- ql [toCode 'x', toCode 'x']; return (f1 x)} `shouldBe`
         ql [toCode 'X', toCode 'X']
    it "should apply f1 to hslist" $
      do {x <- qh [toCode 'x',toCode 'x']; return (f1 x)} `shouldBe`
         qh [toCode 'X', toCode 'X']
    it "should apply f1 to TEnd" $
      do {x <- toCode (TEnd :: Form Atom); return (f1 x)} `shouldBe`
         toCode (TEnd :: Form Atom)

foldableTest :: Spec
foldableTest = do
  let fsum = foldr (\x acc -> case x of
                                AInteger il -> acc + il_value il
                                _           -> acc)
                   0
  describe "taking sum of 1 to 10 with foldr" $ do
    let str1 = "(1 2 3 4 5 6 7 8 9 10)"
    it ("should be 55 for " ++ str1) $
      fsum (parseE str1) `shouldBe` 55
    it "should be 0 for TEnd" $ do
#if MIN_VERSION_ghc(9,0,0)
      let sp = UnhelpfulSpan (UnhelpfulOther (fsLit "<foldableTest>"))
#else
      let sp = UnhelpfulSpan (fsLit "<foldableTest>")
#endif
      fsum (LForm (L sp TEnd)) `shouldBe` 0
  describe "length of nil" $
    it "should be 0" $
      length nil `shouldBe` 0

traversableTest :: Spec
traversableTest = do
  let f atom = case atom of
                 ASymbol sym | '$' : _ <- unpackFS sym
                             -> return (aSymbol "_")
                 _ -> return atom
  describe "replacing symbol with mapM" $ do
    let str1 = "(a $b c [$d e] [f g $h] ($i $j))"
        str2 = "(a  _ c [ _ e] [f g  _] ( _  _))"
    it "should replace $.* with _" $ do
      let form1 = parseE str1
          form2 = parseE str2
      mapM f form1 `shouldBe` Just form2
  describe "traversing TEnd" $
    it "should be Just TEnd" $
      mapM f TEnd `shouldBe` Just TEnd

binaryTest :: Spec
binaryTest = do
  describe "Instances of Get and Put from binary" $ do
    it "should return the original value" $ do
      let to_from_bin :: Code -> Bool
          to_from_bin x = decode (encode x) == x
      property to_from_bin

eqTest :: String -> Spec
eqTest str =
  describe "parsing same string twice" $
   it "should result in equal codes" $
     let c1 = parseE str
         c2 = parseE str
     in  c1 `shouldBe` c2

eqPropTest :: Spec
eqPropTest = do
  describe "Eq instance for LForm" $
    it "should ignore location information" $ do
      let g :: Code -> Bool
          g x@(LForm (L _ body)) = x == LForm (L sp body)
#if MIN_VERSION_ghc(9,0,0)
          sp = UnhelpfulSpan (UnhelpfulOther (fsLit "<eqPropTest>"))
#else
          sp = UnhelpfulSpan (fsLit "<eqPropTest>")
#endif
      property g
  describe "comparing TEnd with TEnd" $
    it "should be True" $
      (TEnd :: Form Atom) `shouldBe` (TEnd :: Form Atom)

locationTest :: Maybe FilePath -> String -> Spec
locationTest mb_path str =
  describe ("location of `" ++ str ++ "'") $
    it (case mb_path of
          Just path -> "should contain `" ++ path ++ "'"
          Nothing   -> "should be unhelpful") $ do
       let c = parseE' mb_path str
           l = showLoc c
       case mb_path of
         Just path -> (path `isPrefixOf` l) `shouldBe` True
         Nothing   -> ("anon" `isSubsequenceOf` l) `shouldBe` True

asLocOfTest :: Spec
asLocOfTest =
  describe ("apply asLocOf to code") $ do
    it "should return the value of first arg" $
      property (\ a b -> asLocOf a b == a)
    it "should use the location of second arg" $
      property (\ a b -> case (asLocOf a b, b) of
                   (LForm (L l1 _), LForm (L l2 _)) -> l1 == l2)

lengthTest :: Int -> String -> Spec
lengthTest n str =
  describe ("length of " ++ str) $
   it ("should be " ++ show n) $
     length (parseE str) `shouldBe` n

homoiconicTests :: Spec
homoiconicTests = do
  let t x = describe ("to/from code " ++ show x) $
              it "shoult match the input" $
                 case fromCode (toCode x) of
                   Just y  -> y `shouldBe` x
                   Nothing -> error ("got Nothing with " ++ show x)
  t (aIntegral (42 :: Int))
  t ()
  t 'x'
  t "string"
  t (42 :: Int)
  t (42 :: Int8)
  t (42 :: Int16)
  t (42 :: Int32)
  t (42 :: Int64)
  t (42 :: Integer)
  t (42 :: Word)
  t (42 :: Word8)
  t (42 :: Word16)
  t (42 :: Word32)
  t (42 :: Word64)
  t (0.123456789 :: Double)
  t (1.234 :: Float)
  t ([1,2,3] :: [Int])
  t (Fixed.MkFixed 2 :: Fixed.Pico)
  t (Identity 'a')
  t (1 :+ 2 :: Complex Int)
  t (Compose (Just (Just 'a')))
  t (Const True :: Const Bool Char)
  t (Product.Pair (Just 'a') (Just 'b'))
  t [Sum.InL (Just 'a'), Sum.InR (Right 'b'), Sum.InR (Left "foo")]
  t ('a' :| ['b', 'c', 'd'])
  t (All False)
  t (Alt (Just True))
  t (Any False)
  t (Dual 'x')
  t (First (Just 'a'))
  t (Last (Just 'a'))
  t (Product (42 :: Int))
  t (Sum (42 :: Int))
  t (Proxy :: Proxy ())
  t (Version [1,2,3] ["foo", "bar"])
  t (1 % 3 :: Rational)
  t (Semigroup.Arg 'x' False)
  t (Semigroup.First 'a')
  t (Semigroup.Last 'z')
  t (Semigroup.Max (42 :: Int))
  t (Semigroup.Min (42 :: Int))
#if !MIN_VERSION_ghc(9,0,0)
  t (Semigroup.Option (Just "foo"))
#endif
  t (Semigroup.WrapMonoid True)
  t (42 :: Natural)
  t (Atom (aIntegral (42 :: Int)))
  t (LForm (genSrc (Atom (aIntegral (42 :: Int)))))
  t [True, False]
  t [EQ, LT, GT]
  t (Just (42 :: Int))
  t [Right True, Left "foo"]
  t (Just 'x', [Right False, Left "foo"])
  t (Just 'x', [Right False, Left "foo"], EQ)
  t (Just 'x', [Right False, Left "foo"], EQ, 42::Int)
  t (Just 'x', [Right False, Left "foo"], EQ, 42::Int ,False)
  t (Just 'x', [Right False, Left "foo"], EQ, 42::Int
    ,False, Just [Right (Just EQ), Left (3.1 :: Double)])

rnfTest :: Spec
rnfTest = do
  describe "rnf of arbitrary form" $
    it "should return ()" $
       property (rnf :: Code -> ())
  describe "rnf of TEnd" $
    it "should return ()" $
      rnf (TEnd :: Form Atom) `shouldBe` ()

listTest :: Spec
listTest =
  describe "list from arbitrary form applied to arbitrary function" $
    it "should be a list" $ do
      let f :: (Code -> Code) -> Code -> Bool
          f g form = isListL (toListL (g form))
      property f

cInt :: Int -> Code
cInt = toCode

cDouble :: Double -> Code
cDouble = toCode

numTest :: Spec
numTest =
  describe "Num instance for Code" $ do
    it "should evaluate +" $ do
      cInt 2 + cInt 40 `shouldBe` 42
      cInt 2 + cDouble 40 `shouldBe` 42.0
      cDouble 2 + cInt 40 `shouldBe` 42.0
      cDouble 2.0 + cDouble 40.0 `shouldBe` 42.0
    it "should evaluate * for AInteger" $ do
      cInt 6 * cInt 7  `shouldBe` 42
      cDouble 6 * cDouble 7 `shouldBe` 42.0
    it "should evalue - for AInteger" $ do
      cInt 50 - cInt 8 `shouldBe` 42
      cDouble 50 - cDouble 8 `shouldBe` 42.0
    it "should evaluate abs" $ do
      abs (cInt (-42)) `shouldBe` 42
      abs (cDouble (-42)) `shouldBe` 42.0
    it "should evaluate signum" $ do
      signum (cInt (-42)) `shouldBe` -1
      signum (cDouble (-42)) `shouldBe` -1.0
    it "should evaluate fromInteger" $
      fromInteger 42 `shouldBe` cInt 42
    it "should result to nil with invalid values" $ do
      3 + toCode 'a' `shouldBe` nil
      signum (toCode 'a') `shouldBe` nil

fractionalTest :: Spec
fractionalTest =
  describe "Fractional instance for Code" $ do
    it "should evaluate /" $ do
      cInt 84 / cInt 2 `shouldBe` 42.0
      cDouble 84.0 / cDouble 2.0 `shouldBe` 42.0
    it "should evaluate recip" $ do
      recip (cInt 4) `shouldBe` 0.25
      recip (cDouble 4.0) `shouldBe` 0.25

monoidTest :: Spec
monoidTest = do
  let a = toCode 'a'
      b = toCode 'b'
      lst = toCode (List [a,b])
      hslst = toCode (HsList [a,b])
  describe "Atom <> XXX" $ do
    it "should result in '(a b)" $
      a <> b `shouldBe` lst
    it "should result in '(a a b)" $
      a <> lst `shouldBe` toCode (List [a,a,b])
    it "should result in '(a a b)" $
      a <> hslst `shouldBe` toCode (List [a,a,b])
  describe "List <> XXX" $ do
    it "should result in '(a b a)" $
      lst <> a `shouldBe` toCode (List [a,b,a])
    it "should result in '(a b a b)" $
      lst <> lst `shouldBe` toCode (List [a,b,a,b])
    it "should result in '(a b a b)" $
      lst <> hslst `shouldBe` toCode (List [a,b,a,b])
  describe "HsList <> XXX" $ do
    it "should result in '(a b a)" $
      hslst <> a `shouldBe` toCode (List [a,b,a])
    it "should result in '(a b a b)" $
      hslst <> lst `shouldBe` toCode (List [a,b,a,b])
    it "should result in '(a b a b)" $
      hslst <> hslst `shouldBe` toCode (List [a,b,a,b])
  describe "TEnd" $ do
    it "should result in non-TEnd" $ do
      let at = Atom True
      at <> TEnd `shouldBe` at
      TEnd <> at `shouldBe` at
  describe "mempty" $ do
    it "should be empty list" $
      mempty `shouldBe` (List [] :: Form Atom)
    it "should be nil" $
      mempty `shouldBe` nil

alternativeTest :: Spec
alternativeTest =
  describe "Alternative" $ do
    describe "empty" $ do
      it "should be nil for Code" $
        empty `shouldBe` nil
      it "should be empty form for Form" $
        empty `shouldBe` (mempty :: Form Atom)
    describe "<|>" $ do
      let a = toCode 'a'
          b = toCode 'b'
          c = toCode 'c'
      it "should append elements for Code" $
        let ab = toCode (List [a,b])
            cb = toCode (List [c,b])
        in  ab <|> cb `shouldBe` toCode (List [a,b,c,b])
      it "should append elements for Form Atom" $
        let ab = List [a,b]
            cb = List [c,b]
        in  ab <|> cb `shouldBe` List [a,b,c,b]

data Foo = Foo deriving (Eq, Show)

instance Homoiconic Foo where
  toCode foo = toCode (aSymbol (show foo))
  parseCode _ = Homoiconic.Failure "Foo"

fromCodeTest :: Spec
fromCodeTest = do
  describe "default toCode implementation" $
    it "should return Nothing" $
      (fromCode nil :: Maybe Foo) `shouldBe` Nothing

  describe "getting Nothing from fromCode" $ do
    let ng title x = it title $ x `shouldBe` Nothing
        q x = qSymbol x "" 0 0 0 0
        foo = q "foo"
        foo1 = qList [q "Foo", q "a"] "" 0 0 0 0
        foo2 = qList [q "Foo", q "a", q "b"] "" 0 0 0 0

    it "should result to Nothing with explicit Nothing" $ do
      fromCode (q "Nothing") `shouldBe` (Just Nothing :: Maybe (Maybe ()))
      toCode (Nothing :: Maybe ()) `shouldBe` q "Nothing"

    ng "()" (fromCode foo :: Maybe ())
    ng "Int" (fromCode foo :: Maybe Int)
    ng "Char" (fromCode nil :: Maybe Char)
    ng "[Int]" (fromCode nil :: Maybe [Int])
    ng "[Char]" (fromCode foo :: Maybe [Char])
    ng "Bool" (fromCode foo :: Maybe Bool)
    ng "Ordering" (fromCode foo :: Maybe Ordering)
    ng "Maybe ()" (fromCode foo1 :: Maybe (Maybe ()))
    ng "Either String ()" (fromCode foo1 :: Maybe (Either String ()))
    ng "(,)" (fromCode foo :: Maybe ((), ()))
    ng "(,,)" (fromCode foo :: Maybe ((), (), ()))
    ng "(,,,)" (fromCode foo :: Maybe ((), (), (), ()))
    ng "(,,,,)" (fromCode foo :: Maybe ((), (), (), (), ()))
    ng "(,,,,,)" (fromCode foo :: Maybe ((), (), (), (), (), ()))
    ng "Data.Functor.Sum.Sum Maybe (Either String) ()"
       (fromCode foo1 :: Maybe (Sum.Sum Maybe (Either String) ()))
    ng "Data.Functor.Product.Product Maybe (Either String) ()"
       (fromCode foo2 :: Maybe (Product.Product Maybe (Either String) ()))
    ng "Sum ()" (fromCode foo1 :: Maybe (Sum ()))
    ng "Proxy ()" (fromCode foo :: Maybe (Proxy ()))
    ng "Atom" (fromCode foo1 :: Maybe Atom)

fromCodeErrorTest :: Spec
fromCodeErrorTest = do
  let err :: Homoiconic a => a -> String -> Spec
      err a ty = it ("should show error message containing " ++ ty) $ do
        case parseCode x `asTypeOf` Homoiconic.Success a of
          Homoiconic.Failure e -> e `shouldSatisfy` isSubsequenceOf ty
          _           -> expectationFailure "parser unexpectedly succeeded"
      x = toCode (List [ toCode (aSymbol "foo")
                       , toCode (aSymbol "x") ])
  describe "Failing to parse Code" $ do
    err (1 :: Integer) "integral"
    err (1 :: Double) "fractional"
    err () "()"
    err 'a' "Char"
    err "string" "String"
    err False "Bool"
    err EQ "Ordering"
    err (Just False) "Maybe"
    err (Right True `asTypeOf` Left "foo") "Either"
    err ((),()) ","
    err ((),(),()) "(,,)"
    err ((),(),(),()) "(,,,)"
    err ((),(),(),(),()) "(,,,,)"
    err ((),(),(),(),(),()) "(,,,,,)"
    err (Sum.InL (Just True) `asTypeOf` Sum.InR (Just False)) "Sum"
    err (All True) "All"
    err (Proxy :: Proxy Int) "Proxy"
    err (aSymbol "foo") "Atom"

data D1 = D1a | D1b | D1c
  deriving (Eq, Show, Data, Typeable, Generic)

instance Homoiconic D1
instance Arbitrary D1 where
  arbitrary = oneof (map pure [D1a, D1b, D1c])

data D2 a = D2a a | D2b a a
  deriving (Eq, Show, Data, Typeable, Generic)

instance Homoiconic a => Homoiconic (D2 a)
instance Arbitrary a => Arbitrary (D2 a) where
  arbitrary = oneof [D2a <$> arbitrary, D2b <$> arbitrary <*> arbitrary]

data D3 a b = D3a Int a b
  deriving (Eq, Show, Data, Typeable, Generic)

instance (Homoiconic a, Homoiconic b) => Homoiconic (D3 a b)
instance (Arbitrary a, Arbitrary b) => Arbitrary (D3 a b) where
  arbitrary = D3a <$> arbitrary <*> arbitrary <*> arbitrary

data D4 a = D4a (a, a, a, a)
  deriving (Eq, Show, Data, Typeable, Generic)

instance Homoiconic a => Homoiconic (D4 a)
instance Arbitrary a => Arbitrary (D4 a) where
  arbitrary =
    D4a <$> ((,,,) <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)

dataToCodeTest :: Spec
dataToCodeTest = do
  let s = toCode . aSymbol
  describe "D1 to Code" $
    it "should match D1 values" $ do
      let e1a = s "D1a"
          e1b = s "D1b"
          e1c = s "D1c"
      dataToCode D1a `shouldBe` e1a
      dataToCode D1b `shouldBe` e1b
      dataToCode D1c `shouldBe` e1c
  describe "D2 to Code" $
    it "should match `D2 Char' values"$ do
      let e2a = toCode (List [s "D2a", toCode 'x'])
          e2b = toCode (List [s "D2b", toCode 'y', toCode 'z'])
      dataToCode (D2a 'x') `shouldBe` e2a
      dataToCode (D2b 'y' 'z') `shouldBe` e2b
  describe "D2 with D1 to Code" $
    it "should match `D2 D1' values" $ do
      let e2b = toCode (List [s "D2b", s "D1a", s "D1b"])
      dataToCode (D2b D1a D1b) `shouldBe` e2b
  describe "D2 with Double to Code" $
    it "should match `D2 Double' values" $ do
      let e2c = toCode (List [s "D2a", toCode (1.23 :: Double)])
      dataToCode (D2a (1.23 :: Double)) `shouldBe` e2c
  describe "D3 to Code" $
    it "should match `D3' value" $ do
      let e3 = toCode (List [ s "D3a"
                            , toCode (42 :: Int)
                            , toCode False
                            , toCode 'a' ])
      dataToCode (D3a 42 False 'a') `shouldBe` e3
  describe "D4 to Code" $
    it "should match `D4' value" $ do
       let e4 = toCode (List [ s "D4a"
                             , toCode (List [ s ","
                                            , toCode 'w'
                                            , toCode 'x'
                                            , toCode 'y'
                                            , toCode 'z'])])
       dataToCode (D4a ('w', 'x', 'y', 'z')) `shouldBe` e4

genericHomoiconicTest :: Spec
genericHomoiconicTest = do
  describe "Result data type for parsing" $ do
    let s1, s2, f1 :: Homoiconic.Result Bool
        s1 = Homoiconic.Success True
        s2 = Homoiconic.Success False
        f1 = Homoiconic.Failure "foo"
    it "should equal to itself" $ do
      s1 `shouldBe` s1
      s1 `shouldNotBe` s2
      f1 `shouldNotBe` s2
    it "should show its conteints" $ do
      show s1 `shouldBe` "Success True"
      show f1 `shouldBe` "Failure \"foo\""
    let isFailure (Homoiconic.Failure _) = True
        isFailure _                      = False
    it "should fail on binding Failure" $
      ((Homoiconic.Failure "X_X" >>= pure) :: Homoiconic.Result Bool)
        `shouldSatisfy` isFailure

  describe "parseCode failure" $ do
    let d2a_sym = toCode $ aSymbol "D2a"
        d3a_sym = toCode $ aSymbol "D3a"
        unit_sym = toCode ()
        fail_with substring r = case r of
          Homoiconic.Failure msg -> substring `isSubsequenceOf` msg
          _                      -> False

    it "should fail on non list Code" $ do
      let r = parseCode @(D2 ()) d2a_sym
      r `shouldSatisfy` fail_with "Not a list"
    it "should fail on unexpected field constructor" $ do
      let r = parseCode @(D3 (D2 Bool) Bool) x
          x = toCode (List [d3a_sym, unit_sym])
      r `shouldSatisfy` fail_with "()"
    it "should fail on unexpected leftover values" $ do
      let r = parseCode @(D2 ()) x
          x = toCode (List [d2a_sym, unit_sym, unit_sym])
      r `shouldSatisfy` fail_with "leftover"
    it "should fail on invalid constructor (no arg)" $ do
      let r = parseCode @FormTest.D1 (toCode (aSymbol "foo"))
      r `shouldSatisfy` fail_with "foo"
    it "should fail on invalid constructor (with args)" $ do
      let r = parseCode @(D2 Bool) (toCode (List [toCode (aSymbol "foo")]))
      r `shouldSatisfy` fail_with "foo"

  describe "genericFromCode" $ do
    it "should result in Code value" $ do
      let d2 :: D2 Int
          d2 = D2a 42
      genericFromCode (toCode d2) `shouldBe` Just d2
    it "should fail with invalid value" $ do
      genericFromCode (toCode ()) `shouldBe` (Nothing :: Maybe (D2 Int))

  describe "To/from code via Generic" $ do
    it "should return itself" $
      let g_to_from :: D4 (D3 (D2 Int) D1) -> Bool
          g_to_from x = Just x == fromCode (toCode x)
      in  property g_to_from
    it "should return itself with nested Maybe data type" $
      let g_to_from :: D3 (Maybe (Maybe (Maybe Int))) (Maybe (Maybe Bool))
                    -> Bool
          g_to_from x = Just x == fromCode (toCode x)
      in  property g_to_from

  let s = toCode . aSymbol
      noParse :: (Eq a, Show a, Homoiconic a) => Maybe a -> IO ()
      noParse = (`shouldBe` Nothing)

  describe "Malformed codes via Generic" $ do
    it "result to Nothing with invalid constructor" $
      noParse (fromCode (s "Foo") :: Maybe D1)
    it "result to Nothing with arity mismatch" $
      noParse
        (fromCode (toCode (List [s "D2a", toCode False, toCode False]))
          :: Maybe (D2 Bool))
    it "result to Nothing with invalid field value" $
      noParse
        (fromCode (toCode (List [s "D2a", s "FOO"])) :: Maybe (D2 Bool))
    it "result to Nothing with non list" $
      noParse (fromCode (toCode "FOO") :: Maybe (D2 Bool))
    it "result to Nothing with invalid form" $
      noParse
        (fromCode (toCode (List [s "D2a", toCode (List [s "Just", s "___"])]))
           :: Maybe (D2 (Maybe Bool)))

unquoteSpliceTest :: Spec
unquoteSpliceTest =
  describe "unquote splicing List" $
    it "should return list contents" $
      property
        (\form ->
           (isListL form || isHsListL form ||
            isStringL form || isUnitL form)
           ==> (0 <= length (unquoteSplice form)))

eqForm :: Code -> Code -> Bool
eqForm a b =
  case (unCode a, unCode b) of
    -- Ignoring rounding error for fractional literals.
    (Atom (AFractional x), Atom (AFractional y))
      -> abs (fl_value x - fl_value y) <= toRational epsilon

    -- Recursively compare with `eqForm' for 'List' and 'HsList'.
    (List [], List []) -> True
    (List (x:xs), List (y:ys)) ->
      let ql z = qList z "" 0 0 0 0
      in  eqForm x y && eqForm (ql xs) (ql ys)

    (HsList [], HsList []) -> True
    (HsList (x:xs), HsList (y:ys)) ->
      let qh z = qHsList z "" 0 0 0 0
      in  eqForm x y && eqForm (qh xs) (qh ys)

    -- Treating empty 'List' and Atom symbol 'nil' as same value.
    (Atom (ASymbol sym), List []) | sym == fsLit "nil" -> True
    (List [], Atom (ASymbol sym)) | sym == fsLit "nil" -> True

    -- Using '==' for other Atom values.
    (Atom x, Atom y) -> x == y

    _ -> False
  where
    epsilon :: Double
    epsilon = 1e-7

pprTest :: Spec
pprTest =
  describe "ppr" $
    it "should return expected String" $ do
      let str0 = "(1 2.34 () #'a \"foo\" [foo bar buzz])"
      str1 <- runPpr str0
      str1 `shouldBe` str0

runPpr :: String -> IO String
runPpr str =
  runFnk (do dflags <- getDynFlags
             return (showPpr dflags (parseE str)))
         defaultFnkEnv

parseE :: String -> Code
parseE = parseE' Nothing

parseE' :: Maybe FilePath -> String -> Code
parseE' mb_path str =
  let inp = stringToStringBuffer str
  in  case runSP sexpr mb_path inp of
        Right (expr, _) -> expr
        Left err        -> error (show err)

isListL :: Code -> Bool
isListL (LForm (L _ (List _))) = True
isListL _                      = False

isHsListL :: Code -> Bool
isHsListL (LForm (L _ (HsList _))) = True
isHsListL _                        = False

isStringL :: Code -> Bool
isStringL (LForm (L _ (Atom (AString _ _)))) = True
isStringL _                                  = False

isUnitL :: Code -> Bool
isUnitL (LForm (L _ (Atom AUnit))) = True
isUnitL _                          = False
