diff --git a/cabal.project.local b/cabal.project.local --- a/cabal.project.local +++ b/cabal.project.local @@ -1,3 +1,3 @@ with-compiler: ghc-8.2.1 -optimization: 2 +optimization: 1 constraints: madlang +development diff --git a/madlang.cabal b/madlang.cabal --- a/madlang.cabal +++ b/madlang.cabal @@ -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 diff --git a/man/madlang.1 b/man/madlang.1 --- a/man/madlang.1 +++ b/man/madlang.1 @@ -1,4 +1,4 @@ -.\" Automatically generated by Pandoc 2.0 +.\" Automatically generated by Pandoc 2.0.1 .\" .TH "madlang (1)" "" "" "" "" .hy diff --git a/src/Text/Madlibs.hs b/src/Text/Madlibs.hs --- a/src/Text/Madlibs.hs +++ b/src/Text/Madlibs.hs @@ -29,6 +29,7 @@ , makeTree -- * Functions and constructs for the `RandTok` data type , run + , runCata , runText , RandTok (..) , Key diff --git a/src/Text/Madlibs/Ana/ParseUtils.hs b/src/Text/Madlibs/Ana/ParseUtils.hs --- a/src/Text/Madlibs/Ana/ParseUtils.hs +++ b/src/Text/Madlibs/Ana/ParseUtils.hs @@ -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 diff --git a/src/Text/Madlibs/Ana/Resolve.hs b/src/Text/Madlibs/Ana/Resolve.hs --- a/src/Text/Madlibs/Ana/Resolve.hs +++ b/src/Text/Madlibs/Ana/Resolve.hs @@ -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 diff --git a/src/Text/Madlibs/Cata/Run.hs b/src/Text/Madlibs/Cata/Run.hs --- a/src/Text/Madlibs/Cata/Run.hs +++ b/src/Text/Madlibs/Cata/Run.hs @@ -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) diff --git a/src/Text/Madlibs/Cata/SemErr.hs b/src/Text/Madlibs/Cata/SemErr.hs --- a/src/Text/Madlibs/Cata/SemErr.hs +++ b/src/Text/Madlibs/Cata/SemErr.hs @@ -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 diff --git a/src/Text/Madlibs/Exec/Main.hs b/src/Text/Madlibs/Exec/Main.hs --- a/src/Text/Madlibs/Exec/Main.hs +++ b/src/Text/Madlibs/Exec/Main.hs @@ -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 diff --git a/src/Text/Madlibs/Internal/Utils.hs b/src/Text/Madlibs/Internal/Utils.hs --- a/src/Text/Madlibs/Internal/Utils.hs +++ b/src/Text/Madlibs/Internal/Utils.hs @@ -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