madlang 4.0.2.13 → 4.0.2.14
raw patch · 12 files changed
+76/−81 lines, 12 filesdep +filepathdep ~composition-prelude
Dependencies added: filepath
Dependency ranges changed: composition-prelude
Files
- CHANGELOG.md +4/−0
- app/Main.hs +4/−3
- app/Text/Madlibs/Packaging/Fetch.hs +7/−11
- cabal.project.local +0/−4
- madlang.cabal +15/−13
- src/Text/Madlibs/Ana/Parse.hs +13/−10
- src/Text/Madlibs/Ana/ParseUtils.hs +5/−2
- src/Text/Madlibs/Ana/Resolve.hs +10/−14
- src/Text/Madlibs/Cata/Display.hs +2/−2
- src/Text/Madlibs/Generate/TH.hs +2/−2
- src/Text/Madlibs/Internal/Types.hs +8/−6
- src/Text/Madlibs/Internal/Utils.hs +6/−14
CHANGELOG.md view
@@ -1,5 +1,9 @@ # madlang +## 4.0.2.14++ * Fix minor Windows bugs related to paths+ ## 4.0.2.13 * Update for new `megaparsec`
app/Main.hs view
@@ -10,6 +10,7 @@ import Options.Applicative hiding (ParseError) import Paths_madlang import System.Directory+import System.FilePath (pathSeparator) import Text.Madlibs import Text.Madlibs.Packaging.Fetch import Text.Megaparsec hiding (many)@@ -112,14 +113,14 @@ template :: Program -> IO () template rec = case sub rec of- Install -> fetchPackages >> cleanPackages+ Install -> fetchPackages *> cleanPackages VimInstall -> installVimPlugin Get remote -> fetchGithub remote _ -> do let toFolder = input . sub $ rec if getDir toFolder == "" then pure () else setCurrentDirectory (getDir toFolder)- let filepath = reverse . takeWhile (/='/') . reverse $ toFolder- let ins = map T.pack (clInputs . sub $ rec)+ let filepath = reverse . takeWhile (/= pathSeparator) . reverse $ toFolder+ ins = map T.pack (clInputs . sub $ rec) case sub rec of (Run reps _) -> (TL.init . TL.unlines . fmap TL.fromStrict <$> runFileN (fromMaybe 1 reps) ins filepath) >>= TLIO.putStrLn
app/Text/Madlibs/Packaging/Fetch.hs view
@@ -7,21 +7,19 @@ ) where import qualified Codec.Archive.Tar as Tar-import Codec.Archive.Zip (ZipOption (..),- extractFilesFromArchive, toArchive)+import Codec.Archive.Zip (ZipOption (..), extractFilesFromArchive, toArchive) import Codec.Compression.GZip (decompress) import Control.Monad (unless)+import Data.Foldable (traverse_) import Network.HTTP.Client hiding (decompress) import Network.HTTP.Client.TLS (tlsManagerSettings)-import System.Directory (getAppUserDataDirectory, removeFile,- renameDirectory)+import System.Directory (getAppUserDataDirectory, removeFile, renameDirectory) import System.Environment (getEnv)+import System.FilePath (pathSeparator, (</>)) import System.Info (os) --- https://hub.darcs.net/vmchale/madlang-libraries/dist- invalid :: String -> Bool-invalid = not . ('/' `elem`)+invalid = not . (pathSeparator `elem`) -- | As an example, `vmchale/some-library` would be valid input. fetchGithub :: String -> IO ()@@ -56,10 +54,8 @@ extractFilesFromArchive [options] (toArchive response) putStrLn "cleaning junk..."- removeFile (packageDir ++ "/TODO.md")- removeFile (packageDir ++ "/vim-screenshot.png")- removeFile (packageDir ++ "/README.md")- removeFile (packageDir ++ "/LICENSE")++ traverse_ removeFile [ packageDir </> "TODO.md", packageDir </> "vim-screenshot.png", packageDir </> "README.md", packageDir </> "LICENSE" ] -- TODO set remote package url flexibly fetchPackages :: IO ()
cabal.project.local view
@@ -1,6 +1,2 @@ constraints: madlang +development max-backjumps: 120000--allow-newer:- base- stm
madlang.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: madlang-version: 4.0.2.13+version: 4.0.2.14 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2016-2018 Vanessa McHale@@ -70,9 +70,10 @@ text -any, template-haskell -any, MonadRandom -any,- composition-prelude >=1.1.0.0,+ composition-prelude >=2.0.2.0, directory -any, file-embed -any,+ filepath -any, random-shuffle -any, mtl -any, ansi-wl-pprint -any,@@ -81,10 +82,10 @@ th-lift-instances -any, recursion >=1.0.0.0, binary -any- + if (flag(development) && impl(ghc <8.4)) ghc-options: -Werror- + if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities@@ -108,14 +109,15 @@ tar -any, zlib -any, zip-archive -any,- http-client-tls -any- + http-client-tls -any,+ filepath -any+ if flag(library) buildable: False- + if (flag(development) && impl(ghc <8.4)) ghc-options: -Werror- + if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities@@ -134,10 +136,10 @@ hspec -any, text -any, hspec-megaparsec -any- + if flag(development) ghc-options: -Werror- + if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities@@ -153,13 +155,13 @@ madlang -any, megaparsec -any, text -any- + if impl(ghc >=8.0) ghc-options: -Wredundant-constraints -Widentities- + if flag(development) ghc-options: -Werror- + if impl(ghc >=8.0) ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Widentities
src/Text/Madlibs/Ana/Parse.hs view
@@ -110,19 +110,19 @@ n <- name ; mod' <- many modifier ; spaceOnly ;- pure $ Name n (foldr (.) id mod')+ pure $ Name n (thread mod') } <|> do { v <- var ; mod' <- many modifier ; spaceOnly ;- pure . PreTok . foldr (.) id mod' $ ins `access` (v-1)+ pure . PreTok . thread mod' $ ins `access` (v-1) } <|> do { s <- quote (many $ noneOf ("\n\"" :: String)) ; mod' <- many modifier ; spaceOnly ;- pure . PreTok . foldr (.) id mod' . T.pack $ s+ pure . PreTok . thread mod' . T.pack $ s } <?> "string or function name" @@ -199,14 +199,17 @@ -- | Parse text as a list of functions parseTokF :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseErrorBundle T.Text Void) [(Key, RandTok)]-parseTokF filename state' ins f = flip execState (filterTemplate filename state') <$> runParser (parseTokM ins) filename f+parseTokF filename state' ins f =+ flip execState (filterTemplate filename state') <$> runParser (parseTokM ins) filename f -- | Parse text as a list of tokens, suitable for printing as a tree. parseTreeF :: FilePath -> [(Key, RandTok)] -> [T.Text] -> T.Text -> Either (ParseErrorBundle T.Text Void) [(Key, RandTok)]-parseTreeF filename state' ins f = flip execState (filterTemplate filename state') <$> runParser (parseTreeM ins) filename f+parseTreeF filename state' ins f =+ flip execState (filterTemplate filename state') <$> runParser (parseTreeM ins) filename f filterTemplate :: String -> [(T.Text, t)] -> [(T.Text, t)]-filterTemplate filename = map (\(i,j) -> if i == "Return" then (strip filename, j) else (i,j)) -- TODO fix the extras+filterTemplate filename =+ fmap (\(i,j) -> if i == "Return" then (strip filename, j) else (i,j)) -- TODO fix the extras -- | Parse text given a context --@@ -216,10 +219,10 @@ -- > f <- TIO.readFile "template.mad" -- > parseTok "filename.mad" [] [] f parseTok :: FilePath -- ^ File name to use for parse errors- -> [(Key, RandTok)] -- ^ Context, i.e. other random data paired with a key.- -> [T.Text] -- ^ list of variables to substitute into the template- -> T.Text -- ^ Actaul text to parse- -> Either (ParseErrorBundle T.Text Void) RandTok -- ^ Result+ -> [(Key, RandTok)] -- ^ Context, i.e. other random data paired with a key.+ -> [T.Text] -- ^ list of variables to substitute into the template+ -> T.Text -- ^ Actaul text to parse+ -> Either (ParseErrorBundle T.Text Void) RandTok -- ^ Result parseTok = fmap takeTemplate .*** parseTokF parseTokInternal :: FilePath
src/Text/Madlibs/Ana/ParseUtils.hs view
@@ -90,7 +90,7 @@ build [(key,pairs)] = do toks <- mapM (\(_,j) -> concatTok key (pure j)) pairs let probs = fmap fst pairs- let tok = List $ zip probs toks+ tok = List $ zip probs toks state (\s -> (tok,(key, tok):s)) build (x:xs) = do y <- build [x]@@ -109,7 +109,10 @@ maybeList Nothing = [] allDeps :: M.Map Key [(Prob, [PreTok])] -> Key -> S.Set Key-allDeps context key = let deps = (maybeList . fmap (mapMaybe maybeName) . getNames) context in S.fromList (deps <> (S.toList . allDeps context =<< deps))+allDeps context key =+ let deps = (maybeList . fmap (mapMaybe 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
src/Text/Madlibs/Ana/Resolve.hs view
@@ -7,7 +7,6 @@ , makeTree , runText , runFileN- , pathSep , cacheFile ) where @@ -17,11 +16,12 @@ import Control.Monad (replicateM, void) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Random.Class+import Data.Foldable (fold) import Data.Semigroup import qualified Data.Text as T import Data.Void import System.Directory-import System.Info (os)+import System.FilePath (dropExtension, pathSeparator, (</>)) import Text.Madlibs.Ana.Parse import Text.Madlibs.Ana.ParseUtils import Text.Madlibs.Cata.Run@@ -40,19 +40,15 @@ -- | Generate text from file with inclusions getInclusionCtx :: (MonadIO m) => Bool -> [T.Text] -> FilePath -> FilePath -> m (Either (ParseErrorBundle T.Text Void) [(Key, RandTok)]) getInclusionCtx isTree ins folder filepath = liftIO $ do- libDir <- do { pathDir <- getAppUserDataDirectory "madlang" ; pure (pathDir <> pure pathSep) }+ libDir <- do { pathDir <- getAppUserDataDirectory "madlang" ; pure (pathDir <> pure pathSeparator) } file <- catch (readFile' (folder ++ filepath)) (pure (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' <>))+ 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 (mconcat . either (pure []) id $ ctx) (folder ++ filepath))- (pure (do { pathDir <- getAppUserDataDirectory "madlang" ; parseCtx isTree ins (mconcat . either (pure []) id $ ctx) (pathDir <> [pathSep] <> folder <> filepath) }) :: IOException -> IO (Either (ParseErrorBundle T.Text Void) [(Key, RandTok)]))--pathSep :: Char-pathSep | os == "windows" = '\\'- | otherwise = '/'+ (parseCtx isTree ins (fold . either (pure []) id $ ctx) (folder ++ filepath))+ (pure (do { pathDir <- getAppUserDataDirectory "madlang" ; parseCtx isTree ins (fold . either (pure []) id $ ctx) (pathDir </> folder <> filepath) }) :: IOException -> IO (Either (ParseErrorBundle T.Text Void) [(Key, RandTok)])) filenameBytecode :: FilePath -> FilePath filenameBytecode = T.unpack . T.replace ".mad" ".mbc" . T.pack@@ -64,17 +60,17 @@ -- | 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+ -> FilePath -- ^ Path to @.mad@ file.+ -> IO T.Text -- ^ Result runFile ins toFolder = do void $ doesDirectoryExist (getDir toFolder)- let filepath = reverse . takeWhile (/= pathSep) . reverse $ toFolder+ let filepath = reverse . takeWhile (/= pathSeparator) . 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+ let filepath = reverse . takeWhile (/= pathSeparator) . reverse $ toFolder runInFolderN n ins (getDir toFolder) filepath -- | Run 'n' times.
src/Text/Madlibs/Cata/Display.hs view
@@ -19,6 +19,6 @@ -- -- > tokToTree 1.0 tok tokToTree :: Prob -> RandTok -> Tree String-tokToTree p (Value a) = Node ((take 4 . show . min 1.0) p ++ " " ++ show a) []+tokToTree p (Value a) = Node ((take 4 . show . min 1.0) p ++ " " ++ show a) [] tokToTree p (List [(_,Value a)]) = Node ((take 4 . show . min 1.0) p ++ " " ++ show a) []-tokToTree p (List xs) = Node (take 4 . show . min 1.0 $ p) (map (uncurry tokToTree) xs)+tokToTree p (List xs) = Node (take 4 . show . min 1.0 $ p) (uncurry tokToTree <$> xs)
src/Text/Madlibs/Generate/TH.hs view
@@ -17,8 +17,8 @@ import Language.Haskell.TH.Syntax (lift) import System.Directory (doesFileExist, getAppUserDataDirectory)+import System.FilePath (pathSeparator, dropExtension) import Text.Madlibs.Ana.Parse-import Text.Madlibs.Ana.Resolve (pathSep) import Text.Madlibs.Internal.Types (Key, RandTok) import Text.Madlibs.Internal.Utils import Text.Megaparsec@@ -69,7 +69,7 @@ if local then madCtx folder path else- madCtx (pathDir ++ pure pathSep) path+ madCtx (pathDir ++ pure pathSeparator) path ctx :: [FilePath] -> [[(Key, RandTok)]] -> [[(Key, RandTok)]] ctx = zipWith resolveKeys
src/Text/Madlibs/Internal/Types.hs view
@@ -35,14 +35,15 @@ instance Eq PreTok where (==) (Name a1 f1) (Name a2 f2) = a1 == a2 && (f1 . T.pack $ ['a'..'z']) == (f2 . T.pack $ ['a'..'z'])- (==) (PreTok a) (PreTok b) = a == b- (==) _ _ = False+ (==) (PreTok a) (PreTok b) = a == b+ (==) _ _ = False -- | datatype for a token returning a random string-data RandTok = List [(Prob, RandTok)] | Value T.Text- deriving (Show, Eq, Lift, Generic, Binary)+data RandTok = List [(Prob, RandTok)]+ | Value T.Text+ deriving (Show, Eq, Lift, Generic, Binary) -apply :: (T.Text -> T.Text) -> RandTok -> RandTok -- TODO make a base functor so we can map f over stuff?+apply :: (T.Text -> T.Text) -> RandTok -> RandTok apply f (Value str) = Value (f str) apply f (List l) = List $ fmap (second (apply f)) l @@ -68,7 +69,8 @@ instance (Eq a) => Eq (Context a) where (==) = on (==) (flip evalState []) -data RandTokF a = ListF [(Prob, a)] | ValueF T.Text+data RandTokF a = ListF [(Prob, a)]+ | ValueF T.Text deriving (Functor) type instance Base RandTok = RandTokF
src/Text/Madlibs/Internal/Utils.hs view
@@ -6,34 +6,26 @@ import Control.Arrow (first) import Control.Exception (IOException, catch, throw)+import Control.Monad import qualified Data.Text as T import Data.Void+import System.FilePath (pathSeparator) import Text.Madlibs.Cata.SemErr import Text.Madlibs.Internal.Types import Text.Megaparsec.Error --- | Drop file Extension-dropExtension :: FilePath -> FilePath-dropExtension = reverse . drop 1 . dropWhile (/='.') . reverse- -- | Get directory associated to a file getDir :: FilePath -> FilePath-getDir = reverse . dropWhile (/='/') . reverse--- FIXME should work on Windows---- | Function to apply a value on both arguments, e.g.------ > between .$ (char '"')-(.$) :: (a -> a -> b) -> a -> b-(.$) f x = f x x+getDir = reverse . dropWhile (/= pathSeparator) . reverse -- | Normalize pre-tokens/corresponding probabilities-normalize :: [(Prob, [PreTok])] -> [(Prob, [PreTok])]+normalize :: (Fractional a) => [(a, [PreTok])] -> [(a, [PreTok])] normalize list = fmap (first (/total)) list where total = sum . fmap fst $ list+ -- TODO: use a half-decent numerical method -- | Helper function for creating a cdf from a pdf-cdf :: [Prob] -> [Prob]+cdf :: Num a => [a] -> [a] cdf = drop 2 . scanl (+) 0 . (:) 0 -- | Show as a T.Text