Introduce CMarkdown to bridge Markdown types

to PureScript. With this we are avoid to bridge just a simple `String`.

src/Guide/Api/ClientTypes.hs

@@ -5,44 +5,56 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 
 {- |
-  API's client types (e.g. generated to and used by PureScript)
+  This module describes API's client types. These are needed to generate
+  Guide's Haskell types to PureScript types by `purescript-bridge`.
+  All types will be provided as JSON to send and receive all data between
+  back- and frontend.
 -}
 
 module Guide.Api.ClientTypes
   ( CCategoryDetail(..)
   , CCategoryOverview(..)
   , CGrandCategory(..)
-  , mkCGrandCategory
+  , CItem(..)
-  , mkCCategoryDetail
+  , CMarkdown(..)
+  , CTrait(..)
+  , toCGrandCategory
+  , toCCategoryDetail
   )
   where
 
 import Imports
 
 import qualified Data.Aeson as A
+import qualified Data.Text.All as T
+import Lucid (toHtml, renderText)
 
-import Guide.Types.Core (Category, CategoryStatus(..), Item, items, notes, status, uid, title, group_)
+import Guide.Types.Core (Category, CategoryStatus(..), Item, ItemKind, Trait
-import Guide.Utils (Uid)
+  , content, created, group_, description, pros, prosDeleted, cons, consDeleted, ecosystem
-import Guide.Markdown (MarkdownBlock)
+  , notes, link, kind, name, items, notes, status, uid, title, group_
+  )
+import Guide.Utils (Uid, Url)
+import Guide.Markdown (MarkdownBlock, MarkdownInline, MarkdownTree, mdHtml, mdText)
 import Guide.Views.Utils (categoryLink)
 
+-- | Client type of `Category`, which describes a category overview
 data CCategoryOverview = CCategoryOverview
   { ccoUid    :: Uid Category
   , ccoTitle  :: Text
   , ccoLink  :: Text
-  }
+  } deriving (Show, Generic)
-  deriving (Show, Generic)
 
 instance A.ToJSON CCategoryOverview where
   toJSON = A.genericToJSON A.defaultOptions
 
-mkCCategoryOverview :: Category -> CCategoryOverview
+toCCategoryOverview :: Category -> CCategoryOverview
-mkCCategoryOverview cat = CCategoryOverview
+toCCategoryOverview cat = CCategoryOverview
   { ccoUid = cat^.uid
   , ccoTitle = cat^.title
   , ccoLink = categoryLink cat
   }
 
+-- | Client type of `Category`, which describes a top or grand category
 data CGrandCategory = CGrandCategory
   { cgcTitle     :: Text
   , cgcFinished  :: [CCategoryOverview]
@@ -54,20 +66,21 @@ data CGrandCategory = CGrandCategory
 instance A.ToJSON CGrandCategory where
   toJSON = A.genericToJSON A.defaultOptions
 
-mkCGrandCategory :: [Category] -> CGrandCategory
+toCGrandCategory :: [Category] -> CGrandCategory
-mkCGrandCategory cats = CGrandCategory
+toCGrandCategory cats = CGrandCategory
   { cgcTitle = cats^?!_head.group_
-  , cgcFinished = fmap mkCCategoryOverview (filter ((== CategoryFinished) . view status) cats)
+  , cgcFinished = fmap toCCategoryOverview (filter ((== CategoryFinished) . view status) cats)
-  , cgcWip = fmap mkCCategoryOverview (filter ((== CategoryWIP) . view status) cats)
+  , cgcWip = fmap toCCategoryOverview (filter ((== CategoryWIP) . view status) cats)
-  , cgcStub = fmap mkCCategoryOverview (filter ((== CategoryStub) . view status) cats)
+  , cgcStub = fmap toCCategoryOverview (filter ((== CategoryStub) . view status) cats)
   }
 
+-- | Client type of `Category`, which describes a category detail
 data CCategoryDetail = CCategoryDetail
   { ccdUid :: Uid Category
   , ccdTitle :: Text
   , ccdGroup :: Text
-  , ccdDescription :: MarkdownBlock
+  , ccdDescription :: CMarkdown
-  , ccdItems :: [Item]
+  , ccdItems :: [CItem]
   , ccdStatus :: CategoryStatus
   }
   deriving (Show, Generic)
@@ -75,12 +88,92 @@ data CCategoryDetail = CCategoryDetail
 instance A.ToJSON CCategoryDetail where
   toJSON = A.genericToJSON A.defaultOptions
 
-mkCCategoryDetail :: Category -> CCategoryDetail
+toCCategoryDetail :: Category -> CCategoryDetail
-mkCCategoryDetail cat = CCategoryDetail
+toCCategoryDetail cat = CCategoryDetail
   { ccdUid = cat^.uid
   , ccdTitle = cat^.title
   , ccdGroup = cat^.group_
-  , ccdDescription = cat^.notes
+  , ccdDescription = toCMarkdown $ cat^.notes
-  , ccdItems = cat^.items
+  , ccdItems = fmap toCItem (cat^.items)
   , ccdStatus = cat^.status
   }
+
+-- | Client type of `Item`
+data CItem = CItem
+  { ciUid :: Uid Item
+  , ciName :: Text
+  , ciCreated :: UTCTime
+  , ciGroup :: Maybe Text
+  , ciDescription :: CMarkdown
+  , ciPros :: [CTrait]
+  , ciProsDeleted :: [CTrait]
+  , ciCons :: [CTrait]
+  , ciConsDeleted :: [CTrait]
+  , ciEcosystem :: CMarkdown
+  , ciNotes :: CMarkdown
+  , ciLink :: Maybe Url
+  , ciKind :: ItemKind
+  } deriving (Show, Generic)
+
+instance A.ToJSON CItem where
+  toJSON = A.genericToJSON A.defaultOptions
+
+toCItem :: Item -> CItem
+toCItem item = CItem
+  { ciUid = item ^. uid
+  , ciName = item ^. name
+  , ciCreated = item ^. created
+  , ciGroup = item ^. group_
+  , ciDescription = toCMarkdown $ item ^. description
+  , ciPros = fmap toCTrait (item ^. pros)
+  , ciProsDeleted = fmap toCTrait (item ^. prosDeleted)
+  , ciCons = fmap toCTrait (item ^. cons)
+  , ciConsDeleted = fmap toCTrait (item ^. consDeleted)
+  , ciEcosystem = toCMarkdown $ item ^. ecosystem
+  , ciNotes = toCMarkdown $ item ^. notes
+  , ciLink = item ^. link
+  , ciKind = item ^. kind
+  }
+
+data CTrait = CTrait
+  { ctUid :: Uid Trait
+  , ctContent :: CMarkdown
+  } deriving (Show, Generic)
+
+
+instance A.ToJSON CTrait where
+  toJSON = A.genericToJSON A.defaultOptions
+
+toCTrait :: Trait -> CTrait
+toCTrait trait = CTrait
+  { ctUid = trait ^. uid
+  , ctContent = toCMarkdown $ trait ^. content
+  }
+
+data CMarkdown = CMarkdown
+  { text :: Text
+  , html :: Text
+  } deriving (Show, Generic)
+
+instance A.ToJSON CMarkdown where
+  toJSON = A.genericToJSON A.defaultOptions
+
+class ToCMardown md where toCMarkdown :: md -> CMarkdown
+
+instance ToCMardown MarkdownInline where
+  toCMarkdown md = CMarkdown
+    { text = md^.mdText
+    , html = T.decodeUtf8 $ md^.mdHtml
+    }
+
+instance ToCMardown MarkdownBlock where
+  toCMarkdown md = CMarkdown
+    { text = md^.mdText
+    , html = T.decodeUtf8 $ md^.mdHtml
+    }
+
+instance ToCMardown MarkdownTree where
+  toCMarkdown md = CMarkdown
+    { text = md^.mdText
+    , html = T.toStrict . renderText $ toHtml md
+    }

src/Guide/Handlers.hs

@@ -41,7 +41,7 @@ import Guide.Merge
 import Guide.Markdown
 import Guide.State
 import Guide.Types
-import Guide.Api.ClientTypes (mkCGrandCategory, mkCCategoryDetail)
+import Guide.Api.ClientTypes (toCGrandCategory, toCCategoryDetail)
 import Guide.Utils
 import Guide.Views
 
@@ -59,11 +59,11 @@ apiMethods = Spock.subcomponent "api" $ do
   middleware simpleCors
   Spock.get "all-categories" $ do
     grands <- groupWith (view group_) <$> dbQuery GetCategories
-    json $ fmap mkCGrandCategory grands
+    json $ fmap toCGrandCategory grands
 
   Spock.get categoryVar $ \catId -> do
     cat <- dbQuery (GetCategory catId)
-    json $ mkCCategoryDetail cat
+    json $ toCCategoryDetail cat
 
 renderMethods :: SpockM () () ServerState ()
 renderMethods = Spock.subcomponent "render" $ do

src/purescript/Main.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric #-}
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module Main
   ( main
@@ -13,9 +15,9 @@ import Language.PureScript.Bridge (BridgeBuilder, BridgePart, Language( Haskell
                                     PSType, TypeInfo (..), (<|>), (^==), buildBridge,
                                     defaultBridge, typeName, mkSumType, writePSTypes)
 import Language.PureScript.Bridge.PSTypes (psString)
-import Guide.Api.ClientTypes (CCategoryDetail, CGrandCategory, CCategoryOverview)
+import Guide.Api.ClientTypes (CCategoryDetail, CCategoryOverview, CGrandCategory, CItem, CTrait, CMarkdown)
 import Guide.Types.Hue (Hue)
-import Guide.Types.Core (CategoryStatus, Item, ItemKind, Trait)
+import Guide.Types.Core (CategoryStatus, ItemKind)
 
 path :: FilePath
 path = "front-ps/src/Generated"
@@ -33,28 +35,17 @@ uidBridge = typeName ^== "Uid" >> pure psString
 byteStringBridge :: BridgePart
 byteStringBridge = typeName ^== "ByteString" >> pure psString
 
-markdownBlockBridge :: BridgePart
-markdownBlockBridge = typeName ^== "MarkdownBlock" >> pure psString
-
-markdownTreeBridge :: BridgePart
-markdownTreeBridge = typeName ^== "MarkdownTree" >> pure psString
-
-markdownInlineBridge :: BridgePart
-markdownInlineBridge = typeName ^== "MarkdownInline" >> pure psString
-
 -- TODO (sectore) Can we use PureScript's `Data.Date` here?
 utcTimeBridge :: BridgePart
 utcTimeBridge = typeName ^== "UTCTime" >> pure psString
 
+
 bridge :: BridgeBuilder PSType
 bridge = defaultBridge
   <|> posixTimeBridge
   <|> uidBridge
   <|> byteStringBridge
   <|> utcTimeBridge
-  <|> markdownBlockBridge
-  <|> markdownTreeBridge
-  <|> markdownInlineBridge
 
 clientTypes :: [SumType  'Haskell]
 clientTypes =
@@ -63,9 +54,10 @@ clientTypes =
   , mkSumType (Proxy :: Proxy CCategoryOverview)
   , mkSumType (Proxy :: Proxy Hue)
   , mkSumType (Proxy :: Proxy CategoryStatus)
-  , mkSumType (Proxy :: Proxy Item)
+  , mkSumType (Proxy :: Proxy CItem)
   , mkSumType (Proxy :: Proxy ItemKind)
-  , mkSumType (Proxy :: Proxy Trait)
+  , mkSumType (Proxy :: Proxy CTrait)
+  , mkSumType (Proxy :: Proxy CMarkdown)
   ]
 
 main :: IO ()