madlang 3.1.1.13 → 3.1.1.18

raw patch · 10 files changed

+70/−31 lines, 10 filesdep +recursion-schemes-extPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: recursion-schemes-ext

API changes (from Hackage documentation)

Files

• cabal.project.local +1/−1
• madlang.cabal +10/−11
• man/madlang.1 +1/−1
• src/Text/Madlibs.hs +1/−0
• src/Text/Madlibs/Ana/ParseUtils.hs +6/−5
• src/Text/Madlibs/Ana/Resolve.hs +19/−4
• src/Text/Madlibs/Cata/Run.hs +18/−4
• src/Text/Madlibs/Cata/SemErr.hs +5/−1
• src/Text/Madlibs/Exec/Main.hs +4/−4
• src/Text/Madlibs/Internal/Utils.hs +5/−0

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

@@ -1,5 +1,5 @@ name:                madlang-version:             3.1.1.13+version:             3.1.1.18 synopsis:            Randomized templating language DSL description:         Madlang is a text templating language written in Haskell,                      meant to explore computational creativity and generative@@ -27,15 +27,16 @@                  , directory                  , process >= 1.4.0.0 -Flag development {-  Description: Turn on '-Werror'+Flag profile {+  Description: Build for profiling   Default: False   Manual: True } -Flag llvm-fast {-  Description: Enable build with llvm backend (produces a faster executable)+Flag development {+  Description: Turn on '-Werror'   Default: False+  Manual: True }  Flag library {@@ -69,6 +70,7 @@                      , file-embed                      , random-shuffle                      , mtl+                     , recursion-schemes-ext                      , ansi-wl-pprint                      , containers                      , titlecase >= 1.0@@ -83,7 +85,7 @@   if flag(development)     ghc-options:       -Werror   if impl(ghc >= 8.0)-    ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates+    ghc-options:       -Wincomplete-uni-patterns -Wincomplete-record-updates   ghc-options:         -Wall  executable madlang@@ -93,8 +95,8 @@     Buildable: True   hs-source-dirs:      app   main-is:             Main.hs-  if flag(llvm-fast)-    ghc-options:       -fllvm -O3 -optlo-O3 -opta-march=native -opta-mtune=native+  if flag(profile)+    ghc-options:       -rtsopts -fprof-auto -prof   if flag(development)     ghc-options:       -Werror   if impl(ghc >= 8.0)@@ -117,9 +119,6 @@     ghc-options:    -Werror   if impl(ghc >= 8.0)     ghc-options:    -Wincomplete-uni-patterns -Wincomplete-record-updates-  if flag(llvm-fast)-    ghc-options:       -fllvm -O3 -optlo-O3 -opta-march=native -opta-mtune=native-  ghc-options:      -O2   default-language: Haskell2010  test-suite madlang-test

@@ -1,4 +1,4 @@-.\" Automatically generated by Pandoc 2.0+.\" Automatically generated by Pandoc 2.0.1 .\" .TH "madlang (1)" "" "" "" "" .hy

@@ -29,6 +29,7 @@                     , makeTree                     -- * Functions and constructs for the `RandTok` data type                     , run+                    , runCata                     , runText                     , RandTok (..)                     , Key

@@ -20,6 +20,7 @@ import qualified Data.Map                    as M import           Data.Maybe                  (catMaybes) import           Data.Monoid+import qualified Data.Set                    as S import qualified Data.Text                   as T import           Data.Text.Titlecase import           System.Random.Shuffle@@ -107,9 +108,9 @@ maybeList (Just x) = x maybeList Nothing  = [] -allDeps :: [(Key, [(Prob, [PreTok])])] -> Key -> [Key]-allDeps context key = let deps = (maybeList . fmap (catMaybes . fmap maybeName) . getNames) context in deps <> (allDeps context =<< deps)-    where getNames = fmap ((=<<) snd) . lookup key+allDeps :: M.Map Key [(Prob, [PreTok])] -> Key -> S.Set Key+allDeps context key = let deps = (maybeList . fmap (catMaybes . fmap maybeName) . getNames) context in S.fromList (deps <> (S.toList . allDeps context =<< deps))+    where getNames = fmap ((=<<) snd) . M.lookup key           maybeName (Name n _) = Just n           maybeName _          = Nothing @@ -120,6 +121,6 @@     | key2 == "Return" = LT     | orderHelper key1 l2 = LT     | orderHelper key2 l1 = GT-    | key2 `elem` allDeps context key1 = GT-    | key1 `elem` allDeps context key2 = LT+    | key2 `S.member` allDeps (M.fromList context) key1 = GT+    | key1 `S.member` allDeps (M.fromList context) key2 = LT     | otherwise = EQ

@@ -6,12 +6,13 @@   , runFile   , makeTree   , runText+  , runFileN   ) where  import           Control.Arrow               (first) import           Control.Composition import           Control.Exception-import           Control.Monad               (void)+import           Control.Monad               (replicateM, void) import           Control.Monad.IO.Class      (MonadIO, liftIO) import           Control.Monad.Random.Class import           Data.Monoid@@ -39,23 +40,37 @@ getInclusionCtx :: (MonadIO m) => Bool -> [T.Text] -> FilePath -> FilePath -> m (Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)]) getInclusionCtx isTree ins folder filepath = liftIO $ do     libDir <- do { home <- getEnv "HOME" ; if os /= home then pure (home <> "/.madlang/") else pure (home <> "\\.madlang\\") }-    file <- catch (readFile' (folder ++ filepath)) (const (readFile' (libDir <> folder <> filepath)) :: IOException -> IO T.Text)+    file <- catch (readFile' (folder ++ filepath)) (const (readLibFile (libDir <> 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' = fmap (first (((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 (ErrorFancy Void)) [(Key, RandTok)]))+        (const (do { home <- getEnv "HOME" ; parseCtx isTree ins (concat . either (const []) id $ ctx) (home <> (pathSep : ".madlang") <> [pathSep] <> folder <> filepath) }) :: IOException -> IO (Either (ParseError Char (ErrorFancy Void)) [(Key, RandTok)])) +pathSep :: Char+pathSep | os == "windows" = '\\'+        | otherwise = '/'+ -- | 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     void $ doesDirectoryExist (getDir toFolder)-    let filepath = reverse . takeWhile (/= '/') . reverse $ toFolder+    let filepath = reverse . takeWhile (/= pathSep) . reverse $ toFolder     runInFolder ins (getDir toFolder) filepath++runFileN :: Int -> [T.Text] -> FilePath -> IO [T.Text]+runFileN n ins toFolder = do+    void $ doesDirectoryExist (getDir toFolder)+    let filepath = reverse . takeWhile (/= pathSep) . reverse $ toFolder+    runInFolderN n ins (getDir toFolder) filepath++-- | Run 'n' times.+runInFolderN :: Int -> [T.Text] -> FilePath -> FilePath -> IO [T.Text]+runInFolderN n = replicateM n .** runInFolder  -- | Run in the appropriate folder runInFolder :: [T.Text] -> FilePath -> FilePath -> IO T.Text

@@ -1,8 +1,10 @@ -- | Module containing functions to get `Text` from `RandTok`-module Text.Madlibs.Cata.Run (run) where+module Text.Madlibs.Cata.Run ( run+                             , runCata ) where  import           Control.Monad.Random.Class-import qualified Data.Text                   as T+import           Data.Functor.Foldable.Exotic (cataM)+import qualified Data.Text                    as T import           Text.Madlibs.Internal.Types import           Text.Madlibs.Internal.Utils @@ -23,7 +25,19 @@         tokNest@List{} -> run tokNest run (Value txt) = pure txt +-- | Same thing, but uses a catamorphism (slower)+runCata :: (MonadRandom m) => RandTok -> m T.Text+runCata = cataM alg where+    alg (ListF tok) = do+        value <- getRandomR (0,1)+        pure $ ((snd . head) . filter ((>= value) . fst)) $ mkCdfCata tok+    alg (ValueF txt) = pure txt+ -- | Helper function to compute the cdf when we have a pdf-mkCdf :: RandTok -> [(Double, RandTok)]-mkCdf (List rs) = zip (cdf . map fst $ rs) (map snd rs)+mkCdf :: RandTok -> [(Prob, RandTok)]+mkCdf (List rs) = zip (cdf . fmap fst $ rs) (fmap snd rs) mkCdf v@Value{} = [(1, v)]++-- | Another helper function, this time for use with our catamorphism.+mkCdfCata :: [(Prob, T.Text)] -> [(Prob, T.Text)]+mkCdfCata rs = zip (cdf . fmap fst $ rs) (fmap snd rs)

@@ -22,7 +22,7 @@ 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+data SemanticError = NoReturn | CircularFunctionCalls T.Text T.Text | InsufficientArgs Int Int | DoubleDefinition T.Text | NoContext T.Text | ImportNotFound FilePath     deriving (Typeable)  -- | display a `SemanticError` nicely with coloration & whatnot@@ -53,6 +53,10 @@         <> (text . show $ i)         <> ", expected at least "         <> (text . show $ j)+    show (ImportNotFound p) = show $+        semErrStart+        <> text "Import file not found: "+        </> indent 4 (yellow $ text p)  -- | Derived via our show instance; instance Exception SemanticError where

@@ -2,11 +2,11 @@ module Text.Madlibs.Exec.Main (     runMadlang ) where -import           Control.Monad import           Data.Maybe import           Data.Monoid import qualified Data.Text                    as T-import qualified Data.Text.IO                 as TIO+import qualified Data.Text.Lazy               as TL+import qualified Data.Text.Lazy.IO            as TLIO import           Data.Version import           Options.Applicative          hiding (ParseError) import           Paths_madlang@@ -129,9 +129,9 @@             let ins = map T.pack (clInputs . sub $ rec)             case sub rec of                 (Run reps _ _) ->-                    replicateM_ (fromMaybe 1 reps) $ runFile ins filepath >>= TIO.putStrLn+                    (TL.init . TL.unlines . fmap TL.fromStrict <$> runFileN (fromMaybe 1 reps) ins filepath) >>= TLIO.putStrLn                 (Sample _ _) ->-                    replicateM_ 60 $ runFile ins filepath >>= TIO.putStrLn+                    (TL.init . TL.unlines . fmap TL.fromStrict <$> runFileN 60 ins filepath) >>= TLIO.putStrLn                 (Debug _) -> putStr . (either show displayTree) =<< makeTree ins "" filepath                 (Lint _ _) -> do                     parsed <- parseFile ins "" filepath

@@ -6,8 +6,10 @@ module Text.Madlibs.Internal.Utils where  import           Control.Arrow               (first)+import           Control.Exception           (IOException, catch, throw) import qualified Data.Text                   as T import           Data.Void+import           Text.Madlibs.Cata.SemErr import           Text.Madlibs.Internal.Types import           Text.Megaparsec.Error @@ -46,6 +48,9 @@ unTok :: PreTok -> T.Text unTok PreTok{}     = "" unTok (Name txt _) = txt++readLibFile :: FilePath -> IO T.Text+readLibFile path = catch (fmap T.pack . readFile $ path) (throw (ImportNotFound path) :: IOException -> IO T.Text)  -- | Read a file in as a `Text` readFile' :: FilePath -> IO T.Text