1 {-# LANGUAGE DeriveFunctor #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Webc.Generator where
6 import Control.Applicative (Applicative (..))
7 import Data.Either (Either (..))
8 import Data.Eq (Eq (..))
9 import Data.Foldable (foldMap)
10 import Data.Function (id, (.))
11 import Data.Functor (Functor (..), (<$>))
12 import Data.List qualified as List
13 import Data.Ord (Ord (..))
14 import Data.Semigroup (Semigroup (..))
15 import Data.Tree (Forest, Tree (..), drawForest, flatten)
16 import Network.URI.Slug as URI
17 import Symantic.Classes (Iso (..), IsoFunctor (..), ProductFunctor (..), SumFunctor ((<+>)))
18 import Text.Show (Show (..))
22 -- * The 'Generator' interpreter
24 -- | This is a very basic generator.
25 newtype Generator a = Generator
27 GeneratorBranch (Forest (GeneratorNode a))
31 generator :: Generator a -> Generator a
34 generate :: Generator a -> Forest (GeneratorNode a)
35 generate = collapseCheckBranch . unGenerator
37 generateValues :: Generator a -> [a]
38 generateValues repr = genValue <$> foldMap flatten (generate repr)
40 generateSlugs :: Generator a -> [[Slug]]
41 generateSlugs repr = genSlugs <$> foldMap flatten (generate repr)
43 {- | Keep the path in the 'Tree'
44 where to append new branches;
45 in reverse order to simplify appending.
47 type GeneratorBranch = []
49 {- | Fold 'GeneratorBranch' maintained for appending;
50 to be done when there is no more appending.
52 collapseCheckBranch ::
53 GeneratorBranch (Forest (GeneratorNode a)) ->
54 Forest (GeneratorNode a)
57 (\ts acc -> ((\(Node n ns) -> Node n (ns <> acc)) <$> ts))
60 instance Show a => Show (Generator a) where
61 show = drawForest . ((show <$>) <$>) . generate
63 instance IsoFunctor Generator where
64 Iso{..} <%> x = a2b <$> x
66 -- ** Type 'GeneratorNode'
67 data GeneratorNode a = GeneratorNode {genValue :: a, genSlugs :: [Slug]}
68 deriving (Eq, Ord, Show, Functor)
69 instance Applicative GeneratorNode where
70 pure a = GeneratorNode a []
71 GeneratorNode f fs <*> GeneratorNode a as =
72 GeneratorNode (f a) (fs <> as)
74 genNode :: GeneratorNode a -> Generator a
75 genNode = Generator . pure . pure . pure
77 instance ProductFunctor Generator where
78 Generator x <.> Generator y =
99 instance SumFunctor Generator where
102 [ collapseCheckBranch (unGenerator (Left <$> x))
103 <> collapseCheckBranch (unGenerator (Right <$> y))
105 mapCheckNode :: (GeneratorNode a -> GeneratorNode b) -> Generator a -> Generator b
106 mapCheckNode f = Generator . (((f <$>) <$>) <$>) . unGenerator
108 instance Repeatable Generator where
111 [ collapseCheckBranch (unGenerator (mapCheckNode (\GeneratorNode{} -> GeneratorNode [] []) x))
112 <> collapseCheckBranch (unGenerator (mapCheckNode (\(GeneratorNode a s) -> GeneratorNode [a] s) x))
113 <> collapseCheckBranch (unGenerator (mapCheckNode (\(GeneratorNode a s) -> GeneratorNode [a, a] (s <> s)) x))
117 [ collapseCheckBranch (unGenerator (mapCheckNode (\(GeneratorNode a s) -> GeneratorNode [a] s) x))
118 <> collapseCheckBranch (unGenerator (mapCheckNode (\(GeneratorNode a s) -> GeneratorNode [a, a] (s <> s)) x))
120 instance Slugable Generator where
121 literalSlug = genNode . GeneratorNode () . pure
122 captureSlug n = genNode (GeneratorNode n [n])