src/Symantic/Formatter/Class.hs

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