diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,18 +1,21 @@ # Madlang DSL for generating random text [![Build Status](https://travis-ci.org/vmchale/madlibs.svg?branch=master)](https://travis-ci.org/vmchale/madlibs) -This is the Madlang DSL for generating random text. There is also a vim plugin, available [here](https://github.com/vmchale/madlang-vim). +This is the Madlang DSL for generating text. You specify a template, and Madlang +will create randomized text from the template. -It enables you to generate random templated text with very little effort or expertise. +It is an interpreted language, written in Haskell. It runs from the command line, but it is also a Haskell library that can be integrated into [other projects](https://github.com/vmchale/toboggan). -It can be used for twitter bots and provides human-readable syntax for Markov -chains often used in natural language processing. +There is also a vim plugin for syntax highlighting, available [here](https://github.com/vmchale/madlang-vim). -## Exmaples +It can be used for twitter bots (among other things) and provides human-readable syntax for the Markov +chains that are often used to generate text. -An exmaple is worth a thousand words, so suppose you wanted to generate a mediocre fortune telling bot. You could write the following code: +## Examples -``` +An example is worth a thousand words, so suppose you wanted to generate a mediocre fortune telling bot. You could write the following code: + +```madlang :define person 0.7 "A close friend will " 0.3 "You will " @@ -22,36 +25,45 @@ :define fortune 0.5 "drink a boatload of milk" 0.5 "get angry for no reason" +:define intense + 1.0 person "wrestle in the WWE".to_upper + 1.0 person "bite in a bottle of hot sauce".to_upper :return - 0.8 person fortune + 0.7 person fortune + 0.1 intense 0.2 goodfortune ``` -There are two "statements" in madlang, `:define` and `:return`. `:return` is the main string we'll be spitting back, so there can be only one per file. `:define` on the other hand can be used to make multiple templates. These templates are combinations of strings (enclosed in quotes) and names of other templates. +### Syntax +There are two keywords in madlang: `:define` and `:return`. `:return` is the main string we'll be spitting back, so there can be only one per file. `:define` on the other hand can be used to make multiple templates. These templates are combinations of strings (enclosed in quotes) and names of other templates. + Of course, you can't have a circular reference with names - if `goodfortune` depends on `fortune` while `fortune` depends on `goodfortune`, we end up with either no fortune or an infinite fortune. So we throw an error. -## Using the libary +There is also a Shakespearean insult generator demo available in +`demo/shakespeare.mad` +## Using the library + The main function you'll want to use is probably `runFile`; it reads a file and generates randomized text: ``` - λ:> runFile [] "test/templates/gambling.mad" - "heads" + λ:> runFile [] "demo/shakespeare.mad" + "Thou hasty-witted gleeking puttock!" ``` -Haddock documentation of all available functionality is located [here](https://hackage.haskell.org/package/madlang#readme). +Haddock documentation of all library functionality is located [here](https://hackage.haskell.org/package/madlang#readme). ## Installation ### Releases -If you're on windows or linux, grabbing release binaries is probably the -easiest. Find them [here](https://github.com/vmchale/madlibs/releases). +If you're on windows or linux, grabbing release binaries simplest. +Find them [here](https://github.com/vmchale/madlibs/releases). ### Nix -If you're on linux or mac, you can just grab the binaries via nix. +If you're on linux or mac, you can get up-to-date binaries via nix. Download nix with @@ -69,17 +81,14 @@ curl -sSL http://haskellstack.org | sh ``` -Then run `stack install madlang --resolver nightly` and you'll get the `madlang` executable installed on your path. - -You can also run `stack install` in the appropriate directory after cloning this -repository. +Then run `stack install madlang --resolver nightly` and you'll get the `madlang` executable installed on your path. This may take a bit of time, as it will build *all* dependencies of `madlang` first. ### Use To use it, try ``` - $ madlang run fortune-teller.mad + $ madlang run demo/shakespeare.mad ``` You can do `madlang --help` if you want a couple other options for debugging. diff --git a/madlang.cabal b/madlang.cabal --- a/madlang.cabal +++ b/madlang.cabal @@ -1,102 +1,112 @@ -name: madlang -version: 2.1.0.4 -synopsis: Randomized templating language DSL -description: Please see README.md -homepage: https://github.com/vmchale/madlang#readme -license: BSD3 -license-file: LICENSE -author: Vanessa McHale -maintainer: tmchale@wisc.edu -copyright: Copyright: (c) 2016 Vanessa McHale -category: Web -build-type: Simple -stability: experimental -extra-source-files: README.md - , test/templates/fortune-teller.mad - , test/templates/gambling.mad - , test/templates/var.mad - , test/templates/ordered.mad - , test/templates/include.mad - , test/templates/err/*.mad - , bench/templates/*.mad - , stack.yaml - , bash/mkCompletions -cabal-version: >=1.10 +name: madlang +version: 2.1.1.0 +cabal-version: >=1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: Copyright: (c) 2016 Vanessa McHale +maintainer: tmchale@wisc.edu +stability: experimental +homepage: https://github.com/vmchale/madlang#readme +synopsis: Randomized templating language DSL +description: + Please see README.md +category: Web +author: Vanessa McHale +extra-source-files: + README.md + test/templates/fortune-teller.mad + test/templates/gambling.mad + test/templates/var.mad + test/templates/ordered.mad + test/templates/include.mad + test/templates/modifiers.mad + test/templates/err/*.mad + bench/templates/*.mad + stack.yaml + bash/mkCompletions -Flag llvm-fast { - Description: Enable build with llvm backend - Default: False -} +source-repository head + type: git + location: https://github.com/vmchale/madlang +flag llvm-fast + description: + Enable build with llvm backend + default: False + library - hs-source-dirs: src - exposed-modules: Text.Madlibs - other-modules: Text.Madlibs.Ana.ParseUtils - , Text.Madlibs.Cata.Run - , Text.Madlibs.Ana.Parse - , Text.Madlibs.Ana.Resolve - , Text.Madlibs.Internal.Types - , Text.Madlibs.Internal.Utils - , Text.Madlibs.Cata.SemErr - , Text.Madlibs.Exec.Main - build-depends: base >= 4.7 && < 5 - , megaparsec - , text - , optparse-applicative - , composition - , directory - , mwc-random - , microlens - , mtl - , ansi-wl-pprint - , containers - , tibetan-utils - default-language: Haskell2010 - default-extensions: OverloadedStrings - , DeriveGeneric - , DeriveFunctor - , DeriveAnyClass + exposed-modules: + Text.Madlibs + build-depends: + base >=4.7 && <5, + megaparsec >=5.2.0 && <5.3, + text >=1.2.2.1 && <1.3, + optparse-applicative >=0.13.2.0 && <0.14, + composition >=1.0.2.1 && <1.1, + directory >=1.3.0.0 && <1.4, + mwc-random >=0.13.5.0 && <0.14, + template-haskell >=2.11.1.0 && <2.12, + microlens >=0.4.8.0 && <0.5, + mtl >=2.2.1 && <2.3, + ansi-wl-pprint >=0.6.7.3 && <0.7, + containers >=0.5.7.1 && <0.6, + tibetan-utils >=0.1.1.2 && <0.2 + default-language: Haskell2010 + default-extensions: OverloadedStrings DeriveGeneric DeriveFunctor + DeriveAnyClass + hs-source-dirs: src + other-modules: + Text.Madlibs.Ana.ParseUtils + Text.Madlibs.Cata.Run + Text.Madlibs.Ana.Parse + Text.Madlibs.Ana.Resolve + Text.Madlibs.Internal.Types + Text.Madlibs.Internal.Utils + Text.Madlibs.Cata.SemErr + Text.Madlibs.Exec.Main executable madlang - hs-source-dirs: app - main-is: Main.hs - if flag(llvm-fast) - ghc-options: -threaded -rtsopts -with-rtsopts=-N -fllvm -optlo-O3 -O3 - else - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: base - , madlang - default-language: Haskell2010 - -benchmark tweeths-bench - type: exitcode-stdio-1.0 - hs-source-dirs: bench - main-is: Bench.hs - build-depends: base - , criterion - , madlang - , megaparsec - , text - if flag(llvm-fast) - ghc-options: -threaded -rtsopts -with-rtsopts=-N -fllvm -optlo-O3 -O3 - else - ghc-options: -threaded -rtsopts -with-rtsopts=-N -O3 - default-language: Haskell2010 + + if flag(llvm-fast) + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fllvm -optlo-O3 -O3 + else + ghc-options: -threaded -rtsopts -with-rtsopts=-N + main-is: Main.hs + build-depends: + base >=4.9.1.0 && <4.10, + madlang >=2.1.1.0 && <2.2 + default-language: Haskell2010 + hs-source-dirs: app test-suite madlang-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs - build-depends: base - , madlang - , hspec - , megaparsec - , text - , mtl - , hspec-megaparsec - ghc-options: -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-depends: + base >=4.9.1.0 && <4.10, + madlang >=2.1.1.0 && <2.2, + hspec >=2.4.3 && <2.5, + megaparsec >=5.2.0 && <5.3, + text >=1.2.2.1 && <1.3, + mtl >=2.2.1 && <2.3, + hspec-megaparsec >=0.3.1 && <0.4 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -source-repository head - type: git - location: https://github.com/vmchale/madlang +benchmark tweeths-bench + + if flag(llvm-fast) + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fllvm -optlo-O3 -O3 + else + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O3 + type: exitcode-stdio-1.0 + main-is: Bench.hs + build-depends: + base >=4.9.1.0 && <4.10, + criterion >=1.1.4.0 && <1.2, + madlang >=2.1.1.0 && <2.2, + megaparsec >=5.2.0 && <5.3, + text >=1.2.2.1 && <1.3 + default-language: Haskell2010 + hs-source-dirs: bench 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 @@ -12,8 +12,10 @@ import qualified Text.Megaparsec.Lexer as L import Data.Monoid import Control.Monad +import qualified Data.Map as M import Control.Monad.State import Control.Exception hiding (try) +import Data.Char import Data.Composition -- | Parse a lexeme, aka deal with whitespace nicely. @@ -75,17 +77,32 @@ name :: Parser String name = lexeme (some (letterChar <|> oneOf ("-/" :: String))) "template name" +-- | Parse a modifier +modifier :: Parser (T.Text -> T.Text) +modifier = do + char '.' + str <- try (string "to_upper") <|> (string "to_lower") + let modifiers = M.fromList [("to_upper", T.map toUpper), ("to_lower", T.map toLower)] in + pure $ maybe id id (M.lookup str modifiers) + -- | Parse template into a `PreTok` of referents and strings preStr :: [T.Text] -> Parser PreTok -preStr ins = (fmap (Name . T.pack) name) <|> +preStr ins = do { + n <- name ; + mod <- optional $ modifier ; + spaceConsumer ; + pure $ Name (T.pack n) (maybe id id mod) + } <|> do { v <- var ; + spaceConsumer ; pure . PreTok $ ins `access` (v-1) -- ins !! (v - 1) } <|> do { s <- quote (many $ noneOf ("\n\"" :: String)) ; + mod <- optional $ modifier ; spaceConsumer ; - pure $ PreTok . T.pack $ s + pure $ PreTok . (maybe id id mod) . T.pack $ s } "string or function name" @@ -101,10 +118,9 @@ inclusions :: Parser [String] inclusions = many . try $ do include - str <- name + str <- name -- make this broader string ".mad" - pure (str ++ ".mad") - -- still needs dependency resolution but eh + pure (str ++ ".mad") -- TODO dependency resolution (?) -- | Parse a `define` block definition :: [T.Text] -> Parser (Key, [(Prob, [PreTok])]) diff --git a/src/Text/Madlibs/Ana/ParseUtils.hs b/src/Text/Madlibs/Ana/ParseUtils.hs --- a/src/Text/Madlibs/Ana/ParseUtils.hs +++ b/src/Text/Madlibs/Ana/ParseUtils.hs @@ -24,7 +24,7 @@ concatTok param pretoks = do ctx <- get let unList (List a) = a - let toRand (Name str) = List . snd . (head' str param) . (filter ((== str) . fst)) . (map (second unList)) $ ctx-- TODO fix head' which can fail because of lack of scope too + let toRand (Name str f) = (apply f) . List . snd . (head' str param) . (filter ((== str) . fst)) . (map (second unList)) $ ctx-- TODO fix head' which can fail because of lack of scope too toRand (PreTok txt) = Value txt fold . (map toRand) <$> pretoks @@ -33,7 +33,7 @@ buildTok param pretoks = do ctx <- get let unList (List a) = a - let toRand (Name str) = List . snd . (head' str param) . (filter ((==str) . fst)) . (map (second unList)) $ ctx + let toRand (Name str f) = (apply f) . List . snd . (head' str param) . (filter ((==str) . fst)) . (map (second unList)) $ ctx -- TODO use modifier alongside name? toRand (PreTok txt) = Value txt List . zip ([1..]) . (map toRand) <$> pretoks 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 @@ -20,12 +20,16 @@ type Key = T.Text -- | Pretoken, aka token as first read in -data PreTok = Name T.Text | PreTok T.Text - deriving (Show, Eq) +data PreTok = Name T.Text (T.Text -> T.Text) | PreTok T.Text + --deriving (Show, Eq) -- | datatype for a token returning a random string 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 f (Value str) = Value (f str) +apply f (List l) = List $ map (over _2 (apply f)) l -- | Function to transform a `RandTok` into a `Tree String` so that it can be pretty-printed. -- diff --git a/src/Text/Madlibs/Internal/Utils.hs b/src/Text/Madlibs/Internal/Utils.hs --- a/src/Text/Madlibs/Internal/Utils.hs +++ b/src/Text/Madlibs/Internal/Utils.hs @@ -52,7 +52,7 @@ -- | Strip a pre-token's name unTok :: PreTok -> T.Text unTok (PreTok txt) = "" -unTok (Name txt) = txt +unTok (Name txt _) = txt -- | Read a file in as a `Text` readFile' :: FilePath -> IO T.Text diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -15,9 +15,9 @@ main :: IO () main = hspec $ do describe "parseTok" $ do - parallel $ it "parses a .mad string" $ do + parallel $ it "parses a .mad string with modifiers" $ do file <- madFile - parseTok "" [] [] file `shouldParse` (List [(1.0,List [(0.5,Value "heads"),(0.5,Value "tails")])]) + 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 parseTok "" [] [] `shouldFailOn` file @@ -39,7 +39,9 @@ -- file <- madFileTibetan -- parseTok "" [] file `shouldParse` (List [(1.0,List [(0.5,Value "heads"),(0.5,Value "tails")])]) describe "runFile" $ do - parallel $ it "parses file with inclusions" $ \file -> do + parallel $ it "parses nested modifiers correctly" $ \file -> do + runFile [] "test/templates/modifiers.mad" >>= (`shouldSatisfy` (\a -> any (a==) ["AAAaaa","AAAaa","AAaaa","AAaa"])) + parallel $ it "parses file with inclusions and modifiers on functions" $ \file -> do runFile [] "test/templates/include.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"])) diff --git a/test/templates/gambling.mad b/test/templates/gambling.mad --- a/test/templates/gambling.mad +++ b/test/templates/gambling.mad @@ -1,5 +1,5 @@ :define something - 0.5 "heads" - 0.5 "tails" + 0.5 "heads".to_upper + 0.5 "tailS".to_lower :return 1.0 something diff --git a/test/templates/include.mad b/test/templates/include.mad --- a/test/templates/include.mad +++ b/test/templates/include.mad @@ -1,6 +1,6 @@ :include gambling.mad :define realistic - 1.0 something + 1.0 something.to_lower 0.03 "on its side" :return 1.0 realistic diff --git a/test/templates/modifiers.mad b/test/templates/modifiers.mad new file mode 100644 --- /dev/null +++ b/test/templates/modifiers.mad @@ -0,0 +1,7 @@ +:define scream + 1.0 "aaa".to_upper + 1.0 "aa".to_upper +:define sedated + 1.0 scream.to_lower +:return + 1.0 scream sedated