Merge pull request #1076 from alexfmpe/ghc-9.8

Support ghc 9.8 in cabal build of skeleton and deps

lib/asset/manifest/obelisk-asset-manifest.cabal

@@ -24,6 +24,7 @@ library
     , filepath
     , template-haskell
     , text
+    , th-abstraction >= 0.4
     , transformers
     , unix-compat
     , vector

lib/asset/manifest/src/Obelisk/Asset/Promoted.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}
@@ -12,6 +13,7 @@ import Obelisk.Asset.Gather
 import Data.Foldable
 import Language.Haskell.TH (pprint)
 import Language.Haskell.TH.Syntax hiding (lift)
+import Language.Haskell.TH.Datatype.TyVarBndr (kindedTVFlag)
 import GHC.TypeLits
 import Data.Sequence (Seq)
 import qualified Data.Sequence as Seq
@@ -88,7 +90,15 @@ staticClass = do
   let n x = Name (OccName x) NameS
       className = n "StaticFile"
       methodName = n "hashedPath"
-      cls = ClassD [] className [KindedTV (n "s") (ConT ''Symbol)] [] [SigD methodName (ConT ''Text)]
+      cls = ClassD [] className [kindedTVFlag (n "s") breq (ConT ''Symbol)] [] [SigD methodName (ConT ''Text)]
+
+-- Can replace with Language.Haskell.TH.Datatype.TyVarBndr.BndrReq once support is dropped for th-abstractions < 0.6
+#if MIN_VERSION_template_haskell(2,21,0)
+      breq = BndrReq
+#else
+      breq = ()
+#endif
+
   tell $ Seq.singleton cls
   return $ StaticContext
     { _staticContext_className = className

lib/asset/manifest/src/Obelisk/Asset/TH.hs

@@ -86,4 +86,4 @@ staticAssetWorker root staticOut fp = do
   exists <- runIO $ doesFileExist $ staticOut </> fp
   when (not exists) $
     fail $ "The file " <> fp <> " was not found in " <> staticOut
-  returnQ $ LitE $ StringL $ root </> fp
+  return $ LitE $ StringL $ root </> fp

lib/backend/src/Obelisk/Backend.hs

@@ -48,12 +48,13 @@ import Data.Monoid ((<>))
 #endif
 
 import Control.Monad
-import Control.Monad.Except
+import Control.Monad.IO.Class (MonadIO (liftIO))
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BSC8
 import Data.Default (Default (..))
 import Data.Dependent.Sum
 import Data.Functor.Identity
+import Data.Kind (Type)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Text (Text)
@@ -202,7 +203,7 @@ data StaticAssets = StaticAssets
   }
   deriving (Show, Read, Eq, Ord)
 
-data GhcjsAppRoute :: (* -> *) -> * -> * where
+data GhcjsAppRoute :: (Type -> Type) -> Type -> Type where
   GhcjsAppRoute_App :: appRouteComponent a -> GhcjsAppRoute appRouteComponent a
   GhcjsAppRoute_Resource :: GhcjsAppRoute appRouteComponent [Text]
 

lib/frontend/src/Obelisk/Frontend.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Obelisk.Frontend
   ( ObeliskWidget
@@ -29,6 +30,10 @@ module Obelisk.Frontend
 #if __GLASGOW_HASKELL__ < 810
 import Data.Monoid ((<>))
 #endif
+#if __GLASGOW_HASKELL__ >= 906
+import Control.Monad (when)
+import Data.Functor (void)
+#endif
 #endif
 
 import Prelude hiding ((.))
@@ -203,7 +208,6 @@ runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = d
            , PrimMonad m
            , MonadSample DomTimeline (Performable m)
            , DOM.MonadJSM m
-           , MonadFix (Client (HydrationDomBuilderT s DomTimeline m))
            , MonadFix (Performable m)
            , MonadFix m
            , Prerender DomTimeline (HydrationDomBuilderT s DomTimeline m)

lib/frontend/src/Obelisk/Frontend/Cookie.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Obelisk.Frontend.Cookie where

lib/route/src/Obelisk/Route.hs

@@ -165,6 +165,10 @@ import Control.Lens
 import Control.Monad.Trans (lift)
 import Data.Monoid ((<>))
 #endif
+#if __GLASGOW_HASKELL__ >= 906
+import Control.Monad (forM, (<=<))
+import Control.Monad.Trans (lift)
+#endif
 #endif
 
 import Control.Monad.Except
@@ -184,6 +188,7 @@ import Data.Functor.Sum
 import Data.GADT.Compare
 import Data.GADT.Compare.TH
 import Data.GADT.Show
+import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -840,10 +845,10 @@ prefixNonemptyTextEncoder p = Encoder $ pure $ EncoderImpl
   }
 
 packTextEncoder :: (Applicative check, Applicative parse, IsText text) => Encoder check parse String text
-packTextEncoder = isoEncoder packed
+packTextEncoder = viewEncoder packed
 
 unpackTextEncoder :: (Applicative check, Applicative parse, IsText text) => Encoder check parse text String
-unpackTextEncoder = isoEncoder unpacked
+unpackTextEncoder = viewEncoder unpacked
 
 toListMapEncoder :: (Applicative check, Applicative parse, Ord k) => Encoder check parse (Map k v) [(k, v)]
 toListMapEncoder = Encoder $ pure $ EncoderImpl
@@ -957,10 +962,39 @@ handleEncoder recover e = Encoder $ do
 
 -- | The typical full route type comprising all of an Obelisk application's routes.
 -- Parameterised by the top level GADTs that define backend and frontend routes, respectively.
-data FullRoute :: (* -> *) -> (* -> *) -> * -> * where
+data FullRoute :: (Type -> Type) -> (Type -> Type) -> Type -> Type where
   FullRoute_Backend :: br a -> FullRoute br fr a
   FullRoute_Frontend :: ObeliskRoute fr a -> FullRoute br fr a
 
+-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your
+-- frontend.
+data ObeliskRoute :: (Type -> Type) -> Type -> Type where
+  -- We need to have the `f a` as an argument here, because otherwise we have no way to specifically check for overlap between us and the given encoder
+  ObeliskRoute_App :: f a -> ObeliskRoute f a
+  ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a
+
+-- | A type representing the various resource routes served by Obelisk. These can in principle map to any physical routes you want,
+-- but sane defaults are provided by 'resourceRouteSegment'
+data ResourceRoute :: Type -> Type where
+  ResourceRoute_Static :: ResourceRoute [Text] -- This [Text] represents the *path in our static files directory*, not necessarily the URL path that the asset gets served at (although that will often be "/static/this/text/thing")
+  ResourceRoute_Ghcjs :: ResourceRoute [Text]
+  ResourceRoute_JSaddleWarp :: ResourceRoute (R JSaddleWarpRoute)
+  ResourceRoute_Version :: ResourceRoute ()
+
+data JSaddleWarpRoute :: Type -> Type where
+  JSaddleWarpRoute_JavaScript :: JSaddleWarpRoute ()
+  JSaddleWarpRoute_WebSocket :: JSaddleWarpRoute ()
+  JSaddleWarpRoute_Sync :: JSaddleWarpRoute [Text]
+
+data IndexOnlyRoute :: Type -> Type where
+  IndexOnlyRoute :: IndexOnlyRoute ()
+
+concat <$> mapM deriveRouteComponent
+  [ ''ResourceRoute
+  , ''JSaddleWarpRoute
+  , ''IndexOnlyRoute
+  ]
+
 instance (GShow br, GShow fr) => GShow (FullRoute br fr) where
   gshowsPrec p = \case
     FullRoute_Backend x -> showParen (p > 10) (showString "FullRoute_Backend " . gshowsPrec 11 x)
@@ -994,13 +1028,6 @@ mkFullRouteEncoder missing backendSegment frontendSegment = handleEncoder (const
     FullRoute_Backend backendRoute -> backendSegment backendRoute
     FullRoute_Frontend obeliskRoute -> obeliskRouteSegment obeliskRoute frontendSegment
 
--- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your
--- frontend.
-data ObeliskRoute :: (* -> *) -> * -> * where
-  -- We need to have the `f a` as an argument here, because otherwise we have no way to specifically check for overlap between us and the given encoder
-  ObeliskRoute_App :: f a -> ObeliskRoute f a
-  ObeliskRoute_Resource :: ResourceRoute a -> ObeliskRoute f a
-
 instance UniverseSome f => UniverseSome (ObeliskRoute f) where
   universeSome = concat
     [ (\(Some x) -> Some (ObeliskRoute_App x)) <$> universe
@@ -1018,14 +1045,6 @@ instance GCompare f => GCompare (ObeliskRoute f) where
   gcompare (ObeliskRoute_App _) (ObeliskRoute_Resource _) = GLT
   gcompare (ObeliskRoute_Resource _) (ObeliskRoute_App _) = GGT
 
--- | A type representing the various resource routes served by Obelisk. These can in principle map to any physical routes you want,
--- but sane defaults are provided by 'resourceRouteSegment'
-data ResourceRoute :: * -> * where
-  ResourceRoute_Static :: ResourceRoute [Text] -- This [Text] represents the *path in our static files directory*, not necessarily the URL path that the asset gets served at (although that will often be "/static/this/text/thing")
-  ResourceRoute_Ghcjs :: ResourceRoute [Text]
-  ResourceRoute_JSaddleWarp :: ResourceRoute (R JSaddleWarpRoute)
-  ResourceRoute_Version :: ResourceRoute ()
-
 -- | If there are no additional backend routes in your app (i.e. ObeliskRoute gives you all the routes you need),
 -- this constructs a suitable 'Encoder' to use for encoding routes to 'PageName's. If you do have additional backend routes,
 -- you'll want to use 'pathComponentEncoder' yourself, applied to a function that will likely use obeliskRouteSegment in order to
@@ -1063,11 +1082,6 @@ resourceRouteSegment = \case
   ResourceRoute_JSaddleWarp -> PathSegment "jsaddle" jsaddleWarpRouteEncoder
   ResourceRoute_Version -> PathSegment "version" $ unitEncoder mempty
 
-data JSaddleWarpRoute :: * -> * where
-  JSaddleWarpRoute_JavaScript :: JSaddleWarpRoute ()
-  JSaddleWarpRoute_WebSocket :: JSaddleWarpRoute ()
-  JSaddleWarpRoute_Sync :: JSaddleWarpRoute [Text]
-
 jsaddleWarpRouteEncoder :: (MonadError Text check, MonadError Text parse) => Encoder check parse (R JSaddleWarpRoute) PageName
 jsaddleWarpRouteEncoder = pathComponentEncoder $ \case
   JSaddleWarpRoute_JavaScript -> PathSegment "jsaddle.js" $ unitEncoder mempty
@@ -1081,8 +1095,6 @@ instance GShow appRoute => GShow (ObeliskRoute appRoute) where
     ObeliskRoute_Resource appRoute -> showParen (prec > 10) $
       showString "ObeliskRoute_Resource " . gshowsPrec 11 appRoute
 
-data IndexOnlyRoute :: * -> * where
-  IndexOnlyRoute :: IndexOnlyRoute ()
 
 indexOnlyRouteSegment :: (Applicative check, MonadError Text parse) => IndexOnlyRoute a -> SegmentResult check parse a
 indexOnlyRouteSegment = \case
@@ -1101,7 +1113,7 @@ someSumEncoder = Encoder $ pure $ EncoderImpl
       Right (Some r) -> Some (InR r)
   }
 
-data Void1 :: * -> * where {}
+data Void1 :: Type -> Type where {}
 
 instance UniverseSome Void1 where
   universeSome = []
@@ -1293,13 +1305,6 @@ isoEncoder = viewEncoder
 prismEncoder :: (Applicative check, MonadError Text parse) => Prism' b a -> Encoder check parse a b
 prismEncoder = reviewEncoder
 
-
-concat <$> mapM deriveRouteComponent
-  [ ''ResourceRoute
-  , ''JSaddleWarpRoute
-  , ''IndexOnlyRoute
-  ]
-
 makePrisms ''ObeliskRoute
 makePrisms ''FullRoute
 deriveGEq ''Void1

lib/route/src/Obelisk/Route/Frontend.hs

@@ -61,6 +61,9 @@ module Obelisk.Route.Frontend
 #if __GLASGOW_HASKELL__ < 810
 import Control.Monad ((<=<))
 #endif
+#if __GLASGOW_HASKELL__ >= 906
+import Control.Monad (when, (<=<))
+#endif
 #endif
 
 import Prelude hiding ((.), id)
@@ -185,7 +188,7 @@ instance Adjustable t m => Adjustable t (RoutedT t r m) where
   traverseDMapWithKeyWithAdjust f a0 a' = RoutedT $ traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
   traverseDMapWithKeyWithAdjustWithMove f a0 a' = RoutedT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
 
-instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RoutedT t r m) where
+instance MonadQuery t vs m => MonadQuery t vs (RoutedT t r m) where
   tellQueryIncremental = lift . tellQueryIncremental
   askQueryResult = lift askQueryResult
   queryIncremental = lift . queryIncremental
@@ -296,13 +299,13 @@ eitherRouted :: (Reflex t, MonadFix m, MonadHold t m) => RoutedT t (Either (Dyna
 eitherRouted r = RoutedT $ ReaderT $ runRoutedT r <=< eitherDyn
 
 -- | WARNING: The input 'Dynamic' must be fully constructed when this is run
-strictDynWidget :: (MonadSample t m, MonadHold t m, Adjustable t m) => (a -> m b) -> RoutedT t a m (Dynamic t b)
+strictDynWidget :: (MonadHold t m, Adjustable t m) => (a -> m b) -> RoutedT t a m (Dynamic t b)
 strictDynWidget f = RoutedT $ ReaderT $ \r -> do
   r0 <- sample $ current r
   (result0, result') <- runWithReplace (f r0) $ f <$> updated r
   holdDyn result0 result'
 
-strictDynWidget_ :: (MonadSample t m, MonadHold t m, Adjustable t m) => (a -> m ()) -> RoutedT t a m ()
+strictDynWidget_ :: (MonadHold t m, Adjustable t m) => (a -> m ()) -> RoutedT t a m ()
 strictDynWidget_ f = RoutedT $ ReaderT $ \r -> do
   r0 <- sample $ current r
   (_, _) <- runWithReplace (f r0) $ f <$> updated r
@@ -383,7 +386,7 @@ instance (MonadHold t m, Adjustable t m) => Adjustable t (SetRouteT t r m) where
   traverseDMapWithKeyWithAdjust f a0 a' = SetRouteT $ traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
   traverseDMapWithKeyWithAdjustWithMove f a0 a' = SetRouteT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
 
-instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (SetRouteT t r m) where
+instance (MonadQuery t vs m) => MonadQuery t vs (SetRouteT t r m) where
   tellQueryIncremental = lift . tellQueryIncremental
   askQueryResult = lift askQueryResult
   queryIncremental = lift . queryIncremental
@@ -461,7 +464,7 @@ instance Adjustable t m => Adjustable t (RouteToUrlT r m) where
   traverseDMapWithKeyWithAdjust f a0 a' = RouteToUrlT $ traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
   traverseDMapWithKeyWithAdjustWithMove f a0 a' = RouteToUrlT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) (coerce a0) $ coerce a'
 
-instance (Monad m, MonadQuery t vs m) => MonadQuery t vs (RouteToUrlT r m) where
+instance MonadQuery t vs m => MonadQuery t vs (RouteToUrlT r m) where
   tellQueryIncremental = lift . tellQueryIncremental
   askQueryResult = lift askQueryResult
   queryIncremental = lift . queryIncremental

skeleton/common/src/Common/Route.hs

@@ -19,20 +19,26 @@ import Control.Category
 
 import Data.Text (Text)
 import Data.Functor.Identity
+import Data.Kind (Type)
 
 import Obelisk.Route
 import Obelisk.Route.TH
 
-data BackendRoute :: * -> * where
+data BackendRoute :: Type -> Type where
   -- | Used to handle unparseable routes.
   BackendRoute_Missing :: BackendRoute ()
   -- You can define any routes that will be handled specially by the backend here.
   -- i.e. These do not serve the frontend, but do something different, such as serving static files.
 
-data FrontendRoute :: * -> * where
+data FrontendRoute :: Type -> Type where
   FrontendRoute_Main :: FrontendRoute ()
   -- This type is used to define frontend routes, i.e. ones for which the backend will serve the frontend.
 
+concat <$> mapM deriveRouteComponent
+  [ ''BackendRoute
+  , ''FrontendRoute
+  ]
+
 fullRouteEncoder
   :: Encoder (Either Text) Identity (R (FullRoute BackendRoute FrontendRoute)) PageName
 fullRouteEncoder = mkFullRouteEncoder
@@ -41,8 +47,3 @@ fullRouteEncoder = mkFullRouteEncoder
       BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty)
   (\case
       FrontendRoute_Main -> PathEnd $ unitEncoder mempty)
-
-concat <$> mapM deriveRouteComponent
-  [ ''BackendRoute
-  , ''FrontendRoute
-  ]