{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Heist.Compiled.Tests where

import           Blaze.ByteString.Builder
import           Control.Applicative
import           Control.Exception
import           Control.Monad.Trans.Except
import           Control.Lens
import           Control.Monad.Trans
import           Data.Bifunctor (first)
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import           Data.Char
import           Data.IORef
import           Data.Maybe
import           Data.Map.Syntax
import           Data.Monoid
import qualified Data.Set as Set
import qualified Data.Text as T
import           Data.Text.Encoding
import           Test.Framework (Test)
import           Test.Framework.Providers.HUnit
import qualified Test.HUnit as H
import qualified Text.XmlHtml as X


------------------------------------------------------------------------------
import           Heist
import           Heist.Compiled
import           Heist.Compiled.Internal
import           Heist.Internal.Types
import           Heist.Tutorial.CompiledSplices
import           Heist.TestCommon

-- NOTE: We can't test compiled templates on the templates directory as it
-- stands today because that directory contains some error conditions such as
-- infinite bind loops, apply tags with no template attribute, and apply tags
-- with ".." in the tag path (which doesn't currently work).

tests :: [Test]
tests = [ testCase     "compiled/simple"        simpleCompiledTest
        , testCase     "compiled/people"        peopleTest
        , testCase     "compiled/namespace1"    namespaceTest1
        , testCase     "compiled/namespace2"    namespaceTest2
        , testCase     "compiled/namespace3"    namespaceTest3
        , testCase     "compiled/namespace4"    namespaceTest4
        , testCase     "compiled/namespace5"    namespaceTest5
        , testCase     "compiled/no-ns-splices" noNsSplices
        , testCase     "compiled/ns-nested"     nsNestedUnused
        , testCase     "compiled/nsbind"        nsBindTest
        , testCase     "compiled/nsbinderr"     nsBindErrorTest
        , testCase     "compiled/nscall"        nsCallTest
        , testCase     "compiled/nscallerr"     nsCallErrTest
        , testCase     "compiled/nsbindstack"   nsBindStackTest
        , testCase     "compiled/doctype"       doctypeTest
        , testCase     "compiled/exceptions"    exceptionsTest
        , testCase     "compiled/defer"         deferTest
        ]

simpleCompiledTest :: IO ()
simpleCompiledTest = do
    res <- runWithStateSplice "templates"
    H.assertEqual "compiled state splice" expected res
  where
    expected =
      mappend doctype "\n\n<html>\n3\n</html>\n"

peopleTest :: IO ()
peopleTest = do
    res <- personListTest "templates"
    H.assertEqual "people splice" expected res
  where
    expected =
      "\n<p>Doe, John: 42&#32;years old</p>\n\n<p>Smith, Jane: 21&#32;years old</p>\n\n"

templateHC :: HeistConfig IO
templateHC = HeistConfig sc "" False
  where
    sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices
                & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu"))
                & scTemplateLocations .~ [loadTemplates "templates"]

genericTest :: String -> ByteString -> ByteString -> IO ()
genericTest nm template expected = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist templateHC
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs template
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual nm (Right expected) res

doctypeTest :: IO ()
doctypeTest = genericTest "doctype test" "rss" expected
  where
    expected = encodeUtf8
      "<rss><channel><link>http://www.devalot.com/</link></channel></rss>\n"

namespaceTest1 :: IO ()
namespaceTest1 = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist templateHC
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "namespaces"
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual "namespace test 1" (Right expected) res
  where
    expected = "Alpha\naoeu\nBeta\n<h:foo aoeu='htns'>Inside h:foo</h:foo>\nEnd\n"


namespaceTest2 :: IO ()
namespaceTest2 = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist $ templateHC & hcErrorNotBound .~ True
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "namespaces"
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual "namespace test 2" (Right expected) res
  where
    expected = "Alpha\naoeu\nBeta\n<h:foo aoeu='htns'>Inside h:foo</h:foo>\nEnd\n"


namespaceTest3 :: IO ()
namespaceTest3 = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "namespaces"
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual "namespace test 3" (Right expected) res
  where
    expected = "Alpha\n<foo aoeu='htns'>Inside foo</foo>\nBeta\naoeu\nEnd\n"


namespaceTest4 :: IO ()
namespaceTest4 = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"
                                     & hcErrorNotBound .~ True
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "namespaces"
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual "namespace test 4" (Right expected) res
  where
    expected = "Alpha\n<foo aoeu='htns'>Inside foo</foo>\nBeta\naoeu\nEnd\n"


namespaceTest5 :: IO ()
namespaceTest5 = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist $ templateHC & hcNamespace .~ "h"
                                     & hcCompiledSplices .~ mempty
                                     & hcErrorNotBound .~ True
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "namespaces"
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual "namespace test 5" (Left ["templates/namespaces.tpl: No splice bound for h:foo"]) res

------------------------------------------------------------------------------
-- | The templates-no-ns directory should have no tags beginning with h: so
-- this test will throw an error.
noNsSplices :: IO ()
noNsSplices = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist hc
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "test"
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual "noNsSplices" (Left [noNamespaceSplicesMsg "h:"]) res
  where
    hc = HeistConfig sc "h" True
    sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices
                & scCompiledSplices .~ ("foo" ## return (yieldPureText "aoeu"))
                & scTemplateLocations .~ [loadTemplates "templates-no-ns"]


------------------------------------------------------------------------------
-- | Test that no namespace splice message works correctly when there are no
-- top level splices used
nsNestedUnused :: IO ()
nsNestedUnused = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist hc
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "test"
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual "ns nested unused warn test" (Right "<div>aeou</div>\n") res
  where
    hc = HeistConfig sc "h" False
    sc = mempty & scCompiledSplices .~ ("foo" ## return $ yieldPureText "aeou")
                & scTemplateLocations .~ [loadTemplates "templates-ns-nested"]


nsBindTemplateHC :: String -> HeistConfig IO
nsBindTemplateHC dir = HeistConfig sc "h" False
  where
    sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices
                & scCompiledSplices .~ nsBindTestSplices
                & scTemplateLocations .~ [loadTemplates dir]


nsBindTestSplices :: Splices (Splice IO)
nsBindTestSplices = do
    "call" ## do
        tpl <- withSplices (callTemplate "_call")
               nsBindSubSplices (return ())
        return $ yieldRuntime $ codeGen tpl
    "main" ## nsBindSubImpl (return ())
    "main2" ## nsBindSubImpl (return ())


nsBindSubImpl :: RuntimeSplice IO b -> Splice IO
nsBindSubImpl _ = do
    tpl <- withSplices runChildren nsBindSubSplices (return ())
    return $ yieldRuntime $ codeGen tpl


nsBindSubSplices :: Splices (RuntimeSplice IO () -> Splice IO)
nsBindSubSplices = do
    "sub" ## pureSplice . textSplice $ const "asdf"
    "recurse" ## nsBindSubImpl


nsBindTest :: IO ()
nsBindTest = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind")
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "nsbind"
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual "namespace bind test" (Right expected)  res
  where
    expected = "Alpha\n\nBeta\nasdf\nGamma\n<sub></sub>\n\n"


------------------------------------------------------------------------------
-- | Test splice error reporting.
nsBindErrorTest :: IO ()
nsBindErrorTest = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nsbind")
                                     & hcErrorNotBound .~ True
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "nsbinderror"
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual "namespace bind error test" (Left [ err1, err2, err3 ])  res
  where
    err1 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid3\n   ... via templates-nsbind/nsbinderror.tpl: h:main2\nBound splices: h:call h:main h:main2 h:recurse h:sub\nNode: Element {elementTag = \"h:invalid3\", elementAttrs = [], elementChildren = []}"
    err2 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid2\n   ... via templates-nsbind/nsbinderror.tpl: h:recurse\n   ... via templates-nsbind/nsbinderror.tpl: h:main\nBound splices: h:call h:main h:main2 h:recurse h:sub\nNode: Element {elementTag = \"h:invalid2\", elementAttrs = [], elementChildren = []}"
    err3 = "templates-nsbind/nsbinderror.tpl: No splice bound for h:invalid1\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:invalid1\", elementAttrs = [], elementChildren = []}"


------------------------------------------------------------------------------
-- | Test splice error data structure.
nsBindStackTest :: IO ()
nsBindStackTest = do
    res <- initHeist (nsBindTemplateHC "templates-nsbind") >>=
           return . (either Left (Right . _spliceErrors))

    H.assertEqual "namespace bind stack test" (Right [ err1, err2, err3 ]) res
  where
    err1 = SpliceError [ ( ["nsbinderror"]
                         , Just "templates-nsbind/nsbinderror.tpl"
                         , "h:main2") ]
               (Just "templates-nsbind/nsbinderror.tpl")
               ["h:call","h:main","h:main2","h:recurse","h:sub"]
               (X.Element "h:invalid3" [] [])
               "No splice bound for h:invalid3"
    err2 = SpliceError [ ( ["nsbinderror"]
                         , Just "templates-nsbind/nsbinderror.tpl"
                         , "h:recurse")
                       , ( ["nsbinderror"]
                         , Just "templates-nsbind/nsbinderror.tpl"
                         ,"h:main") ]
               (Just "templates-nsbind/nsbinderror.tpl")
               ["h:call","h:main","h:main2","h:recurse","h:sub"]
               (X.Element "h:invalid2" [] [])
               "No splice bound for h:invalid2"
    err3 = SpliceError []
               (Just "templates-nsbind/nsbinderror.tpl")
               ["h:call","h:main","h:main2"]
               (X.Element "h:invalid1" [] [])
               "No splice bound for h:invalid1"


nsCallTest :: IO ()
nsCallTest = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall")
                                     & hcErrorNotBound .~ True
                                     & hcCompiledTemplateFilter .~ nsFilter
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "nscall"
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual "namespace call test" (Right "Top\n\nInside 1\nCalled\nasdf\n\nInside 2\n\n") res
  where
    nsFilter = (/=) (fromIntegral $ ord '_') . B.head . head


nsCallErrTest :: IO ()
nsCallErrTest = do
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist $ (nsBindTemplateHC "templates-nscall")
                                     & hcErrorNotBound .~ True
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "nscall"
        b <- lift $ fst runner
        return $ toByteString b

    H.assertEqual "namespace call error test"
      (Left $ Set.fromList [ err1, err2 ])
      (first Set.fromList res)
  where
    err1 = "templates-nscall/_call.tpl: No splice bound for h:sub\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:sub\", elementAttrs = [], elementChildren = []}"
    err2 = "templates-nscall/_invalid.tpl: No splice bound for h:invalid\nBound splices: h:call h:main h:main2\nNode: Element {elementTag = \"h:invalid\", elementAttrs = [], elementChildren = []}"


------------------------------------------------------------------------------
-- | Test exception handling in template load.
exceptionsTest :: IO ()
exceptionsTest = do
    res <- Control.Exception.catch
             (runExceptT $ do
                  hs <- ExceptT $ initHeist hc
                  -- The rest needed only for type inference.
                  runner <- noteT ["Error rendering"] $ hoistMaybe $
                              renderTemplate hs ""
                  _ <- lift $ fst runner
                  throwE ["Unexpected success"])
             (\(e :: CompileException) -> return $ case lines (show e) of
                 l:ls -> Right l
                 _ -> Left [show e])
    H.assertEqual "exceptions" (Right firstLine) res

  where
    firstLine = "templates-loaderror/_error.tpl: Exception in splice compile: Prelude.read: no parse"

    hc = HeistConfig sc "h" True
    sc = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices
                & scCompiledSplices .~ splices
                & scTemplateLocations .~ [loadTemplates "templates-loaderror"]
    splices = do
        "call1" ## callTemplate "_ok"
        "call2" ## callTemplate "_error"
        "adder" ## do
            value :: Int <- read . T.unpack . fromJust .
                              X.getAttribute "value" <$> getParamNode
            return $ yieldPureText $ T.pack $ show $ 1 + value


------------------------------------------------------------------------------
-- | Test for defer functions to see that they correctly save the result of
-- a runtime computation.
deferTest :: IO ()
deferTest = do
    rs <- mapM newIORef $ replicate 5 (0 :: Int)
    res <- runExceptT $ do
        hs <- ExceptT $ initHeist $ hc rs
        runner <- noteT ["Error rendering"] $ hoistMaybe $
                    renderTemplate hs "test"
        b <- lift $ fst runner
        return $ toByteString b

    vs <- mapM readIORef rs
    H.assertEqual "defer test" ([2, 1, 1, 1, 1], Right msg) (vs, res)
  where
    msg = "1&#32;2\n1&#32;1\n1&#32;1\n\n1&#32;1\n"
    hc rs = HeistConfig (sc rs) "h" True
    sc rs = mempty & scLoadTimeSplices .~ defaultLoadTimeSplices
                   & scCompiledSplices .~ (splices rs)
                   & scTemplateLocations .~ [loadTemplates "templates-defer"]
    splices [r1, r2, r3, r4, r5] = do
        "plain" ## subSplice $ addAndReturn r1
        "defer" ## deferMap return subSplice $ addAndReturn r2
        "maydefer" ## mayDeferMap (return . Just) subSplice $ addAndReturn r3
        "maydefer2" ## mayDeferMap (const $ return Nothing) subSplice $
                         addAndReturn r4
        "defermany" ## deferMany subSplice $ addAndReturn' r5
    subSplice =
        withSplices runChildren
          ("use" ## \n -> return $ yieldRuntimeText $ return . T.pack . show =<< n)
    addAndReturn r = liftIO $ modifyIORef r (+1) >> readIORef r
    addAndReturn' r = liftIO $ do
        modifyIORef r (+1)
        val <- readIORef r
        return [val]
