init

6 files changed, 270 insertions, 0 deletions

diff --git a/src/MdBlocks/Address.hs b/src/MdBlocks/Address.hs
new file mode 100644
index 0000000..c3dc5a4
--- /dev/null
+++ b/src/MdBlocks/Address.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module MdBlocks.Address where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import MdBlocks.Types
+
+addressOf :: Block -> Text
+addressOf b =
+  case mdId (blockMeta b) of
+    Just x ->
+      T.pack (blockFile b) <> "#" <> x
+
+    Nothing ->
+      T.pack (blockFile b)
+        <> "#"
+        <> T.pack (show (blockNumber b))
diff --git a/src/MdBlocks/CLI.hs b/src/MdBlocks/CLI.hs
new file mode 100644
index 0000000..96a3193
--- /dev/null
+++ b/src/MdBlocks/CLI.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module MdBlocks.CLI where
+
+import qualified Data.Aeson.Encode.Pretty as JSON
+import qualified Data.ByteString.Lazy.Char8 as BL
+
+import Options.Applicative
+
+import MdBlocks.Repository
+
+data Command
+  = List FilePath
+  | Extract String
+  | ShowMeta String
+
+runCLI :: IO ()
+runCLI =
+  execParser opts >>= run
+  where
+    opts = info parser mempty
+
+parser :: Parser Command
+parser =
+      listP
+  <|> extractP
+  <|> showP
+
+listP :: Parser Command
+listP =
+  List <$> strOption
+    (long "file")
+
+extractP :: Parser Command
+extractP =
+  Extract <$> strOption
+    (long "extract")
+
+showP :: Parser Command
+showP =
+  ShowMeta <$> strOption
+    (long "show")
+
+run :: Command -> IO ()
+
+run (List fp) = do
+  bs <- loadBlocks fp
+  BL.putStrLn $
+    JSON.encodePretty bs
+
+run (Extract addr) =
+  putStrLn ("extract not implemented yet: " ++ addr)
+
+run (ShowMeta addr) =
+  putStrLn ("show not implemented yet: " ++ addr)
diff --git a/src/MdBlocks/Metadata.hs b/src/MdBlocks/Metadata.hs
new file mode 100644
index 0000000..c0b1777
--- /dev/null
+++ b/src/MdBlocks/Metadata.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module MdBlocks.Metadata where
+
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import MdBlocks.Types
+
+emptyMetadata :: Metadata
+emptyMetadata =
+  Metadata Nothing Nothing M.empty
+
+parseMetadataLine :: Text -> Metadata
+parseMetadataLine line =
+  case T.words line of
+    [] ->
+      emptyMetadata
+
+    (langTok:rest)
+      | T.isPrefixOf "@" langTok ->
+          Metadata
+            (Just $ T.drop 1 langTok)
+            (lookupKey "id")
+            attrs
+      | otherwise ->
+          emptyMetadata
+      where
+        attrs =
+          M.fromList
+            [ let (k,v) = T.breakOn "=" x
+              in (k, T.drop 1 v)
+            | x <- rest
+            , "=" `T.isInfixOf` x
+            ]
+
+        lookupKey k = M.lookup k attrs
diff --git a/src/MdBlocks/Parser.hs b/src/MdBlocks/Parser.hs
new file mode 100644
index 0000000..f2f184d
--- /dev/null
+++ b/src/MdBlocks/Parser.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module MdBlocks.Parser where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import MdBlocks.Metadata
+import MdBlocks.Types
+
+parseFile :: FilePath -> Text -> [Block]
+parseFile fp txt =
+  numberBlocks $
+      parseFenced fp ls
+   ++ parseIndented fp ls
+  where
+    ls = zip [1..] (T.lines txt)
+
+numberBlocks :: [Block] -> [Block]
+numberBlocks =
+  zipWith (\n b -> b { blockNumber = n }) [1..]
+
+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
+
+    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
+
+      | otherwise =
+          go True start hdr acc xs
+
+    mk s e hdr body =
+      let meta =
+            parseMetadataLine $
+               "@" <> T.drop 3 (T.strip hdr)
+      in Block fp 0 Fenced meta s e body
+
+parseIndented :: FilePath -> [(Int,Text)] -> [Block]
+parseIndented fp =
+    go
+  where
+    go [] = []
+
+    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
+
+              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
+
+      | otherwise =
+          go xs
+
+    isIndented t =
+      "    " `T.isPrefixOf` t
diff --git a/src/MdBlocks/Repository.hs b/src/MdBlocks/Repository.hs
new file mode 100644
index 0000000..9bacaf2
--- /dev/null
+++ b/src/MdBlocks/Repository.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module MdBlocks.Repository where
+
+import Data.Text.IO as T
+import System.Directory
+
+import MdBlocks.Parser
+import MdBlocks.Types
+
+loadBlocks :: FilePath -> IO [Block]
+loadBlocks fp = do
+  txt <- T.readFile fp
+  pure (parseFile fp txt)
+
+findMarkdownFiles :: FilePath -> IO [FilePath]
+findMarkdownFiles root = do
+  xs <- listDirectory root
+  pure
+    [ root <> "/" <> x
+    | x <- xs
+    , takeExtension x == ".md"
+    ]
+  where
+    takeExtension =
+      reverse . takeWhile (/='.') . reverse
diff --git a/src/MdBlocks/Types.hs b/src/MdBlocks/Types.hs
new file mode 100644
index 0000000..1d8450e
--- /dev/null
+++ b/src/MdBlocks/Types.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module MdBlocks.Types where
+
+import Data.Aeson
+import Data.Map.Strict (Map)
+import Data.Text (Text)
+import GHC.Generics
+
+data BlockKind
+  = Fenced
+  | Indented
+  deriving (Show, Eq, Generic)
+
+instance ToJSON BlockKind
+
+data Metadata = Metadata
+  { mdLanguage :: Maybe Text
+  , mdId       :: Maybe Text
+  , mdAttrs    :: Map Text Text
+  }
+  deriving (Show, Eq, Generic)
+
+instance ToJSON Metadata
+
+data Block = Block
+  { blockFile    :: FilePath
+  , blockNumber  :: Int
+  , blockKind    :: BlockKind
+  , blockMeta    :: Metadata
+  , blockStart   :: Int
+  , blockEnd     :: Int
+  , blockContent :: Text
+  }
+  deriving (Show, Eq, Generic)
+
+instance ToJSON Block