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 import Data.Map.Strict as Map
   9 import Literate.Web
  10 import Relude
  11 import Symantic qualified as Sym
  12
  13 router =
  14   "post" </> capturePathSegment @PostName "post" <.> response @Post @'[PlainText]
  15     <+> "page" </> capturePathSegment @PageName "page" <.> response @Page @'[PlainText]
  16     <+> pathSegment "lorem"
  17
  18 -- content ::
  19 --   ( PostName -> (a :~: a, Post)
  20 --   , PageName -> (a :~: a, Page) )
  21 -- content ::
  22 --   MC.MonadReader Model m =>
  23 --   endpoint ~ m Text =>
  24 --   Sym.ToF
  25 --     (Either (PostName, Sym.Endpoint endpoint (m Post))
  26 --             (PageName, Sym.Endpoint endpoint (m Page)))
  27 --     endpoint
  28 content = contentPost :!: contentPage :!: contentOther
  29   where
  30     contentPost n = Sym.endpoint do
  31       Model{..} <- MC.ask
  32       return $ modelPosts Map.! n
  33     contentPage = Sym.endpoint . \case
  34       CapturedExtra (Left (_n, p)) -> do
  35         return p
  36       CapturedExtra (Right n) -> do
  37         Model{..} <- MC.ask
  38         return $ modelPages Map.! n
  39     contentOther = return "ipsum"
  40
  41 instance MimeEncodable Post PlainText where
  42   mimeEncode (Post t) = mimeEncode @_ @PlainText t
  43 instance MimeEncodable Page PlainText where
  44   mimeEncode (Page t) = mimeEncode @_ @PlainText t
  45
  46 instance MC.MonadReader Model m => Capturable PostName (Compiler m) where
  47   capturePathSegment _n =
  48     Compiler do
  49       model <- MC.ask
  50       return
  51         [ Output{outputPath = [unPostName name], outputExts = [], outputData = name}
  52         | name <- Map.keys (modelPosts model)
  53         ]
  54 instance MC.MonadReader Model m => Capturable PageName (Compiler m) where
  55   -- Keep the 'Page' to avoid looking it up in 'contentPage'.
  56   type Captured PageName (Compiler m) = CapturedExtra PageName Page
  57   capturePathSegment _n =
  58     Compiler do
  59       model <- MC.ask
  60       return
  61         [ Output
  62             { outputPath = [unPageName name]
  63             , outputExts = []
  64             , outputData = CapturedExtra (Left (name, page))
  65             }
  66         | (name, page) <- Map.toList (modelPages model)
  67         ]
  68
  69 -- * Type 'Model'
  70 data Model = Model
  71   { modelPosts :: Map PostName Post
  72   , modelPages :: Map PageName Page
  73   }
  74 model1 =
  75   Model
  76     { modelPosts =
  77         Map.fromList
  78           [ (PostName "post1", Post "post-model-1")
  79           , (PostName "post2", Post "post-model-2")
  80           ]
  81     , modelPages =
  82         Map.fromList
  83           [ (PageName "page1", Page "page-model-1")
  84           , (PageName "page2", Page "page-model-2")
  85           ]
  86     }
  87
  88 -- ** Type 'PostName'
  89 data PostName = PostName {unPostName :: PathSegment}
  90   deriving (Show, Eq, Ord)
  91
  92 -- ** Type 'PageName'
  93 data PageName = PageName {unPageName :: PathSegment}
  94   deriving (Show, Eq, Ord)
  95
  96 -- ** Type 'Post'
  97 data Post = Post {unPost :: Text}
  98   deriving (Show)
  99
 100 -- ** Type 'Page'
 101 data Page = Page {unPage :: Text}
 102   deriving (Show)