mirror of
https://github.com/seanhess/hyperbole.git
synced 2024-10-04 00:49:03 +03:00
Merge a241c36cee
into f44d70d082
This commit is contained in:
commit
77e8da9aff
@ -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
|
||||
|
@ -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 ())
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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"
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -47,7 +47,7 @@ dependencies:
|
||||
- cookie
|
||||
|
||||
executables:
|
||||
woot:
|
||||
examples:
|
||||
main: Main.hs
|
||||
source-dirs:
|
||||
- ../src
|
||||
|
@ -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
|
||||
|
108
src/Simple.hs
Normal file
108
src/Simple.hs
Normal file
@ -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"
|
@ -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?
|
||||
|
@ -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
|
||||
|
@ -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 --------------------------------------
|
||||
-------------------------------------------------
|
||||
|
@ -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)
|
||||
|
32
src/Web/Hyperbole/Types.hs
Normal file
32
src/Web/Hyperbole/Types.hs
Normal file
@ -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
|
||||
)
|
Loading…
Reference in New Issue
Block a user