{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Document.API 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.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 System.Console.ANSI (SGR, setSGRCode)
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

-- * Helper types
type Column = Natural
type Indent = Column
type Width = Natural

-- ** 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 = 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 . 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 . 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 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 :: *
	
	-- | 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))