{-# OPTIONS -Wno-orphans #-}
{-# LANGUAGE AllowAmbiguousTypes        #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PackageImports             #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE LambdaCase                 #-}

import qualified Data.ByteString         as B
import qualified Data.ByteString.Builder as LB
import qualified Data.ByteString.Lazy    as LB
import           Data.Char               ( chr, isSpace )
import           Data.Foldable           ( foldMap )
import qualified Data.HashMap.Strict     as HM
import           Data.List               ( sort )
import           Data.Semigroup
import qualified Data.Text               as T
import qualified Data.Text.Lazy          as LT
import           Data.Word

import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )

import Control.Monad.IO.Class ( liftIO )

import "hspec" Test.Hspec
import "hspec" Test.Hspec.QuickCheck
import "hspec-core" Test.Hspec.Core.Runner
import "QuickCheck" Test.QuickCheck
import "quickcheck-instances" Test.QuickCheck.Instances.ByteString ()
import "QuickCheck" Test.QuickCheck.Monadic
import "quickcheck-unicode" Test.QuickCheck.Unicode

import Data.String.Interpolate ( i, iii, __i, __i'E, __i'L, iii'E, iii'L )
import Data.String.Interpolate.Conversion hiding
  ( build, finalize, interpolate, ofString, chompSpaces )
import Data.String.Interpolate.Types ( InterpSegment(..) )
import Data.String.Interpolate.Parse ( parseInterpSegments )

main :: IO ()
main = hspecWith testConfig $ parallel $ do
  describe "parseInterpSegments" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do
    -- A pretty weaksauce test, but we've had issues with this before.
    prop "terminates" $
      \(UTF8S str) -> parseInterpSegments str `seq` True

  describe "i" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do
    it "should allow an escaped backslash right before an interp" $ do
      let var :: String = "bar"
          expected :: String = "foo\\bar"
      [i|foo\\#{var}|] `shouldBe` expected

    it "should only escape verbatim segments a single time" $ do
      let expected :: String = "\\\\\\\\"
      [i|\\\\\\\\|] `shouldBe` expected

    it "should error on hanging #" $ do
      runQ (quoteExp i "#") `shouldThrow` anyException

    it "should error on unterminated backslash" $ do
      runQ (quoteExp i "\\") `shouldThrow` anyException

    it "should error on unknown escape sequence" $ do
      runQ (quoteExp i "\\c") `shouldThrow` anyException

    it "should error on unclosed expression" $ do
      runQ (quoteExp i "#{") `shouldThrow` anyException

    it "should parse TypeApplications" $ do
      let expected :: String = "2"
      [i|#{show @Int 2}|] `shouldBe` expected

    context "when using String as a parameter" $ do
      prop "just interpolating should be id" $
        \(UTF8S str) -> [i|#{str}|] == str

      prop "should passthrough a conversion to strict Text and back unchanged" $
        \(UTF8S str) -> iID @String @T.Text str
      prop "should passthrough a conversion to lazy Text and back unchanged" $
        \(UTF8S str) -> iID @String @LT.Text str
      prop "should passthrough a conversion to strict ByteString and back unchanged" $
        \(UTF8S str) -> iID @String @B.ByteString str
      prop "should passthrough a conversion to lazy ByteString and back unchanged" $
        \(UTF8S str) -> iID @String @LB.ByteString str

    context "when using strict Text as a parameter" $ do
      prop "just interpolating should be id" $
        \(t :: T.Text) -> [i|#{t}|] == t

      prop "should passthrough a conversion to String and back unchanged" $ iID @T.Text @String
      prop "should passthrough a conversion to lazy Text and back unchanged" $ iID @T.Text @LT.Text
      prop "should passthrough a conversion to strict ByteString and back unchanged" $ iID @T.Text @B.ByteString
      prop "should passthrough a conversion to lazy ByteString and back unchanged" $ iID @T.Text @LB.ByteString

    context "when using lazy Text as a parameter" $ do
      prop "just interpolating should be id" $
        \(lt :: LT.Text) -> [i|#{lt}|] == lt

      prop "should passthrough a conversion to String and back unchanged" $ iID @LT.Text @String
      prop "should passthrough a conversion to strict Text and back unchanged" $ iID @LT.Text @T.Text
      prop "should passthrough a conversion to strict ByteString and back unchanged" $ iID @LT.Text @B.ByteString
      prop "should passthrough a conversion to lazy ByteString and back unchanged" $ iID @LT.Text @LB.ByteString

    context "when using strict ByteString as a parameter" $ do
      prop "just interpolating should be id" $
        \(b :: B.ByteString) -> [i|#{b}|] == b

      prop "should passthrough a conversion to lazy ByteString and back unchanged" $ iID @B.ByteString @LB.ByteString

      context "and the ByteString is valid UTF8" $ do
        prop "should passthrough a conversion to String and back unchanged" $ do
          \(UTF8BS b) -> iID @B.ByteString @String b
        prop "should passthrough a conversion to strict Text and back unchanged" $ do
          \(UTF8BS b) -> iID @B.ByteString @T.Text b
        prop "should passthrough a conversion to lazy Text and back unchanged" $ do
          \(UTF8BS b) -> iID @B.ByteString @LT.Text b

    context "when using lazy ByteString as a parameter" $ do
      prop "just interpolating should be id" $
        \(lb :: LB.ByteString) -> [i|#{lb}|] == lb

      prop "should passthrough a conversion to strict ByteString and back unchanged" $ iID @LB.ByteString @B.ByteString

      context "and the ByteString is valid UTF8" $ do
        prop "should passthrough a conversion to String and back unchanged" $
          \(UTF8LBS lb) -> iID @LB.ByteString @String lb
        prop "should passthrough a conversion to strict Text and back unchanged" $
          \(UTF8LBS lb) -> iID @LB.ByteString @T.Text lb
        prop "should passthrough a conversion to lazy Text and back unchanged" $
          \(UTF8LBS lb) -> iID @LB.ByteString @LT.Text lb

    context "when using Char as a parameter" $ do
      prop "interpolating into a String shouldn't have quotes" $
        \(UTF8C c) -> [i|#{c}|] == [c]
      prop "interpolating into strict Text shouldn't have quotes" $
        \(UTF8C c) -> [i|#{c}|] == T.singleton c
      prop "interpolating into lazy Text shouldn't have quotes" $
        \(UTF8C c) -> [i|#{c}|] == LT.singleton c
      prop "interpolating into strict ByteString shouldn't have quotes" $
        \(UTF8C c) -> [i|#{c}|] == (LB.toStrict $ LB.toLazyByteString $ LB.charUtf8 c)
      prop "interpolating into lazy ByteString shouldn't have quotes" $
        \(UTF8C c) -> [i|#{c}|] == (LB.toLazyByteString $ LB.charUtf8 c)

    context "when interpolating into strict ByteString" $ do
      it "should handle literal Unicode strings correctly" $ do
        let interpolated :: B.ByteString = [i|λ|]
            expected :: B.ByteString = "\xCE\xBB"
        interpolated `shouldBe` expected

    context "when interpolating into lazy ByteString" $ do
      it "should handle literal Unicode strings correctly" $ do
        let interpolated :: LB.ByteString = [i|λ|]
            expected :: LB.ByteString = "\xCE\xBB"
        interpolated `shouldBe` expected

  describe "__i" $ modifyMaxSuccess (const 250) $ modifyMaxSize (const 500) $ do
    context "when there are newlines" $ do
      it "handles a small code snippet correctly/1" $ do
        let interpolated :: T.Text =
              [__i|
                id :: a -> a
                id x = y
                  where y = x
              |]
            expected :: T.Text = "id :: a -> a\nid x = y\n  where y = x"
        interpolated `shouldBe` expected

      it "handles a small code snippet correctly/2" $ do
        let interpolated :: T.Text =
              [__i|


                This is an example message.

                  Title: Foo
                  Description: Bar
                  Categories:



                This is an example body.

              |]
            expected :: T.Text = "This is an example message.\n\n  Title: Foo\n  Description: Bar\n  Categories:\n\n\n\nThis is an example body."
        interpolated `shouldBe` expected

      it "handles a small code snippet correctly/3" $ do
        let input :: Int = 42
            interpolated :: T.Text =
              [__i|
                add :: Int -> Int -> Int
                add x y =
                  let result = x + y + #{input}
                    in result
              |]
            expected :: T.Text = "add :: Int -> Int -> Int\nadd x y =\n  let result = x + y + 42\n    in result"
        interpolated `shouldBe` expected

      it "handles tabs" $ do
        let interpolated :: T.Text =
              [__i|
		id :: a -> a
		id x = y
			where y = x
              |]
            expected = "id :: a -> a\nid x = y\n\twhere y = x"
        interpolated `shouldBe` expected

    -- prop "produces the same output for different indentation levels" $
    --   \(segs :: [InterpSegment], indent :: Word8, offset :: Word8) -> monadicIO $ do
    --     let interpLines = lines $ interpToString $
    --           filter (\case { Expression _ -> False; _ -> True }) segs
    --         fi = fromIntegral
    --         lessIO = runQ $ quoteExp __i (unlines $ leftPad (fi (indent + 1)) ' ' <$> interpLines)
    --         moreIO = runQ $ quoteExp __i (unlines $ leftPad (fi (indent + offset + 2)) ' ' <$> interpLines)
    --     lessExp <- run lessIO
    --     moreExp <- run moreIO
    --     assert $! lessExp == moreExp

  --   prop "non-whitespace chars in output same as in input" $
  --     \(SpaceyText t) -> charFrequencies [__i|#{t}|] == charFrequencies t

  --   prop "output string length <= input string length" $
  --     \(SpaceyText t) -> T.length [__i|#{t}|] <= T.length t

  --   prop "output words = input words" $
  --     \(SpaceyText t) -> T.words t == T.words [__i|#{t}|]

  describe "__i'E" $ modifyMaxSuccess (const 250) $ modifyMaxSize (const 500) $ do
    context "when there are newlines" $ do
      it "handles a small code snippet correctly/1" $ do
        let interpolated :: T.Text =
              [__i'E|
                id :: a -> a
                id x = y
                  where y = x
              |]
            expected :: T.Text = "\nid :: a -> a\nid x = y\n  where y = x\n              "
        interpolated `shouldBe` expected

      it "handles a small code snippet correctly/2" $ do
        let interpolated :: T.Text =
              [__i'E|


                This is an example message.

                  Title: Foo
                  Description: Bar
                  Categories:



                This is an example body.

              |]
            expected :: T.Text = "\n\n\nThis is an example message.\n\n  Title: Foo\n  Description: Bar\n  Categories:\n\n\n\nThis is an example body.\n\n              "
        interpolated `shouldBe` expected

      it "handles a small code snippet correctly/3" $ do
        let input :: Int = 42
            interpolated :: T.Text =
              [__i'E|
                add :: Int -> Int -> Int
                add x y =
                  let result = x + y + #{input}
                    in result
              |]
            expected :: T.Text = "\nadd :: Int -> Int -> Int\nadd x y =\n  let result = x + y + 42\n    in result\n              "
        interpolated `shouldBe` expected

  describe "__i'L" $ modifyMaxSuccess (const 250) $ modifyMaxSize (const 500) $ do
    context "when there are newlines" $ do
      it "handles a small code snippet correctly/1" $ do
        let interpolated :: T.Text =
              [__i'L|

                id :: a -> a
                id x = y
                  where y = x
              |]
            expected :: T.Text = "\nid :: a -> a\nid x = y\n  where y = x\n              "
        interpolated `shouldBe` expected

      it "handles a small code snippet correctly/2" $ do
        let interpolated :: T.Text =
              [__i'L|


                This is an example message.

                  Title: Foo
                  Description: Bar
                  Categories:



                This is an example body.

              |]
            expected :: T.Text = "\nThis is an example message.\n\n  Title: Foo\n  Description: Bar\n  Categories:\n\n\n\nThis is an example body.\n"
        interpolated `shouldBe` expected

      it "handles a small code snippet correctly/3" $ do
        let input :: Int = 42
            interpolated :: T.Text =
              [__i'L|
                add :: Int -> Int -> Int
                add x y =
                  let result = x + y + #{input}
                    in result
              |]
            expected :: T.Text = "\nadd :: Int -> Int -> Int\nadd x y =\n  let result = x + y + 42\n    in result\n              "
        interpolated `shouldBe` expected

  describe "iii" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do
    context "when there is whitespace" $ do
      it "collapses a small example of whitespace" $ do
        let interpolated :: T.Text = [iii| foo   bar      baz |]
            expected :: T.Text = "foo bar baz"
        interpolated `shouldBe` expected

      it "collapses a small example of newlines" $ do
        let interpolated :: T.Text =
              [iii|
                Lorem ipsum dolor sit amet,
                consectetur adipiscing elit.
                Aenean congue iaculis dui,
                at iaculis sapien interdum nec.
              |]
            expected :: T.Text = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Aenean congue iaculis dui, at iaculis sapien interdum nec."
        interpolated `shouldBe` expected

  describe "iii'E" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do
    context "when there is whitespace" $ do
      it "collapses a small example of whitespace" $ do
        let interpolated :: T.Text = [iii'E| foo   bar      baz |]
            expected :: T.Text = "foo bar baz"
        interpolated `shouldBe` expected

      it "collapses a small example of newlines" $ do
        let interpolated :: T.Text =
              [iii'E|

                Lorem ipsum dolor sit amet,
                consectetur adipiscing elit.
                Aenean congue iaculis dui,
                at iaculis sapien interdum nec.

              |]
            expected :: T.Text = "\n\nLorem ipsum dolor sit amet, consectetur adipiscing elit. Aenean congue iaculis dui, at iaculis sapien interdum nec.\n\n              "
        interpolated `shouldBe` expected

  describe "iii'L" $ modifyMaxSuccess (const 10000) $ modifyMaxSize (const 500) $ do
    context "when there is whitespace" $ do
      it "collapses a small example of whitespace" $ do
        let interpolated :: T.Text = [iii'L| foo   bar      baz |]
            expected :: T.Text = "foo bar baz"
        interpolated `shouldBe` expected

      it "collapses a small example of newlines" $ do
        let interpolated :: T.Text =
              [iii'L|

                Lorem ipsum dolor sit amet,
                consectetur adipiscing elit.
                Aenean congue iaculis dui,
                at iaculis sapien interdum nec.

              |]
            expected :: T.Text = "\nLorem ipsum dolor sit amet, consectetur adipiscing elit. Aenean congue iaculis dui, at iaculis sapien interdum nec.\n"
        interpolated `shouldBe` expected

testConfig :: Config
testConfig = defaultConfig
  { configDiff = True
  , configFailureReport = Nothing
  }

iID :: forall from to fromflag toflag.
       ( Eq from
       , Interpolatable fromflag to from
       , Interpolatable toflag from to
       )
    => from
    -> Bool
iID from =
  let to :: to = [i|#{from}|]
      from' :: from = [i|#{to}|]
  in from == from'

-- |
-- Add the given number of the specific characters to the left.
leftPad :: Int -> Char -> String -> String
leftPad amt c t = replicate amt c <> t

-- |
-- The default Arbitrary for Char generates U+FFFF and U+FFFE, which aren't
-- valid Unicode. Sigh...
newtype UTF8Char = UTF8C { unUTF8C :: Char }
  deriving newtype (Eq, Show)

newtype UTF8String = UTF8S { unUTF8S :: String }
  deriving newtype (Eq, Show)

newtype UTF8ByteString = UTF8BS B.ByteString
  deriving newtype (Eq, Show)
newtype UTF8LazyByteString = UTF8LBS LB.ByteString
  deriving newtype (Eq, Show)

newtype SpaceyText = SpaceyText T.Text
  deriving newtype (Eq, Show)
newtype NonwhitespaceText = NonwhitespaceText T.Text
  deriving newtype (Eq, Show)

instance Arbitrary UTF8Char where
  arbitrary = UTF8C <$> unicodeChar
  shrink (UTF8C c) = UTF8C <$> shrinkChar c

instance Arbitrary UTF8String where
  arbitrary = do
    chars <- listOf arbitrary
    pure $ UTF8S (unUTF8C <$> chars)
  shrink (UTF8S str) = UTF8S <$> shrink str

instance Arbitrary T.Text where
  arbitrary = T.pack . unUTF8S <$> arbitrary
  shrink t = if T.null t || T.length t == 1
    then []
    else let mid = T.length t `div` 2
         in [T.take mid t, T.drop mid t]

instance Arbitrary LT.Text where
  arbitrary = LT.pack . unUTF8S <$> arbitrary
  shrink lt = if LT.null lt || LT.length lt == 1
    then []
    else let mid = LT.length lt `div` 2
         in [LT.take mid lt, LT.drop mid lt]

instance Arbitrary UTF8ByteString where
  arbitrary = UTF8BS . LB.toStrict . LB.toLazyByteString . foldMap LB.charUtf8 . unUTF8S
    <$> arbitrary

instance Arbitrary UTF8LazyByteString where
  arbitrary = UTF8LBS . LB.toLazyByteString . foldMap LB.charUtf8 . unUTF8S
    <$> arbitrary

-- Basically, we want this to be an 'alternation' of sequences of printable
-- characters and whitespace characters.
instance Arbitrary SpaceyText where
  arbitrary = SpaceyText . foldMap id
    <$> scale
          (round . sqrt @Double . fromIntegral)
          (listOf (oneof [whitespace, nonwhitespace]))

instance Arbitrary NonwhitespaceText where
  arbitrary = NonwhitespaceText <$> nonwhitespace

instance Arbitrary InterpSegment where
  arbitrary = oneof
    [ Verbatim <$> listOf nonwhitespaceChar
    , Expression <$> arbitrary
    , Spaces <$> arbitrary
    , Tabs <$> arbitrary
    ]

  shrink (Verbatim t) = Verbatim <$> shrink t
  shrink (Expression t) = []
  shrink (Spaces n) = [Spaces (n `div` 2), Spaces (n-1)]
  shrink (Tabs n) = [Tabs (n `div` 2), Tabs (n-1)]

charFrequencies :: T.Text -> HM.HashMap Char Int
charFrequencies = T.foldl' (flip $ HM.alter increment) HM.empty . T.filter (not . isSpace)
  where increment :: Maybe Int -> Maybe Int
        increment Nothing  = Just 1
        increment (Just x) = Just (x + 1)

whitespace :: Gen T.Text
whitespace = T.pack
  <$> listOf1 (elements [' ', '\r', '\t', '\n', '\x1680', '\x2000', '\x2006'])

nonwhitespace :: Gen T.Text
nonwhitespace = T.pack
  <$> listOf1 nonwhitespaceChar

nonwhitespaceChar :: Gen Char
nonwhitespaceChar = unicodeChar `suchThat` (not . isSpace)

unicodeChar :: Gen Char
unicodeChar = chr `fmap` points
  where points = flip suchThat (not . reserved) $ oneof
          [ ascii
          , plane0
          , plane1
          , plane2
          , plane14
          ]
