diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,116 +1,199 @@ # Madlang DSL for generating random text -[![Build Status](https://travis-ci.org/vmchale/madlibs.svg?branch=master)](https://travis-ci.org/vmchale/madlibs) +[![Build Status](https://travis-ci.org/vmchale/madlang.svg?branch=master)](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 +``` diff --git a/bash/mkCompletions b/bash/mkCompletions deleted file mode 100644 --- a/bash/mkCompletions +++ /dev/null @@ -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 diff --git a/cabal.project.local b/cabal.project.local --- a/cabal.project.local +++ b/cabal.project.local @@ -1,3 +1,3 @@ with-compiler: ghc-8.2.1 optimization: 2 -constraints: madlang +development +llvm-fast +constraints: madlang +development diff --git a/madlang.cabal b/madlang.cabal --- a/madlang.cabal +++ b/madlang.cabal @@ -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 diff --git a/man/madlang.1 b/man/madlang.1 --- a/man/madlang.1 +++ b/man/madlang.1 @@ -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. diff --git a/src/Text/Madlibs.hs b/src/Text/Madlibs.hs --- a/src/Text/Madlibs.hs +++ b/src/Text/Madlibs.hs @@ -4,7 +4,7 @@ -- -- 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. +-- 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 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 @@ -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])]) 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 @@ -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)) 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 @@ -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 diff --git a/src/Text/Madlibs/Cata/Display.hs b/src/Text/Madlibs/Cata/Display.hs --- a/src/Text/Madlibs/Cata/Display.hs +++ b/src/Text/Madlibs/Cata/Display.hs @@ -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 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 @@ -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 diff --git a/src/Text/Madlibs/Exec/Helpers.hs b/src/Text/Madlibs/Exec/Helpers.hs --- a/src/Text/Madlibs/Exec/Helpers.hs +++ b/src/Text/Madlibs/Exec/Helpers.hs @@ -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." 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 @@ -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 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 @@ -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] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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"]))