diff --git a/madlang.cabal b/madlang.cabal --- a/madlang.cabal +++ b/madlang.cabal @@ -1,5 +1,5 @@ name: madlang -version: 3.1.1.7 +version: 3.1.1.13 synopsis: Randomized templating language DSL description: Madlang is a text templating language written in Haskell, meant to explore computational creativity and generative diff --git a/man/madlang.1 b/man/madlang.1 --- a/man/madlang.1 +++ b/man/madlang.1 @@ -1,4 +1,4 @@ -.\" Automatically generated by Pandoc 1.19.2.4 +.\" Automatically generated by Pandoc 2.0 .\" .TH "madlang (1)" "" "" "" "" .hy @@ -22,12 +22,12 @@ and computational creativity. .SH OPTIONS .TP -.B \f[B]\-h\f[] \f[B]\-\-help\f[] +.B \f[B]\-h\f[] \f[B]\[en]help\f[] Display help .RS .RE .TP -.B \f[B]\-r\f[] \f[B]\-\-rep\f[] +.B \f[B]\-r\f[] \f[B]\[en]rep\f[] Generate output more than once .RS .RE @@ -91,7 +91,7 @@ .IP \[bu] 2 reverse .IP \[bu] 2 -oulipo (removes all instances of the letter \[aq]e\[aq]) +oulipo (removes all instances of the letter `e') .SH DISPLAYING TREES .PP You may wish to use the command diff --git a/src/Text/Madlibs/Ana/Resolve.hs b/src/Text/Madlibs/Ana/Resolve.hs --- a/src/Text/Madlibs/Ana/Resolve.hs +++ b/src/Text/Madlibs/Ana/Resolve.hs @@ -12,6 +12,7 @@ import Control.Composition import Control.Exception import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Random.Class import Data.Monoid import qualified Data.Text as T @@ -27,15 +28,16 @@ import Text.Megaparsec hiding (parseErrorPretty', try) -- | Parse a template file into the `RandTok` data type -parseFile :: [T.Text] -- ^ variables to substitute into the template +parseFile :: MonadIO m + => [T.Text] -- ^ variables to substitute into the template -> FilePath -- ^ folder -> FilePath -- ^ filepath within folder - -> IO (Either (ParseError Char (ErrorFancy Void)) RandTok) -- ^ parsed `RandTok` + -> m (Either (ParseError Char (ErrorFancy Void)) RandTok) -- ^ parsed `RandTok` parseFile = fmap (fmap takeTemplate) .** getInclusionCtx False -- | Generate text from file with inclusions -getInclusionCtx :: Bool -> [T.Text] -> FilePath -> FilePath -> IO (Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)]) -getInclusionCtx isTree ins folder filepath = do +getInclusionCtx :: (MonadIO m) => Bool -> [T.Text] -> FilePath -> FilePath -> m (Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)]) +getInclusionCtx isTree ins folder filepath = liftIO $ do libDir <- do { home <- getEnv "HOME" ; if os /= home then pure (home <> "/.madlang/") else pure (home <> "\\.madlang\\") } file <- catch (readFile' (folder ++ filepath)) (const (readFile' (libDir <> folder <> filepath)) :: IOException -> IO T.Text) let filenames = map T.unpack $ either (error . show) id $ parseInclusions filepath file -- TODO pass up errors correctly @@ -52,7 +54,7 @@ -> IO T.Text -- ^ Result runFile ins toFolder = do void $ doesDirectoryExist (getDir toFolder) - let filepath = reverse . takeWhile (/='/') . reverse $ toFolder + let filepath = reverse . takeWhile (/= '/') . reverse $ toFolder runInFolder ins (getDir toFolder) filepath -- | Run in the appropriate folder @@ -64,9 +66,9 @@ runText vars name = either (pure . parseErrorPretty') id . fmap run . parseTok name [] vars -- | Get file as context -parseCtx :: Bool -> [T.Text] -> [(Key, RandTok)] -> FilePath -> IO (Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)]) +parseCtx :: (MonadIO m) => Bool -> [T.Text] -> [(Key, RandTok)] -> FilePath -> m (Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)]) parseCtx isTree ins state filepath = do - txt <- readFile' filepath + txt <- liftIO $ readFile' filepath let keys = (if isTree then parseTreeF else parseTokF) filepath state ins txt pure keys diff --git a/src/Text/Madlibs/Exec/Main.hs b/src/Text/Madlibs/Exec/Main.hs --- a/src/Text/Madlibs/Exec/Main.hs +++ b/src/Text/Madlibs/Exec/Main.hs @@ -112,7 +112,7 @@ wrapper :: ParserInfo Program wrapper = info (helper <*> versionInfo <*> orders) (fullDesc - <> progDesc "Madlang templating language" + <> progDesc "Madlang templating language. For more detailed help, use 'man madlang'" <> header ("Madlang - templating text made easy")) -- | given a parsed record perform the appropriate IO action diff --git a/src/Text/Madlibs/Generate/TH.hs b/src/Text/Madlibs/Generate/TH.hs --- a/src/Text/Madlibs/Generate/TH.hs +++ b/src/Text/Madlibs/Generate/TH.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} -- | Module containing Quasi-Quoter and Template Haskell splice for use as an EDSL. module Text.Madlibs.Generate.TH @@ -6,16 +10,22 @@ , madlang ) where +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.FileEmbed import qualified Data.Text as T import Data.Text.Encoding import Data.Void import Language.Haskell.TH hiding (Dec) import Language.Haskell.TH.Quote +--import Language.Haskell.TH.Syntax (Lift, lift) import Text.Madlibs.Ana.Parse +--import Text.Madlibs.Ana.Resolve import Text.Madlibs.Internal.Utils import Text.Megaparsec +instance MonadIO Q where + liftIO = runIO + -- | `QuasiQuoter` for an EDSL, e.g. -- -- @ @@ -26,7 +36,8 @@ -- 1.0 "hello" -- 1.0 "goodbye" -- :return --- 1.0 something|] +-- 1.0 something +-- |] -- @ -- -- Note that this is in general much faster than running interpreted code, though inclusions @@ -48,6 +59,9 @@ errorgen :: Either (ParseError Char (ErrorFancy Void)) a -> a errorgen = either (error . T.unpack . show') id +-- embedFancy :: FilePath -> FilePath -> Q Exp +-- embedFancy file folder = parseFile [] file folder >>= ((VarE 'errorgen `AppE`) . lift) + -- | Splice for embedding a '.mad' file, e.g. -- -- @ @@ -56,9 +70,10 @@ -- $(madFile "twitter-bot.mad") -- @ -- --- Note that the embedded code cannot have any inclusions. +-- Note that the embedded code cannot have any inclusions madFile :: FilePath -> Q Exp madFile path = do file <- embedFile path + -- dependencies <- parse inclusions parse' <- [|parseTok "source" [] [] . decodeUtf8|] -- TODO make this recurse but still work! pure $ VarE 'errorgen `AppE` (parse' `AppE` file)