]> Git — Sourcephile - webc.git/blob - src/Webc/Generator.hs
doc: update `ChangeLog.md`
[webc.git] / 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 (..))
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 (..))
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 ::
27 GeneratorBranch (Forest (GeneratorNode a))
28 }
29 deriving (Functor)
30
31 generator :: Generator a -> Generator a
32 generator = id
33
34 generate :: Generator a -> Forest (GeneratorNode a)
35 generate = collapseCheckBranch . unGenerator
36
37 generateValues :: Generator a -> [a]
38 generateValues repr = genValue <$> foldMap flatten (generate repr)
39
40 generateSlugs :: Generator a -> [[Slug]]
41 generateSlugs repr = genSlugs <$> foldMap flatten (generate repr)
42
43 {- | Keep the path in the 'Tree'
44 where to append new branches;
45 in reverse order to simplify appending.
46 -}
47 type GeneratorBranch = []
48
49 {- | Fold 'GeneratorBranch' maintained for appending;
50 to be done when there is no more appending.
51 -}
52 collapseCheckBranch ::
53 GeneratorBranch (Forest (GeneratorNode a)) ->
54 Forest (GeneratorNode a)
55 collapseCheckBranch =
56 List.foldr
57 (\ts acc -> ((\(Node n ns) -> Node n (ns <> acc)) <$> ts))
58 []
59
60 instance Show a => Show (Generator a) where
61 show = drawForest . ((show <$>) <$>) . generate
62
63 instance IsoFunctor Generator where
64 Iso{..} <%> x = a2b <$> x
65
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)
73
74 genNode :: GeneratorNode a -> Generator a
75 genNode = Generator . pure . pure . pure
76
77 instance ProductFunctor Generator where
78 Generator x <.> Generator y =
79 Generator
80 ( ( \x1 y1 ->
81 ( \x2 y2 ->
82 ( \x3 y3 ->
83 (,) <$> x3 <*> y3
84 )
85 <$> x2
86 <*> y2
87 )
88 <$> x1
89 <*> y1
90 )
91 <$> x
92 <*> y
93 )
94
95 {- TODO:
96 x .> y = undefined
97 x <. y = undefined
98 -}
99 instance SumFunctor Generator where
100 x <+> y =
101 Generator
102 [ collapseCheckBranch (unGenerator (Left <$> x))
103 <> collapseCheckBranch (unGenerator (Right <$> y))
104 ]
105 mapCheckNode :: (GeneratorNode a -> GeneratorNode b) -> Generator a -> Generator b
106 mapCheckNode f = Generator . (((f <$>) <$>) <$>) . unGenerator
107
108 instance Repeatable Generator where
109 many0 x =
110 Generator
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))
114 ]
115 many1 x =
116 Generator
117 [ collapseCheckBranch (unGenerator (mapCheckNode (\(GeneratorNode a s) -> GeneratorNode [a] s) x))
118 <> collapseCheckBranch (unGenerator (mapCheckNode (\(GeneratorNode a s) -> GeneratorNode [a, a] (s <> s)) x))
119 ]
120 instance Slugable Generator where
121 literalSlug = genNode . GeneratorNode () . pure
122 captureSlug n = genNode (GeneratorNode n [n])