diff --git a/src/Guide/Api/ClientTypes.hs b/src/Guide/Api/ClientTypes.hs index 0d6741f..0ec1514 100644 --- a/src/Guide/Api/ClientTypes.hs +++ b/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 - , mkCCategoryDetail + , CItem(..) + , 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.Utils (Uid) -import Guide.Markdown (MarkdownBlock) +import Guide.Types.Core (Category, CategoryStatus(..), Item, ItemKind, Trait + , content, created, group_, description, pros, prosDeleted, cons, consDeleted, ecosystem + , 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 -mkCCategoryOverview cat = CCategoryOverview +toCCategoryOverview :: Category -> 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 -mkCGrandCategory cats = CGrandCategory +toCGrandCategory :: [Category] -> CGrandCategory +toCGrandCategory cats = CGrandCategory { cgcTitle = cats^?!_head.group_ - , cgcFinished = fmap mkCCategoryOverview (filter ((== CategoryFinished) . view status) cats) - , cgcWip = fmap mkCCategoryOverview (filter ((== CategoryWIP) . view status) cats) - , cgcStub = fmap mkCCategoryOverview (filter ((== CategoryStub) . view status) cats) + , cgcFinished = fmap toCCategoryOverview (filter ((== CategoryFinished) . view status) cats) + , cgcWip = fmap toCCategoryOverview (filter ((== CategoryWIP) . 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 - , ccdItems :: [Item] + , ccdDescription :: CMarkdown + , 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 -mkCCategoryDetail cat = CCategoryDetail +toCCategoryDetail :: Category -> CCategoryDetail +toCCategoryDetail cat = CCategoryDetail { ccdUid = cat^.uid , ccdTitle = cat^.title , ccdGroup = cat^.group_ - , ccdDescription = cat^.notes - , ccdItems = cat^.items + , ccdDescription = toCMarkdown $ cat^.notes + , 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 + } diff --git a/src/Guide/Handlers.hs b/src/Guide/Handlers.hs index 6d9d5ec..cff6732 100644 --- a/src/Guide/Handlers.hs +++ b/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 diff --git a/src/purescript/Main.hs b/src/purescript/Main.hs index 4295482..15e0f44 100644 --- a/src/purescript/Main.hs +++ b/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 ()