From a241c36ceed5c9476cac9496aa010ef9f21dc525 Mon Sep 17 00:00:00 2001 From: Sean Hess Date: Mon, 8 Jul 2024 11:19:34 -0700 Subject: [PATCH] Typed Handlers Uses type-level lists to enforce handling hyperviews in a page, and for sub-views --- example/Example/Concurrent.hs | 6 +- example/Example/Contacts.hs | 10 ++- example/Example/Counter.hs | 6 +- example/Example/Errors.hs | 6 +- example/Example/Forms.hs | 6 +- example/Example/LazyLoading.hs | 6 +- example/Example/Redirects.hs | 6 +- example/Example/Sessions.hs | 6 +- example/Example/Simple.hs | 5 +- example/Example/Transitions.hs | 6 +- example/HelloWorld.hs | 7 +- example/Main.hs | 2 +- example/hyperbole-examples.cabal | 2 + example/package.yaml | 2 +- hyperbole.cabal | 2 + src/Simple.hs | 108 +++++++++++++++++++++++++ src/Web/Hyperbole.hs | 70 +++++++++++++++- src/Web/Hyperbole/Effect.hs | 131 ++++++++++++++++++++++-------- src/Web/Hyperbole/Forms.hs | 19 +---- src/Web/Hyperbole/HyperView.hs | 133 ++++++++++++++++++++++++++++++- src/Web/Hyperbole/Types.hs | 32 ++++++++ 21 files changed, 471 insertions(+), 100 deletions(-) create mode 100644 src/Simple.hs create mode 100644 src/Web/Hyperbole/Types.hs diff --git a/example/Example/Concurrent.hs b/example/Example/Concurrent.hs index 5c5c0a3..2ebaca6 100644 --- a/example/Example/Concurrent.hs +++ b/example/Example/Concurrent.hs @@ -6,11 +6,9 @@ import Example.Effects.Debug import Web.Hyperbole -page :: (Hyperbole :> es, Debug :> es, IOE :> es) => Page es Response +page :: (Hyperbole :> es, Debug :> es, IOE :> es) => Page es '[Contents] page = do - handle content - - load $ do + handle content $ load $ do pure $ do col (pad 20) $ do hyper (Contents 50) $ viewPoll 1 diff --git a/example/Example/Contacts.hs b/example/Example/Contacts.hs index 7ea6a05..8f7b663 100644 --- a/example/Example/Contacts.hs +++ b/example/Example/Contacts.hs @@ -13,11 +13,12 @@ import Example.Style qualified as Style import Web.Hyperbole -page :: forall es. (Hyperbole :> es, Users :> es, Debug :> es) => Page es Response +page + :: forall es + . (Hyperbole :> es, Users :> es, Debug :> es) + => Page es [Contacts, Contact] page = do - handle contacts - handle contact - load $ do + handle contacts . handle contact . load $ do us <- usersAll pure $ do col (pad 10 . gap 10) $ do @@ -45,6 +46,7 @@ data Filter instance HyperView Contacts where type Action Contacts = ContactsAction + type Children Contacts = '[Contact] contacts :: (Hyperbole :> es, Users :> es, Debug :> es) => Contacts -> ContactsAction -> Eff es (View Contacts ()) diff --git a/example/Example/Counter.hs b/example/Example/Counter.hs index abce994..578e816 100644 --- a/example/Example/Counter.hs +++ b/example/Example/Counter.hs @@ -10,11 +10,9 @@ import Web.Hyperbole -- We are using a TVar to manage our state -- In normal web applications, state will be managed in a database, abstracted behind a custom Effect. See Example.EFfects.Users for the interface -- Optionally, the count could be stored in a session. See Example.Sessions -page :: (Hyperbole :> es, Concurrent :> es) => TVar Int -> Page es Response +page :: (Hyperbole :> es, Concurrent :> es) => TVar Int -> Page es '[Counter] page var = do - handle $ counter var - - load $ do + handle (counter var) $ load $ do n <- readTVarIO var pure $ col (pad 20 . gap 10) $ do el h1 "Counter" diff --git a/example/Example/Errors.hs b/example/Example/Errors.hs index e8bff7b..90508ef 100644 --- a/example/Example/Errors.hs +++ b/example/Example/Errors.hs @@ -6,11 +6,9 @@ import Web.Hyperbole -- this is already running in a different context -page :: (Hyperbole :> es) => Page es Response +page :: (Hyperbole :> es) => Page es '[Contents] page = do - handle content - - load $ do + handle content $ load $ do pure $ row (pad 20) $ do col (gap 10 . border 1) $ do hyper Contents viewContent diff --git a/example/Example/Forms.hs b/example/Example/Forms.hs index 9ad9f96..fa0e922 100644 --- a/example/Example/Forms.hs +++ b/example/Example/Forms.hs @@ -10,11 +10,9 @@ import Web.Hyperbole import Web.Hyperbole.Forms -page :: (Hyperbole :> es) => Page es Response +page :: (Hyperbole :> es) => Page es '[FormView] page = do - handle formAction - - load $ do + handle formAction $ load $ do pure $ row (pad 20) $ do hyper FormView (formView mempty) diff --git a/example/Example/LazyLoading.hs b/example/Example/LazyLoading.hs index b358d8a..b1b7e1a 100644 --- a/example/Example/LazyLoading.hs +++ b/example/Example/LazyLoading.hs @@ -7,11 +7,9 @@ import Web.Hyperbole -- this is already running in a different context -page :: (Hyperbole :> es, Debug :> es) => Page es Response +page :: (Hyperbole :> es, Debug :> es) => Page es '[Contents] page = do - handle content - - load $ do + handle content $ load $ do pure $ do row (pad 20) $ do col (gap 10 . border 1 . pad 20) $ do diff --git a/example/Example/Redirects.hs b/example/Example/Redirects.hs index feb6b94..713e83e 100644 --- a/example/Example/Redirects.hs +++ b/example/Example/Redirects.hs @@ -5,11 +5,9 @@ import Example.Style as Style import Web.Hyperbole -page :: (Hyperbole :> es) => Page es Response +page :: (Hyperbole :> es) => Page es '[Contents] page = do - handle contents - - load $ do + handle contents $ load $ do pure $ row (pad 20) $ do hyper Contents contentsView diff --git a/example/Example/Sessions.hs b/example/Example/Sessions.hs index 23f8782..f8807ac 100644 --- a/example/Example/Sessions.hs +++ b/example/Example/Sessions.hs @@ -10,11 +10,9 @@ import Web.Hyperbole -- this is already running in a different context -page :: (Hyperbole :> es, Debug :> es) => Page es Response +page :: (Hyperbole :> es, Debug :> es) => Page es '[Contents] page = do - handle content - - load $ do + handle content $ load $ do -- setSession "color" Warning -- setSession "msg" ("________" :: Text) (clr :: Maybe AppColor) <- session "color" diff --git a/example/Example/Simple.hs b/example/Example/Simple.hs index dacf7e4..99da79c 100644 --- a/example/Example/Simple.hs +++ b/example/Example/Simple.hs @@ -14,10 +14,9 @@ main = do liveApp (basicDocument "Example") (page simplePage) -simplePage :: (Hyperbole :> es) => Page es Response +simplePage :: (Hyperbole :> es) => Page es '[Message] simplePage = do - handle message - load $ do + handle message $ load $ do pure $ col (pad 20) $ do el bold "My Page" hyper (Message 1) $ messageView "Hello" diff --git a/example/Example/Transitions.hs b/example/Example/Transitions.hs index 500c87d..e5383fd 100644 --- a/example/Example/Transitions.hs +++ b/example/Example/Transitions.hs @@ -5,11 +5,9 @@ import Example.Style as Style import Web.Hyperbole -page :: (Hyperbole :> es) => Page es Response +page :: (Hyperbole :> es) => Page es '[Contents] page = do - handle content - - load $ do + handle content $ load $ do pure $ row (pad 20) $ do hyper Contents viewSmall diff --git a/example/HelloWorld.hs b/example/HelloWorld.hs index c7138dd..13999d7 100644 --- a/example/HelloWorld.hs +++ b/example/HelloWorld.hs @@ -10,7 +10,7 @@ main = do liveApp (basicDocument "Example") (page messagePage') -messagePage :: (Hyperbole :> es) => Page es Response +messagePage :: (Hyperbole :> es) => Page es '[] messagePage = do load $ do pure $ do @@ -49,10 +49,9 @@ messageView' m = do button (SetMessage "Goodbye World") id "Change Message" -messagePage' :: (Hyperbole :> es) => Page es Response +messagePage' :: (Hyperbole :> es) => Page es '[Message] messagePage' = do - handle message - load $ do + handle message $ load $ do pure $ do el bold "Message Page" hyper Message $ messageView' "Hello World" diff --git a/example/Main.hs b/example/Main.hs index d5ac219..a5e069a 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -124,7 +124,7 @@ app users count = do lnk = Style.link -- Nested Router - hello :: (Hyperbole :> es, Debug :> es) => Hello -> Page es Response + hello :: (Hyperbole :> es, Debug :> es) => Hello -> Page es '[] hello Redirected = load $ do pure $ el_ "You were redirected" hello (Greet s) = load $ do diff --git a/example/hyperbole-examples.cabal b/example/hyperbole-examples.cabal index 15dd85a..7fbe7e4 100644 --- a/example/hyperbole-examples.cabal +++ b/example/hyperbole-examples.cabal @@ -24,6 +24,7 @@ source-repository head executable woot main-is: Main.hs other-modules: + Simple Web.Hyperbole Web.Hyperbole.Application Web.Hyperbole.Effect @@ -32,6 +33,7 @@ executable woot Web.Hyperbole.HyperView Web.Hyperbole.Route Web.Hyperbole.Session + Web.Hyperbole.Types Web.Hyperbole.View BulkUpdate Example.Colors diff --git a/example/package.yaml b/example/package.yaml index 0c43773..3bd8693 100644 --- a/example/package.yaml +++ b/example/package.yaml @@ -47,7 +47,7 @@ dependencies: - cookie executables: - woot: + examples: main: Main.hs source-dirs: - ../src diff --git a/hyperbole.cabal b/hyperbole.cabal index 4379672..0ac14f6 100644 --- a/hyperbole.cabal +++ b/hyperbole.cabal @@ -28,6 +28,7 @@ source-repository head library exposed-modules: + Simple Web.Hyperbole Web.Hyperbole.Application Web.Hyperbole.Effect @@ -36,6 +37,7 @@ library Web.Hyperbole.HyperView Web.Hyperbole.Route Web.Hyperbole.Session + Web.Hyperbole.Types Web.Hyperbole.View other-modules: Paths_hyperbole diff --git a/src/Simple.hs b/src/Simple.hs new file mode 100644 index 0000000..5b0dd58 --- /dev/null +++ b/src/Simple.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +module Simple where + +import Data.Text (pack) +import Effectful +import Web.Hyperbole + + +main = do + run 3000 $ do + liveApp (basicDocument "Example") (page simplePage) + + +simplePage :: (Hyperbole :> es, IOE :> es) => Page es '[MainView, Status] +simplePage = do + handle main' $ handle status $ load $ do + liftIO $ putStrLn "MAIN LOAD" + pure $ col (pad 20) $ do + el bold "My Page" + hyper MainView $ do + row (gap 10) $ do + button GoBegin (border 1) "Start" + + +-- MAIN ---------------------------------------- + +data MainView = MainView + deriving (Show, Read, ViewId) + + +data MainAction + = GoBegin + | GoMid + | GoEnd + deriving (Show, Read, ViewAction) + + +instance HyperView MainView where + type Action MainView = MainAction + type Children MainView = '[Status] + + +main' :: MainView -> MainAction -> Eff es (View MainView ()) +main' _ = \case + GoBegin -> pure beginStep + GoMid -> pure middleStep + GoEnd -> pure endStep + + +beginStep :: View MainView () +beginStep = do + el_ "BEGIN" + button GoMid (border 1) " Mid" + + +middleStep :: View MainView () +middleStep = do + el_ "MIDDLE: running" + button GoBegin (border 1) "Back" + hyper Status $ statusView 0 + + +endStep :: View MainView () +endStep = do + el_ "END" + button GoMid (border 1) "Back" + + +-- Status --------------------------------------- + +data Status = Status + deriving (Show, Read, ViewId) + + +data CheckStatus + = CheckStatus Int + deriving (Show, Read, ViewAction) + + +instance HyperView Status where + type Action Status = CheckStatus + type Children Status = '[MainView] + + +status :: Status -> CheckStatus -> Eff es (View Status ()) +status _ = \case + CheckStatus n -> + if n >= 5 + then pure lazyEnd + else pure $ statusView (n + 1) + + +statusView :: Int -> View Status () +statusView n = do + onLoad (CheckStatus n) 1000 $ do + el_ $ text $ "Checking Status" <> pack (show n) + + +lazyEnd :: View Status () +lazyEnd = do + el_ "Lazy End" + hyper MainView $ do + button GoEnd (border 1) "Go End" diff --git a/src/Web/Hyperbole.hs b/src/Web/Hyperbole.hs index 18218aa..f38cd8b 100644 --- a/src/Web/Hyperbole.hs +++ b/src/Web/Hyperbole.hs @@ -41,8 +41,8 @@ module Web.Hyperbole -- ** Page , Page - , load - , handle + -- , load + -- , handle -- ** HyperView , HyperView (..) @@ -118,6 +118,11 @@ module Web.Hyperbole , ViewId , ViewAction , Response + , handle + , load + , Handler + , Root + , HyperViewHandled -- * Exports @@ -302,3 +307,64 @@ Hyperbole is tighly integrated with [Effectful](https://hackage.haskell.org/pack * See [Effectful.Dispatch.Dynamic](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Dynamic.html) for an example of how to create a custom effect * See [Example.Counter](https://github.com/seanhess/hyperbole/blob/main/example/Example/Counter.hs) for an example of how to compose an existing effect -} + +-- test :: (Hyperbole :> es) => Page '[Woot, Nope] es () +-- test = +-- handler woot $ handler nope $ load $ do +-- pure $ do +-- hyper Woot none +-- hyper Nope none +-- +-- +-- -- makePage +-- -- <$> woot () +-- -- <*> zoop asdflsadfkl +-- -- <*> do +-- -- pure $ do +-- -- hyper Woot none +-- -- hyper Nope none +-- +-- nope :: Nope -> None -> Eff es (View Nope ()) +-- nope = _ +-- +-- +-- -- hyper Nope none +-- +-- data PageView = PageView +-- deriving (Read, Show, ViewId) +-- +-- +-- instance HyperView PageView where +-- type Children PageView = '[Woot] +-- type Action PageView = () +-- +-- +-- data Woot = Woot +-- deriving (Read, Show, ViewId) +-- +-- +-- instance HyperView Woot where +-- type Action Woot = None +-- type Children Woot = '[] +-- +-- +-- woot :: (Hyperbole :> es) => Woot -> None -> Eff es (View Woot ()) +-- woot _ _ = pure none +-- +-- +-- data Nope = Nope +-- deriving (Read, Show, ViewId) +-- +-- +-- instance HyperView Nope where +-- type Action Nope = None +-- +-- +-- viewWoot :: View Woot () +-- viewWoot = do +-- hyper Nope none +-- none +-- +-- -- TODO: woot is allowed to appear in our page +-- -- how can we specify this? +-- -- certain views are allowed in others? diff --git a/src/Web/Hyperbole/Effect.hs b/src/Web/Hyperbole/Effect.hs index 73bfa84..2b61964 100644 --- a/src/Web/Hyperbole/Effect.hs +++ b/src/Web/Hyperbole/Effect.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoFieldSelectors #-} module Web.Hyperbole.Effect where @@ -8,6 +9,7 @@ import Control.Monad (join) import Data.Bifunctor (first) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL +import Data.Kind (Constraint, Type) import Data.List qualified as List import Data.Maybe (isJust) import Data.String.Conversions @@ -78,9 +80,73 @@ pageView = do 'hyper' (Message 1) $ messageView "Starting Message" @ -} -newtype Page es a = Page (Eff es a) - deriving newtype (Applicative, Monad, Functor) +-- newtype Handle (views :: [Type]) (total :: [Type]) es a = Handle (Eff es a) +-- deriving newtype (Functor, Monad, Applicative) + +-- newtype Page views es a = Page (Page' views views es (View (Root views) a)) +-- type Page views es a = Handle views views es (View (Root views) a) +newtype Page (es :: [Effect]) (views :: [Type]) = Page (Eff es Response) + + +data Handler (view :: Type) :: Effect where + RespondEvents :: Handler view m () + + +type instance DispatchOf (Handler view) = Dynamic + + +type family AllHandled (views :: [Type]) (es :: [Effect]) :: Constraint where + AllHandled '[] es = () + AllHandled (x ': xs) es = (Handler x :> es, AllHandled xs es) + + +load :: (Hyperbole :> es, AllHandled total es) => Eff es (View (Root total) ()) -> Page es total +load run = Page $ do + r <- request + case lookupEvent r.query of + -- Are id and action set to something? + Just e -> send $ RespondEarly $ Err $ ErrNotHandled e + Nothing -> do + vw <- run + let vid = TargetViewId (toViewId Root) + let res = Response vid $ addContext Root vw + pure res + + +-- but we actually have to run the handler here... +-- this IS the handler running +handle + :: forall id total es + . (HyperView id, Hyperbole :> es) + => (id -> Action id -> Eff es (View id ())) + -> Page (Handler id : es) total + -> Page es total +handle action (Page inner) = Page $ do + runHandler action $ do + send $ RespondEvents @id + inner + + +runHandler + :: forall id es a + . (HyperView id, Hyperbole :> es) + => (id -> Action id -> Eff es (View id ())) + -> Eff (Handler id : es) a + -> Eff es a +runHandler run = interpret $ \_ -> \case + RespondEvents -> do + -- Get an event matching our type. If it doesn't match, skip to the next handler + mev <- getEvent @id + case mev of + Just event -> do + vw <- run event.viewId event.action + let vid = TargetViewId $ toViewId event.viewId + send $ RespondEarly $ Response vid $ hyperUnsafe event.viewId vw + _ -> pure () + + +-- deriving newtype (Applicative, Monad, Functor) -- | Serialized ViewId newtype TargetViewId = TargetViewId Text @@ -330,7 +396,7 @@ redirect = send . RespondEarly . Redirect respondEarly :: (Hyperbole :> es, HyperView id) => id -> View id () -> Eff es () respondEarly i vw = do let vid = TargetViewId (toViewId i) - let res = Response vid $ hyper i vw + let res = Response vid $ addContext i vw send $ RespondEarly res @@ -350,20 +416,20 @@ myPage userId = do pure $ userPageView user @ -} -load - :: (Hyperbole :> es) - => Eff es (View () ()) - -> Page es Response -load run = Page $ do - r <- request - case lookupEvent r.query of - -- Are id and action set to sometjhing? - Just e -> - pure $ Err $ ErrNotHandled e - Nothing -> do - vw <- run - view vw +-- load +-- :: (Hyperbole :> es) +-- => Eff es (View (Root views) ()) +-- -> Page views es Response +-- load run = Page $ do +-- r <- request +-- case lookupEvent r.query of +-- -- Are id and action set to sometjhing? +-- Just e -> +-- pure $ Err $ ErrNotHandled e +-- Nothing -> do +-- vw <- run +-- view vw {- | A handler is run when an action for that 'HyperView' is triggered. Run any side effects needed, then return a view of the corresponding type @@ -384,25 +450,26 @@ messages (Message mid) (Louder m) = do pure $ messageView new @ -} -handle - :: forall id es - . (Hyperbole :> es, HyperView id) - => (id -> Action id -> Eff es (View id ())) - -> Page es () -handle run = Page $ do - -- Get an event matching our type. If it doesn't match, skip to the next handler - mev <- getEvent @id - case mev of - Just event -> do - vw <- run event.viewId event.action - let vid = TargetViewId $ toViewId event.viewId - send $ RespondEarly $ Response vid $ hyper event.viewId vw - _ -> pure () +-- runHandler +-- :: forall id es +-- . (Hyperbole :> es, HyperView id) +-- => (id -> Action id -> Eff es (View id ())) +-- -> Eff es () +-- runHandler run = do +-- -- Get an event matching our type. If it doesn't match, skip to the next handler +-- mev <- getEvent @id +-- case mev of +-- Just event -> do +-- vw <- run event.viewId event.action +-- let vid = TargetViewId $ toViewId event.viewId +-- send $ RespondEarly $ Response vid $ hyperUnsafe event.viewId vw +-- _ -> pure () -- | Run a 'Page' in 'Hyperbole' page - :: (Hyperbole :> es) - => Page es Response + :: forall views es + . (Hyperbole :> es) + => Page es views -> Eff es Response page (Page eff) = eff diff --git a/src/Web/Hyperbole/Forms.hs b/src/Web/Hyperbole/Forms.hs index b60fe37..897499e 100644 --- a/src/Web/Hyperbole/Forms.hs +++ b/src/Web/Hyperbole/Forms.hs @@ -41,12 +41,12 @@ import Data.Kind (Constraint, Type) import Data.Text (Text, pack) import Effectful import GHC.Generics -import GHC.TypeLits hiding (Mod) import Text.Casing (kebab) import Web.FormUrlEncoded qualified as FE import Web.HttpApiData (FromHttpApiData (..)) import Web.Hyperbole.Effect import Web.Hyperbole.HyperView (HyperView (..), ViewAction (..), ViewId (..), dataTarget) +import Web.Hyperbole.Types (Elem) import Web.Internal.FormUrlEncoded (FormOptions (..), defaultFormOptions) import Web.View hiding (form, input, label) @@ -443,23 +443,6 @@ instance (GFieldParse f) => GFieldParse (M1 S s f) where instance (FromHttpApiData a) => GFieldParse (K1 R a) where gFieldParse t f = K1 <$> FE.parseUnique t f - --- Type family to check if an element is in a type-level list -type Elem e es = ElemGo e es es - - --- 'orig' is used to store original list for better error messages -type family ElemGo e es orig :: Constraint where - ElemGo x (x ': xs) orig = () - ElemGo y (x ': xs) orig = ElemGo y xs orig - -- Note [Custom Errors] - ElemGo x '[] orig = - TypeError - ( 'ShowType x - ':<>: 'Text " not found in " - ':<>: 'ShowType orig - ) - ------------------------------------------------- -- EXAMPLE -------------------------------------- ------------------------------------------------- diff --git a/src/Web/Hyperbole/HyperView.hs b/src/Web/Hyperbole/HyperView.hs index 53a8dfd..7bbfcf2 100644 --- a/src/Web/Hyperbole/HyperView.hs +++ b/src/Web/Hyperbole/HyperView.hs @@ -1,11 +1,14 @@ {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE UndecidableInstances #-} module Web.Hyperbole.HyperView where -import Data.Kind (Type) +import Data.Kind (Constraint, Type) import Data.Text (Text, pack, unpack) +import GHC.TypeLits hiding (Mod) import Text.Read (readMaybe) import Web.Hyperbole.Route (Route (..), routeUrl) +import Web.Hyperbole.Types import Web.View @@ -28,6 +31,8 @@ instance HyperView Message where -} class (ViewId id, ViewAction (Action id)) => HyperView id where type Action id :: Type + type Children id :: [Type] + type Children id = '[] class ViewAction a where @@ -41,6 +46,11 @@ class ViewAction a where parseAction = readMaybe . unpack +instance ViewAction () where + toAction _ = "" + parseAction _ = Just () + + class ViewId a where toViewId :: a -> Text default toViewId :: (Show a) => a -> Text @@ -81,8 +91,21 @@ otherView = do button (Louder \"Hi\") id "Louder" @ -} -hyper :: forall id ctx. (HyperView id) => id -> View id () -> View ctx () -hyper vid vw = do + +-- TODO: if I'm going to limit it, it's going to happen here +-- AND all their children have to be there +-- , All (Elem (Children ctx)) (Children id) +hyper + :: forall id ctx + . (HyperViewHandled id ctx) + => id + -> View id () + -> View ctx () +hyper = hyperUnsafe + + +hyperUnsafe :: (ViewId id) => id -> View id () -> View ctx () +hyperUnsafe vid vw = do el (att "id" (toViewId vid) . flexCol) $ addContext vid vw @@ -214,3 +237,107 @@ data Option opt id action = Option -} route :: (Route a) => a -> Mod -> View c () -> View c () route r = link (routeUrl r) + + +data Root (views :: [Type]) = Root + deriving (Show, Read, ViewId) + + +instance HyperView (Root views) where + type Action (Root views) = () + type Children (Root views) = views + + +type family AllDescendents (xs :: [Type]) :: [Type] where + AllDescendents xs = xs <++> RemoveAll xs (NextDescendents '[] xs) + + +type family ValidDescendents x :: [Type] where + ValidDescendents x = x : NextDescendents '[] '[x] + + +type family NextDescendents (ex :: [Type]) (xs :: [Type]) where + NextDescendents _ '[] = '[] + NextDescendents ex (x ': xs) = + RemoveAll (x : ex) (Children x) + <++> NextDescendents ((x : ex) <++> Children x) (RemoveAll (x : ex) (Children x)) + <++> NextDescendents (x : ex) (RemoveAll (x : ex) xs) + + +-- concat lists +type family (<++>) xs ys where + '[] <++> ys = ys + xs <++> '[] = xs + (x ': xs) <++> ys = x : xs <++> ys + + +type family Remove x ys where + Remove x '[] = '[] + Remove x (x ': ys) = Remove x ys + Remove x (y ': ys) = y ': Remove x ys + + +type family RemoveAll xs ys where + RemoveAll '[] ys = ys + RemoveAll xs '[] = '[] + RemoveAll (x ': xs) ys = RemoveAll xs (Remove x ys) + + +type NotHandled id ctx (views :: [Type]) = + TypeError + ( 'Text "HyperView " + :<>: 'ShowType id + :<>: 'Text " not found in (Children " + :<>: 'ShowType ctx + :<>: 'Text ")" + :$$: 'Text " " :<>: 'ShowType views + :$$: 'Text "Try adding it to the HyperView instance:" + :$$: 'Text " type Children " :<>: 'ShowType ctx :<>: 'Text " = [" :<>: ShowType id :<>: 'Text "]" + ) + + +type NotDesc id ctx x cs = + TypeError + ( 'Text "" + :<>: 'ShowType x + :<>: 'Text ", a child of HyperView " + :<>: 'ShowType id + :<>: 'Text ", not handled by context " + :<>: 'ShowType ctx + :$$: ('Text " Children = " ':<>: 'ShowType cs) + -- ':$$: 'ShowType x + -- ':$$: 'ShowType cs + ) + + +type NotInPage x total = + TypeError + ( 'Text "" + ':<>: 'ShowType x + ':<>: 'Text " not handled by Page: " + ':$$: 'ShowType total + ) + + +type HyperViewHandled id ctx = + ( HyperView id + , HyperView ctx + , -- the id must be found in the children of the context + ElemOr id (Children ctx) (NotHandled id ctx (Children ctx)) + , -- Make sure the descendents of id are in the context for the root page + CheckDescendents id ctx + ) + + +-- TODO: Report which view requires the missing one +type family CheckDescendents id ctx :: Constraint where + CheckDescendents id (Root total) = + ( AllInPage (ValidDescendents id) total + ) + CheckDescendents id ctx = () + + +type family AllInPage ids total :: Constraint where + AllInPage '[] _ = () + AllInPage (x ': xs) total = + (ElemOr x total (NotInPage x total), AllInPage xs total) diff --git a/src/Web/Hyperbole/Types.hs b/src/Web/Hyperbole/Types.hs new file mode 100644 index 0000000..3c7a51f --- /dev/null +++ b/src/Web/Hyperbole/Types.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Web.Hyperbole.Types where + +import Data.Kind (Constraint, Type) +import GHC.TypeLits hiding (Mod) + + +-- Type family to check if an element is in a type-level list +type Elem e es = ElemOr e es (NotElem e es) + + +-- 'orig' is used to store original list for better error messages +type family ElemOr e es err :: Constraint where + ElemOr x (x ': xs) err = () + ElemOr y (x ': xs) err = ElemOr y xs err + -- Note [Custom Errors] + ElemOr x '[] err = err + + +type family AllElemOr xs ys err :: Constraint where + AllElemOr '[] _ _ = () + AllElemOr (x ': xs) ys err = + (ElemOr x ys err, AllElemOr xs ys err) + + +type NotElem x (orig :: [Type]) = + TypeError + ( 'ShowType x + ':<>: 'Text " not found in " + ':<>: 'ShowType orig + )