1 files changed, 140 insertions, 0 deletions
diff --git a/src/Zettel/Parse.hs b/src/Zettel/Parse.hs
new file mode 100644
index 0000000..d6d8aa9
--- /dev/null
+++ b/src/Zettel/Parse.hs
@@ -0,0 +1,140 @@
+module Zettel.Parse where
+
+import Data.Default (def)
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+import Text.Pandoc.Builder (toMetaValue)
+import Text.Pandoc.Chunks (Chunk (..), ChunkedDoc (..), splitIntoChunks)
+import Text.Pandoc.Class (runIOorExplode)
+import Text.Pandoc.Definition (Block (..), Inline (..), Meta (..), MetaValue (..), Pandoc (..))
+import Text.Pandoc.Readers (readOrg)
+import Text.Pandoc.Shared (stringify)
+import Text.Pandoc.Walk (query, walk)
+import Zettel.Types
+
+decode :: ByteString -> Text
+decode = decodeUtf8
+
+removeHeadings :: Block -> Block
+removeHeadings Header {} = Plain []
+removeHeadings a = a
+
+removeDiv :: [Block] -> [Block]
+removeDiv = concatMap removeDiv'
+  where
+    removeDiv' (Div _ b') = b'
+    removeDiv' a = [a]
+
+queryHeaderMetaData :: [Block] -> [(Text, MetaValue)]
+queryHeaderMetaData = query headingAttr
+  where
+    headingAttr (Header _ (_, _, l) i) =
+      map (bimap exportDate MetaString) l
+        <> [ ("title", MetaInlines i),
+             ("author", MetaInlines [Str "Yann", Space, Str "Herklotz"])
+           ]
+    headingAttr _ = []
+    exportDate s
+      | s == "export_date" = "date"
+      | otherwise = s
+
+metaToString :: MetaValue -> Maybe Text
+metaToString (MetaString t) = Just t
+metaToString _ = Nothing
+
+metaToInlines :: MetaValue -> Maybe [Inline]
+metaToInlines (MetaInlines t) = Just t
+metaToInlines _ = Nothing
+
+lookupString :: Text -> Meta -> Maybe Text
+lookupString t m = Map.lookup t (unMeta m) >>= metaToString
+
+lookupInlines :: Text -> Meta -> Maybe [Inline]
+lookupInlines t m = Map.lookup t (unMeta m) >>= metaToInlines
+
+removeSpan :: [Inline] -> [Inline]
+removeSpan = concatMap removeSpan'
+  where
+    removeSpan' (Span _ _) = []
+    removeSpan' a = [a]
+
+removeMathNL :: Inline -> Inline
+removeMathNL (Math mt t) = Math mt . fold $ T.lines t
+removeMathNL a = a
+
+separateTitleTags :: [Inline] -> ([Inline], [ZettelTag])
+separateTitleTags title =
+  (walk removeSpan $ filter (not . isTagSpan) title, map (ZettelTag . stringify) $ filter isTagSpan title)
+  where
+    isTagSpan (Span (_, l, _) _) = "tag" `elem` l
+    isTagSpan _ = False
+
+parseDate :: Text -> Maybe Text
+parseDate t
+  | T.null t = Just t
+  | T.head t == '[' = viaNonEmpty head . T.words $ T.tail t
+  | otherwise = Just t
+
+parseDateVal :: MetaValue -> Maybe MetaValue
+parseDateVal v = MetaString <$> (metaToString v >>= parseDate)
+
+zettelMetaFromMeta :: [ZettelTag] -> Meta -> ZettelMetadata
+zettelMetaFromMeta t m =
+  ZettelMetadata
+    (lookupString "date" m)
+    (lookupString "modified" m)
+    t
+    []
+
+pandocFromChunk :: Chunk -> Pandoc
+pandocFromChunk c =
+  walk removeMathNL
+    . walk removeDiv
+    . walk removeHeadings
+    . Pandoc
+      (Meta (fromList (("custom_id", MetaString (chunkId c)) : headingMeta)))
+    $ chunkContents c
+  where
+    headingMeta = queryHeaderMetaData $ chunkContents c
+
+zettelFromPandoc :: Pandoc -> (ZettelId, Zettel)
+zettelFromPandoc p@(Pandoc attr _) =
+  (ZettelId ident, Zettel title (zettelMetaFromMeta tags attr) p)
+  where
+    ident = fromMaybe "" $ lookupString "custom_id" attr
+    (title, tags) = maybe ([], []) separateTitleTags $ lookupInlines "title" attr
+
+initNode :: Zettel -> ZettelNode
+initNode zettel = ZettelNode zettel cempty cempty
+
+updatePandocAttr :: Pandoc -> Pandoc
+updatePandocAttr (Pandoc attr b) =
+  Pandoc
+    ( Meta
+        ( Map.insert
+            "tags"
+            tags
+            . Map.update
+              (fmap (MetaInlines . fst . separateTitleTags) . metaToInlines)
+              "title"
+            . Map.update
+              parseDateVal
+              "modified"
+            . Map.update parseDateVal "date"
+            $ unMeta attr
+        )
+    )
+    b
+  where
+    tags =
+      toMetaValue . map unZettelTag $
+        maybe [] (snd . separateTitleTags) $
+          lookupInlines "title" attr
+
+parseZettelKasten :: [FilePath] -> IO ZettelGraph
+parseZettelKasten fl = do
+  fs <- mapM readFileBS fl
+  orgFiles <- mapM (runIOorExplode . readOrg def . decode) fs
+  let splitChunks = map (splitIntoChunks "%i.md" False Nothing 15) orgFiles
+  let pandocList = map (updatePandocAttr . pandocFromChunk) $ concatMap chunkedChunks splitChunks
+  return . ZettelGraph . fromList $ map (second initNode . zettelFromPandoc) pandocList