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