diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,16 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + module Main where import Criterion.Main import Text.Megaparsec import Text.Madlibs import qualified Data.Text.IO as TIO +import qualified Data.Text as T fun = parse (parseTokM []) "" +demo = $(madFile "demo/shakespeare.mad") + +demoQQ = [madlang| +:define something + 1.0 "hello" + 1.0 "goodbye" +:return + 1.0 something|] + +runTestQQ :: IO T.Text +runTestQQ = run demoQQ + +runTest :: IO T.Text +runTest = run demo + main = do file <- TIO.readFile "test/templates/fortune-teller.mad" file2 <- TIO.readFile "demo/shakespeare.mad" - defaultMain [ bgroup "parseFile" + defaultMain [ bgroup "parseTok" [ bench "fortune-teller" $ whnf fun file , bench "shakespeare" $ whnf fun file2 ] + , bgroup "run" + [ bench "shakespeare" $ whnfIO runTest + , bench "shakespeare-qq" $ whnfIO runTest ] ] diff --git a/madlang.cabal b/madlang.cabal --- a/madlang.cabal +++ b/madlang.cabal @@ -1,5 +1,5 @@ name: madlang -version: 2.2.0.1 +version: 2.3.0.2 synopsis: Randomized templating language DSL description: Please see README.md homepage: https://github.com/vmchale/madlang#readme @@ -34,6 +34,7 @@ , Text.Madlibs.Ana.Parse , Text.Madlibs.Ana.Resolve , Text.Madlibs.Internal.Types + , Text.Madlibs.Generate.TH , Text.Madlibs.Internal.Utils , Text.Madlibs.Cata.SemErr , Text.Madlibs.Cata.Display @@ -42,9 +43,11 @@ , megaparsec , text , optparse-applicative + , template-haskell , MonadRandom , composition , directory + , file-embed-poly , random-shuffle , microlens , mtl @@ -86,6 +89,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + other-modules: Demo build-depends: base , madlang , hspec diff --git a/src/Text/Madlibs.hs b/src/Text/Madlibs.hs --- a/src/Text/Madlibs.hs +++ b/src/Text/Madlibs.hs @@ -1,4 +1,24 @@ --- | Main module exporting the relevant functions +-- | = Madlang Text Generation Library, EDSL, and Interpreted Language +-- +-- == Purpose +-- +-- Madlang is a text-genrating Domain-Specific Language (DSL). It is similar in purpose +-- to , but it is +-- written in Haskell and therefore offers more flexibility. +-- +-- == Example +-- +-- In file example.mad: +-- @ +-- :define gambling +-- 1.0 "heads" +-- 1.0 "tails" +-- :return +-- 1.0 "The result of the coin flip was: " gambling +-- @ +-- +-- > $ madlang run example.mad +-- > tails module Text.Madlibs ( -- * Parsers for @.mad@ files parseTok @@ -15,6 +35,9 @@ , SemanticError (..) -- * Command-line executable , runMadlang + -- * Template Haskell EDSL + , madlang + , madFile ) where import Text.Madlibs.Ana.Resolve @@ -25,3 +48,4 @@ import Text.Madlibs.Exec.Main import Text.Madlibs.Internal.Types import Text.Madlibs.Internal.Utils +import Text.Madlibs.Generate.TH diff --git a/src/Text/Madlibs/Ana/Parse.hs b/src/Text/Madlibs/Ana/Parse.hs --- a/src/Text/Madlibs/Ana/Parse.hs +++ b/src/Text/Madlibs/Ana/Parse.hs @@ -11,12 +11,12 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Lexer as L import Data.Monoid -import Data.Maybe import Control.Monad import qualified Data.Map as M import Control.Monad.State import Control.Exception hiding (try) import Data.Composition +import Data.Maybe -- | Parse a lexeme, aka deal with whitespace nicely. lexeme :: Parser a -> Parser a @@ -82,25 +82,25 @@ modifier = do char '.' str <- (try $ string "to_upper") <|> (string "to_lower") - pure (maybe id id (M.lookup str modifierList)) "modifier" + pure (fromMaybe id (M.lookup str modifierList)) "modifier" -- | Parse template into a `PreTok` of referents and strings preStr :: [T.Text] -> Parser PreTok preStr ins = do { n <- name ; - mod <- many $ modifier ; + mod <- many modifier ; spaceConsumer ; pure $ Name (T.pack n) (foldr (.) id mod) } <|> do { v <- var ; - mod <- many $ modifier ; + mod <- many modifier ; spaceConsumer ; pure . PreTok . (foldr (.) id mod) $ ins `access` (v-1) -- ins !! (v - 1) } <|> do { s <- quote (many $ noneOf ("\n\"" :: String)) ; - mod <- many $ modifier ; + mod <- many modifier ; spaceConsumer ; pure . PreTok . (foldr (.) id mod) . T.pack $ s } @@ -167,9 +167,14 @@ -- -- > import qualified Data.Text.IO as TIO -- > --- > f <- TIO.readFile "template.mad" --- > parseTok "filename.mad" [] [] f -parseTok :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char Dec) RandTok +-- > getParsed = do +-- > f <- TIO.readFile "template.mad" +-- > parseTok "filename.mad" [] [] f +parseTok :: FilePath -- ^ File name to use for parse errors + -> [(Key, RandTok)] -- ^ Context, i.e. other random data paired with a key. + -> [T.Text] -- ^ list of variables to substitute into the template + -> T.Text -- ^ Actaul text to parse + -> Either (ParseError Char Dec) RandTok -- ^ Result parseTok = (fmap takeTemplate) .*** parseTokF -- | Parse text as a token, suitable for printing as a tree.. 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 @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} - -- | Module containing IO stuff to get/parse files with external dependencies module Text.Madlibs.Ana.Resolve where @@ -31,13 +30,15 @@ getInclusionCtx isTree ins folder filepath = do file <- readFile' (folder ++ filepath) let filenames = either (error . show) id $ parseInclusions filepath file -- TODO pass up errors correctly - let resolveKeys file = map (over _1 ((((T.pack . (<> "-")) . dropExtension) $ file) <>)) + let resolveKeys file = map (over _1 ((((T.pack . (<> "-")) . dropExtension) file) <>)) ctxPure <- mapM (getInclusionCtx isTree ins folder) filenames let ctx = (zipWith resolveKeys filenames) <$> sequence ctxPure parseCtx isTree ins (concat . (either (const []) id) $ ctx) (folder ++ filepath) --- | Generate randomized text from a file conatining a template -runFile :: [T.Text] -> FilePath -> IO T.Text +-- | Generate randomized text from a file containing a template +runFile :: [T.Text] -- ^ List of variables to substitute into the template + -> FilePath -- ^ Path to @.mad@ file. + -> IO T.Text -- ^ Result runFile ins toFolder = do exists <- doesDirectoryExist (getDir toFolder) let filepath = reverse . (takeWhile (/='/')) . reverse $ toFolder diff --git a/src/Text/Madlibs/Cata/Run.hs b/src/Text/Madlibs/Cata/Run.hs --- a/src/Text/Madlibs/Cata/Run.hs +++ b/src/Text/Madlibs/Cata/Run.hs @@ -7,6 +7,13 @@ import Control.Monad.Random.Class -- | Generate randomized text from a `RandTok` +-- +-- @ +-- getText :: IO T.Text +-- getText = do +-- let exampleTok = List [(1.0,List [(0.5,Value "heads"),(0.5,Value "tails")])] +-- run exampleTok +-- @ run :: (MonadRandom m) => RandTok -> m T.Text run tok@(List rs) = do value <- getRandomR (0,1) --(withSystemRandom . asGenST $ \gen -> uniform gen) diff --git a/src/Text/Madlibs/Cata/SemErr.hs b/src/Text/Madlibs/Cata/SemErr.hs --- a/src/Text/Madlibs/Cata/SemErr.hs +++ b/src/Text/Madlibs/Cata/SemErr.hs @@ -24,9 +24,9 @@ -- | display a `SemanticError` nicely with coloration & whatnot instance Show SemanticError where - show (DoubleDefinition f) = show $ semErrStart <> text "File contains two declarations of:" <> indent 4 (yellow $ (text' f)) + show (DoubleDefinition f) = show $ semErrStart <> text "File contains two declarations of:" <> indent 4 (yellow (text' f)) show NoReturn = show $ semErrStart <> text "File must contain exactly one declaration of :return" - show (NoContext f1) = show $ semErrStart <> text "Call in function: " <> indent 4 (yellow $ (text' f1)) <> "which is not in scope" + show (NoContext f1) = show $ semErrStart <> text "Call in function: " <> indent 4 (yellow (text' f1)) <> "which is not in scope" show (CircularFunctionCalls f1 f2) = show $ semErrStart <> text "Circular function declaration between:" <> indent 4 (yellow $ (text' f1) <> (text ", ") <> (text' f2)) show (InsufficientArgs i j) = show $ semErrStart <> text "Insufficent arguments from the command line, given " <> (text . show $ i) <> ", expected at least " <> (text . show $ j) @@ -42,7 +42,7 @@ -- | Throw `NoReturn` error within parser noReturn :: Parser a -noReturn = showCustomError $ NoReturn +noReturn = showCustomError NoReturn noContext :: T.Text -> Parser a noContext f1 = showCustomError $ NoContext f1 @@ -70,7 +70,7 @@ --do we need this all in a monad?? -- | big semantics checker that sequences stuff checkSemantics :: [(Key, [(Prob, [PreTok])])] -> Parser [(Key, [(Prob, [PreTok])])] -checkSemantics keys = foldr (<=<) pure ((checkKey "Return"):[checkKey key | key <- allKeys keys ]) $ keys +checkSemantics keys = foldr (<=<) pure ((checkKey "Return"):[checkKey key | key <- allKeys keys ]) keys where allKeys = fmap name . (concatMap snd) . (concatMap snd)--traversal? name (Name str _) = str name (PreTok _) = "Return" @@ -105,4 +105,4 @@ -- | Checks that there are no instances of a key noInstance :: Key -> [(Key, [(Prob, [PreTok])])] -> Bool -noInstance key = (== []) . (filter ((==key) . fst)) +noInstance key = not . any ((== key) . fst) 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 @@ -11,6 +11,7 @@ import Text.Megaparsec import Options.Applicative hiding (ParseError) import Data.Monoid +import Data.Maybe import Data.Composition import System.Directory @@ -65,6 +66,11 @@ <> help "command-line inputs to the template.")) -- | Main program action +-- +-- Example Usage: +-- +-- > $ madlang run example.mad +-- > some text generated runMadlang :: IO () runMadlang = execParser wrapper >>= template @@ -80,11 +86,11 @@ let toFolder = input rec if getDir toFolder == "" then pure () else setCurrentDirectory (getDir toFolder) let filepath = reverse . (takeWhile (/='/')) . reverse $ toFolder - let ins = map T.pack $ (clInputs . sub $ rec) + let ins = map T.pack (clInputs . sub $ rec) case sub rec of (Run reps _) -> do parsed <- parseFile ins "" filepath - replicateM_ (maybe 1 id reps) $ runFile ins filepath >>= TIO.putStrLn + replicateM_ (fromMaybe 1 reps) $ runFile ins filepath >>= TIO.putStrLn (Debug _) -> do putStr . (either show displayTree) =<< makeTree ins "" filepath (Lint _) -> do diff --git a/src/Text/Madlibs/Generate/TH.hs b/src/Text/Madlibs/Generate/TH.hs new file mode 100644 --- /dev/null +++ b/src/Text/Madlibs/Generate/TH.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Text.Madlibs.Generate.TH + ( textToExpression + , madFile + , madlang + ) where + +import Language.Haskell.TH hiding (Dec) +import qualified Data.Text as T +import Text.Madlibs.Ana.Parse +import Text.Madlibs.Ana.Resolve +import Text.Madlibs.Internal.Utils +import Language.Haskell.TH.Quote +import Data.FileEmbed +import Text.Megaparsec + +-- | `QuasiQuoter` for an EDSL, e.g. +-- +-- @ +-- demoQQ :: T.Text +-- demoQQ = run +-- [madlang| +-- :define something +-- 1.0 "hello" +-- 1.0 "goodbye" +-- :return +-- 1.0 something|] +-- @ +-- +-- Note that this is in general much faster than running interpreted code, though inclusions +-- do not work in the `QuasiQuoter` or in spliced expressions. +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" + } -- TODO add quasiQuoter w/context etc. + +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 Dec) a -> a +errorgen = either (error . T.unpack . show') id + +-- | Splice for embedding a '.mad' file, e.g. +-- +-- @ +-- demo :: IO T.Text +-- demo = run +-- $(madFile "twitter-bot.mad") +-- @ +-- +-- Note that the embedded code cannot have any inclusions. +madFile :: FilePath -> Q Exp +madFile path = do + file <- embedFile path + parse <- [|parseTok "source" [] []|] -- TODO make this recurse but still work! + pure $ (VarE 'errorgen) `AppE` (parse `AppE` file) diff --git a/src/Text/Madlibs/Internal/Types.hs b/src/Text/Madlibs/Internal/Types.hs --- a/src/Text/Madlibs/Internal/Types.hs +++ b/src/Text/Madlibs/Internal/Types.hs @@ -10,7 +10,6 @@ import Lens.Micro import Data.Function import Data.Monoid --- import Data.Tree -- | datatype for a double representing a probability @@ -31,7 +30,7 @@ data RandTok = List [(Prob, RandTok)] | Value T.Text deriving (Show, Eq) -apply :: (T.Text -> T.Text) -> RandTok -> RandTok -- make a base functor so we can map f over stuff? +apply :: (T.Text -> T.Text) -> RandTok -> RandTok -- TODO make a base functor so we can map f over stuff? apply f (Value str) = Value (f str) apply f (List l) = List $ map (over _2 (apply f)) l @@ -46,6 +45,7 @@ mappend v@(Value v2) (List l2) = List $ map (over (_2) (v `mappend`)) l2 mappend l@(List l1) (List l2) = List [ (p, l `mappend` tok) | (p,tok) <- l2 ] +-- TODO make this a map instead of keys for faster parse. -- | State monad providing context, i.e. function we've already called before type Context a = State [(Key, RandTok)] a diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,66 +1,7 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# http://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-8.11 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- '.' -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -extra-deps: [] - -# Override default flag values for local packages and extra-deps flags: {} - -# Extra package databases containing global packages extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.4" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor +packages: +- '.' +extra-deps: +- file-embed-poly-0.1.0 +resolver: lts-8.11 diff --git a/test/Demo.hs b/test/Demo.hs new file mode 100644 --- /dev/null +++ b/test/Demo.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + +module Demo where + +import Text.Madlibs +import qualified Data.Text as T + +demo = $(madFile "test/templates/gambling.mad") + +demoQQ = [madlang| +:define something + 1.0 "hello" + 1.0 "goodbye" +:return + 1.0 something|] + +runTest :: IO T.Text +runTest = run demo + +runTestQQ :: IO T.Text +runTestQQ = run demoQQ diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +import Demo import Test.Hspec import Test.Hspec.Megaparsec import Text.Madlibs @@ -16,7 +17,7 @@ main = hspec $ do describe "parseTok" $ do parallel $ it "parses a .mad string with modifiers" $ do - file <- madFile + file <- madFileBasic parseTok "" [] [] file `shouldParse` (List [(1.0,List [(0.5,Value "HEADS"),(0.5,Value "tails")])]) parallel $ it "fails when quotes aren't closed" $ do file <- madFileFailure @@ -50,6 +51,12 @@ runFile [] "test/templates/include-recursive.mad" >>= (`shouldSatisfy` (\a -> any (a==) ["HEADS","tails","on its side"])) parallel $ it "runs on a file out of order" $ \file -> do runFile [] "test/templates/ordered.mad" >>= (`shouldSatisfy` (\a -> any (a==) ["heads","tails","one","two","three","third"])) + describe "readFileQ" $ do + parallel $ it "executes embedded code" $ do + runTest >>= (`shouldSatisfy` (\a -> any (a==) ["HEADS","tails"])) + describe "madlang" $ do + parallel $ it "provides a quasi-quoter" $ do + runTestQQ >>= (`shouldSatisfy` (\a -> any (a==) ["hello","goodbye"])) semErr :: Selector SemanticError semErr = const True @@ -64,8 +71,8 @@ includeFile :: IO T.Text includeFile = readFile' "test/templates/include.mad" -madFile :: IO T.Text -madFile = readFile' "test/templates/gambling.mad" +madFileBasic :: IO T.Text +madFileBasic = readFile' "test/templates/gambling.mad" madFileTibetan :: IO T.Text madFileTibetan = readFile' "test/templates/ཤོ.mad"