{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Symantic.Plaintext.Classes (
  module Symantic.Plaintext.Classes,
  Emptyable (..),
  Inferable (..),
  ProductFunctor (..),
  Repeatable (..),
  Voidable (..),
  bool,
  char,
  int,
  natural,
  string,
) where

import Data.Bool hiding (bool)
import Data.Char (Char)
import Data.Foldable (Foldable)
import Data.Foldable qualified as Fold
import Data.Function (($), (.))
import Data.Functor qualified as Fct
import Data.Int (Int)
import Data.Maybe (Maybe (..))
import Data.Ord (Ord (..))
import Data.Traversable (Traversable)
import Numeric.Natural (Natural)
import Symantic.Classes (
  Emptyable (..),
  Inferable (..),
  ProductFunctor (..),
  Repeatable (..),
  Voidable (..),
  bool,
  char,
  int,
  natural,
  string,
 )
import Symantic.Derive
import System.Console.ANSI qualified as ANSI
import Prelude (fromIntegral, pred)

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

-- * Class 'Repeatable'
many :: Repeatable repr => repr a -> repr [a]
many = many0
some :: Repeatable repr => repr a -> repr [a]
some = many1

-- * 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 :: 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