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" </> (dataType @(Maybe Lang) $ pathSegment "all" <+> infer) <.> optional (capturePathSegment @Tag "tag")
  29
  30 -- content ::
  31 --   Monad m =>
  32 --   Sym.ToF
  33 --     (Either () (Either () (Maybe Lang, Maybe Tag)))
  34 --     (m BSL.ByteString)
  35 content =
  36   contentStatic
  37     :!: contentFeed
  38     :!: contentFilter
  39   where
  40     contentStatic = return "STATIC"
  41     contentFeed = return "FEED"
  42     contentFilter filterLang filterTag =
  43       return $
  44         fromString $
  45           case filterLang of
  46             Nothing -> maybe "ALL-LANG-ALL-TAGS" show filterTag
  47             Just lang -> case filterTag of
  48               Nothing -> show lang
  49               Just tag -> show (lang, tag)
  50
  51 -- * Type 'Lang'
  52 data Lang
  53   = LangEn
  54   | LangFr
  55   deriving (Eq, Show, Generic)
  56
  57 routeLang = dataType @Lang $ pathSegment "en" <+> pathSegment "fr"
  58
  59 -- | Using 'Inferable' has the downside of requiring
  60 -- to explicit manually the symantices required.
  61 instance (SumFunctor sem, PathSegmentable sem, Dataable sem) => Inferable Lang sem where
  62   infer = routeLang
  63
  64 -- * Type 'Tag'
  65 newtype Tag = Tag {unTag :: PathSegment} deriving (Eq, Ord, Show)
  66 instance IsString Tag where
  67   fromString = Tag . fromString
  68
  69 -- | Capturing a 'Tag' makes no sense when compiling a static site.
  70 -- Hence the 'Compiler' semantic for 'Capturable'
  71 -- requires a readable 'Model' somewhere in the monad stack
  72 -- in order to generate all 'Tag's folders.
  73 instance MC.MonadReader Model m => Capturable Tag (Compiler m) where
  74   capturePathSegment _n =
  75     Compiler do
  76       model <- MC.ask
  77       return
  78         [ Output{outputPath = [unTag tag], outputExts = [], outputData = tag}
  79         | tag <- Set.toList (modelTags model)
  80         ]
  81
  82 -- * Type 'Model'
  83 data Model = Model
  84   { modelTags :: Set Tag
  85   }
  86
  87 model1 = Model{modelTags = Set.fromList []}
  88 model2 = Model{modelTags = Set.fromList ["cat1", "cat2", "cat3"]}