module Language.Symantic.Document.Sym where

import Data.Char (Char)
import Data.Foldable (Foldable(..))
import Data.Function ((.), ($))
import Data.Functor (Functor(..))
import Data.Int (Int, Int64)
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString)
import Data.Text (Text)
import Prelude (Integer, toInteger, fromIntegral)
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL

-- * Class 'Doc_Text'
class (IsString d, Semigroup d) => Doc_Text d where
	charH     :: Char    -> d -- ^ XXX: MUST NOT be '\n'
	stringH   :: String  -> d -- ^ XXX: MUST NOT contain '\n'
	textH     :: Text    -> d -- ^ XXX: MUST NOT contain '\n'
	ltextH    :: TL.Text -> d -- ^ XXX: MUST NOT contain '\n'
	replicate :: Int -> d -> d
	integer   :: Integer -> d
	default replicate :: Doc_Text (ReprOf d) => Trans d => Int -> d -> d
	default integer   :: Doc_Text (ReprOf d) => Trans d => Integer -> d
	default charH     :: Doc_Text (ReprOf d) => Trans d => Char -> d
	default stringH   :: Doc_Text (ReprOf d) => Trans d => String -> d
	default textH     :: Doc_Text (ReprOf d) => Trans d => Text -> d
	default ltextH    :: Doc_Text (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
	spaces      :: Int -> d
	int         :: Int -> d
	char        :: Char    -> d
	string      :: String  -> d
	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 ' '
	spaces i = replicate i space
	int      = integer . toInteger
	char     = \case '\n' -> newline; c -> charH c
	string   = catV . fmap stringH . L.lines
	text     = catV . fmap textH   . T.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 :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
	-- default catV :: Doc_Text (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 'Doc_Align'
class Doc_Align d where
	type Newline d
	type Newline d = d
	type Column d
	type Column d = Int
	type Indent d
	type Indent d = Int
	-- | @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 -> d
	hang ind = align . incrIndent ind
	-- | @incrIndent ind d@, make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
	incrIndent  :: Indent d -> d -> d
	-- | @withIndent ind d@, make @d@ uses @ind@ as 'Indent' level.
	withIndent  :: Indent d -> d -> d
	-- | @withNewline nl d@, make @d@ uses @nl@ as 'newline'.
	withNewline :: d -> Newline d -> d

-- * Class 'Doc_Wrap'
class (Doc_Text d, Doc_Align d) => Doc_Wrap d where
	-- | @ifFit onFit onNoFit@,
	-- return @onFit@ if @onFit@ leads to a 'Column'
	-- lower or equal to the one sets with 'withWrapColumn',
	-- otherwise return @onNoFit@.
	ifFit :: d -> d -> d
	-- | @breakpoint onNoBreak onBreak d@,
	-- return @onNoBreak@ then @d@ if they fit,
	-- @onBreak@ otherwise.
	breakpoint :: d -> d -> d -> d
	-- | @breakableEmpty d@, return @d@ if it fits, 'newline' then @d@ otherwise.
	breakableEmpty :: d -> d
	breakableEmpty = breakpoint empty newline
	-- | @breakableSpace d@, return 'space' then @d@ it they fit, 'newline' then @d@ otherwise.
	breakableSpace :: d -> d
	breakableSpace = breakpoint space newline
	-- | @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 -> d
	-- | @intercalateHorV sep ds@,
	-- return @ds@ with @sep@ intercalated if the whole fits,
	-- otherwise return 'align' of @ds@ with 'newline' and @sep@ intercalated.
	intercalateHorV :: Foldable f => d -> f d -> d
	intercalateHorV sep xs =
		ifFit    (foldr1 (\a acc -> a <> sep            <> acc) xs)
		 (align $ foldr1 (\a acc -> a <> newline <> sep <> acc) xs)

-- * Class 'Doc_Color'
class Doc_Color 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     :: Doc_Color (ReprOf d) => Trans d => d -> d
	default black       :: Doc_Color (ReprOf d) => Trans d => d -> d
	default red         :: Doc_Color (ReprOf d) => Trans d => d -> d
	default green       :: Doc_Color (ReprOf d) => Trans d => d -> d
	default yellow      :: Doc_Color (ReprOf d) => Trans d => d -> d
	default blue        :: Doc_Color (ReprOf d) => Trans d => d -> d
	default magenta     :: Doc_Color (ReprOf d) => Trans d => d -> d
	default cyan        :: Doc_Color (ReprOf d) => Trans d => d -> d
	default white       :: Doc_Color (ReprOf d) => Trans d => d -> d
	default blacker     :: Doc_Color (ReprOf d) => Trans d => d -> d
	default redder      :: Doc_Color (ReprOf d) => Trans d => d -> d
	default greener     :: Doc_Color (ReprOf d) => Trans d => d -> d
	default yellower    :: Doc_Color (ReprOf d) => Trans d => d -> d
	default bluer       :: Doc_Color (ReprOf d) => Trans d => d -> d
	default magentaer   :: Doc_Color (ReprOf d) => Trans d => d -> d
	default cyaner      :: Doc_Color (ReprOf d) => Trans d => d -> d
	default whiter      :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onBlack     :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onRed       :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onGreen     :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onYellow    :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onBlue      :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onMagenta   :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onCyan      :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onWhite     :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onBlacker   :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onRedder    :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onGreener   :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onYellower  :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onBluer     :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onMagentaer :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onCyaner    :: Doc_Color (ReprOf d) => Trans d => d -> d
	default onWhiter    :: Doc_Color (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 'Doc_Decoration'
class Doc_Decoration d where
	bold      :: d -> d
	underline :: d -> d
	italic    :: d -> d
	default bold      :: Doc_Decoration (ReprOf d) => Trans d => d -> d
	default underline :: Doc_Decoration (ReprOf d) => Trans d => d -> d
	default italic    :: Doc_Decoration (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))

int64OfInt :: Int -> Int64
int64OfInt = fromIntegral

intOfInt64 :: Int64 -> Int
intOfInt64 = fromIntegral