]> Git — Sourcephile - haskell/literate-web.git/blob - tests/Examples/Ex03.hs
feat(iface): add `OutputPath`
[haskell/literate-web.git] / 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"]}