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 = contentEndpoint do
  36       Model{..} <- MC.ask
  37       return $ modelPosts Map.! n
  38     contentPage =
  39       contentEndpoint . \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{outputPath = [unPostName name], outputExts = [], outputData = ($ name)}
  60         | name <- Map.keys (modelPosts model)
  61         ]
  62 instance (MC.MonadReader Model m) => Capturable PageName (Compiler m) where
  63   -- Keep the 'Page' to avoid looking it up in 'contentPage'.
  64   type Captured PageName (Compiler m) = CapturedExtra PageName Page
  65   capturePathSegment _n =
  66     Compiler do
  67       model <- MC.ask
  68       return
  69         [ Output
  70           { outputPath = [unPageName name]
  71           , outputExts = []
  72           , outputData = ($ CapturedExtra (Left (name, page)))
  73           }
  74         | (name, page) <- Map.toList (modelPages model)
  75         ]
  76
  77 {-
  78 data Rodel m = Rodel
  79   { rodelPosts :: RW m (Map PostName (RW m Post))
  80   , rodelPages :: RW m (Map PageName (RW m Page))
  81   }
  82 -}
  83
  84 -- * Type 'Model'
  85 data Model = Model
  86   { modelPosts :: Map PostName Post
  87   , modelPages :: Map PageName Page
  88   }
  89 model1 =
  90   Model
  91     { modelPosts =
  92         Map.fromList
  93           [ (PostName "post1", Post "post-model-1")
  94           , (PostName "post2", Post "post-model-2")
  95           ]
  96     , modelPages =
  97         Map.fromList
  98           [ (PageName "page1", Page "page-model-1")
  99           , (PageName "page2", Page "page-model-2")
 100           ]
 101     }
 102
 103 -- ** Type 'PostName'
 104 data PostName = PostName {unPostName :: PathSegment}
 105   deriving (Show, Eq, Ord)
 106
 107 -- ** Type 'PageName'
 108 data PageName = PageName {unPageName :: PathSegment}
 109   deriving (Show, Eq, Ord)
 110
 111 -- ** Type 'Post'
 112 data Post = Post {unPost :: Text}
 113   deriving (Show)
 114
 115 -- ** Type 'Page'
 116 data Page = Page {unPage :: Text}
 117   deriving (Show)