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.Foldable (toList)
  11 import Data.Function (($), (.))
  12 import Data.Functor (Functor (..), (<$>))
  13 import Data.Maybe (Maybe (..))
  14 import Data.Ord (Ord (..))
  15 import Data.Semigroup (Semigroup (..))
  16 import Network.URI.Slug as URI
  17 import Symantic.Classes (Constantable (..), Iso (..), IsoFunctor (..), Optionable (..), ProductFunctor (..), SumFunctor ((<+>)))
  18 import Text.Show (Show (..))
  19
  20 import Webc.Classes
  21
  22 -- * The 'Generator' interpreter
  23
  24 -- | This is a very basic generator.
  25 newtype Generator a = Generator
  26   { unGenerator :: [Gen a]
  27   }
  28   deriving (Functor, Show)
  29
  30 instance Applicative Generator where
  31   pure = Generator . pure . pure
  32   Generator f <*> Generator x = Generator $ (<*>) <$> f <*> x
  33
  34 -- instance Monad Generator where
  35 --   return = pure
  36 --   Generator x >>= f = Generator (x >>=)
  37
  38 generate :: Generator a -> [Gen a]
  39 generate = unGenerator
  40
  41 -- ** Type 'Gen'
  42 data Gen a = Gen
  43   { genSlugs :: [Slug] -- TODO: Endo? Seq?
  44   , genValue :: a
  45   }
  46   deriving (Eq, Ord, Show, Functor)
  47 instance Applicative Gen where
  48   pure = Gen []
  49   f <*> x = Gen (genSlugs f <> genSlugs x) (genValue f (genValue x))
  50
  51 instance IsoFunctor Generator where
  52   (<%>) Iso{..} = (a2b <$>)
  53 instance ProductFunctor Generator where
  54   (<.>) = liftA2 (,)
  55   (<.) = (<*)
  56   (.>) = (*>)
  57 instance SumFunctor Generator where
  58   x <+> y =
  59     Generator $
  60       (<>)
  61         ((Left <$>) <$> unGenerator x)
  62         ((Right <$>) <$> unGenerator y)
  63 instance Repeatable Generator where
  64   many0 (Generator x) =
  65     Generator $
  66       ((\Gen{} -> Gen [] []) <$> x)
  67         <> ((\(Gen s a) -> Gen s [a]) <$> x)
  68         <> ((\(Gen s a) -> Gen (s <> s) [a, a]) <$> x)
  69   many1 (Generator x) =
  70     Generator $
  71       ((\(Gen s a) -> Gen s [a]) <$> x)
  72         <> ((\(Gen s a) -> Gen (s <> s) [a, a]) <$> x)
  73 instance Optionable Generator where
  74   optional x =
  75     Generator $
  76       Gen [] Nothing :
  77       ((Just <$>) <$> unGenerator x)
  78 instance Endable Generator where
  79   end = Generator [Gen [] ()]
  80 instance Slugable Generator where
  81   literalSlug s = Generator [Gen [s] ()]
  82   chooseSlug ss =
  83     Generator $
  84       [ Gen [s] s
  85       | s <- toList ss
  86       ]
  87
  88 -- chooseSlugs ss =
  89 --   Generator $
  90 --     [ Gen s s
  91 --     | s <- toList ss
  92 --     ]
  93 instance Capturable Generator where
  94   captureSlug n = Generator $ [Gen [n] n]
  95 instance Constantable c Generator where
  96   constant = pure