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

    module Heist.Common where

    ------------------------------------------------------------------------------
    import           Control.Applicative      (Alternative (..), Applicative (..), (<$>))
    import           Control.Exception        (SomeException)
    import qualified Control.Monad.CatchIO    as C
    import           Control.Monad            (liftM, mplus)
    import           Control.Monad.Trans.Either
    import qualified Data.Attoparsec.Text     as AP
    import           Data.ByteString          (ByteString)
    import qualified Data.ByteString          as B
    import qualified Data.ByteString.Char8    as BC
    import           Data.Hashable            (Hashable)
    import           Data.HashMap.Strict      (HashMap)
    import qualified Data.HashMap.Strict      as Map
    import           Data.List                (isSuffixOf)
    import           Data.Map.Syntax
    import           Data.Maybe               (isJust)
    import           Data.Monoid              (Monoid (..), (<>))
    import           Data.Text                (Text)
    import qualified Data.Text                as T
    import           Heist.Internal.Types.HeistState
    import           System.FilePath          (pathSeparator)
    import qualified Text.XmlHtml             as X
    ------------------------------------------------------------------------------

    ------------------------------------------------------------------------------
    runHashMap
        :: (Monad m)
        => Splices s
        -> EitherT [String] m (HashMap T.Text s)
    runHashMap ms =
        case runMapSyntax Map.lookup Map.insert ms of
          Left keys -> left $ map (T.unpack . mkMsg) keys
          Right hm -> right $ hm
      where
        mkMsg k = "You tried to bind "<>k<>" more than once!"

    ------------------------------------------------------------------------------
    runMapNoErrors :: (Eq k, Hashable k) => MapSyntaxM k v a -> HashMap k v
    runMapNoErrors = either (const mempty) id .
        runMapSyntax' (\_ new _ -> Just new) Map.lookup Map.insert

    ------------------------------------------------------------------------------
    -- | If Heist is running in fail fast mode, then this function will throw an
    -- exception with the second argument as the error message.  Otherwise, the
    -- first argument will be executed to represent silent failure.
    --
    -- This behavior allows us to fail quickly if an error crops up during
    -- load-time splice processing or degrade more gracefully if the error occurs
    -- while a user request is being processed.
    orError :: Monad m => HeistT n m b -> String -> HeistT n m b
    orError silent msg = do
        hs <- getHS
        if _preprocessingMode hs
          then do fullMsg <- heistErrMsg (T.pack msg)
                  error $ T.unpack fullMsg
          else silent

    ------------------------------------------------------------------------------
    -- | Prepends the location of the template currently being processed to an
    -- error message.
    heistErrMsg :: Monad m => Text -> HeistT n m Text
    heistErrMsg msg = do
        tf <- getsHS _curTemplateFile
        return $ (maybe "" ((`mappend` ": ") . T.pack) tf) `mappend` msg

    ------------------------------------------------------------------------------
    -- | Adds an error message to the list of splice processing errors.
    tellSpliceError :: Monad m => Text -> HeistT n m ()
    tellSpliceError msg = do
        fullMsg <- heistErrMsg msg
        modifyHS (\hs -> hs { _spliceErrors = fullMsg : _spliceErrors hs })

    ------------------------------------------------------------------------------
    -- | Function for showing a TPath.
    showTPath :: TPath -> String
    showTPath = BC.unpack . (`BC.append` ".tpl") . tpathName

    ------------------------------------------------------------------------------
    -- | Convert a TPath into a ByteString path.
    tpathName :: TPath -> ByteString
    tpathName = BC.intercalate "/" . reverse

    ------------------------------------------------------------------------------
    -- | Sets the current template file.
    setCurTemplateFile :: Maybe FilePath -> HeistState n -> HeistState n
    setCurTemplateFile Nothing ts = ts
    setCurTemplateFile fp ts = ts { _curTemplateFile = fp }

    ------------------------------------------------------------------------------
    setCurContext :: TPath -> HeistState n -> HeistState n
    setCurContext tp ts = ts { _curContext = tp }

    ------------------------------------------------------------------------------
    -- | Parser for attribute variable substitution.
    attParser :: AP.Parser [AttAST]
    attParser = liftM ($! []) (loop id)
      where
        append !dl !x = dl . (x:)

        loop !dl = go id
          where
            finish subDL = let !txt = T.concat $! subDL []
                               lit  = Literal $! T.concat $! subDL []
                           in return $! if T.null txt
                                          then dl
                                          else append dl lit

            go !subDL = (gobbleText >>= go . append subDL)
                        <|> (AP.endOfInput *> finish subDL)
                        <|> (do
                                idp <- identParser
                                dl' <- finish subDL
                                loop $! append dl' idp)

        gobbleText = AP.takeWhile1 (AP.notInClass "$")

        identParser = AP.char '$' *> (ident <|> return (Literal "$"))
        ident = (AP.char '{' *> (Ident <$> AP.takeWhile (/='}')) <* AP.string "}")

    ------------------------------------------------------------------------------
    -- | Converts a path into an array of the elements in reverse order.  If the
    -- path is absolute, we need to remove the leading slash so the split doesn't
    -- leave @\"\"@ as the last element of the TPath.
    --
    -- FIXME @\"..\"@ currently doesn't work in paths, the solution is non-trivial
    splitPathWith :: Char -> ByteString -> TPath
    splitPathWith s p = if BC.null p then [] else (reverse $ BC.split s path)
      where
        path = if BC.head p == s then BC.tail p else p

    ------------------------------------------------------------------------------
    -- | Converts a path into an array of the elements in reverse order using the
    -- path separator of the local operating system. See 'splitPathWith' for more
    -- details.
    splitLocalPath :: ByteString -> TPath
    splitLocalPath = splitPathWith pathSeparator

    ------------------------------------------------------------------------------
    -- | Converts a path into an array of the elements in reverse order using a
    -- forward slash (/) as the path separator. See 'splitPathWith' for more
    -- details.
    splitTemplatePath :: ByteString -> TPath
    splitTemplatePath = splitPathWith '/'

    ------------------------------------------------------------------------------
    -- | Convenience function for looking up a template.
    lookupTemplate :: ByteString
                   -> HeistState n
                   -> (HeistState n -> HashMap TPath t)
                   -> Maybe (t, TPath)
    lookupTemplate nameStr ts tm = f (tm ts) path name
      where
        (name:p) = case splitTemplatePath nameStr of
                       [] -> [""]
                       ps -> ps
        ctx = if B.isPrefixOf "/" nameStr then [] else _curContext ts
        path = p ++ ctx
        f = if '/' `BC.elem` nameStr
                then singleLookup
                else traversePath

    ------------------------------------------------------------------------------
    -- | Returns 'True' if the given template can be found in the heist state.
    hasTemplate :: ByteString -> HeistState n -> Bool
    hasTemplate nameStr ts =
        isJust $ lookupTemplate nameStr ts _templateMap

    ------------------------------------------------------------------------------
    -- | Does a single template lookup without cascading up.
    singleLookup :: (Eq a, Hashable a)
                 => HashMap [a] t -> [a] -> a -> Maybe (t, [a])
    singleLookup tm path name = fmap (\a -> (a,path)) $ Map.lookup (name:path) tm

    ------------------------------------------------------------------------------
    -- | Searches for a template by looking in the full path then backing up into
    -- each of the parent directories until the template is found.
    traversePath :: (Eq a, Hashable a)
                 => HashMap [a] t -> [a] -> a -> Maybe (t, [a])
    traversePath tm [] name = fmap (\a -> (a,[])) (Map.lookup [name] tm)
    traversePath tm path name =
        singleLookup tm path name `mplus`
        traversePath tm (tail path) name

    ------------------------------------------------------------------------------
    -- | Maps a splice generating function over a list and concatenates the
    -- results.  This function now has a more general type signature so it works
    -- with both compiled and interpreted splices.  The old type signature was
    -- this:
    --
    -- > mapSplices :: (Monad n)
    -- >         => (a -> Splice n n)
    -- >         -> [a]
    -- >         -> Splice n n
    mapSplices :: (Monad m, Monoid b)
               => (a -> m b)
               -- ^ Splice generating function
               -> [a]
               -- ^ List of items to generate splices for
               -> m b
               -- ^ The result of all splices concatenated together.
    mapSplices f vs = liftM mconcat $ mapM f vs
    {-# INLINE mapSplices #-}

    ------------------------------------------------------------------------------
    -- | Gets the current context
    getContext :: Monad m => HeistT n m TPath
    getContext = getsHS _curContext

    ------------------------------------------------------------------------------
    -- | Gets the full path to the file holding the template currently being
    -- processed.  Returns Nothing if the template is not associated with a file
    -- on disk or if there is no template being processed.
    getTemplateFilePath :: Monad m => HeistT n m (Maybe FilePath)
    getTemplateFilePath = getsHS _curTemplateFile

    ------------------------------------------------------------------------------
    -- | Loads a template with the specified path and filename.  The
    -- template is only loaded if it has a ".tpl" or ".xtpl" extension.
    loadTemplate :: String -- ^ path of the template root
                 -> String -- ^ full file path (includes the template root)
                 -> IO [Either String (TPath, DocumentFile)] --TemplateMap
    loadTemplate templateRoot fname = do
        c <- loadTemplate' fname
        return $ map (fmap (\t -> (splitLocalPath $ BC.pack tName, t))) c
      where -- tName is path relative to the template root directory
        isHTMLTemplate = ".tpl"  `isSuffixOf` fname
        correction = if last templateRoot == '/' then 0 else 1
        extLen     = if isHTMLTemplate then 4 else 5
        tName = drop ((length templateRoot)+correction) $
                -- We're only dropping the template root, not the whole path
                take ((length fname) - extLen) fname

    ------------------------------------------------------------------------------
    -- | Loads a template at the specified path, choosing the appropriate parser
    -- based on the file extension.  The template is only loaded if it has a
    -- \".tpl\" or \".xtpl\" extension.  Returns an empty list if the extension
    -- doesn't match.
    loadTemplate' :: String -> IO [Either String DocumentFile]
    loadTemplate' fullDiskPath
        | isHTMLTemplate = liftM (:[]) $ getDoc fullDiskPath
        | isXMLTemplate = liftM (:[]) $ getXMLDoc fullDiskPath
        | otherwise = return []
      where
        isHTMLTemplate = ".tpl"  `isSuffixOf` fullDiskPath
        isXMLTemplate  = ".xtpl" `isSuffixOf` fullDiskPath

    ------------------------------------------------------------------------------
    -- | Type synonym for parsers.
    type ParserFun = String -> ByteString -> Either String X.Document

    ------------------------------------------------------------------------------
    -- | Reads an HTML or XML template from disk.
    getDocWith :: ParserFun -> String -> IO (Either String DocumentFile)
    getDocWith parser f = do
        bs <- C.catch (liftM Right $ B.readFile f)
                    (\(e::SomeException) -> return $ Left $ show e)

        let eitherDoc = either Left (parser f) bs
        return $ either (\s -> Left $ f ++ " " ++ s)
                        (\d -> Right $ DocumentFile d (Just f)) eitherDoc

    ------------------------------------------------------------------------------
    -- | Reads an HTML template from disk.
    getDoc :: String -> IO (Either String DocumentFile)
    getDoc = getDocWith X.parseHTML

    ------------------------------------------------------------------------------
    -- | Reads an XML template from disk.
    getXMLDoc :: String -> IO (Either String DocumentFile)
    getXMLDoc = getDocWith X.parseXML

    ------------------------------------------------------------------------------
    -- | Sets the templateMap in a HeistState.
    setTemplates :: HashMap TPath DocumentFile -> HeistState n -> HeistState n
    setTemplates m ts = ts { _templateMap = m }

    ------------------------------------------------------------------------------
    -- | Adds a template to the heist state.
    insertTemplate :: TPath
                   -> DocumentFile
                   -> HeistState n
                   -> HeistState n
    insertTemplate p t st =
        setTemplates (Map.insert p t (_templateMap st)) st

    ------------------------------------------------------------------------------
    -- Gives the MIME type for a 'X.Document'
    mimeType :: X.Document -> MIMEType
    mimeType d = case d of
        (X.HtmlDocument e _ _) -> "text/html;charset=" `BC.append` enc e
        (X.XmlDocument  e _ _) -> "text/xml;charset="  `BC.append` enc e
      where
        enc X.UTF8    = "utf-8"
        -- Should not include byte order designation for UTF-16 since
        -- rendering will include a byte order mark. (RFC 2781, Sec. 3.3)
        enc X.UTF16BE = "utf-16"
        enc X.UTF16LE = "utf-16"

    ------------------------------------------------------------------------------
    -- | Binds a set of new splice declarations within a 'HeistState'.
    bindAttributeSplices :: Splices (AttrSplice n) -- ^ splices to bind
                         -> HeistState n           -- ^ start state
                         -> HeistState n
    bindAttributeSplices ss hs =
        hs { _attrSpliceMap = Map.union (runMapNoErrors ss)
                                        (_attrSpliceMap hs) }

    ------------------------------------------------------------------------------
    -- | Mappends a doctype to the state.
    addDoctype :: Monad m => [X.DocType] -> HeistT n m ()
    addDoctype dt = do
        modifyHS (\s -> s { _doctypes = _doctypes s `mappend` dt })