1 {-# LANGUAGE DeriveFunctor #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Webc.Generator where
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 (..))
19 -- * The 'Generator' interpreter
21 -- | This is a very basic generator.
22 newtype Generator a = Generator
23 { unGenerator :: [Gen a]
25 deriving (Functor, Show)
27 generate :: Generator a -> [Gen a]
28 generate = unGenerator
31 data Gen a = Gen {genSlugs :: [Slug], genValue :: a}
32 deriving (Eq, Ord, Show, Functor)
33 instance Applicative Gen where
35 f <*> x = Gen (genSlugs f <> genSlugs x) (genValue f (genValue x))
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
44 unGenerator (Left <$> x)
45 <> unGenerator (Right <$> y)
46 instance Repeatable Generator where
49 ((\Gen{} -> Gen [] []) <$> x)
50 <> ((\(Gen s a) -> Gen s [a]) <$> x)
51 <> ((\(Gen s a) -> Gen (s <> s) [a, a]) <$> x)
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]