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.Either (Either (..))
  11 import Data.Eq (Eq)
  12 import Data.Function (($), (.))
  13 import Data.Maybe (Maybe (..))
  14 import Data.Set (Set)
  15 import Data.Set qualified as Set
  16 import GHC.Generics (Generic)
  17 import Network.URI.Slug qualified as URI
  18 import Symantic.Classes (
  19   Inferable (..),
  20   Iso (..),
  21   IsoFunctor (..),
  22   Optionable (..),
  23   ProductFunctor (..),
  24   SumFunctor (..),
  25   adt,
  26  )
  27 import Symantic.Reader (Reader (..))
  28 import Text.Show (Show)
  29
  30 import Webc
  31
  32 data Site
  33   = SiteStatic
  34   | SiteFeeds
  35   | SiteFilter Filter
  36   -- SitePage [URI.Slug]
  37   -- SiteSpecial [URI.Slug]
  38   deriving (Eq, Show, Generic)
  39
  40 instance Renderable Site where
  41   render Comp{..} = case compValue of
  42     SiteFeeds -> Right ("feeds", "txt")
  43     SiteFilter _fil -> Right ("filter", "txt")
  44     SiteStatic -> Left $ pathOfSlugs compSlugs
  45
  46 gen0 :: [Gen Site]
  47 gen0 = generate (unReader site model0)
  48
  49 enc0 :: [URI.Slug]
  50 enc0 =
  51   encode (unReader site model0) $
  52     SiteFilter
  53       Filter
  54         { filterLang = Just LangFr
  55         , filterTag = Nothing
  56         }
  57
  58 site =
  59   adt @Site $
  60     literalSlug "static"
  61       <+> literalSlug "feed"
  62       <+> "filter" </> infer
  63
  64 -- <+>
  65 -- ("page" </> many1 (captureSlug "page"))
  66 -- <+>
  67 -- ("special" </> many1 (captureSlug "page"))
  68
  69 -- Type 'Filter'
  70 data Filter = Filter
  71   { filterLang :: Maybe Lang
  72   , filterTag :: Maybe Tag
  73   }
  74   deriving (Eq, Show, Generic)
  75
  76 instance
  77   ( IsoFunctor repr
  78   , ProductFunctor repr
  79   , SumFunctor repr
  80   , Slugable repr
  81   , Optionable repr
  82   , -- , Endable repr
  83     Inferable Tag repr
  84   ) =>
  85   Inferable Filter repr
  86   where
  87   infer = adt @Filter $ adt (literalSlug "all" <+> infer) <.> optional infer
  88
  89 -- * Type 'Lang'
  90 data Lang = LangEn | LangFr deriving (Eq, Show, Generic)
  91 instance (IsoFunctor repr, SumFunctor repr, Slugable repr) => Inferable Lang repr where
  92   infer = adt @Lang $ literalSlug "fr" <+> literalSlug "en"
  93
  94 -- * Type 'Model'
  95 data Model = Model
  96   { modelTags :: Set URI.Slug
  97   }
  98
  99 model0 :: Model
 100 model0 = Model{modelTags = Set.fromList ["tag0", "tag1"]}
 101
 102 -- * Type 'Tag'
 103 newtype Tag = Tag {unTag :: URI.Slug} deriving (Eq, Show)
 104
 105 instance (IsoFunctor repr, Slugable repr) => Inferable Tag (Reader Model repr) where
 106   infer = Reader $ (Iso Tag unTag <%>) . chooseSlug . modelTags