Merge a241c36cee into b7ed4c4486

Uses type-level lists to enforce handling hyperviews in a page, and for
sub-views

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

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 ())

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"

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

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)
 

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

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
 

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"

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"

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
 

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"

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

example/hyperbole-examples.cabal

@@ -21,9 +21,10 @@ source-repository head
   type: git
   location: https://github.com/seanhess/hyperbole
 
-executable woot
+executable examples
   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
@@ -64,7 +66,7 @@ executable woot
       DataKinds
       DerivingStrategies
       DeriveAnyClass
-  ghc-options: -Wall -fdefer-typed-holes
+  ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base
     , bytestring

example/package.yaml

@@ -47,8 +47,12 @@ dependencies:
   - cookie
 
 executables:
-  woot:
+  examples:
     main:                Main.hs
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - -with-rtsopts=-N
     source-dirs:
       - ../src
       - ./

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

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"

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?

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

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 --------------------------------------
 -------------------------------------------------

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)

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
+    )