TH.hs

{-# 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           Control.Monad.IO.Class      (MonadIO, liftIO)
import           Data.FileEmbed              (embedStringFile)
import           Data.Monoid
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.Internal.Types (Key, RandTok)
import           Text.Madlibs.Internal.Utils
import           Text.Megaparsec

instance MonadIO Q where
    liftIO = runIO

-- | `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"
                      } -- TODO add quasiQuoter w/inclusions or context

-- | Convert a `String` containing  to a `Q Exp` with the parsed syntax tree.
textToExpression :: String -> Q Exp
textToExpression txt = do
    parse' <- [|parseTok "source" [] []|]
    pure $ VarE 'errorgen `AppE` (parse' `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

embedFileCheck :: FilePath -> FilePath -> Q Exp
embedFileCheck folder path = do
    let tryPath = folder ++ path
    local <- runIO $ doesFileExist tryPath
    home <- runIO $ getEnv "HOME"
    if local then
        embedStringFile tryPath
    else
        embedStringFile (home ++ "/.madlang/" ++ path) -- FIXME windows

ctx :: [FilePath] -> [[(Key, RandTok)]] -> [[(Key, RandTok)]]
ctx = zipWith resolveKeys
    where resolveKeys file = fmap (first (((T.pack . (<> "-")) . dropExtension) 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 files = fmap (traverse (embedFileCheck (getDir path))) (fmap T.unpack <$> inclusions)
    erroredFiles <- errorgen files
    parse' <- [|parseTokInternal path []|]
    parseDependency <- [|(fmap (errorgen . parseTokF "source" [] []))|]
    inclusions' <- lift (fmap T.unpack . errorgen $ inclusions)
    pure $ VarE 'errorgen `AppE` (parse' `AppE` (VarE 'ctx `AppE` inclusions' `AppE` (parseDependency `AppE` ListE erroredFiles)) `AppE` file)