{-# LANGUAGE OverloadedStrings #-}
{-|

    Purpose of this module is to provide a simple, functional way to
    define tabs in Snap applications.

-}

module Snap.Extras.Tabs
    (
    -- * Define Tabs in DOM via Heist
      initTabs
    , tabsSplice
    , tabsCSplice

    -- * Define Tabs in Haskell
    , TabActiveMode (..)
    , Tab
    , mkTabs
    , tab
    ) where

-------------------------------------------------------------------------------
import qualified Blaze.ByteString.Builder as B
import           Control.Lens
import           Control.Monad
import           Control.Monad.Trans
import qualified Data.Map.Syntax          as MS
import           Data.Maybe
import           Data.Monoid              (mempty)
import           Data.Text                (Text)
import qualified Data.Text                as T
import qualified Data.Text.Encoding       as T
import           Heist
import qualified Heist.Compiled           as C
import           Heist.Interpreted
import           Snap.Core
import           Snap.Snaplet
import           Snap.Snaplet.Heist
import           Text.Regex.PCRE.Light
import           Text.XmlHtml
import qualified Text.XmlHtml             as X
-------------------------------------------------------------------------------



-------------------------------------------------------------------------------
initTabs :: HasHeist b => Snaplet (Heist b) -> Initializer b v ()
initTabs h = do
    let splices = ("tabs" MS.## tabsSplice)
        csplices = ("tabs" MS.## tabsCSplice)
    addConfig h $ mempty & scCompiledSplices .~ csplices
                         & scInterpretedSplices .~ splices


                              -------------------
                              -- Splice-Driven --
                              -------------------


-------------------------------------------------------------------------------
-- | Compiled splice for tabs.
tabsCSplice :: MonadSnap m => C.Splice m
tabsCSplice = do
    n <- getParamNode
    let getCtx = lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest
        splices = ("tab" MS.## tabCSplice getCtx)
    case n of
      Element _ attrs ch -> C.withLocalSplices splices mempty $
          C.runNode $ X.Element "ul" attrs ch
      _ -> error "tabs tag has to be an Element"


------------------------------------------------------------------------------
-- | Can't use tabSpliceWorker because we have to explicitly run the
-- attributes in order to get ${} splice substitution.
tabCSplice :: Monad m => RuntimeSplice m Text -> C.Splice m
tabCSplice getCtx = do
    e <- getParamNode
    -- TODO Incomplete pattern matching!
    let (Element _ attrs ch) = e
    attrsAction <- C.runAttributesRaw attrs
    nodes <- C.codeGen `fmap` C.runNodeList ch
    let ps as context = do
          m <- note "tab must specify a 'match' attribute" $ lookup "match" as
          url <- note "tabs must specify a 'url' attribute" $ lookup "url" as
          m' <- case m of
            "Exact" -> Right $ url == context
            "Prefix" -> Right $ url `T.isPrefixOf` context
            "Infix" -> Right $ url `T.isInfixOf` context
            "Regex" -> do
                pat <- note "regex tabs must specify a 'pat' attribute" $ lookup "pat" as
                let r = compile (T.encodeUtf8 pat) []
                Right $ isJust $ match r (T.encodeUtf8 context) []
            "None" -> Right $ False
            _ -> Left "Unknown match type"
          return (url, m')
    return $ C.yieldRuntime $ do
        ctx <- getCtx
        as <- attrsAction
        ns <- nodes
        let innerFrag = X.parseHTML "inner" $ B.toByteString ns
        let res = either (error . ("Tab errror: " ++) ) id $ do
                      (url, matches) <- ps as ctx
                      inner <- innerFrag

                      let actClass = maybe "active" (T.append "active " ) $ lookup "class" as
                          attr' = if matches then ("class", actClass) : as else as
                          a = X.Element "a" (("href", url) : as) (X.docContent inner)
                      return $ X.renderHtmlFragment X.UTF8 [X.Element "li" attr' [a]]
        return res


tabSpliceWorker :: Node -> Text -> [Node]
tabSpliceWorker (Element _ attrs ch) context =
    case ps of
      Left e -> error $ "Tab error: " ++ e
      Right (url, c, matches) ->
        let attr' = if matches then ("class", "active") : attrs else attrs
            a = X.Element "a" (("href", url) : attrs) c
         in [X.Element "li" attr' [a]]
  where
    ps = do
      m <- note "tab must specify a 'match' attribute" $ lookup "match" attrs
      url <- note "tabs must specify a 'url' attribute" $ lookup "url" attrs
      m' <- case m of
        "Exact" -> Right $ url == context
        "Prefix" -> Right $ url `T.isPrefixOf` context
        "Infix" -> Right $ url `T.isInfixOf` context
        "Regex" -> do
            pat <- note "regex tabs must specify a 'pat' attribute" $ lookup "pat" attrs
            let r = compile (T.encodeUtf8 pat) []
            Right $ isJust $ match r (T.encodeUtf8 context) []
        "None" -> Right $ False
        _ -> Left "Unknown match type"
      return (url, ch, m')
tabSpliceWorker _ _ = []


-------------------------------------------------------------------------------
tabsSplice :: MonadSnap m => Splice m
tabsSplice = do
  context <- lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest
  let bind = bindSplices ("tab" MS.## tabSplice context)
  n <- getParamNode
  case n of
    Element _ attrs ch -> localHS bind $ runNodeList [X.Element "ul" attrs ch]
    _ -> error "tabs tag has to be an Element"



-------------------------------------------------------------------------------
tabSplice :: Monad m => Text -> HeistT n m [Node]
tabSplice context = do
  n <- getParamNode
  return $ tabSpliceWorker n context



                             --------------------
                             -- Haskell-Driven --
                             --------------------





-------------------------------------------------------------------------------
-- | How do we decide "active" for tab state?
data TabActiveMode
  = TAMExactMatch
  -- ^ Current url has to match exactly
  | TAMPrefixMatch
  -- ^ Only the prefix needs to match current url
  | TAMInfixMatch
  -- ^ A sub-set of the current url has to match
  | TAMDontMatch


-------------------------------------------------------------------------------
-- | A tab is a 'Node' generator upon receiving a current URL context.
type Tab = Text -> Node


-------------------------------------------------------------------------------
-- | Make tabs from tab definitions. Use the 'tab' combinator to
-- define individual options.
mkTabs
    :: MonadSnap m
    => Text
    -- ^ A class to be given to the parent ul tag
    -> [Tab]
    -- ^ List of tabs in order
    -> Splice m
mkTabs klass ts = do
  p <- lift $ (T.decodeUtf8 . rqContextPath) `liftM` getRequest
  return [X.Element "ul" [("class", klass)] (map ($ p) ts)]


-------------------------------------------------------------------------------
-- | Tab item constructor to be used with 'mkTabs'. Just supply the
-- given arguments here and it will create a 'Tab' ready to be used in
-- 'mkTabs'.
--
-- If the tab is currently active, the li tag will get a class of
-- \'active\'.
--
-- Make sure to provide a trailing / when indicating URLs as snap
-- context paths contain it and active tab checks will be confused
-- without it.
tab
    :: Text
    -- ^ Target URL for tab
    -> Text
    -- ^ A text/label for tab
    -> [(Text, Text)]
    -- ^ A list of attributes as key=val
    -> TabActiveMode
    -- ^ A 'TabActiveMode' for this tab
    -> Tab
tab url text attr md context = X.Element "li" attr' [tlink url text]
  where
    cur = case md of
            TAMExactMatch  -> url == context
            TAMPrefixMatch -> url `T.isPrefixOf` context
            TAMInfixMatch  -> url `T.isInfixOf` context
            TAMDontMatch   -> False
    attr' = if cur
            then ("class", klass) : attr
            else attr
    klass = case lookup "class" attr of
              Just k  -> T.concat [k, " ", "active"]
              Nothing -> "active"


-------------------------------------------------------------------------------
tlink :: Text -> Text -> Node
tlink target text = X.Element "a" [("href", target)] [X.TextNode text]

-------------------------------------------------------------------------------

note :: a -> Maybe b -> Either a b
note a = maybe (Left a) Right