src/Webc/Generator.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4
   5 module Webc.Generator where
   6
   7 import Control.Applicative (Applicative (..), liftA2)
   8 import Data.Either (Either (..))
   9 import Data.Eq (Eq (..))
  10 import Data.Function (($), (.))
  11 import Data.Functor (Functor (..), (<$>))
  12 import Data.Ord (Ord (..))
  13 import Data.Semigroup (Semigroup (..))
  14 import Network.URI.Slug as URI
  15 import Symantic.Classes (Iso (..), IsoFunctor (..), ProductFunctor (..), SumFunctor ((<+>)))
  16 import Text.Show (Show (..))
  17
  18 import Webc.Classes
  19
  20 -- * The 'Generator' interpreter
  21
  22 -- | This is a very basic generator.
  23 newtype Generator a = Generator
  24   { unGenerator :: [Gen a]
  25   }
  26   deriving (Functor, Show)
  27
  28 instance Applicative Generator where
  29   pure = Generator . pure . pure
  30   Generator f <*> Generator x = Generator ((<*>) <$> f <*> x)
  31
  32 generate :: Generator a -> [Gen a]
  33 generate = unGenerator
  34
  35 -- ** Type 'Gen'
  36 data Gen a = Gen {genSlugs :: [Slug], genValue :: a}
  37   deriving (Eq, Ord, Show, Functor)
  38 instance Applicative Gen where
  39   pure = Gen []
  40   f <*> x = Gen (genSlugs f <> genSlugs x) (genValue f (genValue x))
  41
  42 instance IsoFunctor Generator where
  43   (<%>) Iso{..} = (a2b <$>)
  44 instance ProductFunctor Generator where
  45   (<.>) = liftA2 (,)
  46   (<.) = (<*)
  47   (.>) = (*>)
  48 instance SumFunctor Generator where
  49   x <+> y =
  50     Generator $
  51       unGenerator (Left <$> x)
  52         <> unGenerator (Right <$> y)
  53 instance Repeatable Generator where
  54   many0 (Generator x) =
  55     Generator $
  56       ((\Gen{} -> Gen [] []) <$> x)
  57         <> ((\(Gen s a) -> Gen s [a]) <$> x)
  58         <> ((\(Gen s a) -> Gen (s <> s) [a, a]) <$> x)
  59   many1 (Generator x) =
  60     Generator $
  61       ((\(Gen s a) -> Gen s [a]) <$> x)
  62         <> ((\(Gen s a) -> Gen (s <> s) [a, a]) <$> x)
  63 instance Slugable Generator where
  64   literalSlug s = Generator [Gen [s] ()]
  65   captureSlug n = Generator [Gen [n] n]