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