replace ad-hoc fenced parser with state machine

1 files changed, 233 insertions, 72 deletions

diff --git a/src/MdBlocks/Parser.hs b/src/MdBlocks/Parser.hs
index f2f184d..b5ca193 100644
--- a/src/MdBlocks/Parser.hs
+++ b/src/MdBlocks/Parser.hs
@@ -1,95 +1,256 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module MdBlocks.Parser where
+module MdBlocks.Parser
+  ( parseFile
+  )
+where
 
-import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Text (Text)
 
 import MdBlocks.Metadata
 import MdBlocks.Types
 
-parseFile :: FilePath -> Text -> [Block]
+
+data State
+  = Normal
+  | InFence FenceState
+  | InIndented IndentedState
+
+data FenceState = FenceState
+  { fsStartLine :: !Int
+  , fsFenceTok  :: !Text
+  , fsHeader    :: !Text
+  , fsLines     :: [Text]
+  }
+
+data IndentedState = IndentedState
+  { isStartLine :: !Int
+  , isLines     :: [Text]
+  }
+
+data ParseState = ParseState
+  { psFile   :: FilePath
+  , psMode   :: State
+  , psBlocks :: [Block]
+  }
+
+
+parseFile
+  :: FilePath
+  -> Text
+  -> [Block]
 parseFile fp txt =
-  numberBlocks $
-      parseFenced fp ls
-   ++ parseIndented fp ls
+    assignNumbers
+  $ finalize
+  $ foldl step initial numbered
   where
-    ls = zip [1..] (T.lines txt)
+    numbered =
+      zip [1..] (T.lines txt)
 
-numberBlocks :: [Block] -> [Block]
-numberBlocks =
-  zipWith (\n b -> b { blockNumber = n }) [1..]
+    initial =
+      ParseState
+        { psFile = fp
+        , psMode = Normal
+        , psBlocks = []
+        }
 
-parseFenced :: FilePath -> [(Int,Text)] -> [Block]
-parseFenced fp =
-    go False 0 "" []
-  where
-    go _ _ _ acc [] = reverse acc
 
-    go False _ _ acc ((ln,t):xs)
-      | "```" `T.isPrefixOf` T.stripStart t =
-          go True ln t acc xs
-      | otherwise =
-          go False 0 "" acc xs
+assignNumbers :: [Block] -> [Block]
+assignNumbers =
+  zipWith
+    (\n b -> b { blockNumber = n })
+    [1..]
+
+
+isIndented :: Text -> Bool
+isIndented =
+  ("    " `T.isPrefixOf`)
+
+stripIndent :: Text -> Text
+stripIndent =
+  T.drop 4
+
+
+fenceStart :: Text -> Maybe (Text, Text)
+fenceStart line =
+  let s = T.stripStart line
+  in if "```" `T.isPrefixOf` s
+       then Just ("```", T.drop 3 s)
+       else Nothing
+
+
+fenceEnd :: Text -> Text -> Bool
+fenceEnd marker line =
+    marker `T.isPrefixOf`
+      T.stripStart line
+
+
+step
+  :: ParseState
+  -> (Int, Text)
+  -> ParseState
+
+step st@(ParseState _ Normal _) (ln,txt)
 
-    go True start hdr acc ((ln,t):xs)
-      | "```" `T.isPrefixOf` T.stripStart t =
-          let body =
-                 T.unlines $
-                   map snd $
-                     takeWhile
-                       (\(_,x) ->
-                          not ("```"
-                                 `T.isPrefixOf`
-                                 T.stripStart x))
-                       ((ln,t):xs)
-          in go False 0 "" (mk start ln hdr body:acc) xs
+  | Just (marker,hdr) <- fenceStart txt =
+      st
+        { psMode =
+            InFence
+              FenceState
+                { fsStartLine = ln
+                , fsFenceTok  = marker
+                , fsHeader    = T.strip hdr
+                , fsLines     = []
+                }
+        }
 
-      | otherwise =
-          go True start hdr acc xs
+  | isIndented txt =
+      st
+        { psMode =
+            InIndented
+              IndentedState
+                { isStartLine = ln
+                , isLines =
+                    [stripIndent txt]
+                }
+        }
 
-    mk s e hdr body =
-      let meta =
-            parseMetadataLine $
-               "@" <> T.drop 3 (T.strip hdr)
-      in Block fp 0 Fenced meta s e body
+  | otherwise =
+      st
 
-parseIndented :: FilePath -> [(Int,Text)] -> [Block]
-parseIndented fp =
-    go
+step st@(ParseState fp (InFence fs) acc) (ln,txt)
+
+  | fenceEnd (fsFenceTok fs) txt =
+      st
+        { psMode = Normal
+        , psBlocks =
+            mkFenceBlock fp fs ln
+            : acc
+        }
+
+  | otherwise =
+      st
+        { psMode =
+            InFence
+              fs
+                { fsLines =
+                    txt : fsLines fs
+                }
+        }
+
+step st@(ParseState fp (InIndented is) acc) current@(ln,txt)
+
+  | isIndented txt =
+      st
+        { psMode =
+            InIndented
+              is
+                { isLines =
+                    stripIndent txt
+                    : isLines is
+                }
+        }
+
+  | otherwise =
+      let block =
+            mkIndentedBlock
+              fp
+              is
+              (ln - 1)
+
+          reset =
+            st
+              { psMode = Normal
+              , psBlocks = block : acc
+              }
+
+      in step reset current
+
+
+finalize :: ParseState -> [Block]
+
+finalize (ParseState _ Normal xs) =
+  reverse xs
+
+finalize (ParseState fp (InFence fs) xs) =
+  reverse
+    ( mkFenceBlock fp fs (fsStartLine fs)
+    : xs
+    )
+
+finalize (ParseState fp (InIndented is) xs) =
+  reverse
+    ( mkIndentedBlock fp is (isStartLine is)
+    : xs
+    )
+
+
+mkFenceBlock
+  :: FilePath
+  -> FenceState
+  -> Int
+  -> Block
+mkFenceBlock fp fs endLine =
+  Block
+    { blockFile    = fp
+    , blockNumber  = 0
+    , blockKind    = Fenced
+    , blockMeta    = meta
+    , blockStart   = fsStartLine fs
+    , blockEnd     = endLine
+    , blockContent = body
+    }
   where
-    go [] = []
+    body =
+      T.unlines
+        (reverse (fsLines fs))
+
+    meta =
+      parseMetadataLine
+        ("@" <> fsHeader fs)
+
+
+mkIndentedBlock
+  :: FilePath
+  -> IndentedState
+  -> Int
+  -> Block
+mkIndentedBlock fp is endLine =
+  Block
+    { blockFile    = fp
+    , blockNumber  = 0
+    , blockKind    = Indented
+    , blockMeta    = meta
+    , blockStart   = isStartLine is
+    , blockEnd     = endLine
+    , blockContent = code
+    }
+  where
+    raw =
+      T.unlines
+        (reverse (isLines is))
+
+    (meta, code) =
+      splitIndentedMetadata raw
 
-    go ((ln,t):xs)
-      | isIndented t =
-          let (blk,rest) = span (isIndented . snd) xs
-              chunk =
-                  T.unlines $
-                    map (T.drop 4 . snd)
-                    ((ln,t):blk)
 
-              meta =
-                case T.lines chunk of
-                  [] -> emptyMetadata
-                  (x:_)
-                    | "@" `T.isPrefixOf` x ->
-                        parseMetadataLine x
-                    | otherwise ->
-                        emptyMetadata
+splitIndentedMetadata
+  :: Text
+  -> (Metadata, Text)
+splitIndentedMetadata txt =
+  case T.lines txt of
 
-              code =
-                case T.lines chunk of
-                  [] -> ""
-                  (x:rs)
-                    | "@" `T.isPrefixOf` x ->
-                        T.unlines rs
-                    | otherwise ->
-                        chunk
-          in Block fp 0 Indented meta ln (fst $ last (blk++[(ln,t)])) code
-               : go rest
+    [] ->
+      (emptyMetadata, "")
 
-      | otherwise =
-          go xs
+    firstLine : rest
+      | "@" `T.isPrefixOf` firstLine ->
+          ( parseMetadataLine firstLine
+          , T.unlines rest
+          )
 
-    isIndented t =
-      "    " `T.isPrefixOf` t
+      | otherwise ->
+          ( emptyMetadata
+          , txt
+          )