madlang 2.4.2.1 → 2.4.2.2
raw patch · 15 files changed
+260/−144 lines, 15 filesdep +composition-preludedep +recursion-schemesdep −compositiondep −composition-extradep −microlens
Dependencies added: composition-prelude, recursion-schemes
Dependencies removed: composition, composition-extra, microlens
Files
- README.md +147/−64
- bash/mkCompletions +0/−9
- cabal.project.local +1/−1
- madlang.cabal +16/−16
- man/madlang.1 +3/−2
- src/Text/Madlibs.hs +9/−8
- src/Text/Madlibs/Ana/Parse.hs +2/−2
- src/Text/Madlibs/Ana/ParseUtils.hs +13/−9
- src/Text/Madlibs/Ana/Resolve.hs +3/−3
- src/Text/Madlibs/Cata/Display.hs +11/−4
- src/Text/Madlibs/Cata/SemErr.hs +32/−12
- src/Text/Madlibs/Exec/Helpers.hs +4/−5
- src/Text/Madlibs/Internal/Types.hs +14/−5
- src/Text/Madlibs/Internal/Utils.hs +4/−3
- test/Spec.hs +1/−1
README.md view
@@ -1,116 +1,199 @@ # Madlang DSL for generating random text -[](https://travis-ci.org/vmchale/madlibs)+[](https://travis-ci.org/vmchale/madlang) This is the Madlang DSL for generating text. You specify a template, and Madlang will create randomized text from the template. -Madlang is an interpreted language, written in Haskell. It runs from the command line, but also provides a Haskell library that can be integrated into [other projects](https://github.com/vmchale/toboggan), compiled to a [web app](https://github.com/vmchale/madlang-reflex), or used as an EDSL.+Madlang is an interpreted language, written in Haskell. The primary way to use+Madlang is on the command line using the interpreter, but there is also a partially completed library+and EDSL. -There is also a vim plugin for syntax highlighting, available [here](https://github.com/vmchale/madlang-vim).+Madlang is intended to explore computational creativity and provide an easy+way to get started with generative literature. -It can be used for twitter bots (among other things) and provides human-readable-syntax for generating text.+## Installation -## Examples+### Stack +Download `stack` with++```+curl -sSL http://haskellstack.org | sh+```++Then run `stack install madlang --resolver nightly`. This is the recommended way+to install `madlang`, but it may take awhile.++### Nix++If you're on linux or mac, you can get binaries via nix.++Download nix with++```+curl https://nixos.org/nix/install | sh+```++From there, `nix-env -i madlang` will install the executable.++## Tutorial++The smallest program possible in Madlang is simply a return declaration, viz.+ ```madlang-# Madlang is a declarative language. The most basic component is a function, viz.-:define coinFlip+:return 1.0 "heads" 1.0 "tails"+``` -:define die- 1.0 "1"- 1.0 "2"- 1.0 "3"- 1.0 "4"- 1.0 "5"- 1.0 "6"+The `:return` tells us this that this will be the final value when run, while+the numbers in front of the strings denote relative weights. Save this as+`gambling.mad`, and run -# Madlang also has categories, that is, a collection of functions that can be-# bundled together-:category gambling- coinFlip- die+```bash+ $ madlang run gambling.mad+ heads+``` -# :return declarations handle the actual output+Now let's try something a little more complicated:++```madlang+:define person+ 1.0 "me"+ 1.0 "you"+ :return- 0.7 gambling- 0.3 gambling.to_upper # .to_upper is a modifier which make the whole string uppercase+ 1.0 "The only one of us walking out of this room alive is going to be " person "." ``` -### Syntax+A bit more sinister, perhaps. The `:define` statement there declares a new+*identifier*, which we can later reference. Save this as `fate.mad` and run: -There are two keywords in madlang you'll use most: `:define` and `:return`. `:return` is the main string we'll be spitting back; there can be only one per file. `:define` on the other hand can be used to make functions. These functions are combinations of templates, organizing pairs of weights and strings.+```bash+ $ madlang run fate.mad+ The only one of us walking out of this room alive is going to be you.+``` -There is a Shakespearean insult generator demo available in-`demo/shakespeare.mad`+We can also refer to another identifier within a `:define` block. -## Installation+```madlang+:define coin+ 1.0 "heads"+ 1.0 "tails" -### Releases+:define realisticCoin+ 1.0 coin+ 0.03 "on its side" -### Nix+:return realisticCoin+``` -If you're on linux or mac, you can get up-to-date binaries via nix.+In addition to identifiers, we can also define *categories*. Categories are just+groups of identifiers. We can define one like so: -Download nix with+```madlang+:define color+ 1.0 "yellow"+ 1.0 "blue" -```-curl https://nixos.org/nix/install | sh+:define texture+ 1.0 "soft"+ 1.0 "scratchy"+ 1.0 "dimpled"++:category adjective+ color+ texture++:return+ 1.0 adjective ``` -From there, `nix-env -i madlang` will install the proper executables.+Then, when we can `adjective`, it will pick one of "yellow", "blue",…+"dimpled" with equal probability. -### Stack+Finally, one of the most powerful features of `madlang` is the ability to+include libraries in a file. Open the following and save it as `gambling.mad`: -Download `stack` with+```madlang+:define coin+ 1.0 "heads"+ 1.0 "tails" -```-curl -sSL http://haskellstack.org | sh+:return+ 1.0 "" ``` -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.+Then, open the following and save it in the same directory as+`realistic-gambling.mad`: -### Use+```madlang+:include gambling.mad -To use it, try+:define realisticGambling+ 1.0 coin+ 0.03 "on its side" +:return+ 1.0 realisticGambling ```- $ madlang run demo/shakespeare.mad++Then run it with:++```bash+ $ madlang run realistic-gambling.mad ``` -You can do `madlang --help` if you want a couple other options for debugging.+`madlang` comes with several libraries prepackaged. You can install+them for the current user with: -## Using the Haskell library+```bash+ $ madlang install+``` -One function you might want to use is `runFile`; it reads a file and generates randomized text:+Try this out: ```- λ:> runFile [] "demo/shakespeare.mad"- "Thou hasty-witted gleeking puttock!"+:include colors.mad++:define weirdDog+ 1.0 colors-color "dog"++:return+ 1.0 "On my walk today I saw a " weirdDog "." ``` -To use the library as an EDSL, there are two options: splicing in a file or-using a quasi-quoter, viz.+### Examples -```haskell-demo :: IO T.Text-demo = run- $(madFile "demo/shakespeare.mad")+There is a dog complimenter available to test out at [my+site](http://blog.vmchale.com/madlang). -demo :: IO T.Text-demo = run [|madlang-:define f- 1.0 "heads"- 1.0 "tails"-:return- 1.0 f|]+## Tooling++### Vim++There is a vim plugin available [here](https://github.com/vmchale/madlang-vim).++### Project Templates++There is a project template bundled with+[pi](https://github.com/vmchale/project-init), which you can install with++```bash+ $ curl -LSfs https://japaric.github.io/trust/install.sh | sh -s -- --git vmchale/project-init ``` -Haddock documentation of all library functionality is located [here](https://hackage.haskell.org/package/madlang#readme).+and invoke with -## Syntax Highlighting+```+ $ pi new madlang story+``` -Syntax highlighting for the DSL is provided in the vim plugin [here](http://github.com/vmchale/madlang-vim). It includes integration with [syntastic](https://github.com/vim-syntastic/syntastic).+### Manpages++You can view documentation for `madlang` on Linux, Mac, or BSD by typing:++```bash+ $ man madlang+```
− bash/mkCompletions
@@ -1,9 +0,0 @@-#!/bin/bash-mkdir -p ~/.bash_completion.d-for BINARY in madlang-do- $BINARY --bash-completion-script "$(which $BINARY)" > tmp- cp tmp ~/.bash_completion.d/$BINARY- rm tmp-done-printf "\n##Added by madlang\nfor c in ~/.bash_completion.d/* ; do\n . \$c\ndone\n" >> ~/.bashrc
cabal.project.local view
@@ -1,3 +1,3 @@ with-compiler: ghc-8.2.1 optimization: 2-constraints: madlang +development +llvm-fast+constraints: madlang +development
madlang.cabal view
@@ -1,5 +1,5 @@ name: madlang-version: 2.4.2.1+version: 2.4.2.2 synopsis: Randomized templating language DSL description: Madlang is a text templating language written in Haskell, meant to explore computational creativity and generative@@ -17,7 +17,6 @@ , test/templates/*.mad , test/templates/err/*.mad , demo/*.mad- , bash/mkCompletions , cabal.project.local , man/madlang.1 cabal-version: >=1.10@@ -27,7 +26,7 @@ , Cabal , file-embed , directory- , process+ , process >= 2.4.2.2 Flag development { Description: Turn on '-Werror'@@ -66,12 +65,10 @@ , optparse-applicative , template-haskell , MonadRandom- , composition- , composition-extra+ , composition-prelude >= 2.4.2.2 , directory , file-embed , random-shuffle- , microlens , mtl , ansi-wl-pprint , containers@@ -79,14 +76,13 @@ , http-client , tar , zlib+ , recursion-schemes default-language: Haskell2010- default-extensions: OverloadedStrings- , DeriveGeneric- , DeriveFunctor- , DeriveAnyClass if flag(development) ghc-options: -Werror- ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates+ if impl(ghc >= 8.0)+ ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates+ ghc-options: -Wall executable madlang if flag(library)@@ -99,7 +95,9 @@ ghc-options: -fllvm -O3 -optlo-O3 -opta-march=native -opta-mtune=native if flag(development) ghc-options: -Werror- ghc-options: -rtsopts -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates+ if impl(ghc >= 8.0)+ ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates+ ghc-options: -Wall build-depends: base , madlang default-language: Haskell2010@@ -113,11 +111,11 @@ , madlang , megaparsec , text- if flag(llvm-fast)- ghc-options: -fllvm -optlo-O3 -O3 -fwarn-unused-imports if flag(development) ghc-options: -Werror- ghc-options: -rtsopts -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -O3+ if impl(ghc >= 8.0)+ ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates+ ghc-options: -O3 default-language: Haskell2010 test-suite madlang-test@@ -134,7 +132,9 @@ , hspec-megaparsec if flag(development) ghc-options: -Werror- ghc-options: -threaded -rtsopts -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -with-rtsopts=-N+ if impl(ghc >= 8.0)+ ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates+ ghc-options: -threaded -rtsopts -Wall -with-rtsopts=-N default-language: Haskell2010 source-repository head
man/madlang.1 view
@@ -48,7 +48,7 @@ .PP Strings in madlang can be followed by modifiers, for instance .PP-1.0 "some very bad idea".oulipo+1.0 "evil".oulipo .PP Currently supported modifiers are: .IP \[bu] 2@@ -63,6 +63,7 @@ oulipo (removes all instances of the letter \[aq]e\[aq]) .SH EXAMPLES .PP-You can examine some examples in+You can examine an example using the bundled libraries at+https://hub.darcs.net/vmchale/madlang\-insults. .SH AUTHORS Vanessa McHale<vanessa.mchale@reconfigure.io>.
src/Text/Madlibs.hs view
@@ -4,7 +4,7 @@ -- -- 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. +-- written in Haskell and therefore offers more flexibility. -- -- == Example --@@ -24,6 +24,7 @@ parseTok , parseTokM , runFile+ , parseTree , parseFile , makeTree -- * Functions and constructs for the `RandTok` data type@@ -40,10 +41,10 @@ , madFile ) where -import Text.Madlibs.Ana.Resolve-import Text.Madlibs.Ana.Parse-import Text.Madlibs.Cata.Run-import Text.Madlibs.Cata.SemErr-import Text.Madlibs.Exec.Main-import Text.Madlibs.Internal.Types-import Text.Madlibs.Generate.TH+import Text.Madlibs.Ana.Parse+import Text.Madlibs.Ana.Resolve+import Text.Madlibs.Cata.Run+import Text.Madlibs.Cata.SemErr+import Text.Madlibs.Exec.Main+import Text.Madlibs.Generate.TH+import Text.Madlibs.Internal.Types
src/Text/Madlibs/Ana/Parse.hs view
@@ -10,9 +10,9 @@ , parseTreeF , parseTokM ) where +import Control.Composition import Control.Monad import Control.Monad.State-import Data.Composition import qualified Data.Map as M import Data.Maybe import Data.Monoid@@ -142,7 +142,7 @@ include str <- name string ".mad"- pure (str <> ".mad")+ pure (str <> ".mad") <?> "Include statement" -- | Parse a `define` block definition :: [T.Text] -> Parser (Key, [(Prob, [PreTok])])
src/Text/Madlibs/Ana/ParseUtils.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ -- | Helper functions to sort out parsing module Text.Madlibs.Ana.ParseUtils ( modifierList@@ -51,9 +53,9 @@ ctx <- get let unList (List a) = a unList _ = mempty- let toRand (Name str f) = apply f . 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) . fmap (second unList) $ ctx toRand (PreTok txt) = Value txt- fold . map toRand <$> pretoks+ fold . fmap toRand <$> pretoks -- | Build token in tree structure, without concatenating. buildTok :: T.Text -> Context [PreTok] -> Context RandTok@@ -61,9 +63,9 @@ ctx <- get let unList (List a) = a unList _ = mempty- let toRand (Name str f) = apply f . 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) . fmap (second unList) $ ctx toRand (PreTok txt) = Value txt- List . zip [1..] . map toRand <$> pretoks+ List . zip [1..] . fmap toRand <$> pretoks -- | Build the token without concatenating, yielding a `RandTok` suitable to be -- printed as a tree.@@ -71,7 +73,7 @@ buildTree [] = pure mempty buildTree [(key,pairs)] = do toks <- mapM (\(_,j) -> buildTok key (pure j)) pairs- let probs = map fst pairs+ let probs = fmap fst pairs let tok = List $ zip probs toks state (\s -> (tok,(key,tok):s)) buildTree (x:xs) = do@@ -84,7 +86,7 @@ build [] = pure mempty build [(key,pairs)] = do toks <- mapM (\(_,j) -> concatTok key (pure j)) pairs- let probs = map fst pairs+ let probs = fmap fst pairs let tok = List $ zip probs toks state (\s -> (tok,(key, tok):s)) build (x:xs) = do@@ -100,11 +102,13 @@ orderHelper key = any (\pair -> key /= "" && key `elem` (map unTok . snd $ pair)) hasNoDeps :: [(Prob, [PreTok])] -> Bool-hasNoDeps = all isPreTok . concatMap snd+hasNoDeps = all isPreTok . (>>= snd) where isPreTok PreTok{} = True isPreTok _ = False --- TODO 'somethingelse' shouldn't be less than 'athirdthing'!!+-- FIXME if a depends on b depends on c, then we shouldn't consider a and c to be equal.+-- Consider some fancy morphism here too. (chronomorphism? - comonad to pop+-- values off, monad to store things.) -- | Ordering on the keys to account for dependency orderKeys :: (Key, [(Prob, [PreTok])]) -> (Key, [(Prob, [PreTok])]) -> Ordering@@ -120,4 +124,4 @@ | otherwise = EQ -- FIXME transitive dependencies flatten :: [(Prob, [PreTok])] -> [Key]-flatten = concatMap (map unTok . snd)+flatten = (>>= (fmap unTok . snd))
src/Text/Madlibs/Ana/Resolve.hs view
@@ -7,14 +7,14 @@ , makeTree , runText ) where +import Control.Arrow (first)+import Control.Composition import Control.Exception import Control.Monad (void) import Control.Monad.Random.Class-import Data.Composition import Data.Monoid import qualified Data.Text as T import Data.Void-import Lens.Micro import System.Directory import System.Environment import Text.Madlibs.Ana.Parse@@ -36,7 +36,7 @@ getInclusionCtx isTree ins folder filepath = do file <- catch (readFile' (folder ++ filepath)) (const (do { home <- getEnv "HOME" ; readFile' (home <> "/.madlang/" <> folder <> filepath) } ) :: IOException -> IO T.Text) let filenames = map T.unpack $ 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' = fmap (first ((((T.pack . (<> "-")) . dropExtension) file') <>)) ctxPure <- mapM (getInclusionCtx isTree ins folder) filenames let ctx = (zipWith resolveKeys filenames) <$> sequence ctxPure catch
src/Text/Madlibs/Cata/Display.hs view
@@ -1,14 +1,21 @@ -- | Module with helper functions for displaying the parsed tree module Text.Madlibs.Cata.Display (displayTree) where -import Data.Tree-import Text.Madlibs.Internal.Types+import Data.Functor.Foldable+import Data.Tree+import Text.Madlibs.Internal.Types -- | Draw as a syntax Tree displayTree :: RandTok -> String-displayTree = drawTree . tokToTree 1.0+displayTree = drawTree . tokToTree 1.0 . cleanTree --- | Function to transform a `RandTok` into a `Tree String` so that it can be pretty-printed. +cleanTree :: RandTok -> RandTok+cleanTree = cata algebra+ where algebra (ValueF t) = Value t+ algebra (ListF [(1, t)]) = t+ algebra (ListF x) = List x++-- | Function to transform a `RandTok` into a `Tree String` so that it can be pretty-printed. -- -- > tokToTree 1.0 tok tokToTree :: Prob -> RandTok -> Tree String
src/Text/Madlibs/Cata/SemErr.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} -- | Module defining the SemErr data type module Text.Madlibs.Cata.SemErr (@@ -9,7 +10,6 @@ , head' , headNoReturn ) where - import Control.Exception import Control.Monad import qualified Data.Text as T@@ -27,11 +27,32 @@ -- | 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 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 (CircularFunctionCalls f1 f2) = show $ semErrStart <> text "Function" </> indent 4 (yellow (text' f2)) <> text' " refers to a function" </> indent 4 (yellow (text' f1)) <> text' ", which is not in scope." </> indent 2 (text' "This may be due to a circular function dependecy.")- show (InsufficientArgs i j) = show $ semErrStart <> text "Insufficent arguments from the command line; given " <> (text . show $ i) <> ", expected at least " <> (text . show $ j)+ 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 (CircularFunctionCalls f1 f2) = show $+ semErrStart+ <> text "Function"+ </> indent 4 (yellow (text' f2))+ <> text' " refers to a function"+ </> indent 4 (yellow (text' f1))+ <> text' ", which is not in scope."+ </> indent 2 (text' "This may be due to a circular function dependecy.")+ show (InsufficientArgs i j) = show $+ semErrStart+ <> text "Insufficent arguments from the command line; given "+ <> (text . show $ i)+ <> ", expected at least "+ <> (text . show $ j) -- | Derived via our show instance; instance Exception SemanticError where@@ -59,11 +80,10 @@ text' :: T.Text -> Doc text' = text . T.unpack ---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- where allKeys = fmap name . (concatMap snd) . (concatMap snd)--traversal?+checkSemantics keys = foldr (<=<) pure (checkKey "Return":[checkKey key | key <- allKeys keys ]) keys+ where allKeys = fmap name . (>>= snd) . (>>= snd)--traversal? name (Name str _) = str name (PreTok _) = "Return" @@ -78,7 +98,7 @@ -- | Access argument, or throw error if the list is too short. access :: [a] -> Int -> a-access xs i = if (i >= length xs) then throw (InsufficientArgs (length xs) (i+1)) else xs !! i+access xs i = if i >= length xs then throw (InsufficientArgs (length xs) (i+1)) else xs !! i -- | checker to verify there is at most one @:return@ or @:define key@ statement checkKey :: Key -> [(Key, [(Prob, [PreTok])])] -> Parser [(Key, [(Prob, [PreTok])])]@@ -90,7 +110,7 @@ -- | Checks that we have at most one `:return` template in the file singleInstance :: Key -> [(Key, [(Prob, [PreTok])])] -> Bool-singleInstance key = singleton . (filter ((==key) . fst))+singleInstance key = singleton . filter ((==key) . fst) where singleton [_] = True singleton _ = False
src/Text/Madlibs/Exec/Helpers.hs view
@@ -1,10 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+ module Text.Madlibs.Exec.Helpers (fetchPackages, cleanPackages) where import qualified Codec.Archive.Tar as Tar import Codec.Compression.GZip (decompress)-import qualified Data.ByteString.Lazy as BSL import Network.HTTP.Client hiding (decompress)-import System.Directory (removeFile) import System.Environment (getEnv) -- TODO set remote package url flexibly@@ -15,14 +15,13 @@ manager <- newManager defaultManagerSettings initialRequest <- parseRequest "http://vmchale.com/static/packages.tar.gz" response <- httpLbs (initialRequest { method = "GET" }) manager- BSL.writeFile "crapfile.tar.gz" $ responseBody response+ let byteStringResponse = responseBody response putStrLn "unpacking libraries..." home <- getEnv "HOME" let packageDir = home ++ "/.madlang"- Tar.unpack packageDir . Tar.read . decompress =<< BSL.readFile "crapfile.tar.gz"+ Tar.unpack packageDir . Tar.read . decompress $ byteStringResponse cleanPackages :: IO () cleanPackages = do- removeFile "crapfile.tar.gz" putStrLn "done."
src/Text/Madlibs/Internal/Types.hs view
@@ -1,14 +1,21 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} -- | Module with the type of a random token module Text.Madlibs.Internal.Types where +import Control.Arrow (second) import Control.Monad.State import Data.Function+import Data.Functor.Foldable.TH (makeBaseFunctor) import Data.Monoid-import qualified Data.Text as T-import Lens.Micro+import qualified Data.Text as T -- | datatype for a double representing a probability type Prob = Double@@ -34,7 +41,7 @@ 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+apply f (List l) = List $ fmap (second (apply f)) l -- | Make `RandTok` a monoid so we can append them together nicely (since they do generate text). --@@ -43,8 +50,8 @@ instance Monoid RandTok where mempty = Value "" mappend (Value v1) (Value v2) = Value (T.append v1 v2)- mappend (List l1) v@Value{} = List $ map (over _2 (`mappend` v)) l1- mappend v@Value{} (List l2) = List $ map (over _2 (mappend v)) l2+ mappend (List l1) v@Value{} = List $ fmap (second (`mappend` v)) l1+ mappend v@Value{} (List l2) = List $ fmap (second (mappend v)) l2 mappend l@List{} (List l2) = List [ (p, l `mappend` tok) | (p,tok) <- l2 ] -- TODO make this a map instead of keys for faster parse.@@ -54,3 +61,5 @@ -- | Compare inside the state monad using only the underlying objects instance (Eq a) => Eq (Context a) where (==) = on (==) (flip evalState [])++makeBaseFunctor ''RandTok
src/Text/Madlibs/Internal/Utils.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} -- | Internal utils to help out elsewhere module Text.Madlibs.Internal.Utils where +import Control.Arrow (first) import qualified Data.Text as T import Data.Void-import Lens.Micro import Text.Madlibs.Internal.Types import Text.Megaparsec.Error @@ -32,8 +33,8 @@ -- | Normalize pre-tokens/corresponding probabilities normalize :: [(Prob, [PreTok])] -> [(Prob, [PreTok])]-normalize list = map (over _1 (/total)) list- where total = sum . map fst $ list+normalize list = fmap (first (/total)) list+ where total = sum . fmap fst $ list -- | Helper function for creating a cdf from a pdf cdf :: [Prob] -> [Prob]
test/Spec.hs view
@@ -44,7 +44,7 @@ parallel $ it "parses file with recursive inclusions" $ \_ -> do runFile [] "test/templates/include-recursive.mad" >>= (`shouldSatisfy` (\a -> any (a==) ["HEADS","tails","on its side"])) parallel $ it "runs on a file out of order" $ \_ -> do- runFile [] "test/templates/ordered.mad" >>= (`shouldSatisfy` (\a -> any (a==) ["heads","tails","one","two","three","third"]))+ runFile [] "test/templates/ordered.mad" >>= (`shouldSatisfy` (\a -> any (a==) ["heads","tails","one","two","three","third","fourth"])) describe "readFileQ" $ do parallel $ it "executes embedded code" $ do runTest >>= (`shouldSatisfy` (\a -> any (a==) ["HEADS","tails"]))