module Language.Symantic.Document.Valid where

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Eq (Eq(..))
import Data.Foldable (elem)
import Data.Function (($), (.), id)
import Data.Functor (Functor(..))
import Data.Int (Int)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Text.Show (Show)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL

import Language.Symantic.Document.Sym

-- * Type 'Valid'
data Valid repr
 =   KO [Error_Valid]
 |   Ok repr
 deriving (Eq, Show)
instance IsString repr => IsString (Valid repr) where
	fromString = Ok . fromString

valid :: Valid repr -> Valid repr
valid = id

-- ** Type 'Error_Valid'
data Error_Valid
 =   Error_Valid_not_horizontal TL.Text
 |   Error_Valid_negative_replicate Int
 deriving (Eq, Show)

instance Semigroup repr => Semigroup (Valid repr) where
	Ok x <> Ok y = Ok $ x <> y
	KO x <> Ok _ = KO x
	Ok _ <> KO y = KO y
	KO x <> KO y = KO $ x <> y
instance (Doc_Text repr, Semigroup repr) => Monoid (Valid repr) where
	mempty  = empty
	mappend = (<>)
instance Functor Valid where
	fmap _ (KO e) = KO e
	fmap f (Ok a) = Ok $ f a
instance Applicative Valid where
	pure = Ok
	Ok f  <*> Ok a  = Ok $ f a
	KO e  <*> KO e' = KO $ e <> e'
	Ok _f <*> KO e  = KO e
	KO e  <*> Ok _a = KO e
instance Monad Valid where
	return = Ok
	Ok a >>= f = f a
	KO e >>= _ = KO e
instance (Doc_Text repr, Semigroup repr) => Doc_Text (Valid repr) where
	replicate i _ | i < 0 = KO [Error_Valid_negative_replicate i]
	replicate i d         = d >>= Ok . replicate i
	int       = pure . int
	integer   = pure . integer
	char      = pure . char
	string    = pure . string
	text      = pure . text
	ltext     = pure . ltext
	charH '\n'= KO [Error_Valid_not_horizontal $ TL.singleton '\n']
	charH c   = Ok $ charH c
	stringH t | '\n' `elem` t = KO [Error_Valid_not_horizontal $ fromString t]
	stringH t = Ok $ stringH t
	textH   t | T.any (== '\n') t = KO [Error_Valid_not_horizontal $ TL.fromStrict t]
	textH   t = Ok $ textH t
	ltextH  t | TL.any (== '\n') t = KO [Error_Valid_not_horizontal t]
	ltextH  t = Ok $ ltextH t
instance Doc_Color repr => Doc_Color (Valid repr) where
	reverse     = fmap reverse
	black       = fmap black
	red         = fmap red
	green       = fmap green
	yellow      = fmap yellow
	blue        = fmap blue
	magenta     = fmap magenta
	cyan        = fmap cyan
	white       = fmap white
	blacker     = fmap blacker
	redder      = fmap redder
	greener     = fmap greener
	yellower    = fmap yellower
	bluer       = fmap bluer
	magentaer   = fmap magentaer
	cyaner      = fmap cyaner
	whiter      = fmap whiter
	onBlack     = fmap onBlack
	onRed       = fmap onRed
	onGreen     = fmap onGreen
	onYellow    = fmap onYellow
	onBlue      = fmap onBlue
	onMagenta   = fmap onMagenta
	onCyan      = fmap onCyan
	onWhite     = fmap onWhite
	onBlacker   = fmap onBlacker
	onRedder    = fmap onRedder
	onGreener   = fmap onGreener
	onYellower  = fmap onYellower
	onBluer     = fmap onBluer
	onMagentaer = fmap onMagentaer
	onCyaner    = fmap onCyaner
	onWhiter    = fmap onWhiter
instance Doc_Decoration repr => Doc_Decoration (Valid repr) where
	bold      = fmap bold
	italic    = fmap italic
	underline = fmap underline