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])