src/Symantic/Formatter/Class.hs

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