]> Git — Sourcephile - webc.git/blob - src/Webc/Generator.hs
wip
[webc.git] / 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 = Generator [Gen [s] s | s <- toList ss]
83
84 -- chooseSlugs ss =
85 -- Generator $
86 -- [ Gen s s
87 -- | s <- toList ss
88 -- ]
89 instance Capturable Generator where
90 captureSlug n = Generator $ [Gen [n] n]
91 instance Constantable c Generator where
92 constant = pure