{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveLift                 #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TemplateHaskell            #-}

-- | Module containing Quasi-Quoter and Template Haskell splice for use as an EDSL.
module Text.Madlibs.Generate.TH
    ( madFile
    , madlang
    ) where

import           Control.Arrow               (first)
import           Data.FileEmbed              (embedStringFile)
import qualified Data.Text                   as T
import qualified Data.Text.IO                as TIO
import           Data.Void
import           Language.Haskell.TH         hiding (Dec)
import           Language.Haskell.TH.Quote
import           Language.Haskell.TH.Syntax  (lift)
import           System.Directory            (doesFileExist)
import           System.Environment          (getEnv)
import           Text.Madlibs.Ana.Parse
import           Text.Madlibs.Ana.Resolve    (pathSep)
import           Text.Madlibs.Internal.Types (Key, RandTok)
import           Text.Madlibs.Internal.Utils
import           Text.Megaparsec

-- | `QuasiQuoter` for an EDSL, e.g.
--
-- @
-- demoQQ :: T.Text
-- demoQQ = run
-- [madlang|
-- :define something
--     1.0 "hello"
--     1.0 "goodbye"
-- :return
--     1.0 something
-- |]
-- @
--
-- Note that this is in general much faster than running interpreted code, though inclusions
-- do not work in the `QuasiQuoter` or in spliced expressions.
madlang :: QuasiQuoter
madlang = QuasiQuoter { quoteExp = textToExpression
                      , quotePat = error "quasi-quoter does not support patterns"
                      , quoteType = error "quasi-quoter does not support types"
                      , quoteDec = error "quasi-quoter does not support top-level quotes"
                      }

-- | Convert a `String` containing  to a `Q Exp` with the parsed syntax tree.
-- Embedded code can contain inclusions.
textToExpression :: String -> Q Exp
textToExpression txt = do
    parse' <- [|parseTokInternal "haskell quasi-quote" []|]
    inclusions <- parseInclusions "haskell quasi-quote" <$> pure (T.pack txt)
    let context = fmap (traverse (madCtxCheck ".")) (fmap T.unpack <$> inclusions)
    erroredFiles <- errorgen context
    inclusions' <- lift (T.unpack <$> errorgen inclusions)
    pure $ VarE 'errorgen `AppE` (parse' `AppE` (VarE 'ctx `AppE` inclusions' `AppE` ListE erroredFiles) `AppE` (VarE 'T.pack `AppE` LitE (StringL txt)))

-- | Turn a parse error into an error that will be caught when Template Haskell compiles at runtime.
errorgen :: Either (ParseError Char (ErrorFancy Void)) a -> a
errorgen = either (error . T.unpack . show') id

madCtxCheck :: FilePath -> FilePath -> Q Exp
madCtxCheck folder path = do
    let tryPath = folder ++ path
    local <- runIO $ doesFileExist tryPath
    home <- runIO $ getEnv "HOME"
    if local then
        madCtx folder path
    else
        madCtx (home ++ (pathSep : (".madlang" ++ pure pathSep))) path

ctx :: [FilePath] -> [[(Key, RandTok)]] -> [[(Key, RandTok)]]
ctx = zipWith resolveKeys
    where resolveKeys file = fmap (first (((T.pack . (<> "-")) . dropExtension) file <>))

madCtx :: FilePath -> FilePath -> Q Exp
madCtx folder path = do
    let tryPath = folder ++ path
    file <- embedStringFile tryPath
    inclusions <- parseInclusions tryPath <$> runIO (TIO.readFile tryPath)
    parse' <- [|parseTokFInternal path []|]
    dependencies <- traverse (madCtxCheck folder) (T.unpack <$> errorgen inclusions)
    inclusions' <- lift (T.unpack <$> errorgen inclusions)
    pure $ VarE 'errorgen `AppE` (parse' `AppE` (VarE 'ctx `AppE` inclusions' `AppE` ListE dependencies) `AppE` file)

-- | Splice for embedding a '.mad' file, e.g.
--
-- @
-- demo :: IO T.Text
-- demo = run
--     $(madFile "twitter-bot.mad")
-- @
--
-- Embedded code can contain inclusions.
madFile :: FilePath -> Q Exp
madFile path = do
    inclusions <- parseInclusions path <$> runIO (TIO.readFile path)
    file <- embedStringFile path
    let context = fmap (traverse (madCtxCheck (getDir path))) (fmap T.unpack <$> inclusions)
    erroredFiles <- errorgen context
    parse' <- [|parseTokInternal path []|]
    inclusions' <- lift (T.unpack <$> errorgen inclusions)
    pure $ VarE 'errorgen `AppE` (parse' `AppE` (VarE 'ctx `AppE` inclusions' `AppE` ListE erroredFiles) `AppE` file)