]> Git — Sourcephile - webc.git/blob - tests/Examples/Ex02.hs
62986142bed699d955e1aba3c702e89b7353704c
[webc.git] / tests / Examples / Ex02.hs
1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 -- For Inferable
4 {-# LANGUAGE UndecidableInstances #-}
5 {-# LANGUAGE NoMonomorphismRestriction #-}
6 {-# OPTIONS_GHC -Wno-missing-signatures #-}
7
8 module Examples.Ex02 where
9
10 import Data.Eq (Eq)
11 import Data.Function (($), (.))
12 import Data.Maybe (Maybe (..))
13 import Data.Set (Set)
14 import Data.Set qualified as Set
15 import GHC.Generics (Generic)
16 import Network.URI.Slug qualified as URI
17 import Symantic.Classes (
18 Inferable (..),
19 Iso (..),
20 IsoFunctor (..),
21 Optionable (..),
22 ProductFunctor (..),
23 SumFunctor (..),
24 adt,
25 )
26 import Symantic.Reader (Reader (..))
27 import Text.Show (Show)
28
29 import Webc
30
31 data Site
32 = SiteStatic
33 | SiteFeeds
34 | SiteFilter Filter
35 -- SitePage [URI.Slug]
36 -- SiteSpecial [URI.Slug]
37 deriving (Eq, Show, Generic)
38
39 gen0 :: [Gen Site]
40 gen0 = generate (unReader site model0)
41
42 enc0 :: [URI.Slug]
43 enc0 =
44 encode (unReader site model0) $
45 SiteFilter
46 Filter
47 { filterLang = Just LangFr
48 , filterTag = Nothing
49 }
50
51 site =
52 adt @Site $
53 literalSlug "static"
54 <+> literalSlug "feed"
55 <+> "filter" </> infer
56
57 -- <+>
58 -- ("page" </> many1 (captureSlug "page"))
59 -- <+>
60 -- ("special" </> many1 (captureSlug "page"))
61
62 -- Type 'Filter'
63 data Filter = Filter
64 { filterLang :: Maybe Lang
65 , filterTag :: Maybe Tag
66 }
67 deriving (Eq, Show, Generic)
68
69 instance
70 ( IsoFunctor repr
71 , ProductFunctor repr
72 , SumFunctor repr
73 , Slugable repr
74 , Optionable repr
75 , Endable repr
76 , Inferable Tag repr
77 ) =>
78 Inferable Filter repr
79 where
80 infer = adt @Filter $ adt (literalSlug "all" <+> infer) <.> optional infer
81
82 -- * Type 'Lang'
83 data Lang = LangEn | LangFr deriving (Eq, Show, Generic)
84 instance (IsoFunctor repr, SumFunctor repr, Slugable repr) => Inferable Lang repr where
85 infer = adt @Lang $ literalSlug "fr" <+> literalSlug "en"
86
87 -- * Type 'Model'
88 data Model = Model
89 { modelTags :: Set URI.Slug
90 }
91
92 model0 :: Model
93 model0 = Model{modelTags = Set.fromList ["tag0", "tag1"]}
94
95 -- * Type 'Tag'
96 newtype Tag = Tag {unTag :: URI.Slug} deriving (Eq, Show)
97
98 instance (IsoFunctor repr, Slugable repr) => Inferable Tag (Reader Model repr) where
99 infer = Reader $ (Iso Tag unTag <%>) . chooseSlug . modelTags