]> Git — Sourcephile - haskell/literate-web.git/blob - tests/Examples/Ex04.hs
feat(live): init `Literate.Web.Live`
[haskell/literate-web.git] / tests / Examples / Ex04.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# OPTIONS_GHC -Wno-missing-signatures #-}
4
5 module Examples.Ex04 where
6
7 import Control.Monad.Classes qualified as MC
8
9 -- import Control.Reactive
10 import Data.Map.Strict as Map
11 import Literate.Web
12 import Relude
13
14 router =
15 "post"
16 </> capturePathSegment @PostName "post"
17 <.> response @Post @'[PlainText]
18 <+> "page"
19 </> capturePathSegment @PageName "page"
20 <.> response @Page @'[PlainText]
21 <+> pathSegment "lorem"
22
23 -- content ::
24 -- ( PostName -> (a :~: a, Post)
25 -- , PageName -> (a :~: a, Page) )
26 -- content ::
27 -- MC.MonadReader Model m =>
28 -- endpoint ~ m Text =>
29 -- Sym.ToF
30 -- (Either (PostName, Sym.Endpoint endpoint (m Post))
31 -- (PageName, Sym.Endpoint endpoint (m Page)))
32 -- endpoint
33 content = contentPost :!: contentPage :!: contentOther
34 where
35 contentPost n = compilerEndpoint do
36 Model{..} <- MC.ask
37 return $ modelPosts Map.! n
38 contentPage =
39 compilerEndpoint . \case
40 CapturedExtra (Left (_n, p)) -> do
41 return p
42 CapturedExtra (Right n) -> do
43 Model{..} <- MC.ask
44 return $ modelPages Map.! n
45 contentOther = return "ipsum"
46
47 -- c0 = compile CompilerEnv{} router content
48
49 instance MimeEncodable Post PlainText where
50 mimeEncode (Post t) = mimeEncode @_ @PlainText t
51 instance MimeEncodable Page PlainText where
52 mimeEncode (Page t) = mimeEncode @_ @PlainText t
53
54 instance MC.MonadReader Model m => Capturable PostName (Compiler m) where
55 capturePathSegment _n =
56 Compiler do
57 model <- MC.ask
58 return
59 [ Output
60 { outputPath = OutputPath{outputPathSegs = [unPostName name], outputPathExts = []}
61 , outputData = ($ name)
62 }
63 | name <- Map.keys (modelPosts model)
64 ]
65 instance MC.MonadReader Model m => Capturable PageName (Compiler m) where
66 -- Keep the 'Page' to avoid looking it up in 'contentPage'.
67 type Captured PageName (Compiler m) = CapturedExtra PageName Page
68 capturePathSegment _n =
69 Compiler do
70 model <- MC.ask
71 return
72 [ Output
73 { outputPath = OutputPath{outputPathSegs = [unPageName name], outputPathExts = []}
74 , outputData = ($ CapturedExtra (Left (name, page)))
75 }
76 | (name, page) <- Map.toList (modelPages model)
77 ]
78
79 {-
80 data Rodel m = Rodel
81 { rodelPosts :: RW m (Map PostName (RW m Post))
82 , rodelPages :: RW m (Map PageName (RW m Page))
83 }
84 -}
85
86 -- * Type 'Model'
87 data Model = Model
88 { modelPosts :: Map PostName Post
89 , modelPages :: Map PageName Page
90 }
91 model1 =
92 Model
93 { modelPosts =
94 Map.fromList
95 [ (PostName "post1", Post "post-model-1")
96 , (PostName "post2", Post "post-model-2")
97 ]
98 , modelPages =
99 Map.fromList
100 [ (PageName "page1", Page "page-model-1")
101 , (PageName "page2", Page "page-model-2")
102 ]
103 }
104
105 -- ** Type 'PostName'
106 data PostName = PostName {unPostName :: PathSegment}
107 deriving (Show, Eq, Ord)
108
109 -- ** Type 'PageName'
110 data PageName = PageName {unPageName :: PathSegment}
111 deriving (Show, Eq, Ord)
112
113 -- ** Type 'Post'
114 data Post = Post {unPost :: Text}
115 deriving (Show)
116
117 -- ** Type 'Page'
118 data Page = Page {unPage :: Text}
119 deriving (Show)