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)