cleaning warning and adding Endo style

Author: Andika Demas Riyandi

src-ui.v3/src/API.hs

@@ -71,7 +71,7 @@ module API
 import           PkgId
 
 import           Control.Monad    (fail)
-import           Data.Aeson       (FromJSON, ToJSON, decode)
+import           Data.Aeson       (FromJSON, decode)
 import qualified Data.Aeson       as J
 import qualified Data.Aeson.Types as J
 import qualified Data.Char        as C

src-ui.v3/src/Main.hs

@@ -114,7 +114,7 @@ bodyElement4 = do
   -- ticker1 <- tickLossy 1 =<< liftIO getCurrentTime
 --    ticker1cnt <- count ticker1
 
-app :: forall t r m. (SetRoute t (NonEmpty FragRoute) m, SupportsServantReflex t m, MonadFix m, MonadIO m, MonadHold t m, PostBuild t m, DomBuilder t m, Adjustable t m, DomBuilderSpace m ~ GhcjsDomSpace) 
+app :: forall t m. (SetRoute t FragRoute m, SupportsServantReflex t m, MonadFix m, MonadIO m, MonadHold t m, PostBuild t m, DomBuilder t m, Adjustable t m, DomBuilderSpace m ~ GhcjsDomSpace) 
     => Dynamic t FragRoute
     -> m ()
 app dynFrag = do
@@ -707,22 +707,6 @@ findInitialDropDown (Just idx) pkgSet = if Set.member idx pkgSet
                                         else Set.findMax pkgSet
 findInitialDropDown Nothing pkgSet    = Set.findMax pkgSet
 
-switchPkgRoute :: Set PkgIdxTs -> URI ->  PkgIdxTs -> Maybe URI 
-switchPkgRoute setPkgIdx oldRoute (PkgIdxTs 0) = Nothing
-switchPkgRoute setPkgIdx oldRoute idxChange =
-  let routeS  = (T.pack . uriFragment) oldRoute
-      rootURI = "#/package/"
-  in case T.stripPrefix rootURI routeS of
-    Just sfx | (Just pkgN, Just pkgIdx) <- pkgNFromText sfx
-             , True <- idxChange /= pkgIdx
-             , True <- not (Set.null setPkgIdx)
-             , Just setMax <- Set.lookupMax setPkgIdx
-               -> if setMax == idxChange
-                  then Nothing
-                  else parseURI . T.unpack $ rootURI <> (pkgNToText pkgN) <> (T.pack "@") <> (idxTsToText idxChange)
-             | otherwise -> Nothing
-    Nothing  -> Nothing
-
 toggleTagSet :: TagN -> Set.Set TagN -> Set.Set TagN
 toggleTagSet tn st = if Set.member tn st then Set.delete tn st else Set.insert tn st
 

src-ui.v3/src/PkgId.hs

@@ -33,7 +33,6 @@ module PkgId
     , PkgRev
 
     , UserName
-    , FragRoute(..), decodeFrag
     ) where
 
 import           Control.Monad                (fail)
@@ -176,35 +175,7 @@ matchesEmpty = Matches { matchesInput = T.empty, matchesExact = Map.empty, match
 
 ---------------------------------
 
-data FragRoute = RouteHome
-               | RouteQueue
-               | RoutePackages
-               | RoutePackage (PkgN, Maybe PkgIdxTs)
-               | RouteUser UserName
-               | RouteUnknown T.Text
-               deriving (Eq, Ord)
-
-decodeFrag :: T.Text -> FragRoute
-decodeFrag frag = case frag of
-    ""           -> RouteHome
-    "#"          -> RouteHome
-    "#/"         -> RouteHome
-    "#/queue"    -> RouteQueue
-    "#/packages" -> RoutePackages
-
-    _ | Just sfx <- T.stripPrefix "#/package/" frag
-      , not (T.null frag)
-      , (Just pn, idx) <- pkgNFromText sfx
-        -> RoutePackage (pn , idx)
-
-      | Just sfx <- T.stripPrefix "#/user/" frag
-      , not (T.null frag)
-      , T.all (\c -> C.isAsciiLower c || C.isAsciiUpper c || C.isDigit c || c == '_') sfx
-        -> RouteUser sfx
-
-      | otherwise -> RouteUnknown frag
-
---encodeFrag :: FragRoute -> Maybe 
+
 
 
 

src-ui.v3/src/Router.hs

@@ -33,51 +33,53 @@ module Router
   , routeLink
   , routePkgIdxTs
   , runRouteViewT
+  , FragRoute(..), decodeFrag
   ) where
 
 import           Prelude hiding ((.), id)
 import           Control.Category (Category (..), (.))
 import           Control.Lens hiding (Bifunctor, bimap, universe, element)
-import           Control.Monad ((<=<))
 import           Control.Monad.Fix
 import           Control.Monad.Primitive
 import           Control.Monad.Reader
 import           Control.Monad.Ref
-import           Control.Monad.Trans.Control
+import qualified Data.Char                 as C
 import           Data.Coerce
-import qualified Data.List.NonEmpty        as NE
-import           Data.List.NonEmpty        (NonEmpty)
 import qualified Data.Map.Strict           as Map
 import           Data.Monoid
 import           Data.Proxy
 import qualified Data.Set                  as Set
 import           Data.Set                  (Set)
 import           Data.Text (Text)
 import qualified Data.Text as T
-import           Data.Functor.Compose
 import           Reflex.Class
 import           Reflex.Host.Class
 import           Reflex.PostBuild.Class
 import           Reflex.TriggerEvent.Class
 import           Reflex.PerformEvent.Class
 import           Reflex.EventWriter.Class
 import           Reflex.EventWriter.Base
-import           Reflex.Dynamic
 import           Reflex.Dom.Builder.Class
-import           Data.Type.Coercion
 import           Language.Javascript.JSaddle
 import           Reflex.Dom.Core
 import qualified GHCJS.DOM.Types as DOM
 import           Network.URI
-import           Data.Maybe (Maybe(..), fromMaybe, isJust)
-import qualified Data.List as L
+import           Data.Maybe (Maybe(..), fromMaybe)
 
 import           PkgId
 
-newtype SetRouteT t r m a = SetRouteT { unSetRouteT :: EventWriterT t r m a }
+data FragRoute = RouteHome
+               | RouteQueue
+               | RoutePackages
+               | RoutePackage (PkgN, Maybe PkgIdxTs)
+               | RouteUser UserName
+               | RouteUnknown T.Text
+               deriving (Eq, Ord)
+
+newtype SetRouteT t r m a = SetRouteT { unSetRouteT :: EventWriterT t (Endo r) m a }
   deriving (Functor, Applicative, Monad, MonadFix, MonadTrans, MonadIO, NotReady t, MonadHold t, MonadSample t, PostBuild t, TriggerEvent t, MonadReflexCreateTrigger t, HasDocument, DomRenderHook t)
 
-instance (Semigroup r, MonadFix m, MonadHold t m, DomBuilder t m) => DomBuilder t (SetRouteT t r m) where
+instance (MonadFix m, MonadHold t m, DomBuilder t m) => DomBuilder t (SetRouteT t r m) where
   type DomBuilderSpace (SetRouteT t r m) = DomBuilderSpace m
   element t cfg child = SetRouteT $ element t cfg $ unSetRouteT child
   inputElement = lift . inputElement
@@ -91,15 +93,15 @@ instance HasJSContext m => HasJSContext (SetRouteT t r m) where
 mapSetRouteT :: (forall x. m x -> n x) -> SetRouteT t r m a -> SetRouteT t r n a
 mapSetRouteT f (SetRouteT x) = SetRouteT (mapEventWriterT f x)
 
-runSetRouteT :: (Semigroup r, Reflex t, Monad m) => SetRouteT t r m a -> m (a, Event t r)
+runSetRouteT :: (Reflex t, Monad m) => SetRouteT t r m a -> m (a, Event t (Endo r))
 runSetRouteT = runEventWriterT . unSetRouteT
 
 class Reflex t => SetRoute t r m | m -> t r where
-  setRoute :: Event t r -> m ()
+  setRoute :: Event t (r -> r) -> m ()
   setRoute = setRoute
 
-instance (Semigroup r, Reflex t, Monad m) => SetRoute t r (SetRouteT t r m) where
-  setRoute = SetRouteT . tellEvent
+instance (Reflex t, Monad m) => SetRoute t r (SetRouteT t r m) where
+  setRoute = SetRouteT . tellEvent . fmap Endo
 
 instance (Monad m, SetRoute t r m) => SetRoute t r (QueryT t q m)
 
@@ -140,7 +142,7 @@ instance PrimMonad m => PrimMonad (SetRouteT t r m ) where
   type PrimState (SetRouteT t r m) = PrimState m
   primitive = lift . primitive
 
-instance (Semigroup r, MonadHold t m, Adjustable t m) => Adjustable t (SetRouteT t r m) where
+instance (MonadHold t m, Adjustable t m) => Adjustable t (SetRouteT t r m) where
   runWithReplace a0 a' = SetRouteT $ runWithReplace (coerce a0) $ coerceEvent a'
   traverseIntMapWithKeyWithAdjust f a0 a' = SetRouteT $ traverseIntMapWithKeyWithAdjust (coerce f) (coerce a0) $ coerce a'
   traverseDMapWithKeyWithAdjust f a0 a' = SetRouteT $ traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
@@ -151,23 +153,7 @@ instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (SetRouteT t r m) where
   askQueryResult = lift askQueryResult
   queryIncremental = lift . queryIncremental
 
-switchPkgRoute :: Set PkgIdxTs -> URI ->  PkgIdxTs -> Maybe URI 
-switchPkgRoute setPkgIdx oldRoute (PkgIdxTs 0) = Nothing
-switchPkgRoute setPkgIdx oldRoute idxChange =
-  let routeS  = (T.pack . uriFragment) oldRoute
-      rootURI = "#/package/"
-  in case T.stripPrefix rootURI routeS of
-    Just sfx | (Just pkgN, Just pkgIdx) <- pkgNFromText sfx
-             , True <- idxChange /= pkgIdx
-             , True <- not (Set.null setPkgIdx)
-             , Just setMax <- Set.lookupMax setPkgIdx
-               -> if setMax == idxChange
-                  then Nothing
-                  else parseURI . T.unpack $ rootURI <> (pkgNToText pkgN) <> (T.pack "@") <> (idxTsToText idxChange)
-             | otherwise -> Nothing
-    Nothing  -> Nothing
-
-routeLink :: forall t m a route. ( DomBuilder t m, SetRoute t (NonEmpty FragRoute) m) 
+routeLink :: forall t m a. ( DomBuilder t m, SetRoute t FragRoute m) 
           => Bool -- PreventDefault?
           -> Text -- Target route
           -> m a -- Child widget
@@ -177,16 +163,16 @@ routeLink True r w = do
         & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)
         & elementConfig_initialAttributes .~ "href" =: r
   (e, a) <- element "a" cfg w
-  setRoute $ (((decodeFrag r) NE.:| []) <$ domEvent Click e) 
+  setRoute $ (switchPkgRoute (Just $ decodeFrag r)) <$ domEvent Click e
   return a
 routeLink False r w = do
   let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
         & elementConfig_initialAttributes .~ "href" =: r
   (e, a) <- element "a" cfg w
-  setRoute $ (((decodeFrag r) NE.:| []) <$ domEvent Click e) 
+  setRoute $ (switchPkgRoute (Just $ decodeFrag r)) <$ domEvent Click e 
   return a
 
-routePkgIdxTs :: forall t m. ( PostBuild t m, MonadHold t m, MonadFix m, DomBuilder t m, SetRoute t (NonEmpty FragRoute) m) 
+routePkgIdxTs :: forall t m. (PostBuild t m, MonadHold t m, MonadFix m, DomBuilder t m, SetRoute t FragRoute m) 
               => PkgN
               -> PkgIdxTs
               -> Behavior t (Set PkgIdxTs)
@@ -196,50 +182,48 @@ routePkgIdxTs :: forall t m. ( PostBuild t m, MonadHold t m, MonadFix m, DomBuil
 routePkgIdxTs pn k0 setIdx opt ddConf = do
   dd <- dropdown k0 opt ddConf
   let evDD = attach setIdx (updated $ dd ^. dropdown_value)
-  setRoute $ ((\val -> (createRoutePackage pn val) NE.:| []) <$> evDD)
+  setRoute $ (switchPkgRoute . (\tup -> createRoutePackage pn tup)) <$> evDD
   pure dd
 
-createRoutePackage :: PkgN -> (Set PkgIdxTs, PkgIdxTs) -> FragRoute
-createRoutePackage pn (_, PkgIdxTs 0) = RoutePackage (pn, Nothing)
+createRoutePackage :: PkgN -> (Set PkgIdxTs, PkgIdxTs) -> Maybe FragRoute
+createRoutePackage pn (_, PkgIdxTs 0) = Just $ RoutePackage (pn, Nothing)
 createRoutePackage pn (setIdx, pkgIdx) 
   | Just maxIdx <- Set.lookupMax setIdx
   , True     <- maxIdx /= pkgIdx
-  = RoutePackage (pn, Just pkgIdx)
-  | otherwise = RoutePackage (pn, Nothing)
+  = Just $ RoutePackage (pn, Just pkgIdx)
+  | otherwise = Just $ RoutePackage (pn, Nothing)
 
 runRouteViewT  :: forall t m a. (TriggerEvent t m, PerformEvent t m, MonadHold t m, MonadJSM m, MonadJSM (Performable m), MonadFix m)
-               => (Dynamic t FragRoute -> SetRouteT t (NonEmpty FragRoute) m a)
+               => (Dynamic t FragRoute -> SetRouteT t FragRoute m a)
                -> m a
 runRouteViewT app = mdo
   historyState <- manageHistory $ HistoryCommand_PushState <$> setState
-  dynLoc <- browserHistoryWith getLocationUri
-  (result, changeStateE) <- runSetRouteT $ app route -- changeStateE :: Event t (NonEmpty Fragroute)
+  --dynLoc <- browserHistoryWith getLocationUri
+  (result, changeStateE) <- runSetRouteT $ app route -- changeStateE :: Event t (Endo (Fragroute -> FragRoute)
   let 
+    dynLoc = _historyItem_uri <$> historyState
+
     route :: Dynamic t FragRoute
     route = decodeFrag . T.pack . uriFragment <$> dynLoc
 
-    f  (currentHistoryState, oldR) chStateE = -- chState :: NonEmpty Fragroute
-      let newRoute = switchPkgRoute' oldR chStateE
-          oldRoute = case encodeFrag oldR of
-                       (Just a) -> a
-                       Nothing  -> T.empty
-      in 
-        HistoryStateUpdate
-        { _historyStateUpdate_state = DOM.SerializedScriptValue jsNull
-        , _historyStateUpdate_title = ""
-        , _historyStateUpdate_uri   = applyEncoding oldRoute newRoute (_historyItem_uri currentHistoryState)
-        }
-    setState = attachWith f ( (,) <$> current historyState <*> current route) changeStateE
+    f  (currentHistoryState, oldR) chStateE = -- chState :: Endo (FragRoute -> FragRoute)
+      let newRoute = encodeFrag $ appEndo chStateE oldR
+          --oldRoute = case encodeFrag oldR of
+          --             (Just a) -> a
+          --             Nothing  -> T.empty
+      in do
+        oldRoute <- encodeFrag oldR
+        newUri   <- applyEncoding oldRoute newRoute (_historyItem_uri currentHistoryState)
+        pure $ HistoryStateUpdate
+               { _historyStateUpdate_state = DOM.SerializedScriptValue jsNull
+               , _historyStateUpdate_title = ""
+               , _historyStateUpdate_uri   = Just newUri
+               }
+    setState = fmapMaybe id $ attachWith f ( (,) <$> current historyState <*> current route) changeStateE
   pure result
 
-switchPkgRoute' :: FragRoute -> NonEmpty FragRoute -> Text
-switchPkgRoute' oldFrag nEFrag
-  | (fragR, _) <- NE.uncons nEFrag
-  , Just fResult <- encodeFrag fragR
-    = fResult
-  | Just oldResult <- encodeFrag oldFrag
-    = oldResult
-  | otherwise = T.empty
+switchPkgRoute :: Maybe FragRoute -> FragRoute -> FragRoute
+switchPkgRoute newFrag oldFrag = fromMaybe oldFrag newFrag
 
 encodeFrag :: FragRoute -> Maybe Text
 encodeFrag RouteHome = Just "#/"
@@ -252,7 +236,28 @@ encodeFrag (RoutePackage (pkg, maybeIndex))
 encodeFrag (RouteUser usr) = Just $ "#/user/" <> usr
 encodeFrag (RouteUnknown _) = Nothing
 
-applyEncoding :: Text -> Text -> URI -> Maybe URI
-applyEncoding oldR newR u 
+applyEncoding :: Text -> Maybe Text -> URI -> Maybe URI
+applyEncoding _ Nothing _ = Nothing
+applyEncoding oldR (Just newR) u 
   | oldR /= newR = Just $ u { uriFragment = T.unpack newR }
-  | otherwise    = Nothing
+  | otherwise    = Nothing
+
+decodeFrag :: T.Text -> FragRoute
+decodeFrag frag = case frag of
+    ""           -> RouteHome
+    "#"          -> RouteHome
+    "#/"         -> RouteHome
+    "#/queue"    -> RouteQueue
+    "#/packages" -> RoutePackages
+
+    _ | Just sfx <- T.stripPrefix "#/package/" frag
+      , not (T.null frag)
+      , (Just pn, idx) <- pkgNFromText sfx
+        -> RoutePackage (pn , idx)
+
+      | Just sfx <- T.stripPrefix "#/user/" frag
+      , not (T.null frag)
+      , T.all (\c -> C.isAsciiLower c || C.isAsciiUpper c || C.isDigit c || c == '_') sfx
+        -> RouteUser sfx
+
+      | otherwise -> RouteUnknown frag