src/Symantic/Document/Class.hs

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