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

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

-- * Type 'Nat'
newtype Nat = Nat 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 | y <= x    = 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

-- * Type 'Column'
type Column = Nat

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

-- * Class 'Textable'
class (IsString d, Semigroup d) => Textable d where
	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
	replicate :: Int -> d -> d
	integer   :: Integer -> d
	default replicate :: Textable (ReprOf d) => Trans d => Int -> d -> d
	default integer   :: Textable (ReprOf d) => Trans d => Integer -> d
	default charH     :: Textable (ReprOf d) => Trans d => Char -> d
	default stringH   :: Textable (ReprOf d) => Trans d => String -> d
	default textH     :: Textable (ReprOf d) => Trans d => Text.Text -> d
	default ltextH    :: Textable (ReprOf d) => Trans d => TL.Text -> d
	charH     = trans . charH
	stringH   = trans . stringH
	textH     = trans . textH
	ltextH    = trans . ltextH
	replicate = trans1 . replicate
	integer   = trans . integer
	
	empty       :: d
	newline     :: d
	space       :: d
	-- | @x '<+>' y = x '<>' 'space' '<>' y@
	(<+>)       :: d -> d -> d
	-- | @x '</>' y = x '<>' 'newline' '<>' y@
	(</>)       :: d -> d -> d
	int         :: Int -> 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
	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
	
	newline  = "\n"
	space    = char ' '
	x <+> y  = x <> space <> y
	x </> y  = x <> newline <> y
	int      = integer . toInteger
	char     = \case '\n' -> newline; c -> charH c
	string   = catV . fmap stringH . lines
	text     = catV . fmap textH   . Text.lines
	ltext    = catV . fmap ltextH  . TL.lines
	catH     = foldr (<>) empty
	catV     = foldrWith (\x y -> x<>newline<>y)
	foldrWith f ds  = if 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
	-- default catH :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
	-- default catV :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
	-- catH  l = trans (catH (fmap unTrans l))
	-- catV  l = trans (catV (fmap unTrans l))

-- * Class 'Alignable'
class Textable d => Alignable d where
	-- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
	align :: d -> d
	-- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
	hang :: Indent -> d -> d
	hang ind = align . incrIndent ind
	-- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
	incrIndent  :: Indent -> d -> d
	-- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
	withIndent  :: Indent -> d -> d
	-- | @('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
	-- | @('column' f)@ write @f@ applied to the current 'Column'.
	column :: (Column -> d) -> d
	-- | @('endToEndWidth' d f)@ write @d@ then
	-- @f@ applied to 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 $ c2 - c1
	
	-- | @'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) <> empty
			 EQ -> empty
			 GT -> withIndent (c + m) newline

-- * Class 'Wrapable'
class (Textable d, Alignable d) => Wrapable d where
	-- | @('ifWrap' onWrap onNoWrap)@
	-- write @onWrap@ if @onNoWrap@ leads to a 'Column'
	-- greater or equal to the one sets with 'withWrapColumn',
	-- otherwise write @onNoWrap@.
	ifWrap :: d -> d -> d
	-- | @('breakpoint' onNoBreak onBreak d)@
	-- write @onNoBreak@ then @d@ if they fit,
	-- @onBreak@ otherwise.
	breakpoint :: d -> d -> d -> d
	-- | @('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
	-- | @'withWrapColumn' col d@ set the 'Column' triggering wrapping to @col@ within @d@.
	withWrapColumn :: Column -> d -> d
	-- | @('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 =
		ifWrap
		 (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
	-- | @('withColor' b d)@ whether to active colors or not within @d@.
	withColorable :: Bool -> d -> d
	
	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 (ReprOf d) => Trans d => d -> d
	default black       :: Colorable (ReprOf d) => Trans d => d -> d
	default red         :: Colorable (ReprOf d) => Trans d => d -> d
	default green       :: Colorable (ReprOf d) => Trans d => d -> d
	default yellow      :: Colorable (ReprOf d) => Trans d => d -> d
	default blue        :: Colorable (ReprOf d) => Trans d => d -> d
	default magenta     :: Colorable (ReprOf d) => Trans d => d -> d
	default cyan        :: Colorable (ReprOf d) => Trans d => d -> d
	default white       :: Colorable (ReprOf d) => Trans d => d -> d
	default blacker     :: Colorable (ReprOf d) => Trans d => d -> d
	default redder      :: Colorable (ReprOf d) => Trans d => d -> d
	default greener     :: Colorable (ReprOf d) => Trans d => d -> d
	default yellower    :: Colorable (ReprOf d) => Trans d => d -> d
	default bluer       :: Colorable (ReprOf d) => Trans d => d -> d
	default magentaer   :: Colorable (ReprOf d) => Trans d => d -> d
	default cyaner      :: Colorable (ReprOf d) => Trans d => d -> d
	default whiter      :: Colorable (ReprOf d) => Trans d => d -> d
	default onBlack     :: Colorable (ReprOf d) => Trans d => d -> d
	default onRed       :: Colorable (ReprOf d) => Trans d => d -> d
	default onGreen     :: Colorable (ReprOf d) => Trans d => d -> d
	default onYellow    :: Colorable (ReprOf d) => Trans d => d -> d
	default onBlue      :: Colorable (ReprOf d) => Trans d => d -> d
	default onMagenta   :: Colorable (ReprOf d) => Trans d => d -> d
	default onCyan      :: Colorable (ReprOf d) => Trans d => d -> d
	default onWhite     :: Colorable (ReprOf d) => Trans d => d -> d
	default onBlacker   :: Colorable (ReprOf d) => Trans d => d -> d
	default onRedder    :: Colorable (ReprOf d) => Trans d => d -> d
	default onGreener   :: Colorable (ReprOf d) => Trans d => d -> d
	default onYellower  :: Colorable (ReprOf d) => Trans d => d -> d
	default onBluer     :: Colorable (ReprOf d) => Trans d => d -> d
	default onMagentaer :: Colorable (ReprOf d) => Trans d => d -> d
	default onCyaner    :: Colorable (ReprOf d) => Trans d => d -> d
	default onWhiter    :: Colorable (ReprOf d) => Trans d => d -> d
	
	reverse     = trans1 reverse
	black       = trans1 black
	red         = trans1 red
	green       = trans1 green
	yellow      = trans1 yellow
	blue        = trans1 blue
	magenta     = trans1 magenta
	cyan        = trans1 cyan
	white       = trans1 white
	blacker     = trans1 blacker
	redder      = trans1 redder
	greener     = trans1 greener
	yellower    = trans1 yellower
	bluer       = trans1 bluer
	magentaer   = trans1 magentaer
	cyaner      = trans1 cyaner
	whiter      = trans1 whiter
	onBlack     = trans1 onBlack
	onRed       = trans1 onRed
	onGreen     = trans1 onGreen
	onYellow    = trans1 onYellow
	onBlue      = trans1 onBlue
	onMagenta   = trans1 onMagenta
	onCyan      = trans1 onCyan
	onWhite     = trans1 onWhite
	onBlacker   = trans1 onBlacker
	onRedder    = trans1 onRedder
	onGreener   = trans1 onGreener
	onYellower  = trans1 onYellower
	onBluer     = trans1 onBluer
	onMagentaer = trans1 onMagentaer
	onCyaner    = trans1 onCyaner
	onWhiter    = trans1 onWhiter

-- * Class 'Decorable'
class Decorable d where
	-- | @('decorable' f)@ write @f@ applied to whether decorations are activated or not.
	decorable :: (Bool -> d) -> d
	-- | @('withColor' b d)@ whether to active decorations or not within @d@.
	withDecorable :: Bool -> d -> d
	
	bold      :: d -> d
	underline :: d -> d
	italic    :: d -> d
	default bold      :: Decorable (ReprOf d) => Trans d => d -> d
	default underline :: Decorable (ReprOf d) => Trans d => d -> d
	default italic    :: Decorable (ReprOf d) => Trans d => d -> d
	bold      = trans1 bold
	underline = trans1 underline
	italic    = trans1 italic

-- * Class 'Trans'
class Trans tr where
	-- | Return the underlying @tr@ of the transformer.
	type ReprOf tr :: *
	
	-- | Lift a tr to the transformer's.
	trans :: ReprOf tr -> tr
	-- | Unlift a tr from the transformer's.
	unTrans :: tr -> ReprOf tr
	
	-- | Identity transformation for a unary symantic method.
	trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
	trans1 f = trans . f . unTrans
	
	-- | Identity transformation for a binary symantic method.
	trans2
	 :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
	 -> (tr -> tr -> tr)
	trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
	
	-- | Identity transformation for a ternary symantic method.
	trans3
	 :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
	 -> (tr -> tr -> tr -> tr)
	trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))

-- | Break a 'String' into lines while preserving all empty lines.
lines :: String -> [String]
lines cs =
	case List.break (== '\n') cs of
	 (chunk, _:rest) -> chunk : lines rest
	 (chunk, []) -> [chunk]