Switch from HsYaml -> yaml

The 'tags' feature in template is broken. cf. snapframework/heist#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

@@ -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>

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

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,15 +20,15 @@ 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
 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,22 +127,21 @@ 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
 
 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

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