diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012-2015 Simon Hengel +Copyright (c) 2012-2021 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/markdown-unlit.cabal b/markdown-unlit.cabal --- a/markdown-unlit.cabal +++ b/markdown-unlit.cabal @@ -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 maintainer: Simon Hengel build-type: Simple -cabal-version: >= 1.10 description: Documentation is here: 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 diff --git a/src/Text/Markdown/Unlit.hs b/src/Text/Markdown/Unlit.hs --- a/src/Text/Markdown/Unlit.hs +++ b/src/Text/Markdown/Unlit.hs @@ -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 :|: diff --git a/test/Text/Markdown/UnlitSpec.hs b/test/Text/Markdown/UnlitSpec.hs --- a/test/Text/Markdown/UnlitSpec.hs +++ b/test/Text/Markdown/UnlitSpec.hs @@ -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