markdown-unlit 0.4.1 → 0.6.0
raw patch · 4 files changed
Files
- LICENSE +1/−1
- markdown-unlit.cabal +9/−8
- src/Text/Markdown/Unlit.hs +69/−18
- test/Text/Markdown/UnlitSpec.hs +47/−11
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2012-2015 Simon Hengel <sol@typeful.net>+Copyright (c) 2012-2021 Simon Hengel <sol@typeful.net> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
markdown-unlit.cabal view
@@ -1,22 +1,21 @@--- This file has been generated from package.yaml by hpack version 0.21.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack------ hash: 1ed9462425c5de84a4149bff9c95c17ee3c2c60b718cb4673c63fae99d454686 name: markdown-unlit-version: 0.4.1+version: 0.6.0 synopsis: Literate Haskell support for Markdown category: Development homepage: https://github.com/sol/markdown-unlit#readme bug-reports: https://github.com/sol/markdown-unlit/issues license: MIT license-file: LICENSE-copyright: (c) 2012-2015 Simon Hengel+copyright: (c) 2012-2021 Simon Hengel author: Simon Hengel <sol@typeful.net> maintainer: Simon Hengel <sol@typeful.net> build-type: Simple-cabal-version: >= 1.10 description: Documentation is here: <https://github.com/sol/markdown-unlit#readme> source-repository head@@ -53,10 +52,12 @@ type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs:- src test+ src ghc-options: -Wall cpp-options: -DTEST+ build-tool-depends:+ hspec-discover:hspec-discover build-depends: QuickCheck , base ==4.*@@ -67,7 +68,7 @@ , stringbuilder , temporary other-modules:- Text.Markdown.Unlit Text.Markdown.UnlitSpec+ Text.Markdown.Unlit Paths_markdown_unlit default-language: Haskell2010
src/Text/Markdown/Unlit.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-} module Text.Markdown.Unlit ( run , unlit@@ -7,19 +12,22 @@ , CodeBlock (..) , parse #ifdef TEST+, parseReorderingKey , parseClasses #endif ) where import Prelude () import Prelude.Compat-import Data.Maybe-import Data.List.Compat+import Control.Arrow import Data.Char+import Data.List.Compat+import Data.Maybe import Data.String-import System.IO-import System.Exit import System.Environment+import System.Exit+import System.IO+import Text.Read fenceChars :: [Char] fenceChars = ['`', '~']@@ -41,31 +49,74 @@ -- #line 1 "label" -- case break (== "-h") args of- (xs, ["-h", fileName, infile, outfile]) ->- fmap (unlit fileName $ mkSelector xs) (readFileUtf8 infile) >>= writeFileUtf8 outfile- _ -> do- name <- getProgName- hPutStrLn stderr ("usage: " ++ name ++ " [selector] -h label infile outfile")- exitFailure+ (mkSelector -> selector, "-h" : files) -> case files of+ [src, cur, dst] -> do+ readFileUtf8 cur >>= writeFileUtf8 dst . unlit src selector+ [src] -> do+ readFileUtf8 src >>= writeUtf8 stdout . unlit src selector+ _ -> usage+ _ -> usage where+ usage :: IO ()+ usage = do+ name <- getProgName+ hPutStrLn stderr ("usage: " ++ name ++ " [selector] -h SRC CUR DST")+ exitFailure++ mkSelector :: [String] -> Selector mkSelector = fromMaybe ("haskell" :&: Not "ignore") . parseSelector . unwords- readFileUtf8 name = openFile name ReadMode >>= \h -> hSetEncoding h utf8 >> hGetContents h- writeFileUtf8 name str = withFile name WriteMode (\h -> hSetEncoding h utf8 >> hPutStr h str) + readFileUtf8 :: FilePath -> IO String+ readFileUtf8 name = openFile name ReadMode >>= \ handle -> hSetEncoding handle utf8 >> hGetContents handle++ writeFileUtf8 :: FilePath -> String -> IO ()+ writeFileUtf8 name str = withFile name WriteMode $ \ handle -> writeUtf8 handle str++ writeUtf8 :: Handle -> String -> IO ()+ writeUtf8 handle str = hSetEncoding handle utf8 >> hPutStr handle str+ unlit :: FilePath -> Selector -> String -> String-unlit fileName selector = unlines . concatMap formatCB . filter (toP selector . codeBlockClasses) . parse+unlit src selector = unlines . concatMap formatCodeBlock . sortCodeBlocks . filter (toPredicate selector . codeBlockClasses) . parse where- formatCB :: CodeBlock -> [String]- formatCB cb = ("#line " ++ show (codeBlockStartLine cb) ++ " " ++ show fileName) : codeBlockContent cb+ formatCodeBlock :: CodeBlock -> [String]+ formatCodeBlock cb = ("#line " ++ show (codeBlockStartLine cb) ++ " " ++ show src) : codeBlockContent cb - toP :: Selector -> [String] -> Bool- toP = go+ sortCodeBlocks :: [CodeBlock] -> [CodeBlock]+ sortCodeBlocks = map fst . sortOn snd . addSortKey where+ addSortKey :: [CodeBlock] -> [(CodeBlock, (ReorderingKey, DeclarationOrder))]+ addSortKey = zipWith ((id &&&) . sortKey) [0..]++ sortKey :: a -> CodeBlock -> (ReorderingKey, a)+ sortKey n code = (reorderingKey code, n)++ toPredicate :: Selector -> [String] -> Bool+ toPredicate = go+ where go s = case s of Class c -> elem c Not p -> not . go p a :&: b -> (&&) <$> go a <*> go b a :|: b -> (||) <$> go a <*> go b++newtype DeclarationOrder = DeclarationOrder Int+ deriving newtype (Eq, Ord, Enum, Num)++newtype ReorderingKey = ReorderingKey Int+ deriving newtype (Eq, Show, Read, Ord, Bounded, Num)++reorderingKey :: CodeBlock -> ReorderingKey+reorderingKey = parseReorderingKey . codeBlockClasses++parseReorderingKey :: [String] -> ReorderingKey+parseReorderingKey = go+ where+ go :: [String] -> ReorderingKey+ go = \ case+ [] -> 0+ "top" : _ -> minBound+ ('t' : 'o' : 'p' : ':' : (readMaybe -> Just n)) : _ -> minBound + n+ _ : classes -> go classes infixr 3 :&: infixr 2 :|:
test/Text/Markdown/UnlitSpec.hs view
@@ -29,40 +29,76 @@ it "prints a usage message" $ do withProgName "foo" $ do (r, Left (ExitFailure 1)) <- hCapture [stderr] (try $ run [])- r `shouldBe` "usage: foo [selector] -h label infile outfile\n"+ r `shouldBe` "usage: foo [selector] -h SRC CUR DST\n" it "unlits code marked with .haskell by default (unless it is marked with .ignore as well)" $ do withTempFile $ \infile -> withTempFile $ \outfile -> do writeFile infile . build $ do- "~~~ {.haskell}"+ "```haskell" "some code"-- "~~~"- "~~~ {.haskell .ignore}"+ "```"+ "```haskell ignore" "some other code"-- "~~~"+ "```" run ["-h", "Foo.lhs", infile, outfile] readFile outfile `shouldReturn` (build $ do "#line 2 \"Foo.lhs\"" "some code" ) + it "moves code that is marked with .top to the beginning of the file" $ do+ withTempFile $ \infile -> withTempFile $ \outfile -> do+ writeFile infile . build $ do+ "```haskell top"+ "module Foo where"+ "```"+ ""+ "```haskell"+ "foo :: Int"+ "foo = 23"+ "```"+ ""+ "```haskell top"+ "import Bar"+ "```"+ run ["-h", "Foo.lhs", infile, outfile]+ readFile outfile `shouldReturn` (build $ do+ "#line 2 \"Foo.lhs\""+ "module Foo where"+ "#line 11 \"Foo.lhs\""+ "import Bar"+ "#line 6 \"Foo.lhs\""+ "foo :: Int"+ "foo = 23"+ )+ it "can be customized" $ do withTempFile $ \infile -> withTempFile $ \outfile -> do writeFile infile . build $ do- "~~~ {.foo}"+ "```foo" "some code" ""- "~~~"- "~~~ {.bar}"+ "```"+ "``` {.bar}" "some other code"- "~~~"+ "```" run ["bar", "-h", "Foo.lhs", infile, outfile] readFile outfile `shouldReturn` (build $ do "#line 6 \"Foo.lhs\"" "some other code" )++ describe "parseReorderingKey" $ do+ it "returns 0" $ do+ parseReorderingKey [] `shouldBe` 0++ context "with .top" $ do+ it "returns minBound" $ do+ parseReorderingKey ["top"] `shouldBe` minBound++ context "with top:n" $ do+ it "returns (minBound + n)" $ do+ parseReorderingKey ["top:20"] `shouldBe` minBound + 20 describe "parseSelector" $ do it "parses + as :&:" $ do