src/Symantic/Plaintext/Classes.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE UndecidableInstances #-}
   3
   4 module Symantic.Plaintext.Classes (
   5   module Symantic.Plaintext.Classes,
   6   Emptyable (..),
   7   Inferable (..),
   8   ProductFunctor (..),
   9   Repeatable (..),
  10   Voidable (..),
  11   bool,
  12   char,
  13   int,
  14   natural,
  15   string,
  16 ) where
  17
  18 import Data.Bool hiding (bool)
  19 import Data.Char (Char)
  20 import Data.Foldable (Foldable)
  21 import Data.Foldable qualified as Fold
  22 import Data.Function (($), (.))
  23 import Data.Functor qualified as Fct
  24 import Data.Int (Int)
  25 import Data.Maybe (Maybe (..))
  26 import Data.Ord (Ord (..))
  27 import Data.Traversable (Traversable)
  28 import Numeric.Natural (Natural)
  29 import Symantic.Class (
  30   Emptyable (..),
  31   Inferable (..),
  32   ProductFunctor (..),
  33   Repeatable (..),
  34   Voidable (..),
  35   bool,
  36   char,
  37   int,
  38   natural,
  39   string,
  40  )
  41 import Symantic.Derive
  42 import System.Console.ANSI qualified as ANSI
  43 import Prelude (fromIntegral, pred)
  44
  45 concat ::
  46   Emptyable repr =>
  47   ProductFunctor repr =>
  48   Foldable f =>
  49   f (repr ()) ->
  50   repr ()
  51 concat = Fold.foldr (.>) empty
  52
  53 -- * Class 'Repeatable'
  54 many :: Repeatable repr => repr a -> repr [a]
  55 many = many0
  56 some :: Repeatable repr => repr a -> repr [a]
  57 some = many1
  58
  59 -- * Class 'Spaceable'
  60 class
  61   ( ProductFunctor repr
  62   , Emptyable repr
  63   ) =>
  64   Spaceable repr
  65   where
  66   space :: repr ()
  67
  68   -- | @'spaces' ind = 'replicate' ind 'space'@
  69   spaces :: Column -> repr ()
  70
  71   default space :: FromDerived Spaceable repr => repr ()
  72   default spaces :: Column -> repr ()
  73   spaces i = replicate (fromIntegral i) space
  74   space = liftDerived space
  75
  76   -- | @x '<+>' y = x '<>' 'space' '<>' y@
  77   (<+>) :: repr a -> repr b -> repr (a, b)
  78   x <+> y = x <.> space .> y
  79
  80   (+>) :: repr () -> repr a -> repr a
  81   x +> y = x .> space .> y
  82   (<+) :: repr a -> repr () -> repr a
  83   x <+ y = x <. space <. y
  84
  85 type Column = Natural
  86
  87 -- * Class 'Newlineable'
  88 class Newlineable repr where
  89   newline :: repr ()
  90   default newline :: FromDerived Newlineable repr => repr ()
  91   newline = liftDerived newline
  92
  93   unlines ::
  94     Emptyable repr =>
  95     ProductFunctor repr =>
  96     Foldable f =>
  97     f (repr ()) ->
  98     repr ()
  99   unlines = Fold.foldr (\x acc -> x .> newline .> acc) empty
 100   unlines_ :: Listable repr => repr a -> repr [a]
 101   unlines_ = intercalate_ newline
 102
 103   -- | @x '</>' y = x '<>' 'newline' '<>' y@
 104   (</>) :: ProductFunctor repr => repr a -> repr b -> repr (a, b)
 105   x </> y = x <.> newline .> y
 106
 107   catV ::
 108     ProductFunctor repr =>
 109     Emptyable repr =>
 110     Foldable f =>
 111     f (repr ()) ->
 112     repr ()
 113   catV = intercalate newline
 114 infixr 6 <+>
 115 infixr 6 </>
 116
 117 intercalate ::
 118   Foldable f =>
 119   Emptyable repr =>
 120   ProductFunctor repr =>
 121   repr () ->
 122   f (repr ()) ->
 123   repr ()
 124 intercalate sep rs
 125   | Fold.null rs = empty
 126   | otherwise = Fold.foldr1 (\x y -> x .> sep .> y) rs
 127
 128 replicate ::
 129   Emptyable repr =>
 130   ProductFunctor repr =>
 131   Int ->
 132   repr () ->
 133   repr ()
 134 replicate cnt t
 135   | cnt <= 0 = empty
 136   | otherwise = t .> replicate (pred cnt) t
 137
 138 between ::
 139   ProductFunctor repr =>
 140   repr () ->
 141   repr () ->
 142   repr a ->
 143   repr a
 144 between o c x = o .> x <. c
 145 parens
 146   , braces
 147   , brackets
 148   , angles ::
 149     ProductFunctor repr =>
 150     Voidable repr =>
 151     Inferable Char repr =>
 152     repr a ->
 153     repr a
 154 parens = between (void '(' infer) (void ')' infer)
 155 braces = between (void '{' infer) (void '}' infer)
 156 brackets = between (void '[' infer) (void ']' infer)
 157 angles = between (void '<' infer) (void '>' infer)
 158
 159 -- * Class 'Decorable'
 160 class Decorable repr where
 161   bold :: repr a -> repr a
 162   underline :: repr a -> repr a
 163   italic :: repr a -> repr a
 164   default bold :: FromDerived1 Decorable repr => repr a -> repr a
 165   default underline :: FromDerived1 Decorable repr => repr a -> repr a
 166   default italic :: FromDerived1 Decorable repr => repr a -> repr a
 167   bold = liftDerived1 bold
 168   underline = liftDerived1 underline
 169   italic = liftDerived1 italic
 170
 171 -- * Class 'Colorable16'
 172 class Colorable16 repr where
 173   reverse :: repr a -> repr a
 174
 175   -- Foreground colors
 176   -- Dull
 177   black :: repr a -> repr a
 178   red :: repr a -> repr a
 179   green :: repr a -> repr a
 180   yellow :: repr a -> repr a
 181   blue :: repr a -> repr a
 182   magenta :: repr a -> repr a
 183   cyan :: repr a -> repr a
 184   white :: repr a -> repr a
 185
 186   -- Vivid
 187   blacker :: repr a -> repr a
 188   redder :: repr a -> repr a
 189   greener :: repr a -> repr a
 190   yellower :: repr a -> repr a
 191   bluer :: repr a -> repr a
 192   magentaer :: repr a -> repr a
 193   cyaner :: repr a -> repr a
 194   whiter :: repr a -> repr a
 195
 196   -- Background colors
 197   -- Dull
 198   onBlack :: repr a -> repr a
 199   onRed :: repr a -> repr a
 200   onGreen :: repr a -> repr a
 201   onYellow :: repr a -> repr a
 202   onBlue :: repr a -> repr a
 203   onMagenta :: repr a -> repr a
 204   onCyan :: repr a -> repr a
 205   onWhite :: repr a -> repr a
 206
 207   -- Vivid
 208   onBlacker :: repr a -> repr a
 209   onRedder :: repr a -> repr a
 210   onGreener :: repr a -> repr a
 211   onYellower :: repr a -> repr a
 212   onBluer :: repr a -> repr a
 213   onMagentaer :: repr a -> repr a
 214   onCyaner :: repr a -> repr a
 215   onWhiter :: repr a -> repr a
 216
 217   default reverse :: FromDerived1 Colorable16 repr => repr a -> repr a
 218   default black :: FromDerived1 Colorable16 repr => repr a -> repr a
 219   default red :: FromDerived1 Colorable16 repr => repr a -> repr a
 220   default green :: FromDerived1 Colorable16 repr => repr a -> repr a
 221   default yellow :: FromDerived1 Colorable16 repr => repr a -> repr a
 222   default blue :: FromDerived1 Colorable16 repr => repr a -> repr a
 223   default magenta :: FromDerived1 Colorable16 repr => repr a -> repr a
 224   default cyan :: FromDerived1 Colorable16 repr => repr a -> repr a
 225   default white :: FromDerived1 Colorable16 repr => repr a -> repr a
 226   default blacker :: FromDerived1 Colorable16 repr => repr a -> repr a
 227   default redder :: FromDerived1 Colorable16 repr => repr a -> repr a
 228   default greener :: FromDerived1 Colorable16 repr => repr a -> repr a
 229   default yellower :: FromDerived1 Colorable16 repr => repr a -> repr a
 230   default bluer :: FromDerived1 Colorable16 repr => repr a -> repr a
 231   default magentaer :: FromDerived1 Colorable16 repr => repr a -> repr a
 232   default cyaner :: FromDerived1 Colorable16 repr => repr a -> repr a
 233   default whiter :: FromDerived1 Colorable16 repr => repr a -> repr a
 234   default onBlack :: FromDerived1 Colorable16 repr => repr a -> repr a
 235   default onRed :: FromDerived1 Colorable16 repr => repr a -> repr a
 236   default onGreen :: FromDerived1 Colorable16 repr => repr a -> repr a
 237   default onYellow :: FromDerived1 Colorable16 repr => repr a -> repr a
 238   default onBlue :: FromDerived1 Colorable16 repr => repr a -> repr a
 239   default onMagenta :: FromDerived1 Colorable16 repr => repr a -> repr a
 240   default onCyan :: FromDerived1 Colorable16 repr => repr a -> repr a
 241   default onWhite :: FromDerived1 Colorable16 repr => repr a -> repr a
 242   default onBlacker :: FromDerived1 Colorable16 repr => repr a -> repr a
 243   default onRedder :: FromDerived1 Colorable16 repr => repr a -> repr a
 244   default onGreener :: FromDerived1 Colorable16 repr => repr a -> repr a
 245   default onYellower :: FromDerived1 Colorable16 repr => repr a -> repr a
 246   default onBluer :: FromDerived1 Colorable16 repr => repr a -> repr a
 247   default onMagentaer :: FromDerived1 Colorable16 repr => repr a -> repr a
 248   default onCyaner :: FromDerived1 Colorable16 repr => repr a -> repr a
 249   default onWhiter :: FromDerived1 Colorable16 repr => repr a -> repr a
 250
 251   reverse = liftDerived1 reverse
 252   black = liftDerived1 black
 253   red = liftDerived1 red
 254   green = liftDerived1 green
 255   yellow = liftDerived1 yellow
 256   blue = liftDerived1 blue
 257   magenta = liftDerived1 magenta
 258   cyan = liftDerived1 cyan
 259   white = liftDerived1 white
 260   blacker = liftDerived1 blacker
 261   redder = liftDerived1 redder
 262   greener = liftDerived1 greener
 263   yellower = liftDerived1 yellower
 264   bluer = liftDerived1 bluer
 265   magentaer = liftDerived1 magentaer
 266   cyaner = liftDerived1 cyaner
 267   whiter = liftDerived1 whiter
 268   onBlack = liftDerived1 onBlack
 269   onRed = liftDerived1 onRed
 270   onGreen = liftDerived1 onGreen
 271   onYellow = liftDerived1 onYellow
 272   onBlue = liftDerived1 onBlue
 273   onMagenta = liftDerived1 onMagenta
 274   onCyan = liftDerived1 onCyan
 275   onWhite = liftDerived1 onWhite
 276   onBlacker = liftDerived1 onBlacker
 277   onRedder = liftDerived1 onRedder
 278   onGreener = liftDerived1 onGreener
 279   onYellower = liftDerived1 onYellower
 280   onBluer = liftDerived1 onBluer
 281   onMagentaer = liftDerived1 onMagentaer
 282   onCyaner = liftDerived1 onCyaner
 283   onWhiter = liftDerived1 onWhiter
 284
 285 type SGR = ANSI.SGR
 286
 287 -- * Class 'Indentable'
 288 class Spaceable repr => Indentable repr where
 289   -- | @('align' fmt)@ make @fmt@ uses current 'Column' as 'Indent' level.
 290   align :: repr a -> repr a
 291
 292   -- | @('setIndent' p ind fmt)@ make @fmt@ uses @ind@ as 'Indent' level. Using @p@ as 'Indent' text.
 293   setIndent :: repr () -> Indent -> repr a -> repr a
 294
 295   -- | @('incrIndent' p ind fmt)@ make @fmt@ uses current 'Indent' plus @ind@ as 'Indent' level. Appending @p@ to the current 'Indent' text.
 296   incrIndent :: repr () -> Indent -> repr a -> repr a
 297
 298   hang :: Indent -> repr a -> repr a
 299   hang ind = align . incrIndent (spaces ind) ind
 300
 301   -- | @('fill' w fmt)@ write @fmt@, then if @fmt@ is not wider than @w@, write the difference with 'spaces'.
 302   fill :: Width -> repr a -> repr a
 303
 304   fillOrBreak :: Width -> repr a -> repr a
 305
 306   default align :: FromDerived1 Indentable repr => repr a -> repr a
 307   default incrIndent :: FromDerived2 Indentable repr => repr () -> Indent -> repr a -> repr a
 308   default setIndent :: FromDerived2 Indentable repr => repr () -> Indent -> repr a -> repr a
 309   default fill :: FromDerived1 Indentable repr => Width -> repr a -> repr a
 310   default fillOrBreak :: FromDerived1 Indentable repr => Width -> repr a -> repr a
 311
 312   align = liftDerived1 align
 313   setIndent p i = liftDerived2 (`setIndent` i) p
 314   incrIndent p i = liftDerived2 (`incrIndent` i) p
 315   fill = liftDerived1 . fill
 316   fillOrBreak = liftDerived1 . fillOrBreak
 317
 318 type Indent = Column
 319 type Width = Natural
 320
 321 -- * Class 'Listable'
 322 class Listable repr where
 323   ul :: Traversable f => f (repr ()) -> repr ()
 324   ol :: Traversable f => f (repr ()) -> repr ()
 325   default ul ::
 326     FromDerived Listable repr =>
 327     Derivable repr =>
 328     Traversable f =>
 329     f (repr ()) ->
 330     repr ()
 331   default ol ::
 332     FromDerived Listable repr =>
 333     Derivable repr =>
 334     Traversable f =>
 335     f (repr ()) ->
 336     repr ()
 337   ul xs = liftDerived $ ul $ derive Fct.<$> xs
 338   ol xs = liftDerived $ ol $ derive Fct.<$> xs
 339   unorderedList :: repr a -> repr [a]
 340   orderedList :: repr a -> repr [a]
 341   list_ :: repr () -> repr () -> repr () -> repr a -> repr [a]
 342   default unorderedList :: FromDerived1 Listable repr => repr a -> repr [a]
 343   default orderedList :: FromDerived1 Listable repr => repr a -> repr [a]
 344   default list_ :: FromDerived4 Listable repr => repr () -> repr () -> repr () -> repr a -> repr [a]
 345   unorderedList = liftDerived1 unorderedList
 346   orderedList = liftDerived1 orderedList
 347   list_ = liftDerived4 list_
 348   intercalate_ :: repr () -> repr a -> repr [a]
 349   default intercalate_ ::
 350     FromDerived2 Listable repr =>
 351     repr () ->
 352     repr a ->
 353     repr [a]
 354   intercalate_ = liftDerived2 intercalate_
 355   braceList ::
 356     Voidable repr =>
 357     Inferable Char repr =>
 358     repr a ->
 359     repr [a]
 360   braceList = list_ (void '{' infer) (void ',' infer) (void '}' infer)
 361   bracketList ::
 362     Voidable repr =>
 363     Inferable Char repr =>
 364     repr a ->
 365     repr [a]
 366   bracketList = list_ (void '[' infer) (void ',' infer) (void ']' infer)
 367   parenList ::
 368     Voidable repr =>
 369     Inferable Char repr =>
 370     repr a ->
 371     repr [a]
 372   parenList = list_ (void '(' infer) (void ',' infer) (void ')' infer)
 373   angleList ::
 374     Voidable repr =>
 375     Inferable Char repr =>
 376     repr a ->
 377     repr [a]
 378   angleList = list_ (void '<' infer) (void ',' infer) (void '>' infer)
 379
 380 -- * Class 'Wrappable'
 381 class Wrappable repr where
 382   setWidth :: Maybe Width -> repr a -> repr a
 383
 384   -- getWidth   :: (Maybe Width -> repr a) -> repr a
 385   breakpoint :: repr ()
 386   breakspace :: repr ()
 387   breakalt :: repr a -> repr a -> repr a
 388   endline :: repr ()
 389   default breakpoint :: FromDerived Wrappable repr => repr ()
 390   default breakspace :: FromDerived Wrappable repr => repr ()
 391   default breakalt :: FromDerived2 Wrappable repr => repr a -> repr a -> repr a
 392   default endline :: FromDerived Wrappable repr => repr ()
 393   breakpoint = liftDerived breakpoint
 394   breakspace = liftDerived breakspace
 395   breakalt = liftDerived2 breakalt
 396   endline = liftDerived endline
 397   unwords ::
 398     ProductFunctor repr =>
 399     Listable repr =>
 400     Emptyable repr =>
 401     Foldable f =>
 402     f (repr ()) ->
 403     repr ()
 404   unwords_ :: Listable repr => repr a -> repr [a]
 405   unwords = intercalate breakspace
 406   unwords_ = intercalate_ breakspace
 407
 408 -- * Class 'Justifiable'
 409 class Justifiable repr where
 410   justify :: repr a -> repr a