madlang 2.4.0.1 → 2.4.0.2

raw patch · 14 files changed

+179/−185 lines, 14 filesdep ~basedep ~megaparsecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, megaparsec

API changes (from Hackage documentation)

Files

• README.md +22/−17
• bash/mkCompletions +8/−3
• madlang.cabal +2/−2
• src/Text/Madlibs/Ana/Parse.hs +24/−19
• src/Text/Madlibs/Ana/ParseUtils.hs +27/−27
• src/Text/Madlibs/Ana/Resolve.hs +22/−21
• src/Text/Madlibs/Cata/Run.hs +6/−6
• src/Text/Madlibs/Cata/SemErr.hs +27/−18
• src/Text/Madlibs/Generate/TH.hs +12/−11
• src/Text/Madlibs/Internal/Types.hs +12/−8
• src/Text/Madlibs/Internal/Utils.hs +7/−6
• stack.yaml +5/−44
• test/Spec.hs +0/−3
• test/templates/ordered.mad +5/−0

@@ -14,25 +14,30 @@  ## 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 "-:define goodfortune-    0.2 person "make rain on the planet Mars"-    0.8 "nice things will happen today :)"-: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+# Madlang is a declarative language. The most basic component is a function, viz.+:define coinFlip+    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"++# Madlang also has categories, that is, a collection of functions that can be+# bundled together+:category gambling+    coinFlip+    die++# :return declarations handle the actual output :return-    0.7 person fortune-    0.1 intense-    0.2 goodfortune+    0.7 gambling+    0.3 gambling.to_upper # .to_upper is a modifier which make the whole string uppercase ```  ### Syntax

@@ -1,4 +1,9 @@ #!/bin/bash-madlang --bash-completion-script `which madlang` > tmp-sudo cp tmp /etc/bash_completion.d/madlang-rm tmp+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

@@ -1,5 +1,5 @@ name:                madlang-version:             2.4.0.1+version:             2.4.0.2 synopsis:            Randomized templating language DSL description:         Please see README.md homepage:            https://github.com/vmchale/madlang#readme@@ -51,7 +51,7 @@                      , Text.Madlibs.Exec.Main                      , Paths_madlang   build-depends:       base >= 4.7 && < 5-                     , megaparsec+                     , megaparsec >= 6.0                      , text                      , optparse-applicative                      , template-haskell

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ -- | Parse our DSL module Text.Madlibs.Ana.Parse (     parseTok@@ -11,14 +13,17 @@ import           Data.Composition import qualified Data.Map                    as M import           Data.Maybe+import           Data.Monoid import qualified Data.Text                   as T+import           Data.Void import           Text.Madlibs.Ana.ParseUtils import           Text.Madlibs.Cata.SemErr import           Text.Madlibs.Internal.Types import           Text.Madlibs.Internal.Utils import           Text.Megaparsec-import qualified Text.Megaparsec.Lexer       as L-import           Text.Megaparsec.Text+import           Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer  as L+import           Text.Megaparsec.Pos  -- | Parse a lexeme, aka deal with whitespace nicely. lexeme :: Parser a -> Parser a@@ -29,7 +34,7 @@ spaceConsumer = L.space (void . some $ spaceChar) (L.skipLineComment "#") (L.skipBlockComment "{#" "#}")  -- | parse a symbol, i.e. string plus surrouding whitespace-symbol :: String -> Parser String+symbol :: T.Text -> Parser T.Text symbol = L.symbol spaceConsumer  -- | Parse a number/probability@@ -38,20 +43,20 @@  -- | Parse an integer integer :: Parser Integer-integer = lexeme (L.integer {--<|> parseNumber--}) <?> "Integer"+integer = lexeme L.decimal <?> "Integer"  -- | Make sure definition blocks start un-indented nonIndented = L.nonIndented spaceConsumer  -- | Make contents of definition blocks are indented.-indentGuard = L.indentGuard spaceConsumer GT (unsafePos 4)+indentGuard = L.indentGuard spaceConsumer GT (mkPos 4)  -- | Parse between quotes quote :: Parser a -> Parser a quote = between .$ (char '"')  -- | Parse a keyword-keyword :: String -> Parser String+keyword :: T.Text -> Parser T.Text keyword str = (char ':') >> (symbol str) <?> "keyword"  -- | Parse a var@@ -81,15 +86,15 @@     <?> "return block"  -- | Parse a template name (what follows a `:define` or `return` block)-name :: Parser String-name = lexeme (some (letterChar <|> oneOf ("-/" :: String))) <?> "template name" -- TODO make this broader in terms of what it includes+name :: Parser T.Text+name = (lexeme . fmap T.pack) (some (letterChar <|> oneOf ("-/" :: String))) <?> "template name" -- TODO make this broader in terms of what it includes  -- | Parse a modifier modifier :: Parser (T.Text -> T.Text) modifier = do     char '.'     str <- foldr (<|>) (pure "") $ map (try . string) ["to_upper", "to_lower", "reverse", "reverse_words", "oulipo", "capitalize"]-    pure (fromMaybe id (M.lookup str modifierList)) <?> "modifier"+    pure (fromMaybe id (M.lookup (T.unpack str) modifierList)) <?> "modifier"  -- | Parse template into a `PreTok` of referents and strings preStr :: [T.Text] -> Parser PreTok@@ -97,7 +102,7 @@         n <- name ;         mod <- many modifier ;         spaceConsumer ;-        pure $ Name (T.pack n) (foldr (.) id mod)+        pure $ Name n (foldr (.) id mod)     } <|>     do {         v <- var ;@@ -129,12 +134,12 @@     pure (1.0, [str]) <?> "Function name"  -- | Parse an `include`-inclusions :: Parser [String]+inclusions :: Parser [T.Text] inclusions = many . try $ do     include     str <- name     string ".mad"-    pure (str ++ ".mad")+    pure (str <> ".mad")  -- | Parse a `define` block definition :: [T.Text] -> Parser (Key, [(Prob, [PreTok])])@@ -142,7 +147,7 @@     define     str <- name     val <- fmap normalize . some $ pair ins-    pure (T.pack str, val) <?> "define block"+    pure (str, val) <?> "define block"  -- | Parse a `category` block category :: Parser (Key, [(Prob, [PreTok])])@@ -150,7 +155,7 @@     cat     str <- name     val <- fmap normalize . some $ function-    pure (T.pack str, val) <?> "category block"+    pure (str, val) <?> "category block"  -- | Parse the `:return` block final :: [T.Text] -> Parser [(Prob, [PreTok])]@@ -176,12 +181,12 @@ parseTreeM ins = buildTree <$> program ins  -- | Parse text as a list of functions-parseTokF :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char Dec) [(Key, RandTok)]+parseTokF :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)] parseTokF filename state ins f = (flip execState (filterTemplate state)) <$> runParser (parseTokM ins) filename f     where filterTemplate = map (\(i,j) -> if i == "Return" then (strip filename, j) else (i,j)) -- TODO fix the extras  -- | Parse text as a list of tokens, suitable for printing as a tree.-parseTreeF :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char Dec) [(Key, RandTok)]+parseTreeF :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)] parseTreeF filename state ins f = (flip execState (filterTemplate state)) <$> runParser (parseTreeM ins) filename f     where filterTemplate = map (\(i,j) -> if i == "Return" then (strip filename, j) else (i,j)) @@ -196,13 +201,13 @@     -> [(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+    -> Either (ParseError Char (ErrorFancy Void)) RandTok -- ^ Result parseTok = (fmap takeTemplate) .*** parseTokF  -- | Parse text as a token, suitable for printing as a tree..-parseTree :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char Dec) RandTok+parseTree :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char (ErrorFancy Void)) RandTok parseTree = (fmap takeTemplate) .*** parseTreeF  -- | Parse inclustions-parseInclusions :: FilePath -> T.Text -> Either (ParseError Char Dec) [String]+parseInclusions :: FilePath -> T.Text -> Either (ParseError Char (ErrorFancy Void)) [T.Text] parseInclusions = runParser inclusions

@@ -8,27 +8,25 @@   , buildTree   ) where -import Text.Madlibs.Internal.Types-import Text.Madlibs.Internal.Utils-import Text.Madlibs.Cata.SemErr-import Data.List-import qualified Data.Text as T-import Control.Monad.State-import Data.Foldable-import Control.Arrow-import System.Random.Shuffle-import qualified Data.Map as M-import Data.Char-import Data.Monoid-import Data.Function.Contravariant.Syntax-import Control.Monad.Random.Class+import           Control.Arrow+import           Control.Monad.Random.Class+import           Control.Monad.State+import           Data.Char+import           Data.Foldable+import           Data.List+import qualified Data.Map                    as M+import qualified Data.Text                   as T+import           System.Random.Shuffle+import           Text.Madlibs.Cata.SemErr+import           Text.Madlibs.Internal.Types+import           Text.Madlibs.Internal.Utils  --TODO consider moving Ana.ParseUtils to Cata.Sorting  (&) :: a -> (a -> b) -> b (&) x f = f x --- | A map with all the modifiers we +-- | A map with all the modifiers for Madlang modifierList :: M.Map String (T.Text -> T.Text) modifierList = M.fromList [("to_upper", T.map toUpper)     , ("to_lower", T.map toLower)@@ -47,28 +45,28 @@  -- | Get the :return value takeTemplate :: [(Key, RandTok)] -> RandTok-takeTemplate = snd . head . filter (\(i,j) -> i == "Return")+takeTemplate = snd . headNoReturn . filter (\(i,j) -> i == "Return")  -- | Convert the stuff after the number to a `RandTok` concatTok :: T.Text -> Context [PreTok] -> Context RandTok concatTok param pretoks = do     ctx <- get     let unList (List a) = a-    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+    let toRand (Name str f) = (apply f) . List . snd . (head' str param) . (filter ((== str) . fst)) . (map (second unList)) $ ctx         toRand (PreTok txt) = Value txt     fold . (map toRand) <$> pretoks --- | Build token in tree structure, without concatenating. +-- | Build token in tree structure, without concatenating. buildTok :: T.Text -> Context [PreTok] -> Context RandTok buildTok param pretoks = do     ctx <- get     let unList (List a) = a-    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)) . (map (second unList)) $ ctx         toRand (PreTok txt) = Value txt     List . zip ([1..]) . (map toRand) <$> pretoks  -- | Build the token without concatenating, yielding a `RandTok` suitable to be--- printed as a tree. +-- printed as a tree. buildTree :: [(Key, [(Prob, [PreTok])])] -> Context RandTok buildTree list@[(key,pairs)] = do     toks <- mapM (\(i,j) -> buildTok key (pure j)) pairs@@ -96,17 +94,19 @@ sortKeys :: [(Key, [(Prob, [PreTok])])] -> [(Key, [(Prob, [PreTok])])] sortKeys = sortBy orderKeys +orderHelper :: Key -> [(Prob, [PreTok])] -> Bool+orderHelper key = any (\pair -> key `elem` (map unTok . snd $ pair))+ -- | Ordering on the keys to account for dependency orderKeys :: (Key, [(Prob, [PreTok])]) -> (Key, [(Prob, [PreTok])]) -> Ordering orderKeys (key1, l1) (key2, l2)     | key1 == "Return" = GT     | key2 == "Return" = LT-    | any (\pair -> {--hyphenList key1 (map unTok . snd $ pair) ||--} key1 `elem` (map unTok . snd $ pair)) l2 = LT-    | any (\pair -> {--hyphenList key2 (map unTok . snd $ pair) ||--} key2 `elem` (map unTok . snd $ pair)) l1 = GT+    | orderHelper key1 l2 = LT+    | orderHelper key2 l1 = GT+    | any (flip orderHelper l1) (flatten l2) = LT -- FIXME needs to not default to `EQ` when transitive dependencies are a thing.+    | any (flip orderHelper l2) (flatten l1) = GT     | otherwise = EQ -hyphenList :: T.Text -> [T.Text] -> Bool-hyphenList s1 = any (flip hyphenSuffix s1)--hyphenSuffix :: T.Text -> T.Text -> Bool-hyphenSuffix = ("-" <>) -.* T.isSuffixOf+flatten :: [(Prob, [PreTok])] -> [Key]+flatten = concatMap (map unTok . snd)

@@ -7,45 +7,46 @@   , makeTree   , runText ) where -import qualified Data.Text as T-import Text.Megaparsec hiding (try)-import Text.Madlibs.Internal.Types-import Text.Madlibs.Internal.Utils-import Text.Madlibs.Ana.Parse-import Text.Madlibs.Ana.ParseUtils-import Text.Madlibs.Cata.Run-import Data.Composition-import System.Directory-import Lens.Micro-import Data.Monoid-import Control.Monad.Random.Class-import System.Environment-import Control.Exception+import           Control.Exception+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+import           Text.Madlibs.Ana.ParseUtils+import           Text.Madlibs.Cata.Run+import           Text.Madlibs.Internal.Types+import           Text.Madlibs.Internal.Utils+import           Text.Megaparsec             hiding (parseErrorPretty', try)  -- | Parse a template file into the `RandTok` data type parseFile :: [T.Text] -- ^ variables to substitute into the template     -> FilePath -- ^ folder     -> FilePath -- ^ filepath within folder-    -> IO (Either (ParseError Char Dec) RandTok) -- ^ parsed `RandTok`+    -> IO (Either (ParseError Char (ErrorFancy Void)) RandTok) -- ^ parsed `RandTok` parseFile = fmap (fmap takeTemplate) .** (getInclusionCtx False)  -- | Generate text from file with inclusions-getInclusionCtx :: Bool -> [T.Text] -> FilePath -> FilePath -> IO (Either (ParseError Char Dec) [(Key, RandTok)])+getInclusionCtx :: Bool -> [T.Text] -> FilePath -> FilePath -> IO (Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)]) 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 = either (error . show) id $ parseInclusions filepath file -- TODO pass up errors correctly+    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) <>))     ctxPure <- mapM (getInclusionCtx isTree ins folder) filenames     let ctx = (zipWith resolveKeys filenames) <$> sequence ctxPure     catch         (parseCtx isTree ins (concat . (either (const []) id) $ ctx) (folder ++ filepath))-        ((const (do { home <- getEnv "HOME" ; parseCtx isTree ins (concat . (either (const []) id) $ ctx) (home <> "/.madlang/" <> folder <> filepath) }) ) :: IOException -> IO (Either (ParseError Char Dec) [(Key, RandTok)]))+        ((const (do { home <- getEnv "HOME" ; parseCtx isTree ins (concat . (either (const []) id) $ ctx) (home <> "/.madlang/" <> folder <> filepath) }) ) :: IOException -> IO (Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)]))  -- | 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 +runFile ins toFolder = do     exists <- doesDirectoryExist (getDir toFolder)     let filepath = reverse . (takeWhile (/='/')) . reverse $ toFolder     runInFolder ins (getDir toFolder) filepath@@ -59,12 +60,12 @@ runText vars name = (either (pure . parseErrorPretty') id) . (fmap run) . (parseTok name [] vars)  -- | Get file as context-parseCtx :: Bool -> [T.Text] -> [(Key, RandTok)] -> FilePath -> IO (Either (ParseError Char Dec) [(Key, RandTok)])+parseCtx :: Bool -> [T.Text] -> [(Key, RandTok)] -> FilePath -> IO (Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)]) parseCtx isTree ins state filepath = do     txt <- readFile' filepath     let keys = (if isTree then parseTreeF else parseTokF) filepath state ins txt     pure keys  -- | Parse a template into a RandTok suitable to be displayed as a tree-makeTree :: [T.Text] -> FilePath -> FilePath -> IO (Either (ParseError Char Dec) RandTok)+makeTree :: [T.Text] -> FilePath -> FilePath -> IO (Either (ParseError Char (ErrorFancy Void)) RandTok) makeTree = fmap (fmap takeTemplate) .** (getInclusionCtx True)

@@ -1,10 +1,10 @@ -- | Module containing functions to get `Text` from `RandTok` module Text.Madlibs.Cata.Run (run) where -import Text.Madlibs.Internal.Types-import Text.Madlibs.Internal.Utils-import qualified Data.Text as T-import Control.Monad.Random.Class+import           Control.Monad.Random.Class+import qualified Data.Text                   as T+import           Text.Madlibs.Internal.Types+import           Text.Madlibs.Internal.Utils  -- | Generate randomized text from a `RandTok` --@@ -13,13 +13,13 @@ -- 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)     let ret = ((snd . head) . filter ((>=value) . fst)) $ mkCdf tok     case ret of-        (Value txt) -> pure txt+        (Value txt)   -> pure txt         tok@(List rs) -> run tok run (Value txt) = pure txt 

@@ -3,23 +3,28 @@ -- | Module defining the SemErr data type module Text.Madlibs.Cata.SemErr (     SemanticError (..)+  , Parser   , access   , checkSemantics-  , head' ) where+  , head'+  , headNoReturn ) where  -import Text.Madlibs.Internal.Types-import Data.Typeable-import Text.PrettyPrint.ANSI.Leijen-import Control.Exception-import qualified Data.Text as T-import Control.Monad-import qualified Data.Set as S-import Text.Megaparsec.Text-import Text.Megaparsec.Prim-import Text.Megaparsec.Error-import Text.Madlibs.Internal.Utils+import           Control.Exception+import           Control.Monad+import qualified Data.Set                     as S+import qualified Data.Text                    as T+import           Data.Typeable+import           Data.Void+import           Text.Madlibs.Internal.Types+import           Text.Madlibs.Internal.Utils+import           Text.Megaparsec+import           Text.Megaparsec.Char+import           Text.Megaparsec.Error+import           Text.PrettyPrint.ANSI.Leijen +type Parser = Parsec (ErrorFancy Void) T.Text+ -- | Datatype for a semantic error data SemanticError = NoReturn | CircularFunctionCalls T.Text T.Text | InsufficientArgs Int Int | DoubleDefinition T.Text | NoContext T.Text     deriving (Typeable)@@ -29,15 +34,15 @@     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 "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)+    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 circular function dependecies.")+    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  -- | Throw custom error given by string, within the parser customError :: String -> Parser a-customError = (failure .$ S.empty) . S.singleton . representFail+customError = fail  showCustomError :: (Show a) => a -> Parser b showCustomError = customError . show@@ -75,7 +80,7 @@ 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"+          name (PreTok _)   = "Return"  -- | helper to filter out stuff that doesn't sumProb :: [(Prob, [PreTok])] -> Bool@@ -85,9 +90,13 @@ -- | Take the head of the list, or throw the appropriate error given which functions we are trying to call. head' :: T.Text -> T.Text -> [a] -> a head' _ _ (x:xs) = x-head' f1 f2 _ = throw (CircularFunctionCalls f1 f2)+head' f1 f2 _    = throw (CircularFunctionCalls f1 f2) --- | Access argument, or throw error if the list is too short. +headNoReturn :: [a] -> a+headNoReturn (x:xs) = x+headNoReturn _      = throw NoReturn++-- | 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 

@@ -1,22 +1,23 @@ {-# LANGUAGE TemplateHaskell #-}  -- | Module containing Quasi-Quoter and Template Haskell splice for use as an EDSL.-module Text.Madlibs.Generate.TH +module Text.Madlibs.Generate.TH     ( madFile     , madlang     ) where -import Language.Haskell.TH hiding (Dec)-import qualified Data.Text as T-import Text.Madlibs.Ana.Parse-import Text.Madlibs.Internal.Utils-import Language.Haskell.TH.Quote-import Data.FileEmbed-import Text.Megaparsec-import Data.Text.Encoding+import           Data.FileEmbed+import qualified Data.Text                   as T+import           Data.Text.Encoding+import           Data.Void+import           Language.Haskell.TH         hiding (Dec)+import           Language.Haskell.TH.Quote+import           Text.Madlibs.Ana.Parse+import           Text.Madlibs.Internal.Utils+import           Text.Megaparsec  -- | `QuasiQuoter` for an EDSL, e.g.--- +-- -- @ -- demoQQ :: T.Text -- demoQQ = run@@ -44,7 +45,7 @@     pure $ (VarE 'errorgen) `AppE` (parse `AppE` ((VarE 'T.pack) `AppE` (LitE (StringL (txt)))))  -- | Turn a parse error into an error that will be caught when Template Haskell compiles at runtime.-errorgen :: Either (ParseError Char Dec) a -> a+errorgen :: Either (ParseError Char (ErrorFancy Void)) a -> a errorgen = either (error . T.unpack . show') id  -- | Splice for embedding a '.mad' file, e.g.

@@ -1,13 +1,13 @@+{-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}  -- | Module with the type of a random token module Text.Madlibs.Internal.Types where -import qualified Data.Text as T-import Control.Monad.State-import Lens.Micro-import Data.Function+import           Control.Monad.State+import           Data.Function+import qualified Data.Text           as T+import           Lens.Micro  -- | datatype for a double representing a probability type Prob = Double@@ -18,6 +18,10 @@ -- | Pretoken, aka token as first read in data PreTok = Name T.Text (T.Text -> T.Text) | PreTok T.Text +instance Show PreTok where+    show (Name t _) = show t+    show (PreTok t) = show t+ instance Eq PreTok where     (==) (Name a _) (PreTok b) = False     (==) (Name a1 f1) (Name a2 f2) = a1 == a2 && (f1 . T.pack $ ['a'..'z']) == (f2 . T.pack $ ['a'..'z'])@@ -29,16 +33,16 @@  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 $ map (over _2 (apply f)) l --- | Make `RandTok` a monoid so we can append them together nicely (since they do generate text). +-- | Make `RandTok` a monoid so we can append them together nicely (since they do generate text). -- -- > (Value "Hello") <> (List [(0.5," you"), (0.5, " me")]) -- > (List [(0.5,"Hello you"), (0.5, "Hello me")]) instance Monoid RandTok where     mempty = Value ""     mappend (Value v1) (Value v2) = Value (T.append v1 v2)-    mappend (List l1) v@(Value v1) = List $ map (over (_2) (`mappend` v)) l1 +    mappend (List l1) v@(Value v1) = List $ map (over (_2) (`mappend` v)) l1     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 ] 

@@ -1,13 +1,14 @@+{-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}  -- | Internal utils to help out elsewhere module Text.Madlibs.Internal.Utils where -import Text.Madlibs.Internal.Types-import Text.Megaparsec.Error-import qualified Data.Text as T-import Lens.Micro+import qualified Data.Text                   as T+import           Data.Void+import           Lens.Micro+import           Text.Madlibs.Internal.Types+import           Text.Megaparsec.Error  -- | Drop file Extension dropExtension :: FilePath -> FilePath@@ -43,7 +44,7 @@ show' = (T.drop 1) . T.init . T.pack . show  -- | Pretty-print a ParseError-parseErrorPretty' :: ParseError Char Dec -> T.Text+parseErrorPretty' :: ParseError Char (ErrorFancy Void) -> T.Text parseErrorPretty' = T.pack . parseErrorPretty  -- | Strip a pre-token's name

@@ -1,45 +1,6 @@-resolver: lts-8.19+resolver: lts-9.0 packages:- - .- - extra-dep: true-   location:-       git: https://github.com/haskell/deepseq-       commit: 0b22c9825ef79c1ee41d2f19e7c997f5cdc93494- - extra-dep: true-   location:-       git: https://github.com/ekmett/semigroupoids.git-       commit: c3297f970658ae874db098190327ec742044a2e6- - extra-dep: true-   location:-       git: http://github.com/ekmett/lens.git-       commit: 7031e00f62a704a86c3149c75c1e2afc059af022-   #- extra-dep: true-   #location:-   #    git: https://github.com/ekmett/trifecta.git-   #    commit: ea93f257e18e14699f8872a88bfd444c73df9155- - extra-dep: true-   location:-       git: https://github.com/dreixel/syb.git-       commit: f584ecd525179778063df2eb02dc6bbe406d7e75-flags:-    madlang:-        llvm-fast: true-#extra-deps:-#- dhall-1.4.2-allow-newer: true-compiler: ghc-8.2.0.20170507-compiler-check: match-exact-setup-info:- ghc:-  linux64:-   8.2.0.20170507:-    url: https://downloads.haskell.org/~ghc/8.2.1-rc2/ghc-8.2.0.20170507-x86_64-deb8-linux.tar.xz-  linux64-nopie:-   8.2.0.20170507:-    url: https://downloads.haskell.org/~ghc/8.2.1-rc2/ghc-8.2.0.20170507-x86_64-deb8-linux.tar.xz-  macosx:-   8.2.0.20170507:-    url: https://downloads.haskell.org/~ghc/8.2.1-rc2/ghc-8.2.0.20170507-x86_64-apple-darwin.tar.xz-  windows64:-   8.2.0.20170507:-    url: https://downloads.haskell.org/~ghc/8.2.1-rc2/ghc-8.2.0.20170507-x86_64-unknown-mingw32.tar.xz+- .+extra-deps: []+flags: {}+extra-package-dbs: []

@@ -36,9 +36,6 @@         parallel $ it "fails when variables are not passed in" $ do             file <- madVar             (parseTok "" [] [] `shouldFailOn` file) `shouldThrow` anyException-        --parallel $ it "parses tibetan numerals" $ do-        --    file <- madFileTibetan-        --    parseTok "" [] file `shouldParse` (List [(1.0,List [(0.5,Value "heads"),(0.5,Value "tails")])])     describe "runFile" $ do         parallel $ it "parses nested modifiers and modifiers on variables correctly" $ \file -> do             runFile ["aa"] "test/templates/modifiers.mad" >>= (`shouldSatisfy` (\a -> any (a==) ["AAAaaa","AAAaa","AAaaa","AAaa"]))

@@ -3,6 +3,10 @@     1.0 "two"     1.0 "three" +:define afourththing+    1.0 something+    1.0 "fourth".oulipo+ :define something     1.0 "heads"     1.0 "tails"@@ -14,3 +18,4 @@  :return     1.0 something+    1.0 afourththing