src/Webc/Generator.hs

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