Moves code that is marked with .top to the beginning of the file

Author: sol

src/Text/Markdown/Unlit.hs

@@ -1,4 +1,7 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns #-}
 module Text.Markdown.Unlit (
@@ -9,19 +12,22 @@ module Text.Markdown.Unlit (
 , 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 = ['`', '~']
@@ -43,7 +49,7 @@ run args =
   -- #line 1 "label"
   --
   case break (== "-h") args of
-    (mkSelector -> selector, "-h" : foo) -> case foo of
+    (mkSelector -> selector, "-h" : files) -> case files of
       [src, cur, dst] -> do
         readFileUtf8 cur >>= writeFileUtf8 dst . unlit src selector
       [src] -> do
@@ -70,20 +76,48 @@ run args =
       writeUtf8 handle str = hSetEncoding handle utf8 >> hPutStr handle str
 
 unlit :: FilePath -> Selector -> String -> String
-unlit src 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 src) : 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

@@ -34,36 +34,72 @@ spec = do
     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
       parseSelector "foo+bar+baz" `shouldBe` Just ("foo" :&: "bar" :&: "baz")