{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Symantic.Document.Sym where

import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (Foldable, foldr, foldr1)
import Data.Function ((.), ($))
import Data.Functor (Functor(..))
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..), Ordering(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString)
import Prelude (Integer, fromIntegral, Num(..), pred, undefined, Integral, Real, Enum)
import Text.Show (Show(..))
import qualified Data.Foldable as Foldable
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL

-- * Type 'Nat'
newtype Nat = Nat { unNat :: Integer }
 deriving (Eq, Ord, Show, Integral, Real, Enum)
unLength :: Nat -> Integer
unLength (Nat i) = i
instance Num Nat where
	fromInteger i | 0 <= i    = Nat i
	              | otherwise = undefined
	abs = Nat . abs . unLength
	signum = signum . signum
	Nat x + Nat y = Nat (x + y)
	Nat x * Nat y = Nat (x * y)
	Nat x - Nat y | x >= y    = Nat (x - y)
	              | otherwise = undefined

-- * Class 'Lengthable'
class Lengthable a where
	length :: a -> Nat
instance Lengthable Char where
	length _ = Nat 1
instance Lengthable [a] where
	length = Nat . fromIntegral . List.length
instance Lengthable Text.Text where
	length = Nat . fromIntegral . Text.length
instance Lengthable TL.Text where
	length = Nat . fromIntegral . TL.length

-- * Class 'Splitable'
class Monoid a => Splitable a where
	null  :: a -> Bool
	tail  :: a -> a
	break :: (Char -> Bool) -> a -> (a, a)
	lines :: a -> [a]
	lines = splitOnChar (== '\n')
	words :: a -> [a]
	words = splitOnChar (== ' ')
	splitOnChar :: (Char -> Bool) -> a -> [a]
	splitOnChar c a =
		if null a then []
		else let (l,a') = break c a in
			l : if null a' then []
				else let a'' = tail a' in
					if null a'' then [mempty] else splitOnChar c a''
instance Splitable String where
	null  = List.null
	tail  = List.tail
	break = List.break
instance Splitable Text.Text where
	null  = Text.null
	tail  = Text.tail
	break = Text.break
instance Splitable TL.Text where
	null  = TL.null
	tail  = TL.tail
	break = TL.break

-- * Type 'Column'
type Column = Nat

-- ** Type 'Indent'
type Indent = Column

-- * Class 'Textable'
class (IsString d, Semigroup d) => Textable d where
	empty     :: d
	charH     :: Char -- ^ XXX: MUST NOT be '\n'
	          -> d
	stringH   :: String -- ^ XXX: MUST NOT contain '\n'
	          -> d
	textH     :: Text.Text -- ^ XXX: MUST NOT contain '\n'
	          -> d
	ltextH    :: TL.Text -- ^ XXX: MUST NOT contain '\n'
	          -> d
	default empty     :: Textable (UnTrans d) => Trans d => d
	default charH     :: Textable (UnTrans d) => Trans d => Char -> d
	default stringH   :: Textable (UnTrans d) => Trans d => String -> d
	default textH     :: Textable (UnTrans d) => Trans d => Text.Text -> d
	default ltextH    :: Textable (UnTrans d) => Trans d => TL.Text -> d
	empty     = noTrans empty
	charH     = noTrans . charH
	stringH   = noTrans . stringH
	textH     = noTrans . textH
	ltextH    = noTrans . ltextH
	
	newline     :: d
	space       :: d
	-- | @x '<+>' y = x '<>' 'space' '<>' y@
	(<+>)       :: d -> d -> d
	-- | @x '</>' y = x '<>' 'newline' '<>' y@
	(</>)       :: d -> d -> d
	int         :: Int -> d
	integer     :: Integer -> d
	char        :: Char    -> d
	string      :: String  -> d
	text        :: Text.Text  -> d
	ltext       :: TL.Text -> d
	catH        :: Foldable f => f d -> d
	catV        :: Foldable f => f d -> d
	unwords     :: Foldable f => f d -> d
	unlines     :: Foldable f => f d -> d
	foldrWith   :: Foldable f => (d -> d -> d) -> f d -> d
	foldWith    :: Foldable f => (d -> d) -> f d -> d
	intercalate :: Foldable f => d -> f d -> d
	between     :: d -> d -> d -> d
	replicate   :: Int -> d -> d
	
	newline = "\n"
	space   = char ' '
	x <+> y = x <> space <> y
	x </> y = x <> newline <> y
	int     = stringH . show
	integer = stringH . show
	char    = \case '\n' -> newline; c -> charH c
	string  = catV . fmap stringH . lines
	text    = catV . fmap textH   . lines
	ltext   = catV . fmap ltextH  . lines
	catH    = foldr (<>) empty
	catV    = foldrWith (\x y -> x<>newline<>y)
	unwords = foldr (<>) space
	unlines = foldr (\x y -> x<>newline<>y) empty
	foldrWith f ds  = if Foldable.null ds then empty else foldr1 f ds
	foldWith  f     = foldrWith $ \a acc -> a <> f acc
	intercalate sep = foldrWith (\x y -> x<>sep<>y)
	between o c d = o<>d<>c
	replicate cnt t | cnt <= 0  = empty
	                | otherwise = t <> replicate (pred cnt) t

-- * Class 'Indentable'
class Textable d => Indentable d where
	-- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
	align :: d -> d
	default align :: Indentable (UnTrans d) => Trans d => d -> d
	align = noTrans1 align
	-- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
	incrIndent :: Indent -> d -> d
	default incrIndent :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
	incrIndent = noTrans1 . incrIndent
	-- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
	withIndent :: Indent -> d -> d
	default withIndent :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
	withIndent = noTrans1 . withIndent
	-- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.
	--
	-- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.
	withNewline          :: d -> d -> d
	newlineWithoutIndent :: d
	newlineWithIndent    :: d
	default withNewline          :: Indentable (UnTrans d) => Trans d => d -> d -> d
	default newlineWithoutIndent :: Indentable (UnTrans d) => Trans d => d
	default newlineWithIndent    :: Indentable (UnTrans d) => Trans d => d
	withNewline          = noTrans2 withNewline
	newlineWithoutIndent = noTrans newlineWithoutIndent
	newlineWithIndent    = noTrans newlineWithIndent
	-- | @('column' f)@ write @f@ applied to the current 'Column'.
	column :: (Column -> d) -> d
	default column :: Indentable (UnTrans d) => Trans d => (Column -> d) -> d
	column f = noTrans $ column (unTrans . f)
	-- | @('indent' f)@ write @f@ applied to the current 'Indent'.
	indent :: (Indent -> d) -> d
	default indent :: Indentable (UnTrans d) => Trans d => (Indent -> d) -> d
	indent f = noTrans $ indent (unTrans . f)
	
	-- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
	hang :: Indent -> d -> d
	hang ind = align . incrIndent ind
	
	-- | @('endToEndWidth' d f)@ write @d@ then
	-- @f@ applied to the absolute value of the difference between
	-- the end 'Column' and start 'Column' of @d@.
	--
	-- Note that @f@ is given the end-to-end width,
	-- which is not necessarily the maximal width.
	endToEndWidth :: d -> (Column -> d) -> d
	endToEndWidth d f =
		column $ \c1 ->
			(d <>) $
			column $ \c2 ->
			f $ if c2 - c1 >= 0
				then c2 - c1
				else c1 - c2
	
	-- | @'spaces' ind = 'replicate' ind 'space'@
	spaces :: Indent -> d
	spaces i = replicate (fromIntegral i) space
	
	-- | @('fill' ind d)@ write @d@,
	-- then if @d@ is not wider than @ind@,
	-- write the difference with 'spaces'.
	fill :: Indent -> d -> d
	fill m d =
		endToEndWidth d $ \w ->
			case w`compare`m of
			 LT -> spaces $ m - w
			 _  -> empty
	
	-- | @('breakableFill' ind d)@ write @d@,
	-- then if @d@ is not wider than @ind@, write the difference with 'spaces'
	-- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @ind@.
	breakableFill :: Indent -> d -> d
	breakableFill m d =
		column $ \c ->
		endToEndWidth d $ \w ->
			case w`compare`m of
			 LT -> spaces (m - w)
			 EQ -> empty
			 GT -> withIndent (c + m) newline

-- * Class 'Breakable'
class (Textable d, Indentable d) => Breakable d where
	-- | @('breakable' f)@ write @f@ applied to whether breaks are activated or not.
	breakable :: (Maybe Column -> d) -> d
	default breakable :: Breakable (UnTrans d) => Trans d => (Maybe Column -> d) -> d
	breakable f = noTrans $ breakable (unTrans . f)
	-- | @('withBreakable' b d)@ whether to active breaks or not within @d@.
	withBreakable :: Maybe Column -> d -> d
	default withBreakable :: Breakable (UnTrans d) => Trans d => Maybe Column -> d -> d
	withBreakable = noTrans1 . withBreakable
	
	-- | @('ifBreak' onWrap onNoWrap)@
	-- write @onWrap@ if @onNoWrap@ leads to a 'Column'
	-- greater or equal to the one sets with 'withBreakable',
	-- otherwise write @onNoWrap@.
	ifBreak :: d -> d -> d
	default ifBreak :: Breakable (UnTrans d) => Trans d => d -> d -> d
	ifBreak = noTrans2 ifBreak
	-- | @('breakpoint' onNoBreak onBreak d)@
	-- write @onNoBreak@ then @d@ if they fit,
	-- @onBreak@ otherwise.
	breakpoint :: d -> d -> d -> d
	default breakpoint :: Breakable (UnTrans d) => Trans d => d -> d -> d -> d
	breakpoint = noTrans3 breakpoint
	
	-- | @('breakableEmpty' d)@ write @d@ if it fits, 'newline' then @d@ otherwise.
	breakableEmpty :: d -> d
	breakableEmpty = breakpoint empty newline
	
	-- | @x '><' y = x '<>' 'breakableEmpty' y@
	(><) :: d -> d -> d
	x >< y = x <> breakableEmpty y
	
	-- | @('breakableSpace' d)@ write 'space' then @d@ it they fit,
	-- 'newline' then @d@ otherwise.
	breakableSpace :: d -> d
	breakableSpace = breakpoint space newline
	
	-- | @x '>+<' y = x '<>' 'breakableSpace' y@
	(>+<) :: d -> d -> d
	x >+< y = x <> breakableSpace y
	
	-- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
	-- between items of @ds@.
	breakableSpaces :: Foldable f => f d -> d
	breakableSpaces = foldWith breakableSpace
	
	-- | @('intercalateHorV' sep ds)@
	-- write @ds@ with @sep@ intercalated if the whole fits,
	-- otherwise write 'align' of @ds@ with 'newline' and @sep@ intercalated.
	intercalateHorV :: Foldable f => d -> f d -> d
	intercalateHorV sep xs =
		ifBreak
		 (align $ foldWith ((newline <> sep) <>) xs)
		 (foldWith (sep <>) xs)

-- * Class 'Colorable'
class Colorable d where
	-- | @('colorable' f)@ write @f@ applied to whether colors are activated or not.
	colorable :: (Bool -> d) -> d
	default colorable :: Colorable (UnTrans d) => Trans d => (Bool -> d) -> d
	colorable f = noTrans $ colorable (unTrans . f)
	-- | @('withColor' b d)@ whether to active colors or not within @d@.
	withColorable :: Bool -> d -> d
	default withColorable :: Colorable (UnTrans d) => Trans d => Bool -> d -> d
	withColorable = noTrans1 . withColorable
	
	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     :: Colorable (UnTrans d) => Trans d => d -> d
	default black       :: Colorable (UnTrans d) => Trans d => d -> d
	default red         :: Colorable (UnTrans d) => Trans d => d -> d
	default green       :: Colorable (UnTrans d) => Trans d => d -> d
	default yellow      :: Colorable (UnTrans d) => Trans d => d -> d
	default blue        :: Colorable (UnTrans d) => Trans d => d -> d
	default magenta     :: Colorable (UnTrans d) => Trans d => d -> d
	default cyan        :: Colorable (UnTrans d) => Trans d => d -> d
	default white       :: Colorable (UnTrans d) => Trans d => d -> d
	default blacker     :: Colorable (UnTrans d) => Trans d => d -> d
	default redder      :: Colorable (UnTrans d) => Trans d => d -> d
	default greener     :: Colorable (UnTrans d) => Trans d => d -> d
	default yellower    :: Colorable (UnTrans d) => Trans d => d -> d
	default bluer       :: Colorable (UnTrans d) => Trans d => d -> d
	default magentaer   :: Colorable (UnTrans d) => Trans d => d -> d
	default cyaner      :: Colorable (UnTrans d) => Trans d => d -> d
	default whiter      :: Colorable (UnTrans d) => Trans d => d -> d
	default onBlack     :: Colorable (UnTrans d) => Trans d => d -> d
	default onRed       :: Colorable (UnTrans d) => Trans d => d -> d
	default onGreen     :: Colorable (UnTrans d) => Trans d => d -> d
	default onYellow    :: Colorable (UnTrans d) => Trans d => d -> d
	default onBlue      :: Colorable (UnTrans d) => Trans d => d -> d
	default onMagenta   :: Colorable (UnTrans d) => Trans d => d -> d
	default onCyan      :: Colorable (UnTrans d) => Trans d => d -> d
	default onWhite     :: Colorable (UnTrans d) => Trans d => d -> d
	default onBlacker   :: Colorable (UnTrans d) => Trans d => d -> d
	default onRedder    :: Colorable (UnTrans d) => Trans d => d -> d
	default onGreener   :: Colorable (UnTrans d) => Trans d => d -> d
	default onYellower  :: Colorable (UnTrans d) => Trans d => d -> d
	default onBluer     :: Colorable (UnTrans d) => Trans d => d -> d
	default onMagentaer :: Colorable (UnTrans d) => Trans d => d -> d
	default onCyaner    :: Colorable (UnTrans d) => Trans d => d -> d
	default onWhiter    :: Colorable (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

-- * Class 'Decorable'
class Decorable d where
	-- | @('decorable' f)@ write @f@ applied to whether decorations are activated or not.
	decorable :: (Bool -> d) -> d
	default decorable :: Decorable (UnTrans d) => Trans d => (Bool -> d) -> d
	decorable f = noTrans $ decorable (unTrans . f)
	-- | @('withColor' b d)@ whether to active decorations or not within @d@.
	withDecorable :: Bool -> d -> d
	default withDecorable :: Decorable (UnTrans d) => Trans d => Bool -> d -> d
	withDecorable = noTrans1 . withDecorable
	
	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 '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))