{-# LANGUAGE TemplateHaskell #-}
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, getAppUserDataDirectory)
import System.FilePath (dropExtension, pathSeparator)
import Text.Madlibs.Ana.Parse
import Text.Madlibs.Internal.Types (Key, RandTok)
import Text.Madlibs.Internal.Utils
import Text.Megaparsec
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"
}
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)))
errorgen :: Either (ParseErrorBundle T.Text 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
pathDir <- runIO $ getAppUserDataDirectory "madlang"
if local then
madCtx folder path
else
madCtx (pathDir ++ pure pathSeparator) 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)
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)