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' <- [|parseTok "source" [] []|]
pure $ VarE 'errorgen `AppE` (parse' `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 <>))
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)