madlang 2.1.1.3 → 2.1.2.0

raw patch · 15 files changed

+138/−70 lines, 15 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• madlang.cabal +5/−8
• src/Text/Madlibs.hs +1/−1
• src/Text/Madlibs/Ana/Parse.hs +18/−16
• src/Text/Madlibs/Ana/ParseUtils.hs +3/−3
• src/Text/Madlibs/Ana/Resolve.hs +18/−6
• src/Text/Madlibs/Cata/Display.hs +16/−0
• src/Text/Madlibs/Cata/SemErr.hs +45/−17
• src/Text/Madlibs/Exec/Main.hs +1/−4
• src/Text/Madlibs/Internal/Types.hs +5/−9
• src/Text/Madlibs/Internal/Utils.hs +4/−5
• test/Spec.hs +5/−0
• test/templates/err/bad-modifier.mad +5/−0
• test/templates/err/double-declarations.mad +6/−0
• test/templates/include-recursive.mad +5/−0
• test/templates/include.mad +1/−1

@@ -1,5 +1,5 @@ name:                madlang-version:             2.1.1.3+version:             2.1.2.0 synopsis:            Randomized templating language DSL description:         Please see README.md homepage:            https://github.com/vmchale/madlang#readme@@ -12,14 +12,9 @@ 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/modifiers.mad+                   , test/templates/*.mad                    , test/templates/err/*.mad-                   , demo/shakespeare.mad+                   , demo/*.mad                    , default.nix                    , release.nix                    , stack.yaml@@ -41,6 +36,7 @@                      , Text.Madlibs.Internal.Types                      , Text.Madlibs.Internal.Utils                      , Text.Madlibs.Cata.SemErr+                     , Text.Madlibs.Cata.Display                      , Text.Madlibs.Exec.Main   build-depends:       base >= 4.7 && < 5                      , megaparsec@@ -58,6 +54,7 @@   default-extensions:  OverloadedStrings                      , DeriveGeneric                      , DeriveFunctor+                     , DeriveAnyClass  executable madlang   hs-source-dirs:      app

@@ -1,6 +1,6 @@ -- | Main module exporting the relevant functions module Text.Madlibs (-                    -- * Parsers for `.mad` files+                    -- * Parsers for @.mad@ files                       parseTok                     , parseTokM                     , runFile

@@ -11,6 +11,7 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Lexer as L import Data.Monoid+import Data.Maybe import Control.Monad import qualified Data.Map as M import Control.Monad.State@@ -31,7 +32,7 @@  -- | Parse a number/probability float :: Parser Prob-float = lexeme L.float <|> (fromIntegral <$> integer) <?> "Float"+float = lexeme L.float <|> (fromIntegral <$> integer) <?> "Number"  -- | Parse an integer integer :: Parser Integer@@ -45,7 +46,7 @@  -- | Parse between quotes quote :: Parser a -> Parser a-quote = between (char '"') (char '"') +quote = between .$ (char '"')  -- | Parse a keyword keyword :: String -> Parser String@@ -74,14 +75,14 @@  -- | Parse a template name (what follows a `:define` or `return` block) name :: Parser String-name = lexeme (some (letterChar <|> oneOf ("-/" :: String))) <?> "template name"+name = lexeme (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 <- try (string "to_upper") <|> (string "to_lower")-    pure $ maybe id id (M.lookup str modifierList)+    str <- (try $ string "to_upper") <|> (string "to_lower")+    pure (maybe id id (M.lookup str modifierList)) <?> "modifier"  -- | Parse template into a `PreTok` of referents and strings preStr :: [T.Text] -> Parser PreTok@@ -99,7 +100,7 @@     } <|>     do {         s <- quote (many $ noneOf ("\n\"" :: String)) ;-        mod <- many $ modifier ; -- TODO: parse many via a fold?+        mod <- many $ modifier ;         spaceConsumer ;         pure . PreTok . (foldr (.) id mod) . T.pack $ s     } @@ -111,15 +112,15 @@     indentGuard     p <- float     str <- some (preStr ins)-    pure (p, str) <?> "Probability/text pair"+    pure (p, str) <?> "Probability-text pair"  -- | Parse an `include` inclusions :: Parser [String] inclusions = many . try $ do     include-    str <- name -- make this broader+    str <- name     string ".mad"-    pure (str ++ ".mad") -- TODO dependency resolution (?)+    pure (str ++ ".mad")  -- | Parse a `define` block definition :: [T.Text] -> Parser (Key, [(Prob, [PreTok])])@@ -140,7 +141,7 @@ program :: [T.Text] -> Parser [(Key, [(Prob, [PreTok])])] program ins = sortKeys <$> (checkSemantics =<< do     inclusions-    p <- many (try (definition ins) <|> ((,) "Template" <$> final ins))+    p <- many (try (definition ins) <|> ((,) "Return" <$> final ins))     lexeme eof     pure p) @@ -155,18 +156,19 @@ -- | Parse text as a list of functions parseTokF :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char Dec) [(Key, RandTok)] parseTokF filename state ins f = (flip execState (filterTemplate state)) <$> runParser (parseTokM ins) filename f -    where filterTemplate = map (\(i,j) -> if i == "Template" then (strip filename, j) else (i,j)) -- problem: doesn't tell what file we're reading FROM+    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 filename state ins f = (flip execState (filterTemplate state)) <$> runParser (parseTreeM ins) filename f -    where filterTemplate = map (\(i,j) -> if i == "Template" then (strip filename, j) else (i,j))+    where filterTemplate = map (\(i,j) -> if i == "Return" then (strip filename, j) else (i,j)) --- | Parse text as a token------ > f <- readFile "template.mad"--- > parseTok f -- | Parse text given a context+--+-- > import qualified Data.Text.IO as TIO+-- >+-- > f <- TIO.readFile "template.mad"+-- > parseTok "filename.mad" [] [] f parseTok :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseError Char Dec) RandTok parseTok = (fmap takeTemplate) .*** parseTokF 

@@ -26,7 +26,7 @@  -- | Get the :return value takeTemplate :: [(Key, RandTok)] -> RandTok-takeTemplate = snd . head . filter (\(i,j) -> i == "Template")+takeTemplate = snd . head . filter (\(i,j) -> i == "Return")  -- | Convert the stuff after the number to a `RandTok` concatTok :: T.Text -> Context [PreTok] -> Context RandTok@@ -78,8 +78,8 @@ -- | Ordering on the keys to account for dependency orderKeys :: (Key, [(Prob, [PreTok])]) -> (Key, [(Prob, [PreTok])]) -> Ordering orderKeys (key1, l1) (key2, l2)-    | key1 == "Template" = GT-    | key2 == "Template" = LT+    | key1 == "Return" = GT+    | key2 == "Return" = LT     | any (\pair -> any (T.isInfixOf key1) (map unTok . snd $ pair)) l1 = GT     | any (\pair -> any (T.isInfixOf key2) (map unTok . snd $ pair)) l1 = LT     | otherwise = EQ

@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}++ -- | Module containing IO stuff to get/parse files with external dependencies module Text.Madlibs.Ana.Resolve where @@ -10,18 +13,27 @@ import Text.Madlibs.Cata.Run import Data.Composition import System.Directory+import Lens.Micro+import Data.Monoid+import Control.Applicative+import Control.Monad  -- | Parse a template file into the `RandTok` data type-parseFile :: [T.Text] -> FilePath -> FilePath -> IO (Either (ParseError Char Dec) RandTok)+parseFile :: [T.Text] -- ^ variables to substitute into the template+    -> FilePath -- ^ folder+    -> FilePath -- ^ filepath within folder+    -> IO (Either (ParseError Char Dec) 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 isTree ins folder filepath = do     file <- readFile' (folder ++ filepath)-    let filenames = either (const []) id $ parseInclusions filepath file -- FIXME pass up errors correctly-    ctx <- mapM (getInclusionCtx isTree ins folder) filenames -    parseCtx isTree ins (concatMap (either (const []) id) ctx) (folder ++ filepath)+    let filenames = either (error . show) id $ parseInclusions filepath file -- TODO pass up errors correctly+    let resolveKeys file = map (over _1 ((((T.pack . (<> "-")) . dropExtension) $ file) <>))+    ctxPure <- mapM (getInclusionCtx isTree ins folder) filenames+    let ctx = (zipWith resolveKeys filenames) <$> sequence ctxPure+    parseCtx isTree ins (concat . (either (const []) id) $ ctx) (folder ++ filepath)  -- | Generate randomized text from a file conatining a template runFile :: [T.Text] -> FilePath -> IO T.Text@@ -36,10 +48,10 @@  -- | Run based on text input, with nothing linked. runText :: [T.Text] -> String -> T.Text -> IO T.Text-runText vars name txt = (either (pure . parseErrorPretty') id) . (fmap run) $ (parseTok name [] vars txt)+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 Dec) [(Key, RandTok)]) parseCtx isTree ins state filepath = do     txt <- readFile' filepath     let keys = (if isTree then parseTreeF else parseTokF) filepath state ins txt

@@ -0,0 +1,16 @@+module Text.Madlibs.Cata.Display where++import Data.Tree+import Text.Madlibs.Internal.Types++-- | Draw as a syntax Tree+displayTree :: RandTok -> String+displayTree = drawTree . tokToTree 1.0++-- | 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+tokToTree p (Value a) = Node ((take 4 . show . min 1.0) p ++ " " ++ show a) []+tokToTree p (List [(_,Value a)]) = Node ((take 4 . show . min 1.0) p ++ " " ++ show a) []+tokToTree p (List xs) = Node (take 4 . show . min 1.0 $ p) (map (uncurry tokToTree) xs)

@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+ -- | Module defining the SemErr data type module Text.Madlibs.Cata.SemErr where @@ -7,18 +9,24 @@ import Control.Exception import qualified Data.Text as T import Control.Monad+import Lens.Micro+import Lens.Micro.Extras import qualified Data.Set as S import Text.Megaparsec.Text import Text.Megaparsec.Prim+import Data.Composition import Text.Megaparsec.Error+import Text.Madlibs.Internal.Utils  -- | Datatype for a semantic error-data SemanticError = OverloadedReturns | CircularFunctionCalls T.Text T.Text | InsufficientArgs Int Int+data SemanticError = NoReturn | CircularFunctionCalls T.Text T.Text | InsufficientArgs Int Int | DoubleDefinition T.Text | NoContext T.Text     deriving (Typeable)  -- | display a `SemanticError` nicely with coloration & whatnot instance Show SemanticError where-    show OverloadedReturns = show $ semErrStart <> text "File must contain exactly one declaration of :return"+    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) @@ -27,19 +35,29 @@  -- | Throw custom error given by string, within the parser customError :: String -> Parser a-customError = failure S.empty S.empty . S.singleton . representFail+customError = (failure .$ S.empty) . S.singleton . representFail --- | Throw `OverloadedReturns` error within parser-overloadedReturns :: Parser a-overloadedReturns = customError . show $ OverloadedReturns+showCustomError :: (Show a) => a -> Parser b+showCustomError = customError . show +-- | Throw `NoReturn` error within parser+noReturn :: Parser a+noReturn = showCustomError $ NoReturn++noContext :: T.Text -> Parser a+noContext f1 = showCustomError $ NoContext f1+ -- | Throws argument for circular function calls circularFunctionCalls :: T.Text -> T.Text -> Parser a-circularFunctionCalls f1 f2 = customError . show $ CircularFunctionCalls f1 f2+circularFunctionCalls f1 f2 = showCustomError $ CircularFunctionCalls f1 f2 +-- | Throws error when a function is defined twice+doubleDefinition :: T.Text -> Parser a+doubleDefinition f = showCustomError $ DoubleDefinition f+ -- | Throws error for insufficient arguments insufficientArgs :: Int -> Int -> Parser a-insufficientArgs i j = customError . show $ InsufficientArgs i j+insufficientArgs i j = showCustomError $ InsufficientArgs i j  -- | Constant to start `SemanticError`s semErrStart :: Doc@@ -49,10 +67,14 @@ 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 = foldr (<=<) pure [ checkReturn-                                  ] -- do we need this all to be in a monad? +checkSemantics keys = foldr (<=<) pure ((checkKey "Return"):[checkKey key | key <- allKeys keys ])+                                       $ keys+    where allKeys = fmap name . (concatMap snd) . (concatMap snd) -- TODO use a traversal here!!+          name (Name str _) = str+          name (PreTok _) = "Return"  -- | helper to filter out stuff that doesn't sumProb :: [(Prob, [PreTok])] -> Bool@@ -68,14 +90,20 @@ access :: [a] -> Int -> a 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` statement-checkReturn :: [(Key, [(Prob, [PreTok])])] -> Parser [(Key, [(Prob, [PreTok])])]-checkReturn keys-    | singleReturn keys = pure keys-    | otherwise = overloadedReturns+-- | checker to verify there is at most one @:return@ or @:define key@ statement+checkKey :: Key -> [(Key, [(Prob, [PreTok])])] -> Parser [(Key, [(Prob, [PreTok])])]+checkKey key keys+    | singleInstance key keys = pure keys+    | noInstance key keys = pure keys -- noContext key -- FIXME only if it recurses properly!+    | key == "Return" && noInstance key keys = noReturn+    | otherwise = doubleDefinition key  -- | Checks that we have at most one `:return` template in the file-singleReturn :: [(Key, [(Prob, [PreTok])])] -> Bool-singleReturn = singleton . (filter ((=="Template") . fst))+singleInstance :: Key -> [(Key, [(Prob, [PreTok])])] -> Bool+singleInstance key = singleton . (filter ((==key) . fst))     where singleton [a] = True           singleton _   = False++-- | Checks that there are no instances of a key+noInstance :: Key -> [(Key, [(Prob, [PreTok])])] -> Bool+noInstance key = (== []) . (filter ((==key) . fst))

@@ -2,8 +2,8 @@ module Text.Madlibs.Exec.Main where  import Control.Monad-import Text.Madlibs.Cata.Run import Text.Madlibs.Ana.Resolve+import Text.Madlibs.Cata.Display import Text.Madlibs.Internal.Types import Text.Madlibs.Internal.Utils import qualified Data.Text as T@@ -13,8 +13,6 @@ import Data.Monoid import Data.Composition import System.Directory----import Text.Madlibs.Ana.Parse  -- | datatype for the program data Program = Program { sub :: Subcommand @@ -57,7 +55,6 @@         (short 'i'         <>  metavar "VAR"         <> help "command-line inputs to the template."))-        -- TODO consider making arguments nicer?  -- | Parser for the lint subcommand lint :: Parser Subcommand

@@ -21,8 +21,12 @@  -- | Pretoken, aka token as first read in data PreTok = Name T.Text (T.Text -> T.Text) | PreTok T.Text-    --deriving (Show, Eq) +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'])+    (==) (PreTok a) (PreTok b) = a == b+ -- | datatype for a token returning a random string data RandTok = List [(Prob, RandTok)] | Value T.Text     deriving (Show, Eq)@@ -30,14 +34,6 @@ 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. ------ > tokToTree 1.0 tok-tokToTree :: Prob -> RandTok -> Tree String-tokToTree p (Value a) = Node ((take 4 . show . min 1.0) p ++ " " ++ show a) []-tokToTree p (List [(_,Value a)]) = Node ((take 4 . show . min 1.0) p ++ " " ++ show a) []-tokToTree p (List xs) = Node (take 4 . show . min 1.0 $ p) (map (uncurry tokToTree) xs)  -- | Make `RandTok` a monoid so we can append them together nicely (since they do generate text).  --

@@ -10,11 +10,10 @@ import qualified Data.Text as T import System.IO.Unsafe import Lens.Micro-import Data.Tree --- | Draw as a syntax Tree-displayTree :: RandTok -> String-displayTree = drawTree . tokToTree 1.0+-- | Drop file Extension+dropExtension :: FilePath -> FilePath+dropExtension = reverse . drop 1 . (dropWhile (/='.')) . reverse  -- | Get directory associated to a file getDir :: FilePath -> FilePath@@ -22,7 +21,7 @@  -- | Function to apply a value on both arguments, e.g. ----- > between .$ (symbol "\'")+-- > between .$ (char '"') (.$) :: (a -> a -> b) -> a -> b (.$) f x = f x x 

@@ -21,6 +21,9 @@         parallel $ it "fails when quotes aren't closed" $ do             file <- madFileFailure             parseTok "" [] [] `shouldFailOn` file+        parallel $ it "fails on nonsensical modifiers" $ do+            file <- readFile' "test/templates/err/bad-modifier.mad"+            parseTok "" [] [] `shouldFailOn` file         parallel $ it "parses when functions are out of order" $ do             file <- madComplexFile             parseTok "" [] [] `shouldSucceedOn` file@@ -43,6 +46,8 @@             runFile ["aa"] "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 "parses file with recursive inclusions" $ \file -> 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" $ \file -> do             runFile [] "test/templates/ordered.mad" >>= (`shouldSatisfy` (\a -> any (a==) ["heads","tails","one","two","three","third"])) 

@@ -0,0 +1,5 @@+:define main+    1.0 "loud string".to_opper+    1.0 "quiet string"+:return+    1.0 main

@@ -0,0 +1,6 @@+:define something+    1.0 "something"+:define something+    1.0 "something else"+:return+    1.0 something

@@ -0,0 +1,5 @@+:include include.mad+:define another+    1.0 include-gambling-something+:return+    1.0 another

@@ -1,6 +1,6 @@ :include gambling.mad :define realistic-    1.0 something.to_lower+    1.0 gambling-something.to_lower     0.03 "on its side" :return     1.0 realistic