From f16d08a510725a98b75b7495c0fe6750535ef82f Mon Sep 17 00:00:00 2001
From: Sridhar Ratnakumar <srid@srid.ca>
Date: Sun, 16 May 2021 16:58:49 -0400
Subject: [PATCH] Switch from HsYaml -> yaml

The 'tags' feature in template is broken. cf. https://github.com/snapframework/heist/issues/128

One way to address it is to specify a frontmatter.yaml default for Aeson.Value, to ensure that all fields are present regardless of what's in the individual Markdown file.
---
 docs/.emabook/templates/_default.tpl | 14 ++++-----
 emabook.cabal                        |  3 +-
 flake.lock                           |  6 ++--
 src/Data/YAML/ToJSON.hs              | 43 ---------------------------
 src/Emabook/Model.hs                 | 44 +++++++++++++---------------
 src/Main.hs                          | 15 ++++------
 6 files changed, 38 insertions(+), 87 deletions(-)
 delete mode 100644 src/Data/YAML/ToJSON.hs

diff --git a/docs/.emabook/templates/_default.tpl b/docs/.emabook/templates/_default.tpl
index f7a682db5..faea0a8a6 100644
--- a/docs/.emabook/templates/_default.tpl
+++ b/docs/.emabook/templates/_default.tpl
@@ -69,17 +69,17 @@
         <apply template="components/markdown" />
         <apply template="components/backlinks" />
 
-        <ema:note:tags>
+        <apply template="components/breadcrumbs" />
+
+        <note-meta>
           <div class="flex items-center justify-center mt-8 space-x-2 font-mono text-sm">
-            <tag>
+            <with var="tags">
               <a title="Tag" class="px-1 bg-gray-100 rounded">
-                <tag:name />
+                <value />
               </a>
-            </tag>
+            </with>
           </div>
-        </ema:note:tags>
-
-        <apply template="components/breadcrumbs" />
+        </note-meta>
 
         <footer class="flex items-center justify-center my-8 space-x-4 text-center text-gray-500">
           <div>
diff --git a/emabook.cabal b/emabook.cabal
index 15237445d..2401d7393 100644
--- a/emabook.cabal
+++ b/emabook.cabal
@@ -34,7 +34,6 @@ executable emabook
     , ema                  >=0.2
     , filepath
     , heist                >=1.1.0.1
-    , HsYAML
     , ixset-typed
     , lens
     , lvar
@@ -51,6 +50,7 @@ executable emabook
     , text
     , time
     , unliftio
+    , yaml
     , xmlhtml
 
   mixins:
@@ -77,7 +77,6 @@ executable emabook
   hs-source-dirs:     src
   default-language:   Haskell2010
   other-modules:
-    Data.YAML.ToJSON
     Emabook.Model
     Emabook.PandocUtil
     Emabook.Route
diff --git a/flake.lock b/flake.lock
index 07bd7fe80..8bd539c2f 100644
--- a/flake.lock
+++ b/flake.lock
@@ -7,11 +7,11 @@
         "nixpkgs": "nixpkgs"
       },
       "locked": {
-        "lastModified": 1621195402,
-        "narHash": "sha256-jYv6G7csQaBbE2fF4JRYkmkB2GKsrl3nVR8USDOkxkc=",
+        "lastModified": 1621197248,
+        "narHash": "sha256-DQTpGeujaAVuXwmt+2zUb6uWF6V6ASL1Ol/WsCcaM/s=",
         "owner": "srid",
         "repo": "ema",
-        "rev": "df58a6213919eef65c60cce88090770b1421e96d",
+        "rev": "ff7692e944e203d63023a0fe0ebc256d11235850",
         "type": "github"
       },
       "original": {
diff --git a/src/Data/YAML/ToJSON.hs b/src/Data/YAML/ToJSON.hs
deleted file mode 100644
index 3a8e76bb8..000000000
--- a/src/Data/YAML/ToJSON.hs
+++ /dev/null
@@ -1,43 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
--- | Import this module if you want `toJSON` on YAML AST.
-module Data.YAML.ToJSON where
-
-import Data.Aeson
-import qualified Data.Aeson as Aeson
-import qualified Data.Aeson.Encoding as AesonEncoding
-import qualified Data.YAML as Y
-
-instance Aeson.ToJSONKey (Y.Node Y.Pos) where
-  toJSONKey = ToJSONKeyText f (AesonEncoding.text . f)
-    where
-      f = \case
-        Y.Scalar _ x -> scalarToText x
-        Y.Mapping _ _ x -> show x
-        Y.Sequence _ _ x -> show x
-        Y.Anchor _ _ x -> f x
-      scalarToText = \case
-        Y.SNull -> "null"
-        Y.SBool x -> show x
-        Y.SFloat x -> show x
-        Y.SInt x -> show x
-        Y.SStr x -> x
-        Y.SUnknown _tag x -> show x
-
-instance Aeson.ToJSON (Y.Node Y.Pos) where
-  toJSON = \case
-    Y.Scalar _ x -> toJSON x
-    Y.Mapping _ _ x -> toJSON x
-    Y.Sequence _ _ x -> toJSON x
-    -- Not sure what to do here, but we don't expect to get this in neuron.
-    Y.Anchor {} -> toJSON ("unsupported" :: Text)
-
-instance ToJSON Y.Scalar where
-  toJSON = \case
-    Y.SNull -> Aeson.Null
-    Y.SBool x -> toJSON x
-    Y.SFloat x -> toJSON x
-    Y.SInt x -> toJSON x
-    Y.SStr x -> toJSON x
-    Y.SUnknown _tag x -> toJSON x
diff --git a/src/Emabook/Model.hs b/src/Emabook/Model.hs
index 9c75df466..2bd01487a 100644
--- a/src/Emabook/Model.hs
+++ b/src/Emabook/Model.hs
@@ -10,6 +10,7 @@
 module Emabook.Model where
 
 import Control.Monad.Writer.Strict (MonadWriter (tell))
+import Data.Aeson (FromJSON)
 import qualified Data.Aeson as Aeson
 import Data.Data (Data)
 import Data.Default (Default (..))
@@ -19,8 +20,7 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import Data.Tree (Tree)
-import qualified Data.YAML as Y
-import Data.YAML.ToJSON ()
+import qualified Data.Yaml as Yaml
 import Ema (Ema (..), Slug)
 import qualified Ema
 import qualified Ema.Helper.PathTree as PathTree
@@ -28,6 +28,7 @@ import qualified Emabook.PandocUtil as PandocUtil
 import Emabook.Route (MarkdownRoute)
 import qualified Emabook.Route as R
 import qualified Emabook.Template as T
+import Relude.Extra.Map
 import Text.Pandoc.Definition (Pandoc (..))
 import qualified Text.Pandoc.Definition as B
 import qualified Text.Pandoc.LinkContext as LC
@@ -46,15 +47,13 @@ data Model = Model
 instance Default Model where
   def = Model Ix.empty Ix.empty mempty Aeson.Null (Left $ one "Heist state not yet loaded")
 
-parseYaml :: Y.FromYAML a => FilePath -> Text -> Either Text a
-parseYaml n (encodeUtf8 -> v) = do
-  let mkError (loc, emsg) =
-        toText $ n <> ":" <> Y.prettyPosWithSource loc v " error" <> emsg
-  first mkError $ Y.decode1 v
+parseYaml :: FromJSON a => ByteString -> Either Text a
+parseYaml v = do
+  first show $ Yaml.decodeEither' v
 
 data Note = Note
   { noteDoc :: Pandoc,
-    noteMeta :: Meta,
+    noteMeta :: Aeson.Value,
     noteRoute :: MarkdownRoute
   }
   deriving (Eq, Ord, Data, Show, Generic, Aeson.ToJSON)
@@ -128,12 +127,6 @@ data Meta = Meta
   }
   deriving (Eq, Show, Ord, Data, Generic, Aeson.ToJSON)
 
-instance Y.FromYAML Meta where
-  parseYAML = Y.withMap "FrontMatter" $ \m ->
-    Meta
-      <$> (fromMaybe def <$> m Y..:? "order")
-      <*> (fromMaybe mempty <$> m Y..:? "tags")
-
 instance Default Meta where
   def = Meta def mempty
 
@@ -141,9 +134,14 @@ modelLookup :: MarkdownRoute -> Model -> Maybe Note
 modelLookup k =
   Ix.getOne . Ix.getEQ k . modelNotes
 
-modelLookupMeta :: MarkdownRoute -> Model -> Meta
-modelLookupMeta k =
-  maybe def noteMeta . modelLookup k
+lookupNoteMeta :: (Default a, FromJSON a) => a -> Text -> Note -> a
+lookupNoteMeta x k note =
+  fromMaybe x $ do
+    Aeson.Object kw <- pure $ noteMeta note
+    val <- lookup k kw
+    case Aeson.fromJSON val of
+      Aeson.Error _ -> Nothing
+      Aeson.Success v -> pure v
 
 modelLookupRouteByWikiLink :: R.WikiLinkTarget -> Model -> [MarkdownRoute]
 modelLookupRouteByWikiLink wl model =
@@ -165,15 +163,15 @@ modelLookupTitle :: MarkdownRoute -> Model -> Text
 modelLookupTitle r =
   maybe (R.markdownRouteFileBase r) noteTitle . modelLookup r
 
-modelUpdateSettings :: FilePath -> Text -> Model -> Model
-modelUpdateSettings settingsFile s model =
+modelUpdateSettings :: ByteString -> Model -> Model
+modelUpdateSettings s model =
   model
     { modelSettings =
-        either error Aeson.toJSON $
-          parseYaml @(Y.Node Y.Pos) settingsFile s
+        either error id $
+          parseYaml s
     }
 
-modelInsert :: MarkdownRoute -> (Meta, Pandoc) -> Model -> Model
+modelInsert :: MarkdownRoute -> (Aeson.Value, Pandoc) -> Model -> Model
 modelInsert k v model =
   let note = Note (snd v) (fst v) k
       modelNotes' =
@@ -198,7 +196,7 @@ modelInsert k v model =
       note <- Ix.getOne $ Ix.getEQ r notes
       pure $
         (,)
-          (order $ noteMeta note)
+          (lookupNoteMeta @Int 0 "order" note)
           (noteTitle note)
 
 modelDelete :: MarkdownRoute -> Model -> Model
diff --git a/src/Main.hs b/src/Main.hs
index 3d8952bda..118791b8a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -84,9 +84,9 @@ main =
         SourceTemplate dir ->
           M.modelSetHeistTemplate <$> T.loadHeistTemplates dir
         SourceTemplateSettings _ ->
-          M.modelUpdateSettings fp <$> readFileText fp
+          M.modelUpdateSettings <$> readFileBS fp
   where
-    readMarkdown :: (MonadIO m, MonadLogger m) => FilePath -> m (Maybe (MarkdownRoute, (M.Meta, Pandoc)))
+    readMarkdown :: (MonadIO m, MonadLogger m) => FilePath -> m (Maybe (MarkdownRoute, (Aeson.Value, Pandoc)))
     readMarkdown fp =
       runMaybeT $ do
         r :: MarkdownRoute <- MaybeT $ pure $ R.mkMarkdownRouteFromFilePath fp
@@ -96,9 +96,9 @@ main =
           Left (BadMarkdown -> err) -> do
             throw err
           Right (mMeta, doc) ->
-            pure (r, (fromMaybe def mMeta, doc))
+            pure (r, (fromMaybe Aeson.Null mMeta, doc))
     parseMarkdown =
-      Markdown.parseMarkdownWithFrontMatter @M.Meta $
+      Markdown.parseMarkdownWithFrontMatter @Aeson.Value $
         Markdown.wikilinkSpec <> Markdown.fullMarkdownSpec
 
 newtype BadMarkdown = BadMarkdown Text
@@ -142,11 +142,8 @@ render _ model r = do
     "ema:note:title"
       ## HI.textSplice
       $ M.modelLookupTitle r model
-    "ema:note:tags"
-      ## Splices.listSplice (maybe mempty (M.tags . M.noteMeta) mNote) "tag"
-      $ \tag ->
-        MapSyntax.mapV HI.textSplice $ do
-          "tag:name" ## tag
+    "note-meta"
+      ## HJ.bindJson (traceShowId $ maybe Aeson.Null M.noteMeta mNote)
     "ema:note:backlinks"
       ## Splices.listSplice (M.modelLookupBacklinks r model) "backlink"
       $ \(source, ctx) -> do