{-# LANGUAGE OverloadedStrings #-}
module Text.Madlibs.Ana.Resolve (
parseFile
, runFile
, makeTree
, runText
, runFileN
, cacheFile
) where
import Control.Arrow (first)
import Control.Composition
import Control.Exception
import Control.Monad (replicateM, void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Random.Class
import Data.Foldable (fold)
import qualified Data.Text as T
import Data.Void
import System.Directory
import System.FilePath (dropExtension, pathSeparator, (</>))
import Text.Madlibs.Ana.Parse
import Text.Madlibs.Ana.ParseUtils
import Text.Madlibs.Cata.Run
import Text.Madlibs.Internal.Types
import Text.Madlibs.Internal.Utils
import Text.Megaparsec
parseFile :: MonadIO m
=> [T.Text]
-> FilePath
-> FilePath
-> m (Either (ParseErrorBundle T.Text Void) RandTok)
parseFile = fmap (fmap takeTemplate) .** getInclusionCtx False
getInclusionCtx :: (MonadIO m) => Bool -> [T.Text] -> FilePath -> FilePath -> m (Either (ParseErrorBundle T.Text Void) [(Key, RandTok)])
getInclusionCtx isTree ins folder filepath = liftIO $ do
libDir <- do { pathDir <- getAppUserDataDirectory "madlang" ; pure (pathDir <> pure pathSeparator) }
file <- catch (readFile' (folder ++ filepath)) (pure (readLibFile (libDir <> folder <> filepath)) :: IOException -> IO T.Text)
let filenames = map T.unpack $ either (error . show) id $ parseInclusions filepath file
resolveKeys file' = fmap (first (((T.pack . (<> "-")) . dropExtension) file' <>))
ctxPure <- mapM (getInclusionCtx isTree ins folder) filenames
let ctx = zipWith resolveKeys filenames <$> sequence ctxPure
catch
(parseCtx isTree ins (fold . either (pure []) id $ ctx) (folder ++ filepath))
(pure (do { pathDir <- getAppUserDataDirectory "madlang" ; parseCtx isTree ins (fold . either (pure []) id $ ctx) (pathDir </> folder <> filepath) }) :: IOException -> IO (Either (ParseErrorBundle T.Text Void) [(Key, RandTok)]))
filenameBytecode :: FilePath -> FilePath
filenameBytecode = T.unpack . T.replace ".mad" ".mbc" . T.pack
cacheFile :: FilePath -> IO T.Text
cacheFile = runFile [] . filenameBytecode
runFile :: [T.Text]
-> FilePath
-> IO T.Text
runFile ins toFolder = do
void $ doesDirectoryExist (getDir toFolder)
let filepath = reverse . takeWhile (/= pathSeparator) . reverse $ toFolder
runInFolder ins (getDir toFolder) filepath
runFileN :: Int -> [T.Text] -> FilePath -> IO [T.Text]
runFileN n ins toFolder = do
void $ doesDirectoryExist (getDir toFolder)
let filepath = reverse . takeWhile (/= pathSeparator) . reverse $ toFolder
runInFolderN n ins (getDir toFolder) filepath
runInFolderN :: Int -> [T.Text] -> FilePath -> FilePath -> IO [T.Text]
runInFolderN n = replicateM n .** runInFolder
runInFolder :: [T.Text] -> FilePath -> FilePath -> IO T.Text
runInFolder = (either (pure . errorBundlePretty') (>>= pure) =<<) .** (fmap (fmap run) .** parseFile)
runText :: (MonadRandom m) => [T.Text] -> String -> T.Text -> m T.Text
runText vars name = either (pure . errorBundlePretty') id . fmap run . parseTok name [] vars
parseCtx :: (MonadIO m) => Bool -> [T.Text] -> [(Key, RandTok)] -> FilePath -> m (Either (ParseErrorBundle T.Text Void) [(Key, RandTok)])
parseCtx isTree ins state filepath = do
txt <- liftIO $ readFile' filepath
let keys = (if isTree then parseTreeF else parseTokF) filepath state ins txt
pure keys
makeTree :: [T.Text] -> FilePath -> FilePath -> IO (Either (ParseErrorBundle T.Text Void) RandTok)
makeTree = fmap (fmap takeTemplate) .** getInclusionCtx True