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.Ana.Resolve (pathSep)
import Text.Madlibs.Internal.Types (Key, RandTok)
import Text.Madlibs.Internal.Utils
import Text.Megaparsec
instance MonadIO Q where
liftIO = runIO
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 (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)
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)