{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hdoc.DTC.Write.Plain where

import Control.Applicative (Applicative(..), liftA2)
import Control.Category
import Control.Monad
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..), concat)
import Data.Function (($))
import Data.Int (Int)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..))
import Data.Tuple (fst, snd)
import Data.String (String, IsString(..))
import Prelude (mod)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB

import Data.Locale hiding (Index)

import Hdoc.DTC.Write.XML ()
import Hdoc.DTC.Document as DTC hiding (Plain)
import qualified Hdoc.DTC.Document as DTC

-- * Type 'Plain'
type Plain = S.State State TLB.Builder

runPlain :: Plain -> State -> (TL.Text, State)
runPlain p s =
	let (b,s') = S.runState p s in
	(TLB.toLazyText b, s')

text :: Plainify a => State -> a -> TL.Text
text st a = fst $ runPlain (plainify a) st

instance IsString Plain where
	fromString = return . fromString
instance Semigroup Plain where
	(<>) = liftA2 (<>)
instance Monoid Plain where
	mempty  = return ""
	mappend = (<>)

-- ** Type 'State'
data State = State -- TODO: could be a Reader
 { state_l10n   :: Loqualization (L10n Plain)
 , state_italic :: Bool
 , state_quote  :: Nat
 }
instance Default State where
	def = State
	 { state_l10n   = Loqualization EN_US
	 , state_italic = False
	 , state_quote  = Nat 0
	 }

-- * Class 'Plainify'
class Plainify a where
	plainify :: a -> Plain
instance Plainify String where
	plainify = return . TLB.fromString
instance Plainify Text where
	plainify = return . TLB.fromText
instance Plainify TL.Text where
	plainify = return . TLB.fromLazyText
{-
instance Plainify Para where
	plainify = \case
	 ParaItem{..}  -> plainify item
	 ParaItems{..} -> plainify items
-}
instance Plainify DTC.Plain where
	plainify = foldMap plainify
instance Plainify (Tree PlainNode) where
	plainify (Tree n ls) =
		case n of
		 PlainBreak    -> "\n"
		 PlainText txt -> plainify txt
		 PlainGroup    -> plainify ls
		 PlainB        -> "*"<>plainify ls<>"*"
		 PlainCode     -> "`"<>plainify ls<>"`"
		 PlainDel      -> "-"<>plainify ls<>"-"
		 PlainI        -> "/"<>plainify ls<>"/"
		 PlainNote{..} -> "" -- TODO: to be coded, with a switch on/off in State
		 PlainQ        -> do
			State{state_l10n=Loqualization loc} <- S.get
			l10n_Quote (plainify ls) loc
		 PlainSC       -> plainify ls
		 PlainSpan{..} -> plainify ls
		 PlainSub      -> plainify ls
		 PlainSup      -> plainify ls
		 PlainU        -> "_"<>plainify ls<>"_"
		 PlainEref{..} -> plainify ls
		 PlainIref{..} -> plainify ls
		 PlainTag{..}  -> "#"<>plainify ls<>"#"
		 PlainRref{..} -> plainify ls
instance Plainify Title where
	plainify (Title t) = plainify t
instance Plainify XmlPosPath where
	plainify =
		plainify .
		snd . foldl' (\(nParent,acc) (n,c) ->
			(n,
				(if TL.null acc then acc else acc <> ".") <>
				(if n == nParent
					then TL.pack (show c)
					else TL.pack (show n)<>TL.pack (show c))
			)
		 )
		 ("","")
instance Plainify XmlName where
	plainify = plainify . show
instance Plainify Int where
	plainify = plainify . show
instance Plainify Nat where
	plainify (Nat n) = plainify n
instance Plainify Nat1 where
	plainify (Nat1 n) = plainify n

-- * Type 'L10n'
class L10n msg lang where
	l10n_Colon             ::         FullLocale lang -> msg
	l10n_Table_of_Contents ::         FullLocale lang -> msg
	l10n_Quote             :: msg  -> FullLocale lang -> msg
	l10n_Date              :: Date -> FullLocale lang -> msg

instance L10n TL.Text FR where
	l10n_Colon _loc = " : "
	l10n_Table_of_Contents _loc = "Sommaire"
	l10n_Quote msg _loc = "« "<>msg<>" »"
	l10n_Date Date{..} _loc =
		TL.pack $
		mconcat $
		List.intersperse " " $
		concat
		 [ maybe [] (pure . show) day
		 , case month of
			 Nothing -> []
			 Just (Nat1 m) ->
				case m of
				 1  -> pure "janvier"
				 2  -> pure "février"
				 3  -> pure "mars"
				 4  -> pure "avril"
				 5  -> pure "mai"
				 6  -> pure "juin"
				 7  -> pure "juillet"
				 8  -> pure "août"
				 9  -> pure "septembre"
				 10 -> pure "octobre"
				 11 -> pure "novembre"
				 12 -> pure "décembre"
				 _  -> []
		 , [show year]
		 ]
instance L10n TL.Text EN where
	l10n_Colon _loc = ": "
	l10n_Table_of_Contents _loc = "Table of Contents"
	l10n_Quote msg _loc = "“"<>msg<>"”"
	l10n_Date Date{..} _loc =
		TL.pack $
		mconcat $
		List.intersperse " " $
		concat
		 [ maybe [] (pure . show) day
		 , case month of
			 Nothing -> []
			 Just (Nat1 m) ->
				case m of
				 1  -> pure "January"
				 2  -> pure "February"
				 3  -> pure "March"
				 4  -> pure "April"
				 5  -> pure "May"
				 6  -> pure "June"
				 7  -> pure "July"
				 8  -> pure "August"
				 9  -> pure "September"
				 10 -> pure "October"
				 11 -> pure "November"
				 12 -> pure "December"
				 _  -> []
		 , [show year]
		 ]

instance L10n Plain FR where
	l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
	l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
	l10n_Quote msg _loc = do
		depth <- S.gets state_quote
		let (o,c) =
			case unNat depth `mod` 3 of
			 0 -> ("« "," »")
			 1 -> ("“","”")
			 _ -> ("‟","„")
		S.modify' $ \s -> s{state_quote=succNat depth}
		m <- msg
		S.modify' $ \s -> s{state_quote=depth}
		return $ o <> m <> c
	l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)
instance L10n Plain EN where
	l10n_Colon loc = plainify (l10n_Colon loc::TL.Text)
	l10n_Table_of_Contents loc = plainify (l10n_Table_of_Contents loc::TL.Text)
	l10n_Quote msg _loc = do
		depth <- S.gets state_quote
		let (o,c) =
			case unNat depth `mod` 3 of
			 0 -> ("“","”")
			 1 -> ("« "," »")
			 _ -> ("‟","„")
		S.modify' $ \s -> s{state_quote=succNat depth}
		m <- msg
		S.modify' $ \s -> s{state_quote=depth}
		return $ o <> m <> c
	l10n_Date date loc = plainify (l10n_Date date loc::TL.Text)

{-
-- ** Type 'L10nPlain'
-- | Useful newtype to just use 'plainify', instead of 'state_l10n'.
newtype L10nPlain = L10nPlain (forall l. L10n l Plain => FullLocale l -> Plain)
instance Plainify L10nPlain where
	plainify (L10nPlain l10n) = do
		State{state_l10n} <- S.get
		l10n state_l10n
-}