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