Merge pull request #209 from aelve/sectore/bridge-uid-more-type-safety

Bridge `Uid` in a more type safety way

front-ps/common/Guide/CategoryDetail/Events.purs

@@ -5,7 +5,8 @@ import Prelude
 import Data.Array ((:))
 import Data.Either (Either(..))
 import Data.Maybe (Maybe(..))
-import Guide.Api.Types (CCategoryDetail, CUid)
+import Guide.Api.Types (CategoryInfo, CCategoryDetail)
+import Guide.Utils (Uid)
 import Guide.CategoryDetail.Routes (Route(..))
 import Guide.CategoryDetail.State (State(..))
 import Guide.Common.Api (EndpointError, getCategory)
@@ -16,9 +17,7 @@ import Pux (EffModel, noEffects)
 
 data Event
   = PageView Route
-  | RequestCategory CategoryName (CUid String)
-  -- TODO: ^ Use `CUid Category` instead of `CUid String` as second type parameter
-  -- if we have found a way to bridge `Uid a` properly from `Haskell` to `PS`
+  | RequestCategory CategoryName (Uid CategoryInfo)
   | ReceiveCategory (Either EndpointError CCategoryDetail)
 
 foldp :: ∀ fx. Event -> State -> EffModel State Event (AppEffects fx)

front-ps/common/Guide/CategoryDetail/Routes.purs

@@ -4,13 +4,14 @@ import Prelude
 
 import Data.Generic (class Generic, gEq, gShow)
 import Data.Maybe (fromMaybe)
-import Guide.Api.Types (CUid(..))
+import Guide.Api.Types (CategoryInfo)
+import Guide.Utils (Uid)
 import Guide.Common.Routes (categoryLit, categoryDetailUrl)
-import Guide.Common.Types (CategoryName(..))
+import Guide.Common.Types (CategoryName(..), mkUid)
 import Pux.Router (end, lit, router, str)
 
 data Route
-  = CategoryDetail CategoryName (CUid String)
+  = CategoryDetail CategoryName (Uid CategoryInfo)
   | NotFound String
 
 derive instance genericRoute :: Generic Route
@@ -23,7 +24,7 @@ instance eqRoute :: Eq Route where
 match :: String -> Route
 match url = fromMaybe (NotFound url) $ router url $
   CategoryDetail <<< CategoryName <$> (lit categoryLit *> str)
-                                  <*> (CUid <$> str) <* end
+                                  <*> (mkUid <$> str) <* end
 
 toURL :: Route -> String
 toURL (NotFound url)                  = url

front-ps/common/Guide/CategoryDetail/View/CategoryDetail.purs

@@ -2,8 +2,8 @@ module Guide.CategoryDetail.View.CategoryDetail where
 
 import Prelude
 
-import Data.Lens ((^.))
-import Guide.Api.Types (CCategoryDetail(..), _CUid)
+import Guide.Api.Types (CCategoryDetail(..))
+import Guide.Common.Types (unwrapUid)
 import Guide.CategoryDetail.Events (Event)
 import Guide.CategoryDetail.State (State(..))
 import Network.RemoteData (RemoteData(..))
@@ -19,4 +19,4 @@ view (State state) =
       NotAsked -> S.div $ S.text "Categories not asked."
       Loading -> S.div $ S.text "Loading data..."
       Failure error -> S.div $ S.text $ "Error loading data: " <> (show error)
-      (Success (CCategoryDetail cat)) -> S.h2 $ S.text (cat.ccdTitle <> " - " <> (cat.ccdUid ^. _CUid))
+      (Success (CCategoryDetail cat)) -> S.h2 $ S.text (cat.ccdTitle <> " - " <> (unwrapUid cat.ccdUid))

front-ps/common/Guide/CategoryOverview/View/CategoryOverview.purs

@@ -3,12 +3,11 @@ module Guide.CategoryOverview.View.CategoryOverview where
 import Prelude
 
 import Data.Foldable (for_)
-import Data.Lens ((^.))
-import Guide.Api.Types (CategoryInfo(..), _CUid)
+import Guide.Api.Types (CategoryInfo(..))
 import Guide.CategoryOverview.Events (Event)
 import Guide.CategoryOverview.State (State(..))
 import Guide.Common.Routes (categoryDetailUrl)
-import Guide.Common.Types (CCategories)
+import Guide.Common.Types (CCategories, unwrapUid)
 import Network.RemoteData (RemoteData(..))
 import Pux.DOM.HTML (HTML) as P
 import Pux.DOM.HTML.Attributes (key) as P
@@ -35,7 +34,7 @@ catsView st@(State state) cats =
 catView :: State -> CategoryInfo -> P.HTML Event
 catView (State state) (CategoryInfo cat) =
   S.li
-    ! P.key (cat.categoryInfoUid ^. _CUid) $ do
+    ! P.key (unwrapUid cat.categoryInfoUid) $ do
     S.a
       ! S.href (categoryDetailUrl state.categoryName cat.categoryInfoUid)
       $ S.text cat.categoryInfoTitle

front-ps/common/Guide/Common/Api.purs

@@ -9,8 +9,9 @@ import Data.Bifunctor (bimap)
 import Data.Either (Either(..), either)
 import Data.Foreign (Foreign, unsafeFromForeign)
 import Data.Generic (class Generic)
-import Guide.Api.Types (CCategoryDetail, CUid(..))
-import Guide.Common.Types (CCategories, CategoryName)
+import Guide.Api.Types (CategoryInfo, CCategoryDetail)
+import Guide.Utils (Uid)
+import Guide.Common.Types (CCategories, CategoryName, unwrapUid)
 import IsomorphicFetch (FETCH, get, json)
 
 endpoint :: String
@@ -44,8 +45,8 @@ getCategories _ = do
   pure $ decodeResult json'
 
 -- | Fetches a categories by a given category id
-getCategory :: forall eff. CategoryName -> (CUid String) -> Aff (fetch :: FETCH | eff) (Either EndpointError CCategoryDetail)
-getCategory _ (CUid catId) = do
-  response <- get $ endpoint <> "/category/" <> catId
+getCategory :: forall eff. CategoryName -> (Uid CategoryInfo) -> Aff (fetch :: FETCH | eff) (Either EndpointError CCategoryDetail)
+getCategory _ catId = do
+  response <- get $ endpoint <> "/category/" <> unwrapUid catId
   json' <- json response
   pure $ decodeResult json'

front-ps/common/Guide/Common/Routes.purs

@@ -2,7 +2,8 @@ module Guide.Common.Routes where
 
 import Prelude
 
-import Guide.Api.Types (CUid(..))
+import Guide.Api.Types (CategoryInfo)
+import Guide.Utils (Uid(..))
 import Guide.Common.Types (CategoryName(..))
 
 litUrl :: String -> String
@@ -14,5 +15,5 @@ categoryLit = "category"
 categoryUrl :: CategoryName -> String
 categoryUrl (CategoryName name) = (litUrl categoryLit) <> (litUrl name)
 
-categoryDetailUrl :: forall a. CategoryName -> CUid a -> String
-categoryDetailUrl catName (CUid catId) = (categoryUrl catName) <> (litUrl catId)
+categoryDetailUrl :: CategoryName -> Uid CategoryInfo -> String
+categoryDetailUrl catName (Uid catId) = (categoryUrl catName) <> (litUrl catId.uidToText)

front-ps/common/Guide/Common/Types.purs

@@ -5,6 +5,7 @@ import Prelude
 import Data.Generic (class Generic, gShow)
 import Data.Newtype (class Newtype)
 import Guide.Api.Types (CategoryInfo)
+import Guide.Utils (Uid(..))
 import IsomorphicFetch (FETCH)
 
 type AppEffects eff = (fetch :: FETCH | eff)
@@ -16,3 +17,11 @@ instance showCategoryName :: Show CategoryName where
   show = gShow
 
 type CCategories = Array CategoryInfo
+
+-- helper
+
+mkUid :: forall a . String -> Uid a
+mkUid s = Uid {uidToText: s}
+
+unwrapUid :: forall a . Uid a -> String
+unwrapUid (Uid uid) = uid.uidToText

src/Guide/Api/Types.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE DeriveDataTypeable    #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE TypeOperators         #-}
 
@@ -11,7 +10,6 @@ module Guide.Api.Types
   , ApiError(..)
   , CategoryInfo(..)
   , CCategoryDetail(..)
-  , CUid(..)
   , CItem(..)
   , CMarkdown(..)
   , CTrait(..)
@@ -43,8 +41,8 @@ import Guide.Markdown (MarkdownBlock, MarkdownInline, MarkdownTree, mdHtml, mdSo
 -- | The description of the served API.
 data Site route = Site
   {
-  -- | A list of all categories (the /haskell page). Returns category
-  -- titles.
+  -- | A list of all categories (the /haskell page). Returns a small info
+  -- about a category
     _getCategories :: route :-
       "categories"    :> Get '[JSON] (Either ApiError [CategoryInfo])
 
@@ -56,18 +54,29 @@ data Site route = Site
   deriving (Generic)
 
 type Api = ToServant (Site AsApi)
+
 ----------------------------------------------------------------------------
 -- Client types
+
+-- These are more "light-weight" Haskell types of `Guide`,
+-- which can be bridged into PureScript types by using `purescript-bridge`
+-- w/o any issues.
+
+-- Furthermore using these "light-weight" types we keep all data small
+-- to send these over the wire w/o having deep nested data,
+-- we might not need on front-end.
 ----------------------------------------------------------------------------
 
-data ApiError = ApiError !Text
+-- | Client-side API error
+newtype ApiError = ApiError Text
   deriving (Generic)
 
 instance A.FromJSON ApiError
 instance A.ToJSON ApiError
 
+-- | A "light-weight" client type of `Category`, which describes a category info
 data CategoryInfo = CategoryInfo
-  { categoryInfoUid     :: CUid String
+  { categoryInfoUid     :: Uid CategoryInfo
   , categoryInfoTitle   :: Text
   , categoryInfoCreated :: UTCTime
   , categoryInfoGroup_  :: Text
@@ -77,19 +86,19 @@ data CategoryInfo = CategoryInfo
 
 instance A.ToJSON CategoryInfo
 
--- | Client type of `Category`, which describes a category info
+-- | Factory to create a `CategoryInfo` from a `Category`
 toCategoryInfo :: Category -> CategoryInfo
 toCategoryInfo Category{..} = CategoryInfo
-  { categoryInfoUid     = toCUid _categoryUid
+  { categoryInfoUid     = bridgeUid _categoryUid
   , categoryInfoTitle   = _categoryTitle
   , categoryInfoCreated = _categoryCreated
   , categoryInfoGroup_  = _categoryGroup_
   , categoryInfoStatus  = _categoryStatus
   }
 
--- | Client type of `Category`, which describes a category detail
+-- | A "light-weight" client type of `Category`, which describes a category detail
 data CCategoryDetail = CCategoryDetail
-  { ccdUid :: CUid String
+  { ccdUid :: Uid CCategoryDetail
   , ccdTitle :: Text
   , ccdGroup :: Text
   , ccdDescription :: CMarkdown
@@ -101,9 +110,10 @@ data CCategoryDetail = CCategoryDetail
 instance A.ToJSON CCategoryDetail where
   toJSON = A.genericToJSON A.defaultOptions
 
+-- | Factory to create a `CCategoryDetail` from a `Category`
 toCCategoryDetail :: Category -> CCategoryDetail
 toCCategoryDetail Category{..} = CCategoryDetail
-  { ccdUid = toCUid _categoryUid
+  { ccdUid = bridgeUid _categoryUid
   , ccdTitle = _categoryTitle
   , ccdGroup = _categoryGroup_
   , ccdDescription = toCMarkdown _categoryNotes
@@ -113,7 +123,7 @@ toCCategoryDetail Category{..} = CCategoryDetail
 
 -- | Client type of `Item`
 data CItem = CItem
-  { ciUid :: CUid String
+  { ciUid :: Uid CItem
   , ciName :: Text
   , ciCreated :: UTCTime
   , ciGroup :: Maybe Text
@@ -131,9 +141,10 @@ data CItem = CItem
 instance A.ToJSON CItem where
   toJSON = A.genericToJSON A.defaultOptions
 
+-- | Factory to create a `CItem` from an `Item`
 toCItem :: Item -> CItem
 toCItem Item{..} = CItem
-  { ciUid = toCUid _itemUid
+  { ciUid = bridgeUid _itemUid
   , ciName = _itemName
   , ciCreated = _itemCreated
   , ciGroup = _itemGroup_
@@ -150,7 +161,7 @@ toCItem Item{..} = CItem
 
 -- | Client type of `Trait`
 data CTrait = CTrait
-  { ctUid :: CUid String
+  { ctUid :: Uid CTrait
   , ctContent :: CMarkdown
   } deriving (Show, Generic)
 
@@ -158,9 +169,10 @@ data CTrait = CTrait
 instance A.ToJSON CTrait where
   toJSON = A.genericToJSON A.defaultOptions
 
+-- | Factory to create a `CTrait` from a `Trait`
 toCTrait :: Trait -> CTrait
 toCTrait trait = CTrait
-  { ctUid = toCUid (trait ^. uid)
+  { ctUid = bridgeUid (trait ^. uid)
   , ctContent = toCMarkdown $ trait ^. content
   }
 
@@ -173,6 +185,7 @@ data CMarkdown = CMarkdown
 instance A.ToJSON CMarkdown where
   toJSON = A.genericToJSON A.defaultOptions
 
+-- | Type class to create `CMarkdown`
 class ToCMardown md where toCMarkdown :: md -> CMarkdown
 
 instance ToCMardown MarkdownInline where
@@ -193,14 +206,15 @@ instance ToCMardown MarkdownTree where
     , html = T.toStrict . renderText $ toHtml md
     }
 
--- | Client type of `Uid`.
--- It's needed because we don't find a way
--- to bridge `Uid a` properly (for example `Uid Category` )
-newtype CUid a = CUid Text
-  deriving (Eq, Ord, Show, Generic, Data, Typeable)
+----------------------------------------------------------------------------
+-- Helpers
+----------------------------------------------------------------------------
 
-instance A.ToJSON (CUid a) where
-  toJSON = A.genericToJSON A.defaultOptions
-
-toCUid :: Uid a -> CUid b
-toCUid (Uid t) = CUid t
+-- | It converts `Uid a` into a more client-side friendly type `Uid b`,
+-- where `b` is compatible to bridge it w/ `purescript-bridge` w/o any mess.
+--
+-- For example: With `Uid Category` we have some issue to bridge
+-- it into PureScript. By using `bridgeUid` we can transform this type
+-- into a more client-side friendly `Uid CCategoryDetail`
+bridgeUid :: Uid a -> Uid b
+bridgeUid (Uid t) = Uid t

src/Guide/Utils.hs

@@ -311,7 +311,10 @@ sockAddrToIP _ = Nothing
 newtype Uid a = Uid {uidToText :: Text}
   deriving (Generic, Eq, Ord, Show, Data,
             ToHttpApiData, FromHttpApiData,
-            T.Buildable, Hashable, A.ToJSON)
+            T.Buildable, Hashable)
+
+instance A.ToJSON (Uid a) where
+  toJSON = A.genericToJSON A.defaultOptions
 
 -- This instance is written manually because otherwise it produces a warning:
 --     • Redundant constraint: SafeCopy a
@@ -451,7 +454,7 @@ getRequestDetails
   :: (MonadIO m, HasSpock (ActionCtxT ctx m))
   => ActionCtxT ctx m (UTCTime, Maybe IP, Maybe Text, Maybe Text)
 getRequestDetails = do
-  time <- liftIO $ getCurrentTime
+  time <- liftIO getCurrentTime
   mbForwardedFor <- liftA2 (<|>) (Spock.header "Forwarded-For")
                                  (Spock.header "X-Forwarded-For")
   mbIP <- case mbForwardedFor of

src/purescript/Main.hs

@@ -18,9 +18,10 @@ import Language.PureScript.Bridge ( BridgePart, Language( Haskell ), PSType,
 import Language.PureScript.Bridge.PSTypes (psString)
 import Language.PureScript.Bridge.TypeParameters (A)
 
-import Guide.Api.Types (ApiError, CategoryInfo, CCategoryDetail, CItem, CMarkdown, CTrait, CUid)
+import Guide.Api.Types (ApiError, CategoryInfo, CCategoryDetail, CItem, CMarkdown, CTrait)
 import Guide.Types.Core (CategoryStatus, ItemKind)
 import Guide.Types.Hue (Hue)
+import Guide.Utils (Uid)
 
 path :: FilePath
 path = "front-ps/common/Generated"
@@ -56,12 +57,8 @@ clientTypes =
   , mkSumType (Proxy @CMarkdown)
   , mkSumType (Proxy @Hue)
   , mkSumType (Proxy @ItemKind)
-  , mkSumType (Proxy @(CUid A))
+  , mkSumType (Proxy @(Uid A))
   ]
 
--- FIXME: Currently `Uid a` defined in `Guide.Utils` is bridged into a `String`.
--- For example: `Uid Category` on Haskell side is bridged to `String`
--- It would be better to bridge it to a similar `Uid a` type
-
 main :: IO ()
 main = writePSTypes path (buildBridge bridge) clientTypes

templates/item-description.widget

@@ -19,7 +19,7 @@ HTML
           title  = "edit summary"
           class  = "edit-item-description"
           action = [| editItemDescription(
-                        {{{%js item.uid}}},
+                        {{{%js item.uid.uidToText}}},
                         {{{%js item.description.text}}}); |] }}
     <div class="notes-like">
       {{# item.description.text}}
@@ -38,7 +38,7 @@ HTML
           src    = "/pencil.svg"
           title  = "quit editing summary"
           class  = "edit-item-description"
-          action = [| stopEditingItemDescription({{{%js item.uid}}}); |] }}
+          action = [| stopEditingItemDescription({{{%js item.uid.uidToText}}}); |] }}
     <div class="editor"></div>
   </div>
 </div>

templates/item-info.widget

@@ -79,25 +79,25 @@ HTML: item-info-controls
           src    = "/arrow-thick-top.svg"
           title  = "move item up"
           class  = "move-item-up"
-          action = [| moveItem("up", {{{%js item.uid}}}); |] }}
+          action = [| moveItem("up", {{{%js item.uid.uidToText}}}); |] }}
     {{> img-button
           src    = "/arrow-thick-bottom.svg"
           title  = "move item down"
           class  = "move-item-down"
-          action = [| moveItem("down", {{{%js item.uid}}}); |] }}
+          action = [| moveItem("down", {{{%js item.uid.uidToText}}}); |] }}
   </span>
   <span>
     {{> img-button
           src    = "/cog.svg"
           title  = "edit item info"
           class  = "edit-item-info"
-          action = [| editItemInfo({{{%js item.uid}}}); |] }}
+          action = [| editItemInfo({{{%js item.uid.uidToText}}}); |] }}
     {{> space em=0.4 }}
     {{> img-button
           src    = "/x.svg"
           title  = "delete item"
           class  = "delete-item"
-          action = [| deleteItem({{{%js item.uid}}}); |] }}
+          action = [| deleteItem({{{%js item.uid.uidToText}}}); |] }}
   </span>
 </div>
 
@@ -177,7 +177,7 @@ CSS
 HTML: item-info-edit-form
 ------------------------------------------------------------
 {{! "autocomplete=off" everywhere: http://stackoverflow.com/q/8311455 }}
-<form class="item-info-edit-form" onsubmit="submitItemInfo('{{item.uid}}', this); return false;">
+<form class="item-info-edit-form" onsubmit="submitItemInfo('{{item.uid.uidToText}}', this); return false;">
   <label for="name">
     Name
   </label>
@@ -228,7 +228,7 @@ HTML: item-info-edit-form
   <div class="form-btn-group">
     <input value="Save" class="save" type="submit">
     <input value="Cancel" class="cancel" type="button"
-          onclick="itemInfoCancelEdit('{{item.uid}}');">
+          onclick="itemInfoCancelEdit('{{item.uid.uidToText}}');">
   </div>
 </form>
 

templates/trait.widget

@@ -5,9 +5,9 @@ A list item containing a trait (pro/con), together with some JS that lets the us
 
 Required context:
 
-  * item.uid
+  * item.uid.uidToText
 
-  * trait.uid
+  * trait.uid.uidToText
     trait.content.html
     trait.content.text
 
@@ -15,7 +15,7 @@ Required context:
 HTML
 ============================================================
 
-<li id="trait-{{trait.uid}}">
+<li id="trait-{{trait.uid.uidToText}}">
 
   <div class="section normal editable shown noscript-shown">
     {{{trait.content.html}}}
@@ -26,22 +26,22 @@ HTML
       {{> small-control
             src    = "/arrow-thick-top.svg"
             title  = "move trait up"
-            action = [| moveTrait("up",{{{%js item.uid}}},{{{%js trait.uid}}}); |] }}
+            action = [| moveTrait("up",{{{%js item.uid.uidToText}}},{{{%js trait.uid.uidToText}}}); |] }}
       {{> small-control
             src    = "/arrow-thick-bottom.svg"
             title  = "move trait down"
-            action = [| moveTrait("down",{{{%js item.uid}}},{{{%js trait.uid}}}); |] }}
+            action = [| moveTrait("down",{{{%js item.uid.uidToText}}},{{{%js trait.uid.uidToText}}}); |] }}
       {{> space px=16}}
       {{> small-control
             src    = "/pencil.svg"
             title  = "edit trait"
-            action = [| editTrait({{{%js item.uid}}}, {{{%js trait.uid}}},
+            action = [| editTrait({{{%js item.uid.uidToText}}}, {{{%js trait.uid.uidToText}}},
                                   {{{%js trait.content.text}}}); |] }}
       {{> space px=16}}
       {{> small-control
             src    = "/x.svg"
             title  = "delete trait"
-            action = [| deleteTrait({{{%js item.uid}}},{{{%js trait.uid}}}); |] }}
+            action = [| deleteTrait({{{%js item.uid.uidToText}}},{{{%js trait.uid.uidToText}}}); |] }}
     </div>
   </div>