madlang 1.1.3.0 → 2.0.0.0

raw patch · 7 files changed

+161/−77 lines, 7 filesdep +containersdep +optparse-applicativedep −gitrevdep −optparse-genericdep ~madlang

Dependencies added: containers, optparse-applicative

Dependencies removed: gitrev, optparse-generic

Dependency ranges changed: madlang

Files

• madlang.cabal +5/−5
• src/Text/Madlibs/Ana/Parse.hs +14/−9
• src/Text/Madlibs/Ana/ParseUtils.hs +31/−14
• src/Text/Madlibs/Cata/SemErr.hs +8/−1
• src/Text/Madlibs/Exec/Main.hs +74/−42
• src/Text/Madlibs/Internal/Types.hs +23/−0
• test/Spec.hs +6/−6

@@ -1,5 +1,5 @@ name: madlang-version: 1.1.3.0+version: 2.0.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -35,12 +35,12 @@         base >=4.7 && <5,         megaparsec >=5.2.0 && <5.3,         text >=1.2.2.1 && <1.3,-        optparse-generic >=1.1.4 && <1.2,+        optparse-applicative >=0.13.2.0 && <0.14,         mwc-random >=0.13.5.0 && <0.14,         lens >=4.15.1 && <4.16,         mtl >=2.2.1 && <2.3,         ansi-wl-pprint >=0.6.7.3 && <0.7,-        gitrev >=1.2.0 && <1.3+        containers >=0.5.7.1 && <0.6     default-language: Haskell2010     default-extensions: OverloadedStrings DeriveGeneric DeriveFunctor                         DeriveAnyClass@@ -63,7 +63,7 @@     main-is: Main.hs     build-depends:         base >=4.9.1.0 && <4.10,-        madlang >=1.1.3.0 && <1.2+        madlang >=2.0.0.0 && <2.1     default-language: Haskell2010     hs-source-dirs: app @@ -72,7 +72,7 @@     main-is: Spec.hs     build-depends:         base >=4.9.1.0 && <4.10,-        madlang >=1.1.3.0 && <1.2,+        madlang >=2.0.0.0 && <2.1,         hspec >=2.4.2 && <2.5,         megaparsec >=5.2.0 && <5.3,         text >=1.2.2.1 && <1.3,

@@ -13,8 +13,6 @@ import Data.Monoid import Control.Monad import Control.Monad.State----import System.IO.Unsafe  -- | Parse a lexeme, aka deal with whitespace nicely.  lexeme :: Parser a -> Parser a@@ -32,13 +30,14 @@ float :: Parser Prob float = lexeme L.float +-- | Parse an integer integer :: Parser Integer integer = lexeme L.integer  -- | Make sure definition blocks start un-indented nonIndented = L.nonIndented spaceConsumer---nonIndented = L.indentGuard spaceConsumer EQ (unsafePos 1) +-- | Make contents of definition blocks are indented. indentGuard = L.indentGuard spaceConsumer GT (unsafePos 4)  -- | Parse between quotes@@ -74,13 +73,13 @@ preStr ins = (fmap (Name . T.pack) name) <|>     do {         v <- var ;-        pure . PreTok $ ins !! (v - 1)+        pure . PreTok $ ins `access` (v-1) -- ins !! (v - 1)     } <|>     do {         s <- quote (many $ noneOf ("\"" :: String)) ;         spaceConsumer ;         pure $ PreTok . T.pack $ s-    } --needs to stop on \n though+    }      <?> "string or function name"  -- | Parse a probability/corresponding template@@ -89,7 +88,7 @@     indentGuard     p <- float     str <- some $ (preStr ins)-    pure (p, str)+    pure (p, str) <?> "Probability/text pair"  -- | Parse a `define` block definition :: [T.Text] -> Parser (Key, [(Prob, [PreTok])])@@ -97,7 +96,7 @@     define     str <- name     val <- fmap normalize . some $ pair ins-    pure (T.pack str, val)+    pure (T.pack str, val) <?> "define block"  -- | Parse the `:return` block final :: [T.Text] -> Parser [(Prob, [PreTok])]@@ -112,6 +111,9 @@     p <- many (try (definition ins) <|> ((,) "Template" <$> final ins))     pure p +parseTreeM :: [T.Text] -> Parser (Context RandTok)+parseTreeM ins = buildTree <$> program ins+ -- | Parse text as a token + context (aka a reader monad with all the other functions) parseTokM :: [T.Text] -> Parser (Context RandTok) parseTokM ins = build <$> program ins@@ -120,5 +122,8 @@ -- -- > f <- readFile "template.mad" -- > parseTok f-parseTok :: [T.Text] -> T.Text -> Either (ParseError Char Dec) RandTok-parseTok ins f = snd . head . (filter (\(i,j) -> i == "Template")) . (flip execState []) <$> runParser (parseTokM ins) "" f+parseTok :: FilePath -> [T.Text] -> T.Text -> Either (ParseError Char Dec) RandTok+parseTok filename ins f = snd . head . (filter (\(i,j) -> i == "Template")) . (flip execState []) <$> runParser (parseTokM ins) filename f++parseTree :: FilePath -> [T.Text] -> T.Text -> Either (ParseError Char Dec) RandTok+parseTree filename ins f = snd . head . (filter (\(i,j) -> i == "Template")) . (flip execState []) <$> runParser (parseTreeM ins) filename f

@@ -18,25 +18,42 @@ concatTok param pretoks = do     ctx <- get     let unList (List a) = a-    let toRand (Name str) = List . snd . (head' str param) . (filter ((== str) . fst)). (map (second unList)) $ ctx+    let toRand (Name str) = List . snd . (head' str param) . (filter ((== str) . fst)) . (map (second unList)) $ ctx         toRand (PreTok txt) = Value txt     fold . (map toRand) <$> pretoks +buildTok :: T.Text -> Context [PreTok] -> Context RandTok+buildTok param pretoks = do+    ctx <- get+    let unList (List a) = a+    let toRand (Name str) = List . snd . (head' str param) . (filter ((==str) . fst)) . (map (second unList)) $ ctx+        toRand (PreTok txt) = Value txt+    List . zip ([1..]) . (map toRand) <$> pretoks++buildTree :: [(Key, [(Prob, [PreTok])])] -> Context RandTok+buildTree list@[(key,pairs)] = do+    toks <- mapM (\(i,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+    y <- buildTree [x]+    ys <- pure <$> buildTree xs+    pure . List . zip ([1..]) $ (y:ys)++-- basically just substitute? + -- | Given keys naming the tokens, and lists of `PreTok`, build our `RandTok` build :: [(Key, [(Prob, [PreTok])])] -> Context RandTok-build list-    | length list == 1 = do-        let [(key, pairs)] = list-        toks <- mapM (\(i,j) -> concatTok key (pure j)) pairs-        let probs = map fst pairs-        let tok = List $ zip probs toks-        state (\s -> (tok,((key, tok):s)))-        --should do: recurse or take "Template" key-    | otherwise = do-        let (x:xs) = list-        y <- (build [x])-        ys <- pure <$> build xs-        pure $ fold (y:ys)+build list@[(key,pairs)] = do+    toks <- mapM (\(i,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])+    ys <- pure <$> build xs+    pure $ fold (y:ys)  -- | Sort the keys that we have parsed so that dependencies are in the correct places sortKeys :: [(Key, [(Prob, [PreTok])])] -> [(Key, [(Prob, [PreTok])])]

@@ -8,7 +8,7 @@ import qualified Data.Text as T  -- | Datatype for a semantic error-data SemanticError = OverloadedReturns | CircularFunctionCalls T.Text T.Text | ProbSum T.Text+data SemanticError = OverloadedReturns | CircularFunctionCalls T.Text T.Text | ProbSum T.Text | InsufficientArgs Int Int     deriving (Typeable)  --also consider overloading parseError tbqh@@ -16,6 +16,7 @@ instance Show SemanticError where     show OverloadedReturns = show $ semErrStart <> text "File contains multiple declarations of :return"     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 (ProbSum f) = show $ semErrStart <> text "Function's options do not sum to 1:\n" <> indent 4 (yellow (text' f))     --we probably want to do our instance of `Show` for `ParseError` since that will let us color the position nicely @ least @@ -35,6 +36,9 @@ checkSemantics = foldr (.) id [ checkProb                               , checkReturn ] +-- checker to verify we have the right number of command-line args+-- checkArgs :: [(Key, [(Prob, [PreTok])])] -> [(Key, [(Prob, [PreTok])])]+ -- | checker to verify probabilities sum to 1 checkProb :: [(Key, [(Prob, [PreTok])])] -> [(Key, [(Prob, [PreTok])])] checkProb = map (\(i,j) -> if sumProb j then (i,j) else throw (ProbSum i))@@ -49,6 +53,9 @@ head' :: T.Text -> T.Text -> [a] -> a head' _ _ (x:xs) = x head' f1 f2 _ = throw (CircularFunctionCalls f1 f2)++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])])] -> [(Key, [(Prob, [PreTok])])]

@@ -1,7 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}- -- | Provides `madlang` runMadlangutable module Text.Madlibs.Exec.Main where @@ -13,67 +9,103 @@ import qualified Data.Text as T import qualified Data.Text.IO as TIO import Text.Megaparsec-import Options.Generic-import Development.GitRev+import Options.Applicative hiding (ParseError)+import Data.Monoid+--+import Data.Tree  -- | datatype for the program-data Program = Program { input :: FilePath <?> "filepath to template"-                       , debug :: Bool <?> "whether to display parsed RandTok" -                       , rep :: Maybe Int <?> "How many times to repeat"-                       , v :: [String] <?> "Extra input to the template" --fix soon?-                       , version :: Bool <?> "Display version information for debugging"-                       } deriving (Generic)+data Program = Program { sub :: Subcommand +                       , input :: FilePath +                       } -data Subcommand = Debug { file :: FilePath } -                | Run { file :: FilePath , rep' :: Maybe Int , input' :: [String] } +data Subcommand = Debug { version :: Bool }+                | Run { rep :: Maybe Int , clInputs :: [String] }+                | Lint { clInputs :: [String] }+                -- Repeat { rep :: Maybe Int } --- | Generated automatically by optparse-generic.-instance ParseRecord Program where+orders :: Parser Program+orders = Program+    <$> (hsubparser+        (command "run" (info temp (progDesc "Generate text from a .mad file"))+        <> command "debug" (info debug (progDesc "Debug a template"))+        <> command "lint" (info lint (progDesc "Lint a file"))))+    <*> (argument str+        (metavar "FILEPATH"+        <> help "File path to madlang template")) +debug :: Parser Subcommand+debug = Debug+    <$> switch+        (long "version"+        <> short 'v'+        <> help "Show version information")++temp :: Parser Subcommand+temp = Run+    <$> (optional $ read <$> strOption+        (long "rep"+        <> short 'r'+        <> metavar "REPETITIONS"+        <> help "Number of times to repeat"))+    <*> (many $ strOption+        (short 'i'+        <> metavar "VAR"+        <> help "command-line inputs to the template."))++lint :: Parser Subcommand+lint = Lint+    <$> (many $ strOption+        (short 'i'+        <> metavar "VAR"+        <> help "command-line inputs to the template."))+ -- | Main program action runMadlang :: IO ()-runMadlang = do-    x <- getRecord "Text.Madlibs templating DSL"-    if unHelpful . version $ x then putStrLn build else pure ()-    case unHelpful . rep $ x of-        (Just n) -> replicateM_ n $ template x-        Nothing -> template x+runMadlang = execParser wrapper >>= template +    --case rep . sub $ x of+    --    (Just n) -> replicateM_ n $ template x+    --    Nothing -> template x +wrapper = info (helper <*> orders)+    (fullDesc+    <> progDesc "Madlang templating language"+    <> header "Madlang - markov chains made easy")+ -- | given a parsed record perform the appropriate IO action template :: Program -> IO () template rec = do-    let filepath = unHelpful . input $ rec-    let ins = map T.pack $ (unHelpful . v $ rec)+    let filepath = input $ rec+    let ins = map T.pack $ (clInputs . sub $ rec)     parsed <- parseFile ins filepath-    runFile ins filepath >>= TIO.putStrLn-    if unHelpful . debug $ rec then-        print parsed-    else-        pure ()+    case sub rec of+        (Run reps _) -> do+            replicateM_ (maybe 1 id reps) $ runFile ins filepath >>= TIO.putStrLn -- fix so it parses once!! either show run $ parsed +        (Debug _) -> do+            putStrLn . (either show (drawTree . tokToTree)) =<< makeTree ins filepath -- parsed+            --print parsed+        (Lint _) -> do+            putStrLn $ either show (const "No errors found.") parsed  -- | Generate randomized text from a template-templateGen :: [T.Text] -> T.Text -> Either (ParseError Char Dec) (IO T.Text)-templateGen ins txt = run <$> parseTok ins txt+templateGen :: FilePath -> [T.Text] -> T.Text -> Either (ParseError Char Dec) (IO T.Text)+templateGen filename ins txt = run <$> parseTok filename ins txt  -- | Generate randomized text from a file conatining a template runFile :: [T.Text] -> FilePath -> IO T.Text runFile ins filepath = do     txt <- readFile' filepath-    either (pure . parseErrorPretty') (>>= (pure . show')) (templateGen ins txt)+    either (pure . parseErrorPretty') (>>= (pure . show')) (templateGen filepath ins txt)  -- | Parse a template file into the `RandTok` data type parseFile :: [T.Text] -> FilePath -> IO (Either (ParseError Char Dec) RandTok) parseFile ins filepath = do     txt <- readFile' filepath-    let val = parseTok ins txt+    let val = parseTok filepath ins txt     pure val --- | String with git commit string-build :: String-build = concat [ "[version: ", $(gitBranch), "@", $(gitHash)-               , " (", $(gitCommitDate), ")"-               , " (", $(gitCommitCount), " commits in HEAD)"-               , dirty, "] "] -    where-        dirty | $(gitDirty) = " (uncommitted files present)" -              | otherwise   = ""+makeTree :: [T.Text] -> FilePath -> IO (Either (ParseError Char Dec) RandTok)+makeTree ins filepath = do+    txt <- readFile' filepath+    let val = parseTree filepath ins txt+    pure val

@@ -10,6 +10,8 @@ import Control.Lens hiding (List, Context) import Data.Function import Data.Monoid+--+import Data.Tree  -- | datatype for a double representing a probability type Prob = Double@@ -25,6 +27,27 @@ data RandTok = List [(Prob, RandTok)] | Value T.Text     deriving (Show, Eq) +tokToTree :: RandTok -> Tree String+tokToTree (Value a) = Node (show a) []+tokToTree (List xs) = Node "++" (map (tokToTree . snd) xs)++-- | Neat 2-dimensional drawing of a parsed tree.+{--+drawTree :: Tree String -> String+drawTree  = unlines . draw+++draw :: Tree String -> [String]+draw (Node x ts0) = lines x ++ drawSubTrees ts0+  where+    drawSubTrees [] = []+    drawSubTrees [t] =+        "|" : shift "`- " "   " (draw t)+    drawSubTrees (t:ts) =+        "|" : shift "+- " "|  " (draw t) ++ drawSubTrees ts++    shift first other = zipWith (++) (first : repeat other)+--} -- | 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")])

@@ -15,19 +15,19 @@ main = hspec $ do     describe "parseTok" $ do         parallel $ it "parses a .mad string" $ do-            parseTok [] madFile `shouldParse` (List [(1.0,List [(0.5,Value "heads"),(0.5,Value "tails")])])+            parseTok "" [] madFile `shouldParse` (List [(1.0,List [(0.5,Value "heads"),(0.5,Value "tails")])])         parallel $ it "fails when quotes aren't closed" $ do-            parseTok [] `shouldFailOn` madFileFailure+            parseTok "" [] `shouldFailOn` madFileFailure         parallel $ it "parses when functions are out of order" $ do-            parseTok [] `shouldSucceedOn` madComplexFile+            parseTok "" [] `shouldSucceedOn` madComplexFile         parallel $ it "returns a correct string from the template when evaluating a token" $ do             (testIO . run) exampleTok `shouldSatisfy` (\a -> on (||) (a ==) "heads" "tails")         parallel $ it "throws exception when two `:return`s are declared" $ do-            (parseTok [] `shouldFailOn` semErrFile) `shouldThrow` semErr+            (parseTok "" [] `shouldFailOn` semErrFile) `shouldThrow` semErr         parallel $ it "substitutes a variable correctly" $ do-            parseTok ["maxine"] `shouldSucceedOn` madVar+            parseTok "" ["maxine"] `shouldSucceedOn` madVar         parallel $ it "fails when variables are not passed in" $ do-            (parseTok [] `shouldFailOn` madVar) `shouldThrow` anyException+            (parseTok "" [] `shouldFailOn` madVar) `shouldThrow` anyException  semErr :: Selector SemanticError semErr = const True