madlang 2.2.0.1 → 2.3.0.2

raw patch · 13 files changed

+192/−91 lines, 13 filesdep +file-embed-polydep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: file-embed-poly, template-haskell

API changes (from Hackage documentation)

Files

• bench/Bench.hs +24/−1
• madlang.cabal +5/−1
• src/Text/Madlibs.hs +25/−1
• src/Text/Madlibs/Ana/Parse.hs +13/−8
• src/Text/Madlibs/Ana/Resolve.hs +5/−4
• src/Text/Madlibs/Cata/Run.hs +7/−0
• src/Text/Madlibs/Cata/SemErr.hs +5/−5
• src/Text/Madlibs/Exec/Main.hs +8/−2
• src/Text/Madlibs/Generate/TH.hs +61/−0
• src/Text/Madlibs/Internal/Types.hs +2/−2
• stack.yaml +5/−64
• test/Demo.hs +22/−0
• test/Spec.hs +10/−3

@@ -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 ]                 ]

@@ -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

@@ -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 <https://github.com/galaxykate/tracery tracery>, 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

@@ -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..

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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)

@@ -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 

@@ -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

@@ -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

@@ -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"