diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -9,8 +9,8 @@ main = do file <- TIO.readFile "test/templates/fortune-teller.mad" - file2 <- TIO.readFile "bench/templates/magical-realism.mad" + file2 <- TIO.readFile "demo/shakespeare.mad" defaultMain [ bgroup "parseFile" [ bench "fortune-teller" $ whnf fun file - , bench "magical-realism" $ whnf fun file2 ] + , bench "shakespeare" $ whnf fun file2 ] ] diff --git a/bench/templates/magical-realism.mad b/bench/templates/magical-realism.mad deleted file mode 100644 --- a/bench/templates/magical-realism.mad +++ /dev/null @@ -1,38 +0,0 @@ -:define nationality - 1.0 "Hungarian" - 1.0 "Japanese" - 1.0 "Bhutanese" - 1.0 "Spainish" - 1.0 "American" - -:define location - 1.0 "the Basque country" - 1.0 "a Bön monastery" - 1.0 "America" - 1.0 "Saint Petersburg" - 0.5 "the old country" - -:define subject - 1.0 "A princess " - 1.0 "A frog " - 1.0 "A " nationality " professor " - -:define gnomic - 1.0 "That is all." - 1.0 "And so it was written." - 1.0 "The day went on forever." - -:define predicate - 1.0 "invents " object - 3.0 "discovers " object - 1.0 "sleeps" - -:define object - 1.0 "memories" - 1.0 "a ziggurat" - 1.0 "the global financial system" - -:return - 3.0 subject predicate " in " location "." - 5.0 subject predicate "." - 1.0 subject predicate ". " gnomic diff --git a/default.nix b/default.nix new file mode 100644 --- /dev/null +++ b/default.nix @@ -0,0 +1,22 @@ +{ mkDerivation, ansi-wl-pprint, base, composition, containers +, directory, hspec, hspec-megaparsec, megaparsec, microlens, mtl +, mwc-random, optparse-applicative, random-shuffle, stdenv, text +}: +mkDerivation { + pname = "madlang"; + version = "2.1.1.0"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + ansi-wl-pprint base composition containers directory megaparsec + microlens mtl mwc-random optparse-applicative random-shuffle text + ]; + executableHaskellDepends = [ base ]; + testHaskellDepends = [ + base hspec hspec-megaparsec megaparsec mtl text + ]; + homepage = "https://github.com/vmchale/madlang#readme"; + description = "Randomized templating language DSL"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/demo/shakespeare.mad b/demo/shakespeare.mad new file mode 100644 --- /dev/null +++ b/demo/shakespeare.mad @@ -0,0 +1,156 @@ +:define adjective + 1.0 "artless" + 1.0 "base-court" + 1.0 "bawdy" + 1.0 "bat-fowling" + 1.0 "beslubbering" + 1.0 "beef-witted" + 1.0 "bootless" + 1.0 "beetle-headed" + 1.0 "churlish" + 1.0 "boil-brained" + 1.0 "cockered" + 1.0 "clapper-clawed" + 1.0 "clouted" + 1.0 "clay-brained" + 1.0 "craven" + 1.0 "common-kissing" + 1.0 "currish" + 1.0 "crook-pated" + 1.0 "dankish" + 1.0 "dismal-dreaming" + 1.0 "dissembling" + 1.0 "dizzy-eyed" + 1.0 "droning" + 1.0 "doghearted" + 1.0 "errant" + 1.0 "dread-bolted" + 1.0 "fawning" + 1.0 "earth-vexing" + 1.0 "fobbing" + 1.0 "elf-skinned" + 1.0 "froward" + 1.0 "fat-kidneyed" + 1.0 "frothy" + 1.0 "fen-sucked" + 1.0 "gleeking" + 1.0 "flap-mouthed" + 1.0 "goatish" + 1.0 "fly-bitten" + 1.0 "gorbellied" + 1.0 "folly-fallen" + 1.0 "impertinent" + 1.0 "fool-born" + 1.0 "infectious" + 1.0 "full-gorged" + 1.0 "jarring" + 1.0 "guts-griping" + 1.0 "loggerheaded" + 1.0 "half-faced" + 1.0 "lumpish" + 1.0 "hasty-witted" + 1.0 "mammering" + 1.0 "hedge-born" + 1.0 "mangled" + 1.0 "hell-hated" + 1.0 "mewling" + 1.0 "idle-headed" + 1.0 "paunchy" + 1.0 "ill-breeding" + 1.0 "pribbling" + 1.0 "ill-nurtured" + 1.0 "puking" + 1.0 "knotty-pated" + 1.0 "puny" + 1.0 "milk-livered" + 1.0 "qualling" + 1.0 "motley-minded" + 1.0 "rank" + 1.0 "onion-eyed" + 1.0 "reeky" + 1.0 "plume-plucked" + 1.0 "roguish" + 1.0 "pottle-deep" + 1.0 "ruttish" + 1.0 "pox-marked" + 1.0 "saucy" + 1.0 "reeling-ripe" + 1.0 "spleeny" + 1.0 "rough-hewn" + 1.0 "spongy" + 1.0 "rude-growing" + 1.0 "surly" + 1.0 "rump-fed" + 1.0 "tottering" + 1.0 "shard-borne" + 1.0 "unmuzzled" + 1.0 "sheep-biting" + 1.0 "vain" + 1.0 "spur-galled" + 1.0 "venomed" + 1.0 "swag-bellied" + 1.0 "villainous" + 1.0 "tardy-gaited" + 1.0 "warped" + 1.0 "tickle-brained" + 1.0 "wayward" + 1.0 "toad-spotted" + 1.0 "weedy" + 1.0 "unchin-snouted" + 1.0 "yeasty" + 1.0 "weather-bitten" + +:define noun + 1.0 "apple-john" + 1.0 "baggage" + 1.0 "barnacle" + 1.0 "bladder" + 1.0 "boar-pig" + 1.0 "bugbear" + 1.0 "bum-bailey" + 1.0 "canker-blossom" + 1.0 "clack-dish" + 1.0 "clotpole" + 1.0 "coxcomb" + 1.0 "codpiece" + 1.0 "death-token" + 1.0 "dewberry" + 1.0 "flap-dragon" + 1.0 "flax-wench" + 1.0 "flirt-gill" + 1.0 "foot-licker" + 1.0 "fustilarian" + 1.0 "giglet" + 1.0 "gudgeon" + 1.0 "haggard" + 1.0 "harpy" + 1.0 "hedge-pig" + 1.0 "horn-beast" + 1.0 "hugger-mugger" + 1.0 "joithead" + 1.0 "lewdster" + 1.0 "lout" + 1.0 "maggot-pie" + 1.0 "malt-worm" + 1.0 "mammet" + 1.0 "measle" + 1.0 "minnow" + 1.0 "miscreant" + 1.0 "moldwarp" + 1.0 "mumble-news" + 1.0 "nut-hook" + 1.0 "pigeon-egg" + 1.0 "pignut" + 1.0 "puttock" + 1.0 "pumpion" + 1.0 "ratsbane" + 1.0 "scut" + 1.0 "skainsmate" + 1.0 "strumpet" + 1.0 "varlot" + 1.0 "vassal" + 1.0 "whey-face" + 1.0 "wagtail" + +:return + 1.0 "Thou " adjective " " adjective " " noun "!" diff --git a/madlang.cabal b/madlang.cabal --- a/madlang.cabal +++ b/madlang.cabal @@ -1,5 +1,5 @@ name: madlang -version: 2.1.1.0 +version: 2.1.1.1 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -22,7 +22,9 @@ test/templates/include.mad test/templates/modifiers.mad test/templates/err/*.mad - bench/templates/*.mad + demo/shakespeare.mad + default.nix + release.nix stack.yaml bash/mkCompletions @@ -46,15 +48,13 @@ composition >=1.0.2.1 && <1.1, directory >=1.3.0.0 && <1.4, mwc-random >=0.13.5.0 && <0.14, - template-haskell >=2.11.1.0 && <2.12, + random-shuffle >=0.0.4 && <0.1, microlens >=0.4.8.0 && <0.5, mtl >=2.2.1 && <2.3, ansi-wl-pprint >=0.6.7.3 && <0.7, - containers >=0.5.7.1 && <0.6, - tibetan-utils >=0.1.1.2 && <0.2 + containers >=0.5.7.1 && <0.6 default-language: Haskell2010 default-extensions: OverloadedStrings DeriveGeneric DeriveFunctor - DeriveAnyClass hs-source-dirs: src other-modules: Text.Madlibs.Ana.ParseUtils @@ -75,7 +75,7 @@ main-is: Main.hs build-depends: base >=4.9.1.0 && <4.10, - madlang >=2.1.1.0 && <2.2 + madlang >=2.1.1.1 && <2.2 default-language: Haskell2010 hs-source-dirs: app @@ -84,7 +84,7 @@ main-is: Spec.hs build-depends: base >=4.9.1.0 && <4.10, - madlang >=2.1.1.0 && <2.2, + madlang >=2.1.1.1 && <2.2, hspec >=2.4.3 && <2.5, megaparsec >=5.2.0 && <5.3, text >=1.2.2.1 && <1.3, @@ -105,7 +105,7 @@ build-depends: base >=4.9.1.0 && <4.10, criterion >=1.1.4.0 && <1.2, - madlang >=2.1.1.0 && <2.2, + madlang >=2.1.1.1 && <2.2, megaparsec >=5.2.0 && <5.3, text >=1.2.2.1 && <1.3 default-language: Haskell2010 diff --git a/release.nix b/release.nix new file mode 100644 --- /dev/null +++ b/release.nix @@ -0,0 +1,5 @@ +let + pkgs = import { }; + +in + pkgs.haskell.lib.justStaticExecutables (pkgs.haskellPackages.callPackage ./default.nix { }) diff --git a/src/Text/Madlibs/Ana/Parse.hs b/src/Text/Madlibs/Ana/Parse.hs --- a/src/Text/Madlibs/Ana/Parse.hs +++ b/src/Text/Madlibs/Ana/Parse.hs @@ -15,7 +15,6 @@ import qualified Data.Map as M import Control.Monad.State import Control.Exception hiding (try) -import Data.Char import Data.Composition -- | Parse a lexeme, aka deal with whitespace nicely. @@ -81,28 +80,28 @@ modifier :: Parser (T.Text -> T.Text) modifier = do char '.' - str <- try (string "to_upper") <|> (string "to_lower") - let modifiers = M.fromList [("to_upper", T.map toUpper), ("to_lower", T.map toLower)] in - pure $ maybe id id (M.lookup str modifiers) + str <- try (string "to_upper") <|> (string "to_lower") + pure $ maybe id id (M.lookup str modifierList) -- | Parse template into a `PreTok` of referents and strings preStr :: [T.Text] -> Parser PreTok preStr ins = do { n <- name ; - mod <- optional $ modifier ; + mod <- many $ modifier ; spaceConsumer ; - pure $ Name (T.pack n) (maybe id id mod) + pure $ Name (T.pack n) (foldr (.) id mod) } <|> do { v <- var ; + mod <- many $ modifier ; spaceConsumer ; - pure . PreTok $ 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 <- optional $ modifier ; + mod <- many $ modifier ; -- TODO: parse many via a fold? spaceConsumer ; - pure $ PreTok . (maybe id id mod) . T.pack $ s + pure . PreTok . (foldr (.) id mod) . T.pack $ s } "string or function name" 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 @@ -10,9 +10,18 @@ import Data.Foldable import Control.Exception import Control.Arrow +import System.Random.Shuffle +import qualified Data.Map as M +import Data.Char --TODO consider moving Ana.ParseUtils to Cata.Sorting +modifierList :: M.Map String (T.Text -> T.Text) +modifierList = M.fromList [("to_upper", T.map toUpper), ("to_lower", T.map toLower)] + +jumble :: T.Text -> IO T.Text +jumble = (fmap (T.pack . unwords)) . shuffleM . words . T.unpack + strip = T.pack . reverse . drop 4 . reverse -- | Get the :return value @@ -33,7 +42,7 @@ 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 -- TODO use modifier alongside name? + 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 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 @@ -34,6 +34,9 @@ runInFolder :: [T.Text] -> FilePath -> FilePath -> IO T.Text runInFolder = ((either (pure . parseErrorPretty') (>>= (pure . show'))) =<<) .** (fmap (fmap run) .** parseFile) +runText :: [T.Text] -> String -> T.Text -> IO T.Text +runText vars name txt = (either (pure . parseErrorPretty') id) . (fmap run) $ (parseTok name [] vars txt) + -- | Get file as context parseCtx :: Bool -> [T.Text] -> [(Key, RandTok)] -> FilePath -> IO (Either (ParseError Char Dec) [(Key, RandTok)]) parseCtx isTree ins state filepath = do 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 @@ -18,7 +18,7 @@ -- | display a `SemanticError` nicely with coloration & whatnot instance Show SemanticError where - show OverloadedReturns = show $ semErrStart <> text "File contains multiple declarations of :return" + show OverloadedReturns = show $ semErrStart <> text "File must contain exactly one declaration 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) @@ -52,7 +52,7 @@ -- | 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? -- | helper to filter out stuff that doesn't sumProb :: [(Prob, [PreTok])] -> Bool diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: nightly-2017-04-10 +resolver: lts-8.11 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -39,8 +39,8 @@ -- file <- madFileTibetan -- parseTok "" [] file `shouldParse` (List [(1.0,List [(0.5,Value "heads"),(0.5,Value "tails")])]) describe "runFile" $ do - parallel $ it "parses nested modifiers correctly" $ \file -> do - runFile [] "test/templates/modifiers.mad" >>= (`shouldSatisfy` (\a -> any (a==) ["AAAaaa","AAAaa","AAaaa","AAaa"])) + parallel $ it "parses nested modifiers and modifiers on variables correctly" $ \file -> 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 runFile [] "test/templates/include.mad" >>= (`shouldSatisfy` (\a -> any (a==) ["heads","tails","on its side"])) parallel $ it "runs on a file out of order" $ \file -> do diff --git a/test/templates/gambling.mad b/test/templates/gambling.mad --- a/test/templates/gambling.mad +++ b/test/templates/gambling.mad @@ -1,5 +1,5 @@ :define something - 0.5 "heads".to_upper + 0.5 "heads".to_upper.to_upper 0.5 "tailS".to_lower :return 1.0 something diff --git a/test/templates/modifiers.mad b/test/templates/modifiers.mad --- a/test/templates/modifiers.mad +++ b/test/templates/modifiers.mad @@ -1,7 +1,8 @@ :define scream 1.0 "aaa".to_upper 1.0 "aa".to_upper + 1.0 $1.to_upper :define sedated - 1.0 scream.to_lower + 1.0 scream.to_lower.to_upper.to_lower :return 1.0 scream sedated