madlang 2.4.1.1 → 2.4.1.2

raw patch · 9 files changed

+62/−61 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• cabal.project.local +1/−1
• madlang.cabal +1/−1
• src/Text/Madlibs/Ana/Parse.hs +14/−11
• src/Text/Madlibs/Ana/ParseUtils.hs +24/−24
• src/Text/Madlibs/Ana/Resolve.hs +3/−2
• src/Text/Madlibs/Exec/Main.hs +3/−2
• src/Text/Madlibs/Generate/TH.hs +4/−4
• test/Demo.hs +6/−4
• test/Spec.hs +6/−12

@@ -1,3 +1,3 @@ with-compiler: ghc-8.2.1 optimization: 2-constraints: madlang -development +llvm-fast+constraints: madlang +development +llvm-fast

@@ -1,5 +1,5 @@ name:                madlang-version:             2.4.1.1+version:             2.4.1.2 synopsis:            Randomized templating language DSL description:         Madlang is a text templating language written in Haskell,                      meant to explore computational creativity and generative

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# LANGUAGE OverloadedStrings #-}  -- | Parse our DSL@@ -5,6 +6,7 @@     parseTok   , parseTokF   , parseInclusions+  , parseTree   , parseTreeF   , parseTokM ) where @@ -23,7 +25,6 @@ import           Text.Megaparsec 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@@ -46,18 +47,20 @@ integer = lexeme L.decimal <?> "Integer"  -- | Make sure definition blocks start un-indented+nonIndented :: Parser a -> Parser a nonIndented = L.nonIndented spaceConsumer  -- | Make contents of definition blocks are indented.+indentGuard :: Parser Pos indentGuard = L.indentGuard spaceConsumer GT (mkPos 4)  -- | Parse between quotes quote :: Parser a -> Parser a-quote = between .$ (char '"')+quote = between .$ char '"'  -- | Parse a keyword keyword :: T.Text -> Parser T.Text-keyword str = (char ':') >> (symbol str) <?> "keyword"+keyword str = char ':' >> symbol str <?> "keyword"  -- | Parse a var var :: Parser Int@@ -100,21 +103,21 @@ preStr :: [T.Text] -> Parser PreTok preStr ins = do {         n <- name ;-        mod <- many modifier ;+        mod' <- many modifier ;         spaceConsumer ;-        pure $ Name n (foldr (.) id mod)+        pure $ Name n (foldr (.) id mod')     } <|>     do {         v <- var ;-        mod <- many modifier ;+        mod' <- many modifier ;         spaceConsumer ;-        pure . PreTok . (foldr (.) id mod) $ ins `access` (v-1) -- ins !! (v - 1)+        pure . PreTok . foldr (.) id mod' $ ins `access` (v-1) -- ins !! (v - 1)     } <|>     do {         s <- quote (many $ noneOf ("\n\"" :: String)) ;-        mod <- many modifier ;+        mod' <- many modifier ;         spaceConsumer ;-        pure . PreTok . (foldr (.) id mod) . T.pack $ s+        pure . PreTok . foldr (.) id mod' . T.pack $ s     }     <?> "string or function name" @@ -182,12 +185,12 @@  -- | Parse text as a list of functions 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+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 (ErrorFancy Void)) [(Key, RandTok)]-parseTreeF filename state ins f = (flip execState (filterTemplate state)) <$> runParser (parseTreeM ins) filename f+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))  -- | Parse text given a context

@@ -6,6 +6,7 @@   , sortKeys   , build   , buildTree+  , jumble   ) where  import           Control.Arrow@@ -16,8 +17,6 @@ import           Data.List import qualified Data.Map                    as M import qualified Data.Text                   as T-import           Debug.Trace-import           Debug.Trace import           System.Random.Shuffle import           Text.Madlibs.Cata.SemErr import           Text.Madlibs.Internal.Types@@ -25,21 +24,18 @@  --TODO consider moving Ana.ParseUtils to Cata.Sorting -(&) :: a -> (a -> b) -> b-(&) x f = f x- -- | 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)-    , ("capitalize", (\t -> toUpper (T.head t) `T.cons` T.tail t))+    , ("capitalize", \t -> toUpper (T.head t) `T.cons` T.tail t)     , ("reverse", T.reverse)     , ("reverse_words", T.unwords . reverse . T.words)     , ("oulipo", T.filter (/='e'))]  -- | Jumble the words in a string jumble :: (MonadRandom m) => T.Text -> m T.Text-jumble = (fmap (T.pack . unwords)) . shuffleM . words . T.unpack+jumble = fmap (T.pack . unwords) . shuffleM . words . T.unpack  -- | Strip file extension strip :: String -> T.Text@@ -47,48 +43,52 @@  -- | Get the :return value takeTemplate :: [(Key, RandTok)] -> RandTok-takeTemplate = snd . headNoReturn . filter (\(i,j) -> i == "Return")+takeTemplate = snd . headNoReturn . filter (\(i,_) -> 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+        unList _        = mempty+    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+    fold . map toRand <$> pretoks  -- | 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+        unList _        = mempty+    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+    List . zip [1..] . map toRand <$> pretoks  -- | Build the token without concatenating, yielding a `RandTok` suitable to be -- printed as a tree. buildTree :: [(Key, [(Prob, [PreTok])])] -> Context RandTok-buildTree list@[(key,pairs)] = do-    toks <- mapM (\(i,j) -> buildTok key (pure j)) pairs+buildTree [] = pure mempty+buildTree [(key,pairs)] = do+    toks <- mapM (\(_,j) -> buildTok key (pure j)) pairs     let probs = map fst pairs     let tok = List $ zip probs toks-    state (\s -> (tok,((key,tok):s)))-buildTree list@(x:xs) = do+    state (\s -> (tok,(key,tok):s))+buildTree (x:xs) = do     y <- buildTree [x]     ys <- pure <$> buildTree xs-    pure . List . zip ([1..]) $ (y:ys)+    pure . List . zip [1..] $ (y:ys)  -- | Given keys naming the tokens, and lists of `PreTok`, build our `RandTok` build :: [(Key, [(Prob, [PreTok])])] -> Context RandTok-build list@[(key,pairs)] = do-    toks <- mapM (\(i,j) -> concatTok key (pure j)) pairs+build [] = pure mempty+build [(key,pairs)] = do+    toks <- mapM (\(_,j) -> concatTok key (pure j)) pairs     let probs = map fst pairs     let tok = List $ zip probs toks-    state (\s -> (tok,((key, tok):s)))-build list@(x:xs) = do-    y <- (build [x])+    state (\s -> (tok,(key, tok):s))+build (x:xs) = do+    y <- build [x]     ys <- pure <$> build xs     pure $ fold (y:ys) @@ -97,12 +97,12 @@ sortKeys = sortBy orderKeys  orderHelper :: Key -> [(Prob, [PreTok])] -> Bool-orderHelper key = any (\pair -> key `elem` (map unTok . snd $ pair))+orderHelper key = any (\pair -> key /= "" && key `elem` (map unTok . snd $ pair))  hasNoDeps :: [(Prob, [PreTok])] -> Bool hasNoDeps = all isPreTok . concatMap snd     where isPreTok PreTok{} = True-          isPreTok x        = False+          isPreTok _        = False  -- TODO 'somethingelse' shouldn't be less than 'athirdthing'!! 

@@ -8,6 +8,7 @@   , runText ) where  import           Control.Exception+import           Control.Monad               (void) import           Control.Monad.Random.Class import           Data.Composition import           Data.Monoid@@ -35,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' = map (over _1 ((((T.pack . (<> "-")) . dropExtension) file') <>))     ctxPure <- mapM (getInclusionCtx isTree ins folder) filenames     let ctx = (zipWith resolveKeys filenames) <$> sequence ctxPure     catch@@ -47,7 +48,7 @@     -> FilePath -- ^ Path to @.mad@ file.     -> IO T.Text -- ^ Result runFile ins toFolder = do-    exists <- doesDirectoryExist (getDir toFolder)+    void $ doesDirectoryExist (getDir toFolder)     let filepath = reverse . (takeWhile (/='/')) . reverse $ toFolder     runInFolder ins (getDir toFolder) filepath 

@@ -21,7 +21,7 @@  -- | datatype for the subcommands data Subcommand = Debug { input :: FilePath }-                | Run { rep :: Maybe Int , clInputs :: [String] , input :: FilePath }+                | Run { _rep :: Maybe Int , clInputs :: [String] , input :: FilePath }                 | Lint { clInputs :: [String] , input :: FilePath }  -- | Parser for command-line options for the program@@ -77,9 +77,11 @@ runMadlang :: IO () runMadlang = execParser wrapper >>= template +versionInfo :: Parser (a -> a) versionInfo = infoOption ("madlang version: " ++ showVersion version) (short 'v' <> long "version" <> help "Show version")  -- | Wraps parser with help parser+wrapper :: ParserInfo Program wrapper = info (helper <*> versionInfo <*> orders)     (fullDesc     <> progDesc "Madlang templating language"@@ -94,7 +96,6 @@     let ins = map T.pack (clInputs . sub $ rec)     case sub rec of         (Run reps _ _) -> do-            parsed <- parseFile ins "" filepath             replicateM_ (fromMaybe 1 reps) $ runFile ins filepath >>= TIO.putStrLn         (Debug _) -> putStr . (either show displayTree) =<< makeTree ins "" filepath         (Lint _ _) -> do

@@ -41,8 +41,8 @@ -- | Convert a `String` containing  to a `Q Exp` with the parsed syntax tree. textToExpression :: String -> Q Exp textToExpression txt = do-    parse <- [|parseTok "source" [] []|]-    pure $ (VarE 'errorgen) `AppE` (parse `AppE` ((VarE 'T.pack) `AppE` (LitE (StringL (txt)))))+    parse' <- [|parseTok "source" [] []|]+    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 (ErrorFancy Void)) a -> a@@ -60,5 +60,5 @@ madFile :: FilePath -> Q Exp madFile path = do     file <- (embedFile path)-    parse <- [|(parseTok "source" [] []) . decodeUtf8|] -- TODO make this recurse but still work!-    pure $ (VarE 'errorgen) `AppE` (parse `AppE` file)+    parse' <- [|(parseTok "source" [] []) . decodeUtf8|] -- TODO make this recurse but still work!+    pure $ (VarE 'errorgen) `AppE` (parse' `AppE` file)

@@ -1,15 +1,17 @@+{-# LANGUAGE QuasiQuotes     #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-}  module Demo (     runTest-  , runTestQQ ) where +  , runTestQQ ) where -import Text.Madlibs-import qualified Data.Text as T+import qualified Data.Text    as T+import           Text.Madlibs +demo :: RandTok demo = $(madFile "test/templates/gambling.mad") +demoQQ :: RandTok demoQQ = [madlang| :define something     1.0 "hello"

@@ -37,13 +37,13 @@             file <- madVar             (parseTok "" [] [] `shouldFailOn` file) `shouldThrow` anyException     describe "runFile" $ do-        parallel $ it "parses nested modifiers and modifiers on variables correctly" $ \file -> do+        parallel $ it "parses nested modifiers and modifiers on variables correctly" $ \_ -> do             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+        parallel $ it "parses file with inclusions and modifiers on functions" $ \_ -> do             runFile [] "test/templates/include.mad" >>= (`shouldSatisfy` (\a -> any (a==) ["heads","tails","on its side"]))-        parallel $ it "parses file with recursive inclusions" $ \file -> do+        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" $ \file -> do+        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"]))     describe "readFileQ" $ do         parallel $ it "executes embedded code" $ do@@ -52,9 +52,6 @@         parallel $ it "provides a quasi-quoter" $ do             runTestQQ >>= (`shouldSatisfy` (\a -> any (a==) ["hello","goodbye"])) -semErr :: Selector SemanticError-semErr = const True- -- | Read a file in as a `Text` readFile' :: FilePath -> IO T.Text readFile' = (fmap T.pack) . readFile@@ -62,14 +59,11 @@ exampleTok :: RandTok exampleTok = List [(1.0,List [(0.5,Value "heads"),(0.5,Value "tails")])] -includeFile :: IO T.Text-includeFile = readFile' "test/templates/include.mad"+--includeFile :: IO T.Text+--includeFile = readFile' "test/templates/include.mad"  madFileBasic :: IO T.Text madFileBasic = readFile' "test/templates/gambling.mad"--madFileTibetan :: IO T.Text-madFileTibetan = readFile' "test/templates/ཤོ.mad"  madFileFailure :: IO T.Text madFileFailure = readFile' "test/templates/err/bad.mad"