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
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 (madCtx ".")) (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
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)
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
file <- embedFileCheck folder path
let tryPath = folder ++ "/" ++ path
inclusions <- parseInclusions tryPath <$> runIO (TIO.readFile tryPath)
parse' <- [|parseTokFInternal path []|]
dependencies <- traverse (madCtx 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 (madCtx (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)