tests/Examples/Ex03.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2 -- For Inferable
   3 {-# LANGUAGE UndecidableInstances #-}
   4 {-# LANGUAGE NoMonomorphismRestriction #-}
   5 {-# OPTIONS_GHC -Wno-missing-signatures #-}
   6
   7 module Examples.Ex03 where
   8
   9 import Control.Monad (Monad (..))
  10 import Control.Monad.Classes qualified as MC
  11 import Data.Eq (Eq)
  12 import Data.Function (($), (.))
  13 import Data.Maybe (Maybe (..), maybe)
  14 import Data.Ord (Ord)
  15 import Data.Set (Set)
  16 import Data.Set qualified as Set
  17 import Data.String (IsString (..))
  18 import GHC.Generics (Generic)
  19 import Text.Show (Show (..))
  20
  21 import Literate.Web
  22
  23 -- | 'dataType' can be used at any point where
  24 -- the Tuples-of-Functions are no longer wanted.
  25 router =
  26   pathSegment "static"
  27     <+> pathSegment "feed"
  28     <+> "filter"
  29     </> (dataType @(Maybe Lang) $ pathSegment "all" <+> infer)
  30     <.> optional (capturePathSegment @Tag "tag")
  31
  32 -- content ::
  33 --   Monad m =>
  34 --   Sym.ToF
  35 --     (Either () (Either () (Maybe Lang, Maybe Tag)))
  36 --     (m BSL.ByteString)
  37 content =
  38   contentStatic
  39     :!: contentFeed
  40     :!: contentFilter
  41   where
  42     contentStatic = return "STATIC"
  43     contentFeed = return "FEED"
  44     contentFilter filterLang filterTag =
  45       return $
  46         fromString $
  47           case filterLang of
  48             Nothing -> maybe "ALL-LANG-ALL-TAGS" show filterTag
  49             Just lang -> case filterTag of
  50               Nothing -> show lang
  51               Just tag -> show (lang, tag)
  52
  53 -- c0 = compile CompilerEnv{} router content
  54
  55 address_static, address_feed :: Address
  56 address_filter :: Maybe Lang -> Maybe (Captured Tag Addresser) -> Address
  57 ( address_static
  58     :!: address_feed
  59     :!: address_filter
  60   ) = address router
  61
  62 -- * Type 'Lang'
  63 data Lang
  64   = LangEn
  65   | LangFr
  66   deriving (Eq, Show, Generic)
  67
  68 routeLang = dataType @Lang $ pathSegment "en" <+> pathSegment "fr"
  69
  70 -- | Using 'Inferable' has the downside of requiring
  71 -- to explicit manually the symantices required.
  72 instance (SumFunctor sem, PathSegmentable sem, Dataable Lang sem) => Inferable Lang sem where
  73   infer = routeLang
  74
  75 -- * Type 'Tag'
  76 newtype Tag = Tag {unTag :: PathSegment} deriving (Eq, Ord, Show)
  77 instance IsString Tag where
  78   fromString = Tag . fromString
  79
  80 -- | Capturing a 'Tag' makes no sense when compiling a static site.
  81 -- Hence the 'Compiler' semantic for 'Capturable'
  82 -- requires a readable 'Model' somewhere in the monad stack
  83 -- in order to generate all 'Tag's folders.
  84 instance MC.MonadReader Model m => Capturable Tag (Compiler m) where
  85   capturePathSegment _n =
  86     Compiler do
  87       model <- MC.ask
  88       return
  89         [ Output
  90           { outputPath = OutputPath{outputPathSegs = [unTag tag], outputPathExts = []}
  91           , outputData = ($ tag)
  92           }
  93         | tag <- Set.toList (modelTags model)
  94         ]
  95
  96 instance Capturable Tag Addresser where
  97   -- FIXME: check given tag exists?
  98   capturePathSegment _n = Addresser \k t -> k (Address [unTag t])
  99
 100 -- * Type 'Model'
 101 data Model = Model
 102   { modelTags :: Set Tag
 103   }
 104
 105 model1 = Model{modelTags = Set.fromList []}
 106 model2 = Model{modelTags = Set.fromList ["cat1", "cat2", "cat3"]}