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

--import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Char (Char)
import Data.Foldable (Foldable)
import Data.Function ((.), ($))
--import Data.Function ((.), ($), id, const)
--import Data.Functor (Functor(..), (<$>))
import Data.Int (Int)
--import Data.Kind (Type)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Prelude (fromIntegral, pred)
import Data.String (String)
--import Data.Text (Text)
import Data.Traversable (Traversable)
import Numeric.Natural (Natural)
import qualified Data.Functor as Fct
import qualified Data.Foldable as Fold
--import qualified Data.Text.Lazy.Builder as TLB
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

-- * Helper types
type Column = Natural
type Indent = Column
type Width = Natural
type SGR = ANSI.SGR

{-
-- ** Type 'Horiz'
newtype Horiz repr a = Horiz { unHoriz :: repr a }
  deriving (Eq, Show, Semigroup)
type instance Derived (Horiz repr) = repr
instance Derivable (Horiz repr) where
  derive = unHoriz
instance LiftDerived (Horiz repr) where
  liftDerived = Horiz
instance LiftDerived1 (Horiz repr)
instance LiftDerived2 (Horiz repr)
instance LiftDerived3 (Horiz repr)
instance Emptyable repr => Emptyable (Horiz repr)
--instance Semigroupable repr => Semigroupable (Horiz repr)
instance ProductFunctor repr => ProductFunctor (Horiz repr) where
  (<.) = liftDerived2 (<.)
  (.>) = liftDerived2 (.>)
instance
  ( ProductFunctor repr
  , Spaceable repr
  ) => Spaceable (Horiz repr)
-}

{-
instance From [SGR] repr => From [SGR] (Horiz repr) where
  from = Horiz . from

class Inject a repr ty where
  inject :: a -> repr ty
instance Inject String repr H => Inject Int repr H where
  inject = inject . show
instance Inject String repr H => Inject Integer repr H where
  inject = inject . show
instance Inject String repr H => Inject Natural repr H where
  inject = inject . show
instance Inject String repr H => Inject [SGR] repr H where
  inject = inject . ANSI.setSGRCode
instance Inject Text repr a => Inject TL.Text repr a where
  inject = inject . TL.toStrict
-}

{-
-- * Class 'From'
class From a repr where
  from :: a -> repr
  default from :: From String repr => Show a => a -> repr
  from = from . show

-- String
instance From repr String => From (Line repr) String where
  from = from . unLine
instance From repr String => From (Word repr) String where
  from = from . unWord
instance From [SGR] String where
  from = ANSI.setSGRCode

-- Text
instance From repr Text => From (Line repr) Text where
  from = from . unLine
instance From repr Text => From (Word repr) Text where
  from = from . unWord
instance From [SGR] Text where
  from = from . ANSI.setSGRCode

-- TL.Text
instance From repr TL.Text => From (Line repr) TL.Text where
  from = from . unLine
instance From repr TL.Text => From (Word repr) TL.Text where
  from = from . unWord
instance From [SGR] TL.Text where
  from = from . ANSI.setSGRCode

-- TLB.Builder
instance From repr TLB.Builder => From (Line repr) TLB.Builder where
  from = from . unLine
instance From repr TLB.Builder => From (Word repr) TLB.Builder where
  from = from . unWord
instance From [SGR] TLB.Builder where
  from = from . ANSI.setSGRCode

runTextBuilder :: TLB.Builder -> TL.Text
runTextBuilder = TLB.toLazyText
-}

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

-- * 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 </>
{-
instance Spaceable (f String) where
  newline  = "\n"
  space    = " "
  spaces n = List.replicate (fromIntegral n) ' '
instance Spaceable Text where
  newline  = "\n"
  space    = " "
  spaces n = Text.replicate (fromIntegral n) " "
instance Spaceable TL.Text where
  newline  = "\n"
  space    = " "
  spaces n = TL.replicate (fromIntegral n) " "
instance Spaceable TLB.Builder where
  newline  = TLB.singleton '\n'
  space    = TLB.singleton ' '
  spaces   = TLB.fromText . spaces
-}

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

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

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