{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where

import Control.Monad (forM_, when)
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import GHC.Exts (IsList(..))
import Options.Applicative as Opt
import Prelude (error)
import System.IO (IO, FilePath, hPrint, hPutStrLn, stderr, stdout)
import qualified Data.ByteString as BS
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified System.Environment as Env
import qualified Text.Blaze.Renderer.Utf8 as Blaze
import qualified Text.Blaze.Utils as Blaze

import Data.Locale

import qualified Data.TreeSeq.Strict as Tree
import qualified Language.DTC.Read.TCT as DTC.Read.TCT
import qualified Language.DTC.Sym as DTC
import qualified Language.DTC.Write.HTML5 as DTC.Write.HTML5
import qualified Language.DTC.Write.XML   as DTC.Write.XML
import qualified Language.RNC.Write as RNC
import qualified Language.TCT as TCT
import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5
import qualified Language.TCT.Write.XML   as TCT.Write.XML
import qualified Text.Blaze.DTC   as Blaze.DTC
import qualified Text.Blaze.HTML5 as Blaze.HTML5
import qualified Text.Megaparsec  as P

import Read

type Langs = '[FR, EN]
type Lang = LocaleIn Langs

main :: IO ()
main = do
	lang <-
		(\v -> Map.findWithDefault
		 (LocaleIn @Langs en_US)
		 (Text.pack $ List.takeWhile (\c -> Char.isAlphaNum c || c == '_') v)
		 (locales @Langs)) .
		fromMaybe ""
		 <$> Env.lookupEnv "LANG"
	cmd <- execParser $ pArgv lang
	mainWithCommand cmd
	where
	pArgv lang =
		info (pCommand lang <**> helper) $ mconcat
		 [ fullDesc
		 , progDesc "document tool"
		 , header "hdoc - TCT and DTC command line tool"
		 ]

mainWithCommand :: Command -> IO ()
mainWithCommand (CommandTCT ArgsTCT{..}) =
	readFile input $ \_fp txt ->
		case TCT.readTCTs input txt of
		 Left err -> error $ P.parseErrorPretty err
		 Right tct -> do
			hPrint stderr $ Tree.Pretty tct
			case format of
			 TctFormatHTML5 ->
				Blaze.renderMarkupToByteStringIO BS.putStr $
				TCT.Write.HTML5.html5Document tct
mainWithCommand (CommandDTC ArgsDTC{..}) =
	readFile input $ \_fp txt ->
		case TCT.readTCTs input txt of
		 Left err -> error $ P.parseErrorPretty err
		 Right tct -> do
			when (trace_TCT trace) $ do
				hPutStrLn stderr "### TCT ###"
				hPrint stderr $ Tree.Pretty tct
			let xml = TCT.Write.XML.xmlDocument tct
			when (trace_XML trace) $ do
				hPutStrLn stderr "### XML ###"
				hPrint stderr $ Tree.Pretty xml
			case DTC.Read.TCT.readDTC xml of
			 Left err -> error $ P.parseErrorPretty err
			 Right dtc -> do
				when (trace_DTC trace) $ do
					hPutStrLn stderr "### DTC ###"
					hPrint stderr dtc
				case format of
				 DtcFormatXML ->
					Blaze.prettyMarkupIO Blaze.DTC.indentTag BS.putStr $
					DTC.Write.XML.xmlDocument locale dtc
				 DtcFormatHTML5 ->
					Blaze.prettyMarkupIO Blaze.HTML5.indentTag BS.putStr $
					DTC.Write.HTML5.html5Document locale dtc
mainWithCommand (CommandRNC ArgsRNC{}) =
	forM_ DTC.dtcRNC $ \w ->
		Text.hPutStrLn stdout $ RNC.renderWriter w

-- * Options utils

instance IsList (Opt.Mod f a) where
	type Item (Opt.Mod f a) = Opt.Mod f a
	fromList = mconcat
	toList   = pure

readMap :: Map String a -> ReadM a
readMap m =
	eitherReader $ \s ->
		case Map.lookup s m of
		 Nothing -> Left $ "cannot parse value \"" <> s
			 <> "\"\nexpecting one of: "
			 <> (List.intercalate ", " $ Map.keys m)
		 Just a -> Right a

-- * Type 'Command'
data Command
 =   CommandTCT ArgsTCT
 |   CommandDTC ArgsDTC
 |   CommandRNC ArgsRNC

pCommand :: Lang -> Parser Command
pCommand lang =
	hsubparser
	 [ metavar "tct"
	 , command "tct" $
		info (CommandTCT <$> pArgsTCT) $
			progDesc "TCT (Texte Convivial Technique) rendition."
	 ] <|>
	hsubparser
	 [ metavar "dtc"
	 , command "dtc" $
		info (CommandDTC <$> pArgsDTC lang) $
			progDesc "DTC (Document Technique Convivial) rendition."
	 ] <|>
	hsubparser
	 [ metavar "rnc"
	 , command "rnc" $
		info (CommandRNC <$> pArgsRNC) $
			progDesc "RNC (RelaxNG Compact) schema."
	 ]

-- * Type 'Trace'
data Trace
 =   Trace
 {   trace_TCT :: Bool
 ,   trace_XML :: Bool
 ,   trace_DTC :: Bool
 }
instance Default Trace where
	def = Trace
	 { trace_TCT = False
	 , trace_XML = False
	 , trace_DTC = False
	 }
instance Semigroup Trace where
	x <> y =
		Trace
		 { trace_TCT = trace_TCT x || trace_TCT y
		 , trace_XML = trace_XML x || trace_XML y
		 , trace_DTC = trace_DTC x || trace_DTC y
		 }
instance Monoid Trace where
	mempty  = def
	mappend = (<>)

pTrace :: Parser Trace
pTrace =
	(mconcat <$>) $
	many $
	option
	 (readMap m)
	 [ long "trace"
	 , help $ "Print trace. (choices: "
		 <> (List.intercalate ", " $ Map.keys m) <> ")"
	 ]
	where
	m = Map.fromList
	 [ ("tct", def{trace_TCT=True})
	 , ("xml", def{trace_XML=True})
	 , ("dtc", def{trace_DTC=True})
	 ]

-- ** Type 'ArgsTCT'
data ArgsTCT
 =   ArgsTCT
 {   input  :: FilePath
 ,   format :: TctFormat
 }

pArgsTCT :: Parser ArgsTCT
pArgsTCT =
	ArgsTCT
	 <$> argument str (metavar "FILE")
	 <*> pTctFormat

-- *** Type 'TctFormat'
data TctFormat
 =   TctFormatHTML5

pTctFormat :: Parser TctFormat
pTctFormat =
	flag TctFormatHTML5 TctFormatHTML5
	 [ long "html5"
	 , help "Render as HTML5."
	 ]

-- ** Type 'ArgsDTC'
data ArgsDTC
 =   ArgsDTC
 {   input  :: FilePath
 ,   format :: DtcFormat
 ,   locale :: Lang
 ,   trace  :: Trace
 }
pArgsDTC :: Lang -> Parser ArgsDTC
pArgsDTC lang =
	ArgsDTC
	 <$> argument str (metavar "FILE")
	 <*> pDtcFormat
	 <*> pLocale lang
	 <*> pTrace

pLocale :: Lang -> Parser (LocaleIn Langs)
pLocale lang =
	option
	 (maybeReader $ \s -> Map.lookup (Text.pack s) $ locales @Langs)
	 [ long "lang"
	 , help "Language."
	 , showDefault
	 , value lang
	 , metavar "LOCALE"
	 ]

-- *** Type 'DtcFormat'
data DtcFormat
 =   DtcFormatHTML5
 |   DtcFormatXML

pDtcFormat :: Parser DtcFormat
pDtcFormat =
	flag DtcFormatHTML5 DtcFormatHTML5
	 [ long "html5"
	 , help "Render as HTML5."
	 ] <|>
	flag DtcFormatHTML5 DtcFormatXML
	 [ long "xml"
	 , help "Render as XML."
	 ]

-- ** Type 'ArgsRNC'
data ArgsRNC
 =   ArgsRNC

pArgsRNC :: Parser ArgsRNC
pArgsRNC = pure ArgsRNC


{-
	Args
	 <$> strOption (  long "hello"
	               <> metavar "TARGET"
	               <> help "Target for the greeting")
	 <*> switch (  long "quiet"
	            <> short 'q'
	            <> help "Whether to be quiet")
	 <*> option auto ( long "enthusiasm"
	                 <> help "How enthusiastically to greet"
	                 <> showDefault
	                 <> value 1
	                 <> metavar "INT")
-}