1
1
mirror of https://github.com/aelve/guide.git synced 2024-12-23 04:42:24 +03:00

[WIP] Bridge Uid type and replace to Uid String in types

This commit is contained in:
vrom911 2017-08-08 13:51:13 +03:00
parent f06663fe68
commit ed9431531d
8 changed files with 60 additions and 50 deletions

View File

@ -11,6 +11,7 @@ import Data.Either (Either(..), either)
import Data.Generic (class Generic) import Data.Generic (class Generic)
import Guide.Api.ClientTypes (CCategoryDetail) import Guide.Api.ClientTypes (CCategoryDetail)
import Guide.Types (CGrandCategories, CategoryName(..), Users) import Guide.Types (CGrandCategories, CategoryName(..), Users)
import Guide.Utils (Uid(..))
import Lib.IsomorphicFetch (FETCH, fetch) import Lib.IsomorphicFetch (FETCH, fetch)
apiEndpoint :: String apiEndpoint :: String
@ -34,7 +35,7 @@ fetchGrandCategories (CategoryName catName) = do
-- TODO: Use `Uid Category` instead of `String` as second function parameter -- TODO: Use `Uid Category` instead of `String` as second function parameter
-- if we have found a way to bridge `Uid a` properly from `Haskell` to `PS` -- if we have found a way to bridge `Uid a` properly from `Haskell` to `PS`
fetchCategory :: forall eff. CategoryName -> String -> Aff (fetch :: FETCH | eff) (Either String CCategoryDetail) fetchCategory :: forall eff. CategoryName -> (Uid String) -> Aff (fetch :: FETCH | eff) (Either String CCategoryDetail)
fetchCategory (CategoryName catName) catId = do fetchCategory (CategoryName catName) (Uid catId) = do
res <- attempt <<< fetch $ apiEndpoint <> catName <> "/category/" <> catId res <- attempt <<< fetch $ apiEndpoint <> catName <> "/category/" <> catId.uidToText
pure $ either (Left <<< show) decodeJson res pure $ either (Left <<< show) decodeJson res

View File

@ -2,6 +2,7 @@ module Guide.Events where
import Guide.Api.ClientTypes (CCategoryDetail) import Guide.Api.ClientTypes (CCategoryDetail)
import Data.Either (Either) import Data.Either (Either)
import Guide.Utils (Uid)
import Guide.Routes (Route) import Guide.Routes (Route)
import Guide.Types (CGrandCategories, CategoryName, Users) import Guide.Types (CGrandCategories, CategoryName, Users)
import Pux.DOM.Events (DOMEvent) import Pux.DOM.Events (DOMEvent)
@ -13,7 +14,7 @@ data Event
-- API -- API
| RequestGrandCategories CategoryName | RequestGrandCategories CategoryName
| ReceiveGrandCategories (Either String CGrandCategories) | ReceiveGrandCategories (Either String CGrandCategories)
| RequestCategory CategoryName String -- (String == Uid Category) | RequestCategory CategoryName (Uid String) -- (String == Uid Category)
-- TODO: ^ Use `Uid Category` instead of `String` as second type parameter -- TODO: ^ Use `Uid Category` instead of `String` as second type parameter
-- if we have found a way to bridge `Uid a` properly from `Haskell` to `PS` -- if we have found a way to bridge `Uid a` properly from `Haskell` to `PS`
| ReceiveCategory (Either String CCategoryDetail) | ReceiveCategory (Either String CCategoryDetail)

View File

@ -6,13 +6,14 @@ import Control.Alt ((<|>))
import Data.Generic (class Generic, gEq, gShow) import Data.Generic (class Generic, gEq, gShow)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Guide.Types (CategoryName(..)) import Guide.Types (CategoryName(..))
import Guide.Utils (Uid(..))
import Pux.Router (end, lit, router, str) import Pux.Router (end, lit, router, str)
data Route data Route
= Home = Home
| CategoryOverview CategoryName | CategoryOverview CategoryName
| CategoryDetail CategoryName String -- String == (Uid Category) | CategoryDetail CategoryName (Uid String) -- String == (Uid Category)
-- TODO: Use `Uid Category` instead of `String` -- TODO: Use `Uid Category` instead of `Uid String`
-- if we have found a way to bridge `Uid a` properly from `Haskell` to `PS` -- if we have found a way to bridge `Uid a` properly from `Haskell` to `PS`
| Playground | Playground
| NotFound String | NotFound String
@ -30,7 +31,7 @@ match url = fromMaybe (NotFound url) $ router url $
CategoryOverview <<< CategoryName <$> (lit categoryLit *> str) <* end CategoryOverview <<< CategoryName <$> (lit categoryLit *> str) <* end
<|> <|>
CategoryDetail <<< CategoryName <$> (lit categoryLit *> str) CategoryDetail <<< CategoryName <$> (lit categoryLit *> str)
<*> str <* end <*> ((\s -> Uid {uidToText : s}) <$> str) <* end
<|> <|>
Playground <$ (lit playgroundLit) <* end Playground <$ (lit playgroundLit) <* end
@ -56,8 +57,8 @@ categoryUrl (CategoryName name) = (litUrl categoryLit) <> (litUrl name)
categoryDetailLit :: String categoryDetailLit :: String
categoryDetailLit = "detail" categoryDetailLit = "detail"
categoryDetailUrl :: CategoryName -> String -> String categoryDetailUrl :: CategoryName -> Uid String -> String
categoryDetailUrl catName catId = (categoryUrl catName) <> (litUrl catId) categoryDetailUrl catName (Uid catId) = (categoryUrl catName) <> (litUrl catId.uidToText)
playgroundLit :: String playgroundLit :: String
playgroundLit = "playground" playgroundLit = "playground"

View File

@ -8,6 +8,7 @@ import Guide.Events (Event(..))
import Guide.Routes (Route(..), toUrl) import Guide.Routes (Route(..), toUrl)
import Guide.State (State(..)) import Guide.State (State(..))
import Guide.Types (CategoryName(..)) import Guide.Types (CategoryName(..))
import Guide.Utils (Uid(..))
import Pux.DOM.Events (onClick) as P import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P import Pux.DOM.HTML (HTML) as P
import Text.Smolder.HTML (div, h1, a) as S import Text.Smolder.HTML (div, h1, a) as S
@ -15,10 +16,10 @@ import Text.Smolder.HTML.Attributes (href) as S
import Text.Smolder.Markup ((#!), (!)) import Text.Smolder.Markup ((#!), (!))
import Text.Smolder.Markup (text) as S import Text.Smolder.Markup (text) as S
view :: CategoryName -> String -> State -> P.HTML Event view :: CategoryName -> Uid String -> State -> P.HTML Event
view (CategoryName cName) catId (State st) = view (CategoryName cName) (Uid catId) (State st) =
S.div $ do S.div $ do
S.h1 $ S.text (cName <> " - " <> catId) S.h1 $ S.text (cName <> " - " <> catId.uidToText)
S.a ! S.href (toUrl Home) S.a ! S.href (toUrl Home)
#! P.onClick (Navigate $ toUrl Home) #! P.onClick (Navigate $ toUrl Home)
$ S.text "Back to Home" $ S.text "Back to Home"

View File

@ -12,6 +12,7 @@ import Guide.Routes (Route(..), toUrl)
import Guide.State (State(..)) import Guide.State (State(..))
import Guide.Types (CGrandCategories, CategoryName(..)) import Guide.Types (CGrandCategories, CategoryName(..))
import Guide.Util.DOMUtil (mkKey) import Guide.Util.DOMUtil (mkKey)
import Guide.Utils (Uid(..))
import Network.RemoteData (RemoteData(..)) import Network.RemoteData (RemoteData(..))
import Pux.DOM.Events (onClick) as P import Pux.DOM.Events (onClick) as P
import Pux.DOM.HTML (HTML) as P import Pux.DOM.HTML (HTML) as P
@ -68,7 +69,7 @@ catOverviewView :: State -> CCategoryOverview -> P.HTML Event
catOverviewView (State st) (CCategoryOverview cat) = catOverviewView (State st) (CCategoryOverview cat) =
let url = toUrl $ CategoryDetail st.currentCategoryName cat.ccoUid in let url = toUrl $ CategoryDetail st.currentCategoryName cat.ccoUid in
S.li S.li
! P.key cat.ccoUid ! P.key ((\(Uid t) -> t.uidToText) cat.ccoUid)
$ S.a $ S.a
! S.href url ! S.href url
#! P.onClick (Navigate url) #! P.onClick (Navigate url)

View File

@ -1,7 +1,7 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{- | {- |
@ -33,13 +33,13 @@ import Guide.Types.Core (Category, CategoryStatus(..), Item, ItemKind, Trait
, content, created, group_, description, pros, prosDeleted, cons, consDeleted, ecosystem , content, created, group_, description, pros, prosDeleted, cons, consDeleted, ecosystem
, notes, link, kind, name, items, notes, status, uid, title, group_ , notes, link, kind, name, items, notes, status, uid, title, group_
) )
import Guide.Utils (Uid, Url) import Guide.Utils (Uid(..), Url)
import Guide.Markdown (MarkdownBlock, MarkdownInline, MarkdownTree, mdHtml, mdText) import Guide.Markdown (MarkdownBlock, MarkdownInline, MarkdownTree, mdHtml, mdText)
import Guide.Views.Utils (categoryLink) import Guide.Views.Utils (categoryLink)
-- | Client type of `Category`, which describes a category overview -- | Client type of `Category`, which describes a category overview
data CCategoryOverview = CCategoryOverview data CCategoryOverview = CCategoryOverview
{ ccoUid :: Uid Category { ccoUid :: Uid String
, ccoTitle :: Text , ccoTitle :: Text
, ccoLink :: Text , ccoLink :: Text
} deriving (Show, Generic) } deriving (Show, Generic)
@ -49,7 +49,7 @@ instance A.ToJSON CCategoryOverview where
toCCategoryOverview :: Category -> CCategoryOverview toCCategoryOverview :: Category -> CCategoryOverview
toCCategoryOverview cat = CCategoryOverview toCCategoryOverview cat = CCategoryOverview
{ ccoUid = cat^.uid { ccoUid = toUid (cat^.uid)
, ccoTitle = cat^.title , ccoTitle = cat^.title
, ccoLink = categoryLink cat , ccoLink = categoryLink cat
} }
@ -76,7 +76,7 @@ toCGrandCategory cats = CGrandCategory
-- | Client type of `Category`, which describes a category detail -- | Client type of `Category`, which describes a category detail
data CCategoryDetail = CCategoryDetail data CCategoryDetail = CCategoryDetail
{ ccdUid :: Uid Category { ccdUid :: Uid String
, ccdTitle :: Text , ccdTitle :: Text
, ccdGroup :: Text , ccdGroup :: Text
, ccdDescription :: CMarkdown , ccdDescription :: CMarkdown
@ -90,7 +90,7 @@ instance A.ToJSON CCategoryDetail where
toCCategoryDetail :: Category -> CCategoryDetail toCCategoryDetail :: Category -> CCategoryDetail
toCCategoryDetail cat = CCategoryDetail toCCategoryDetail cat = CCategoryDetail
{ ccdUid = cat^.uid { ccdUid = toUid (cat^.uid)
, ccdTitle = cat^.title , ccdTitle = cat^.title
, ccdGroup = cat^.group_ , ccdGroup = cat^.group_
, ccdDescription = toCMarkdown $ cat^.notes , ccdDescription = toCMarkdown $ cat^.notes
@ -100,7 +100,7 @@ toCCategoryDetail cat = CCategoryDetail
-- | Client type of `Item` -- | Client type of `Item`
data CItem = CItem data CItem = CItem
{ ciUid :: Uid Item { ciUid :: Uid String
, ciName :: Text , ciName :: Text
, ciCreated :: UTCTime , ciCreated :: UTCTime
, ciGroup :: Maybe Text , ciGroup :: Maybe Text
@ -120,7 +120,7 @@ instance A.ToJSON CItem where
toCItem :: Item -> CItem toCItem :: Item -> CItem
toCItem item = CItem toCItem item = CItem
{ ciUid = item ^. uid { ciUid = toUid (item ^. uid)
, ciName = item ^. name , ciName = item ^. name
, ciCreated = item ^. created , ciCreated = item ^. created
, ciGroup = item ^. group_ , ciGroup = item ^. group_
@ -136,7 +136,7 @@ toCItem item = CItem
} }
data CTrait = CTrait data CTrait = CTrait
{ ctUid :: Uid Trait { ctUid :: Uid String
, ctContent :: CMarkdown , ctContent :: CMarkdown
} deriving (Show, Generic) } deriving (Show, Generic)
@ -146,7 +146,7 @@ instance A.ToJSON CTrait where
toCTrait :: Trait -> CTrait toCTrait :: Trait -> CTrait
toCTrait trait = CTrait toCTrait trait = CTrait
{ ctUid = trait ^. uid { ctUid = toUid (trait ^. uid)
, ctContent = toCMarkdown $ trait ^. content , ctContent = toCMarkdown $ trait ^. content
} }
@ -177,3 +177,6 @@ instance ToCMardown MarkdownTree where
{ text = md^.mdText { text = md^.mdText
, html = T.toStrict . renderText $ toHtml md , html = T.toStrict . renderText $ toHtml md
} }
toUid :: Uid a -> Uid b
toUid (Uid t) = Uid t

View File

@ -299,7 +299,8 @@ sockAddrToIP _ = Nothing
newtype Uid a = Uid {uidToText :: Text} newtype Uid a = Uid {uidToText :: Text}
deriving (Eq, Ord, Show, Data, deriving (Eq, Ord, Show, Data,
ToHttpApiData, FromHttpApiData, ToHttpApiData, FromHttpApiData,
T.Buildable, Hashable, A.ToJSON) T.Buildable, Hashable, A.ToJSON,
Generic)
-- This instance is written manually because otherwise it produces a warning: -- This instance is written manually because otherwise it produces a warning:
-- • Redundant constraint: SafeCopy a -- • Redundant constraint: SafeCopy a

View File

@ -1,7 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
module Main module Main
@ -11,13 +11,18 @@ module Main
import Prelude import Prelude
import Data.Proxy (Proxy (..)) import Data.Proxy (Proxy (..))
import Language.PureScript.Bridge (BridgeBuilder, BridgePart, Language( Haskell ), SumType, import Language.PureScript.Bridge ( BridgePart, Language( Haskell ), PSType,
PSType, TypeInfo (..), (<|>), (^==), buildBridge, SumType, TypeInfo (..), (<|>),
defaultBridge, typeName, mkSumType, writePSTypes) (^==), buildBridge, defaultBridge,
typeName, mkSumType, writePSTypes)
import Language.PureScript.Bridge.PSTypes (psString) import Language.PureScript.Bridge.PSTypes (psString)
import Guide.Api.ClientTypes (CCategoryDetail, CCategoryOverview, CGrandCategory, CItem, CTrait, CMarkdown) import Language.PureScript.Bridge.TypeParameters (A)
import Guide.Api.ClientTypes ( CCategoryDetail, CCategoryOverview
, CGrandCategory, CItem, CTrait, CMarkdown
)
import Guide.Types.Hue (Hue) import Guide.Types.Hue (Hue)
import Guide.Types.Core (CategoryStatus, ItemKind) import Guide.Types.Core (CategoryStatus, ItemKind)
import Guide.Utils (Uid)
path :: FilePath path :: FilePath
path = "front-ps/src/Generated" path = "front-ps/src/Generated"
@ -25,13 +30,10 @@ path = "front-ps/src/Generated"
psPosixTime :: PSType psPosixTime :: PSType
psPosixTime = TypeInfo "" "Data.Time.NominalDiffTime" "NominalDiffTime" [] psPosixTime = TypeInfo "" "Data.Time.NominalDiffTime" "NominalDiffTime" []
posixTimeBridge :: BridgeBuilder PSType posixTimeBridge :: BridgePart
posixTimeBridge = posixTimeBridge =
typeName ^== "NominalDiffTime" >> pure psPosixTime typeName ^== "NominalDiffTime" >> pure psPosixTime
uidBridge :: BridgePart
uidBridge = typeName ^== "Uid" >> pure psString
byteStringBridge :: BridgePart byteStringBridge :: BridgePart
byteStringBridge = typeName ^== "ByteString" >> pure psString byteStringBridge = typeName ^== "ByteString" >> pure psString
@ -39,25 +41,24 @@ byteStringBridge = typeName ^== "ByteString" >> pure psString
utcTimeBridge :: BridgePart utcTimeBridge :: BridgePart
utcTimeBridge = typeName ^== "UTCTime" >> pure psString utcTimeBridge = typeName ^== "UTCTime" >> pure psString
bridge :: BridgePart
bridge :: BridgeBuilder PSType
bridge = defaultBridge bridge = defaultBridge
<|> posixTimeBridge <|> posixTimeBridge
<|> uidBridge
<|> byteStringBridge <|> byteStringBridge
<|> utcTimeBridge <|> utcTimeBridge
clientTypes :: [SumType 'Haskell] clientTypes :: [SumType 'Haskell]
clientTypes = clientTypes =
[ mkSumType (Proxy :: Proxy CGrandCategory) [ mkSumType (Proxy @CGrandCategory)
, mkSumType (Proxy :: Proxy CCategoryDetail) , mkSumType (Proxy @CCategoryDetail)
, mkSumType (Proxy :: Proxy CCategoryOverview) , mkSumType (Proxy @CCategoryOverview)
, mkSumType (Proxy :: Proxy Hue) , mkSumType (Proxy @Hue)
, mkSumType (Proxy :: Proxy CategoryStatus) , mkSumType (Proxy @CategoryStatus)
, mkSumType (Proxy :: Proxy CItem) , mkSumType (Proxy @CItem)
, mkSumType (Proxy :: Proxy ItemKind) , mkSumType (Proxy @ItemKind)
, mkSumType (Proxy :: Proxy CTrait) , mkSumType (Proxy @CTrait)
, mkSumType (Proxy :: Proxy CMarkdown) , mkSumType (Proxy @CMarkdown)
, mkSumType (Proxy @(Uid A))
] ]
-- FIXME: Currently `Uid a` defined in `Guide.Utils` is bridged into a `String`. -- FIXME: Currently `Uid a` defined in `Guide.Utils` is bridged into a `String`.