{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Formatter.Class
  ( module Symantic.Formatter.Class
  , Emptyable(..)
  , ProductFunctor(..)
  , Voidable(..)
  ) where

import Data.Bool
import Data.Char (Char)
import Data.Foldable (Foldable)
import Data.Function ((.), ($))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Prelude (fromIntegral, pred)
import Data.String (String)
import Data.Traversable (Traversable)
import Numeric.Natural (Natural)
import qualified Data.Functor as Fct
import qualified Data.Foldable as Fold
import qualified System.Console.ANSI as ANSI
import Symantic.Derive
import Symantic.Class
  ( Emptyable(..)
  , ProductFunctor(..)
  , Voidable(..)
  )

concat ::
  Emptyable repr => ProductFunctor repr =>
  Foldable f => f (repr ()) -> repr ()
concat = Fold.foldr (.>) empty

-- * Class 'Spaceable'
class
  ( ProductFunctor repr
  , Emptyable repr
  ) => Spaceable repr where
  space :: repr ()
  -- | @'spaces' ind = 'replicate' ind 'space'@
  spaces :: Column -> repr ()
  default space :: FromDerived Spaceable repr => repr ()
  default spaces :: Column -> repr ()
  spaces i = replicate (fromIntegral i) space
  space = liftDerived space
  -- | @x '<+>' y = x '<>' 'space' '<>' y@
  (<+>) :: repr a -> repr b -> repr (a,b)
  x <+> y = x <.> space .> y
  (+>) :: repr () -> repr a -> repr a
  x +> y = x .> space .> y
  (<+) :: repr a -> repr () -> repr a
  x <+ y = x <. space <. y

type Column = Natural

-- * Class 'Newlineable'
class Newlineable repr where
  newline :: repr ()
  default newline :: FromDerived Newlineable repr => repr ()
  newline = liftDerived newline

  unlines ::
    Emptyable repr =>
    ProductFunctor repr =>
    Foldable f =>
    f (repr ()) -> repr ()
  unlines = Fold.foldr (\x acc -> x.>newline.>acc) empty
  unlines_ :: Listable repr => repr a -> repr [a]
  unlines_ = intercalate_ newline
  -- | @x '</>' y = x '<>' 'newline' '<>' y@
  (</>) :: ProductFunctor repr => repr a -> repr b -> repr (a,b)
  x </> y = x <.> newline .> y
  catV ::
    ProductFunctor repr =>
    Emptyable repr =>
    Foldable f =>
    f (repr ()) -> repr ()
  catV = intercalate newline
infixr 6 <+>
infixr 6 </>

intercalate ::
  Foldable f => Emptyable repr =>
  ProductFunctor repr =>
  repr () -> f (repr ()) -> repr ()
intercalate sep rs
  | Fold.null rs = empty
  | otherwise = Fold.foldr1 (\x y -> x.>sep.>y) rs

replicate ::
  Emptyable repr => ProductFunctor repr =>
  Int -> repr () -> repr ()
replicate cnt t
  | cnt <= 0  = empty
  | otherwise = t .> replicate (pred cnt) t

between ::
  ProductFunctor repr =>
  repr () -> repr () -> repr a -> repr a
between o c x = o.>x<.c
parens, braces, brackets, angles ::
  ProductFunctor repr =>
  Voidable repr =>
  Inferable Char repr =>
  repr a -> repr a
parens   = between (void '(' infer) (void ')' infer)
braces   = between (void '{' infer) (void '}' infer)
brackets = between (void '[' infer) (void ']' infer)
angles   = between (void '<' infer) (void '>' infer)

-- * Class 'Decorable'
class Decorable repr where
  bold      :: repr a -> repr a
  underline :: repr a -> repr a
  italic    :: repr a -> repr a
  default bold      :: FromDerived1 Decorable repr => repr a -> repr a
  default underline :: FromDerived1 Decorable repr => repr a -> repr a
  default italic    :: FromDerived1 Decorable repr => repr a -> repr a
  bold      = liftDerived1 bold
  underline = liftDerived1 underline
  italic    = liftDerived1 italic

-- * Class 'Colorable16'
class Colorable16 repr where
  reverse :: repr a -> repr a

  -- Foreground colors
  -- Dull
  black   :: repr a -> repr a
  red     :: repr a -> repr a
  green   :: repr a -> repr a
  yellow  :: repr a -> repr a
  blue    :: repr a -> repr a
  magenta :: repr a -> repr a
  cyan    :: repr a -> repr a
  white   :: repr a -> repr a

  -- Vivid
  blacker   :: repr a -> repr a
  redder    :: repr a -> repr a
  greener   :: repr a -> repr a
  yellower  :: repr a -> repr a
  bluer     :: repr a -> repr a
  magentaer :: repr a -> repr a
  cyaner    :: repr a -> repr a
  whiter    :: repr a -> repr a

  -- Background colors
  -- Dull
  onBlack   :: repr a -> repr a
  onRed     :: repr a -> repr a
  onGreen   :: repr a -> repr a
  onYellow  :: repr a -> repr a
  onBlue    :: repr a -> repr a
  onMagenta :: repr a -> repr a
  onCyan    :: repr a -> repr a
  onWhite   :: repr a -> repr a

  -- Vivid
  onBlacker   :: repr a -> repr a
  onRedder    :: repr a -> repr a
  onGreener   :: repr a -> repr a
  onYellower  :: repr a -> repr a
  onBluer     :: repr a -> repr a
  onMagentaer :: repr a -> repr a
  onCyaner    :: repr a -> repr a
  onWhiter    :: repr a -> repr a

  default reverse     :: FromDerived1 Colorable16 repr => repr a -> repr a
  default black       :: FromDerived1 Colorable16 repr => repr a -> repr a
  default red         :: FromDerived1 Colorable16 repr => repr a -> repr a
  default green       :: FromDerived1 Colorable16 repr => repr a -> repr a
  default yellow      :: FromDerived1 Colorable16 repr => repr a -> repr a
  default blue        :: FromDerived1 Colorable16 repr => repr a -> repr a
  default magenta     :: FromDerived1 Colorable16 repr => repr a -> repr a
  default cyan        :: FromDerived1 Colorable16 repr => repr a -> repr a
  default white       :: FromDerived1 Colorable16 repr => repr a -> repr a
  default blacker     :: FromDerived1 Colorable16 repr => repr a -> repr a
  default redder      :: FromDerived1 Colorable16 repr => repr a -> repr a
  default greener     :: FromDerived1 Colorable16 repr => repr a -> repr a
  default yellower    :: FromDerived1 Colorable16 repr => repr a -> repr a
  default bluer       :: FromDerived1 Colorable16 repr => repr a -> repr a
  default magentaer   :: FromDerived1 Colorable16 repr => repr a -> repr a
  default cyaner      :: FromDerived1 Colorable16 repr => repr a -> repr a
  default whiter      :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onBlack     :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onRed       :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onGreen     :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onYellow    :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onBlue      :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onMagenta   :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onCyan      :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onWhite     :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onBlacker   :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onRedder    :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onGreener   :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onYellower  :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onBluer     :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onMagentaer :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onCyaner    :: FromDerived1 Colorable16 repr => repr a -> repr a
  default onWhiter    :: FromDerived1 Colorable16 repr => repr a -> repr a

  reverse     = liftDerived1 reverse
  black       = liftDerived1 black
  red         = liftDerived1 red
  green       = liftDerived1 green
  yellow      = liftDerived1 yellow
  blue        = liftDerived1 blue
  magenta     = liftDerived1 magenta
  cyan        = liftDerived1 cyan
  white       = liftDerived1 white
  blacker     = liftDerived1 blacker
  redder      = liftDerived1 redder
  greener     = liftDerived1 greener
  yellower    = liftDerived1 yellower
  bluer       = liftDerived1 bluer
  magentaer   = liftDerived1 magentaer
  cyaner      = liftDerived1 cyaner
  whiter      = liftDerived1 whiter
  onBlack     = liftDerived1 onBlack
  onRed       = liftDerived1 onRed
  onGreen     = liftDerived1 onGreen
  onYellow    = liftDerived1 onYellow
  onBlue      = liftDerived1 onBlue
  onMagenta   = liftDerived1 onMagenta
  onCyan      = liftDerived1 onCyan
  onWhite     = liftDerived1 onWhite
  onBlacker   = liftDerived1 onBlacker
  onRedder    = liftDerived1 onRedder
  onGreener   = liftDerived1 onGreener
  onYellower  = liftDerived1 onYellower
  onBluer     = liftDerived1 onBluer
  onMagentaer = liftDerived1 onMagentaer
  onCyaner    = liftDerived1 onCyaner
  onWhiter    = liftDerived1 onWhiter

type SGR = ANSI.SGR

-- * Class 'Indentable'
class Spaceable repr => Indentable repr where
  -- | @('align' fmt)@ make @fmt@ uses current 'Column' as 'Indent' level.
  align :: repr a -> repr a
  -- | @('setIndent' p ind fmt)@ make @fmt@ uses @ind@ as 'Indent' level.
  -- Using @p@ as 'Indent' text.
  setIndent :: repr () -> Indent -> repr a -> repr a
  -- | @('incrIndent' p ind fmt)@ make @fmt@ uses current 'Indent' plus @ind@ as 'Indent' level.
  -- Appending @p@ to the current 'Indent' text.
  incrIndent :: repr () -> Indent -> repr a -> repr a
  hang :: Indent -> repr a -> repr a
  hang ind = align . incrIndent (spaces ind) ind
  -- | @('fill' w fmt)@ write @fmt@,
  -- then if @fmt@ is not wider than @w@,
  -- write the difference with 'spaces'.
  fill :: Width -> repr a -> repr a
  -- | @('fillOrBreak' w fmt)@ write @fmt@,
  -- then if @fmt@ is not wider than @w@, write the difference with 'spaces'
  -- otherwise write a 'newline' indented to the start 'Column' of @fmt@ plus @w@.
  fillOrBreak :: Width -> repr a -> repr a

  default align       :: FromDerived1 Indentable repr => repr a -> repr a
  default incrIndent  :: FromDerived2 Indentable repr => repr () -> Indent -> repr a -> repr a
  default setIndent   :: FromDerived2 Indentable repr => repr () -> Indent -> repr a -> repr a
  default fill        :: FromDerived1 Indentable repr => Width -> repr a -> repr a
  default fillOrBreak :: FromDerived1 Indentable repr => Width -> repr a -> repr a

  align          = liftDerived1 align
  setIndent  p i = liftDerived2 (`setIndent`i) p
  incrIndent p i = liftDerived2 (`incrIndent`i) p
  fill           = liftDerived1 . fill
  fillOrBreak    = liftDerived1 . fillOrBreak

type Indent = Column
type Width = Natural

-- * Class 'Listable'
class Listable repr where
  ul :: Traversable f => f (repr ()) -> repr ()
  ol :: Traversable f => f (repr ()) -> repr ()
  default ul ::
    FromDerived Listable repr => Derivable repr =>
    Traversable f => f (repr ()) -> repr ()
  default ol ::
    FromDerived Listable repr => Derivable repr =>
    Traversable f => f (repr ()) -> repr ()
  ul xs = liftDerived $ ul $ derive Fct.<$> xs
  ol xs = liftDerived $ ol $ derive Fct.<$> xs
  unorderedList :: repr a -> repr [a]
  orderedList :: repr a -> repr [a]
  list_ :: repr () -> repr () -> repr () -> repr a -> repr [a]
  default unorderedList :: FromDerived1 Listable repr => repr a -> repr [a]
  default orderedList :: FromDerived1 Listable repr => repr a -> repr [a]
  default list_ :: FromDerived4 Listable repr => repr () -> repr () -> repr () -> repr a -> repr [a]
  unorderedList = liftDerived1 unorderedList
  orderedList = liftDerived1 orderedList
  list_ = liftDerived4 list_
  intercalate_ :: repr () -> repr a -> repr [a]
  default intercalate_ ::
    FromDerived2 Listable repr =>
    repr () -> repr a -> repr [a]
  intercalate_ = liftDerived2 intercalate_
  braceList ::
    Voidable repr => Inferable Char repr =>
    repr a -> repr [a]
  braceList = list_ (void '{' infer) (void ',' infer) (void '}' infer)
  bracketList ::
    Voidable repr => Inferable Char repr =>
    repr a -> repr [a]
  bracketList = list_ (void '[' infer) (void ',' infer) (void ']' infer)
  parenList ::
    Voidable repr => Inferable Char repr =>
    repr a -> repr [a]
  parenList = list_ (void '(' infer) (void ',' infer) (void ')' infer)
  angleList ::
    Voidable repr => Inferable Char repr =>
    repr a -> repr [a]
  angleList = list_ (void '<' infer) (void ',' infer) (void '>' infer)

-- * Class 'Wrappable'
class Wrappable repr where
  setWidth   :: Maybe Width -> repr a -> repr a
  -- getWidth   :: (Maybe Width -> repr a) -> repr a
  breakpoint :: repr ()
  breakspace :: repr ()
  breakalt   :: repr a -> repr a -> repr a
  endline    :: repr ()
  default breakpoint :: FromDerived Wrappable repr => repr ()
  default breakspace :: FromDerived Wrappable repr => repr ()
  default breakalt   :: FromDerived2 Wrappable repr => repr a -> repr a -> repr a
  default endline    :: FromDerived Wrappable repr => repr ()
  breakpoint = liftDerived breakpoint
  breakspace = liftDerived breakspace
  breakalt   = liftDerived2 breakalt
  endline    = liftDerived endline
  unwords ::
    ProductFunctor repr =>
    Listable repr =>
    Emptyable repr =>
    Foldable f =>
    f (repr ()) -> repr ()
  unwords_ :: Listable repr => repr a -> repr [a]
  unwords = intercalate breakspace
  unwords_ = intercalate_ breakspace

-- * Class 'Justifiable'
class Justifiable repr where
  justify :: repr a -> repr a

-- * Class 'Inferable'
class Inferable a repr where
  infer :: repr a
  default infer :: FromDerived (Inferable a) repr => repr a
  infer = liftDerived infer
string :: Inferable String repr => repr String
string = infer
int :: Inferable Int repr => repr Int
int = infer
natural :: Inferable Natural repr => repr Natural
natural = infer