{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Document.Class where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable)
import Data.Function ((.), ($), id, const)
import Data.Functor (Functor(..), (<$>))
import Data.Int (Int)
import Data.Kind (Type)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Data.Traversable (Traversable)
import Numeric.Natural (Natural)
import Prelude (Integer, fromIntegral, pred)
import Text.Show (Show(..))
import qualified Data.Foldable as Fold
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified System.Console.ANSI as ANSI

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

-- ** Type 'Line'
newtype Line d = Line d
 deriving (Eq,Show)
unLine :: Line d -> d
unLine (Line d) = d

-- ** Type 'Word'
newtype Word d = Word d
 deriving (Eq,Show,Semigroup)
unWord :: Word d -> d
unWord (Word d) = d
instance From [SGR] d => From [SGR] (Word d) where
  from = Word . from

-- * Class 'From'
class From a d where
  from :: a -> d
  default from :: From String d => Show a => a -> d
  from = from . show
instance From (Line String) d => From Int d where
  from = from . Line . show
instance From (Line String) d => From Integer d where
  from = from . Line . show
instance From (Line String) d => From Natural d where
  from = from . Line . show

-- String
instance From Char String where
  from = pure
instance From String String where
  from = id
instance From Text String where
  from = Text.unpack
instance From TL.Text String where
  from = TL.unpack
instance From d String => From (Line d) String where
  from = from . unLine
instance From d String => From (Word d) String where
  from = from . unWord
instance From [SGR] String where
  from = ANSI.setSGRCode

-- Text
instance From Char Text where
  from = Text.singleton
instance From String Text where
  from = Text.pack
instance From Text Text where
  from = id
instance From TL.Text Text where
  from = TL.toStrict
instance From d Text => From (Line d) Text where
  from = from . unLine
instance From d Text => From (Word d) Text where
  from = from . unWord
instance From [SGR] Text where
  from = from . ANSI.setSGRCode

-- TL.Text
instance From Char TL.Text where
  from = TL.singleton
instance From String TL.Text where
  from = TL.pack
instance From Text TL.Text where
  from = TL.fromStrict
instance From TL.Text TL.Text where
  from = id
instance From d TL.Text => From (Line d) TL.Text where
  from = from . unLine
instance From d TL.Text => From (Word d) TL.Text where
  from = from . unWord
instance From [SGR] TL.Text where
  from = from . ANSI.setSGRCode

-- TLB.Builder
instance From Char TLB.Builder where
  from = TLB.singleton
instance From String TLB.Builder where
  from = fromString
instance From Text TLB.Builder where
  from = TLB.fromText
instance From TL.Text TLB.Builder where
  from = TLB.fromLazyText
instance From TLB.Builder TLB.Builder where
  from = id
instance From d TLB.Builder => From (Line d) TLB.Builder where
  from = from . unLine
instance From d TLB.Builder => From (Word d) 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 'Lengthable'
class Lengthable d where
  width :: d -> Column
  nullWidth :: d -> Bool
  nullWidth d = width d == 0
instance Lengthable Char where
  width _ = 1
  nullWidth = const False
instance Lengthable String where
  width = fromIntegral . List.length
  nullWidth = Fold.null
instance Lengthable Text.Text where
  width = fromIntegral . Text.length
  nullWidth = Text.null
instance Lengthable TL.Text where
  width = fromIntegral . TL.length
  nullWidth = TL.null
instance Lengthable d => Lengthable (Line d) where
  width = fromIntegral . width . unLine
  nullWidth = nullWidth . unLine
instance Lengthable d => Lengthable (Word d) where
  width = fromIntegral . width . unWord
  nullWidth = nullWidth . unWord

-- * Class 'Spaceable'
class Monoid d => Spaceable d where
  newline :: d
  space   :: d
  default newline :: Spaceable (UnTrans d) => Trans d => d
  default space   :: Spaceable (UnTrans d) => Trans d => d
  newline = noTrans newline
  space   = noTrans space

  -- | @'spaces' ind = 'replicate' ind 'space'@
  spaces :: Column -> d
  default spaces :: Monoid d => Column -> d
  spaces i = replicate (fromIntegral i) space
  unlines :: Foldable f => f (Line d) -> d
  unlines = Fold.foldr (\(Line x) acc -> x<>newline<>acc) mempty
  unwords :: Foldable f => Functor f => f (Word d) -> d
  unwords = intercalate space . (unWord <$>)
  -- | Like 'unlines' but without the trailing 'newline'.
  catLines :: Foldable f => Functor f => f (Line d) -> d
  catLines = catV . (unLine <$>)
  -- | @x '<+>' y = x '<>' 'space' '<>' y@
  (<+>) :: d -> d -> d
  -- | @x '</>' y = x '<>' 'newline' '<>' y@
  (</>) :: d -> d -> d
  x <+> y = x <> space <> y
  x </> y = x <> newline <> y
  catH :: Foldable f => f d -> d
  catV :: Foldable f => f d -> d
  catH = Fold.foldr (<>) mempty
  catV = intercalate newline
infixr 6 <+>
infixr 6 </>
instance Spaceable 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, Monoid d) => d -> f d -> d
intercalate sep ds = if Fold.null ds then mempty else Fold.foldr1 (\x y -> x<>sep<>y) ds

replicate :: Monoid d => Int -> d -> d
replicate cnt t | cnt <= 0  = mempty
                | otherwise = t `mappend` replicate (pred cnt) t

between :: Semigroup d => d -> d -> d -> d
between o c d = o<>d<>c
parens :: Semigroup d => From (Word Char) d => d -> d
parens = between (from (Word '(')) (from (Word ')'))
braces :: Semigroup d => From (Word Char) d => d -> d
braces = between (from (Word '{')) (from (Word '}'))
brackets :: Semigroup d => From (Word Char) d => d -> d
brackets = between (from (Word '[')) (from (Word ']'))
angles :: Semigroup d => From (Word Char) d => d -> d
angles = between (from (Word '<')) (from (Word '>'))

-- * Class 'Splitable'
class (Lengthable d, Monoid d) => Splitable d where
  tail  :: d -> Maybe d
  break :: (Char -> Bool) -> d -> (d, d)
  span :: (Char -> Bool) -> d -> (d, d)
  span f = break (not . f)
  lines :: d -> [Line d]
  words :: d -> [Word d]
  linesNoEmpty :: d -> [Line d]
  wordsNoEmpty :: d -> [Word d]
  lines = (Line <$>) . splitOnChar (== '\n')
  words = (Word <$>) . splitOnChar (== ' ')
  linesNoEmpty = (Line <$>) . splitOnCharNoEmpty (== '\n')
  wordsNoEmpty = (Word <$>) . splitOnCharNoEmpty (== ' ')

  splitOnChar :: (Char -> Bool) -> d -> [d]
  splitOnChar f d0 =
    if nullWidth d0 then [] else go d0
    where
    go d =
      let (l,r) = f`break`d in
      l : case tail r of
       Nothing -> []
       Just rt | nullWidth rt -> [mempty]
               | otherwise -> go rt
  splitOnCharNoEmpty :: (Char -> Bool) -> d -> [d]
  splitOnCharNoEmpty f d =
    let (l,r) = f`break`d in
    (if nullWidth l then [] else [l]) <>
    case tail r of
     Nothing -> []
     Just rt -> splitOnCharNoEmpty f rt
instance Splitable String where
  tail [] = Nothing
  tail s = Just $ List.tail s
  break = List.break
instance Splitable Text.Text where
  tail "" = Nothing
  tail s = Just $ Text.tail s
  break = Text.break
instance Splitable TL.Text where
  tail "" = Nothing
  tail s = Just $ TL.tail s
  break = TL.break

-- * Class 'Decorable'
class Decorable d where
  bold      :: d -> d
  underline :: d -> d
  italic    :: d -> d
  default bold      :: Decorable (UnTrans d) => Trans d => d -> d
  default underline :: Decorable (UnTrans d) => Trans d => d -> d
  default italic    :: Decorable (UnTrans d) => Trans d => d -> d
  bold      = noTrans1 bold
  underline = noTrans1 underline
  italic    = noTrans1 italic

-- * Class 'Colorable16'
class Colorable16 d where
  reverse :: d -> d

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

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

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

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

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

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

-- | For debugging purposes.
instance Colorable16 String where
  reverse     = xmlSGR "reverse"
  black       = xmlSGR "black"
  red         = xmlSGR "red"
  green       = xmlSGR "green"
  yellow      = xmlSGR "yellow"
  blue        = xmlSGR "blue"
  magenta     = xmlSGR "magenta"
  cyan        = xmlSGR "cyan"
  white       = xmlSGR "white"
  blacker     = xmlSGR "blacker"
  redder      = xmlSGR "redder"
  greener     = xmlSGR "greener"
  yellower    = xmlSGR "yellower"
  bluer       = xmlSGR "bluer"
  magentaer   = xmlSGR "magentaer"
  cyaner      = xmlSGR "cyaner"
  whiter      = xmlSGR "whiter"
  onBlack     = xmlSGR "onBlack"
  onRed       = xmlSGR "onRed"
  onGreen     = xmlSGR "onGreen"
  onYellow    = xmlSGR "onYellow"
  onBlue      = xmlSGR "onBlue"
  onMagenta   = xmlSGR "onMagenta"
  onCyan      = xmlSGR "onCyan"
  onWhite     = xmlSGR "onWhite"
  onBlacker   = xmlSGR "onBlacker"
  onRedder    = xmlSGR "onRedder"
  onGreener   = xmlSGR "onGreener"
  onYellower  = xmlSGR "onYellower"
  onBluer     = xmlSGR "onBluer"
  onMagentaer = xmlSGR "onMagentaer"
  onCyaner    = xmlSGR "onCyaner"
  onWhiter    = xmlSGR "onWhiter"

-- | For debugging purposes.
xmlSGR :: Semigroup d => From String d => String -> d -> d
xmlSGR newSGR s = from ("<"<>newSGR<>">")<>s<>from ("</"<>newSGR<>">")

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

  default align         :: Indentable (UnTrans d) => Trans d => d -> d
  default incrIndent    :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
  default setIndent     :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
  default fill          :: Indentable (UnTrans d) => Trans d => Width -> d -> d
  default fillOrBreak   :: Indentable (UnTrans d) => Trans d => Width -> d -> d

  align          = noTrans1 align
  setIndent  p i = noTrans . setIndent  (unTrans p) i . unTrans
  incrIndent p i = noTrans . incrIndent (unTrans p) i . unTrans
  fill           = noTrans1 . fill
  fillOrBreak    = noTrans1 . fillOrBreak

class Listable d where
  ul :: Traversable f => f d -> d
  ol :: Traversable f => f d -> d
  default ul ::
   Listable (UnTrans d) => Trans d =>
   Traversable f => f d -> d
  default ol ::
   Listable (UnTrans d) => Trans d =>
   Traversable f => f d -> d
  ul ds = noTrans $ ul $ unTrans <$> ds
  ol ds = noTrans $ ol $ unTrans <$> ds

-- * Class 'Wrappable'
class Wrappable d where
  setWidth :: Maybe Width -> d -> d
  -- getWidth :: (Maybe Width -> d) -> d
  breakpoint :: d
  breakspace :: d
  breakalt   :: d -> d -> d
  endline    :: d
  default breakpoint :: Wrappable (UnTrans d) => Trans d => d
  default breakspace :: Wrappable (UnTrans d) => Trans d => d
  default breakalt   :: Wrappable (UnTrans d) => Trans d => d -> d -> d
  default endline    :: Wrappable (UnTrans d) => Trans d => d
  breakpoint = noTrans breakpoint
  breakspace = noTrans breakspace
  breakalt   = noTrans2 breakalt
  endline    = noTrans endline

-- * Class 'Justifiable'
class Justifiable d where
  justify :: d -> d

-- * Class 'Trans'
class Trans repr where
  -- | Return the underlying @repr@ of the transformer.
  type UnTrans repr :: Type

  -- | Lift a repr to the transformer's.
  noTrans :: UnTrans repr -> repr
  -- | Unlift a repr from the transformer's.
  unTrans :: repr -> UnTrans repr

  -- | Identity transformation for a unary symantic method.
  noTrans1 :: (UnTrans repr -> UnTrans repr) -> (repr -> repr)
  noTrans1 f = noTrans . f . unTrans

  -- | Identity transformation for a binary symantic method.
  noTrans2
   :: (UnTrans repr -> UnTrans repr -> UnTrans repr)
   -> (repr -> repr -> repr)
  noTrans2 f a b = noTrans (f (unTrans a) (unTrans b))

  -- | Identity transformation for a ternary symantic method.
  noTrans3
   :: (UnTrans repr -> UnTrans repr -> UnTrans repr -> UnTrans repr)
   -> (repr -> repr -> repr -> repr)
  noTrans3 f a b c = noTrans (f (unTrans a) (unTrans b) (unTrans c))