---------------------------------------------------------------------------------------------------
-- |
-- Module      :  Text.Bravo.Translate
-- Copyright   :  Matthias Reisner
-- License     :  BSD3
--
-- Maintainer  :  Matthias Reisner <matthias.reisner@googlemail.com>
-- Stability   :  experimental
-- Portability :  unknown
--
-- Translation functions from Bravo templates to Haskell declarations.
--
---------------------------------------------------------------------------------------------------

module Text.Bravo.Translate (
        mkTemplates,
        mkTemplatesWithOptions,
        mkTemplatesFromFile,
        mkTemplatesFromFileWithOptions,

        TplOptions (..),
        defaultTplOptions
    )
where


import Control.Monad.State

import Data.Char
import Data.Generics
import Data.Maybe
import Data.Function

import qualified Language.Haskell.Exts.Syntax as Hs
import           Language.Haskell.Meta.Syntax.Translate
import           Language.Haskell.TH

import Text.Bravo.Syntax
import Text.Bravo.Util
import Text.Bravo.Parser
import Text.ParserCombinators.Parsec (parse, eof)



-- | Transforms a string into a list of template declarations.
mkTemplates :: String -> Q [Dec]
mkTemplates = mkTemplates' defaultTplOptions ""

-- | Transforms a string into a list of template declarations, using custom options for the
-- data type generation.
mkTemplatesWithOptions :: TplOptions -> String -> Q [Dec]
mkTemplatesWithOptions = flip mkTemplates' ""

mkTemplates' :: TplOptions -> FilePath -> String -> Q [Dec]
mkTemplates' options path s = case parse (templates << eof) path s of
    Left err  -> report True ("Error while parsing templates:\n" ++ show err) >> return []
    Right tpl -> liftM join $ mapM (translateTpl options) tpl


-- | Reads a file and transforms the read file content into a list of template declarations.
mkTemplatesFromFile :: FilePath -> Q [Dec]
mkTemplatesFromFile = mkTemplatesFromFile' defaultTplOptions

-- | Reads a file and transforms the read file content into a list of template declarations, using
-- custom options for the data type generation.
mkTemplatesFromFileWithOptions :: TplOptions -> FilePath -> Q [Dec]
mkTemplatesFromFileWithOptions = mkTemplatesFromFile'

mkTemplatesFromFile' :: TplOptions -> FilePath -> Q [Dec]
mkTemplatesFromFile' options path = do
    text <- runIO $ safeReadFile path
    case text of
        Nothing    -> report True ("Error while reading file \"" ++ path ++ "\"") >> return []
        Just text' -> mkTemplates' options path text'


-- | A set of functions to change the style of the generated templates.
data TplOptions = TplOptions {
                      -- | Creates the data type and constructor name for a given template name.
                      tplMkName :: String -> String,
                      -- | Creates the record field name for a given template name and field name.
                      tplMkFieldName :: String -> String -> String,
                      -- | This function is applied to each template text splice, allowing e.g. the
                      -- removal of extra whitespace etc.
                      tplModifyText :: String -> String
                  }

-- | The default template generation options used by 'mkTemplates' and 'mkTemplatesFromFile'.
-- An example:
--
-- @
--     tplMkName defaultTplOptions \"example\"              == \"TplExample\"
--     tplMkFieldName defaultTplOptions \"example\" \"field\" == \"exampleField\"
--     tplModifyText defaultTplOptions                    == id
-- @
defaultTplOptions :: TplOptions
defaultTplOptions = TplOptions {
                        tplMkName = defaultMkName,
                        tplMkFieldName = defaultMkFieldName,
                        tplModifyText = id
                    }

defaultMkName :: String -> String
defaultMkName ""     = error "*** bug: empty name in defaultMkName"
defaultMkName (c:cs) = "Tpl" ++ (toUpper c : cs)

defaultMkFieldName :: String -> String -> String
defaultMkFieldName _    ""     = error "*** bug: empty field name in defaultMkFieldName"
defaultMkFieldName name (c:cs) = name ++ (toUpper c : cs)


data TplState = TplState {
                    tplName :: String,
                    tplFields :: [(String, Maybe Type)],
                    tplOptions :: TplOptions
                }

type TplTrans a = State TplState a

translateTpl :: TplOptions -> Template -> Q [Dec]
translateTpl options (Template name ts) = sequence decls
    where
        transFields cs = let parts = partition' ((==) `on` fst) cs in
            zip (map (fst . head) parts) (map (listToMaybe . catMaybes . map snd) parts)
        (decls, _) = runState trans TplState { tplName = name, tplFields = [], tplOptions = options}
        trans = do
            expr <- translateTplSplices ts
            modify $ \st -> st { tplFields = transFields $ tplFields st }
            recD <- mkRecDecl
            showD <- mkShowInstance expr
            return [recD, showD]

mkRecDecl :: TplTrans DecQ
mkRecDecl = do
    st <- get
    let name' = mkName . tplMkName (tplOptions st) . tplName $ st
        fDec (f, t) = return (mkName $ tplMkFieldName (tplOptions st) (tplName st) f, NotStrict,
            fromMaybe (ConT $ mkName "String") t)
    return $ dataD (cxt []) name' [] [recC name' . map fDec . tplFields $ st] []

mkShowInstance :: ExpQ -> TplTrans DecQ
mkShowInstance e = get >>= \st -> return $ instanceD (cxt [])
        (appT (conT $ mkName "Show") (conT . mkName . tplMkName (tplOptions st) . tplName $ st))
        [funD (mkName "show") [clause [varP $ mkName "tpl"] (normalB e) []]]

translateTplSplice :: TemplateSplice -> TplTrans (Maybe ExpQ)
translateTplSplice (TText s) = do
    f <- gets $ (tplModifyText . tplOptions)
    return . Just . litE . stringL . f $ s
translateTplSplice (TComment _) = return Nothing
translateTplSplice (TExpr e) = liftM Just $ translateExpr e
translateTplSplice (TConditions conds) = liftM2
    (\cs es -> Just $ (newName "cond") >>=
        \name -> letE [valD (varP name) (guardedB $ fCond cs es) []] (varE name))
    (mapM (translateExpr . fst) conds)
    (mapM (translateTplSplices . snd) conds)
    where
        fCond = zipWith (\c -> liftM2 (,) (normalG c))

translateTplSplices :: [TemplateSplice] -> TplTrans ExpQ
translateTplSplices = liftM ((\es -> appE (varE $ mkName "concat") (listE es)) . catMaybes) .
    mapM translateTplSplice

translateExpr :: Hs.Exp -> TplTrans ExpQ
translateExpr e = liftM (return . toExp) $ replaceVars e

replaceVars :: Hs.Exp -> TplTrans Hs.Exp
replaceVars = everywhereM $ mkM f
    where
        f (Hs.SpliceExp (Hs.IdSplice field)) = rep Nothing field
        f (Hs.SpliceExp (Hs.ParenSplice (Hs.Var (Hs.UnQual (Hs.Ident field))))) = rep Nothing field
        f (Hs.SpliceExp (Hs.ParenSplice (Hs.ExpTypeSig _
            (Hs.Var (Hs.UnQual (Hs.Ident field))) t))) = rep (Just $ toType t) field
        f e = return e

        rep t field = do
            st <- get
            modify $ \st' -> st' { tplFields = (field, t) : tplFields st'}
            return $ Hs.App (var $ (tplMkFieldName . tplOptions) st (tplName st) field) (var "tpl")
        var = Hs.Var . Hs.UnQual . Hs.Ident