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

import Control.Monad (forM_, when)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Locale
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.ByteString.Lazy as BSL
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 Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Data.TreeSeq.Strict as Tree
import qualified System.Environment as Env
import qualified Text.Blaze.Renderer.Utf8 as Blaze
import qualified Text.Blaze.Utils as Blaze
import qualified Text.Megaparsec as P

-- TCT imports
import qualified Language.TCT             as TCT
import qualified Language.TCT.Write.HTML5 as TCT.Write.HTML5
import qualified Language.TCT.Write.Plain as TCT.Write.Plain
import qualified Language.TCT.Write.XML   as TCT.Write.XML

-- DTC imports
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 Text.Blaze.DTC           as Blaze.DTC
import qualified Text.Blaze.HTML5         as Blaze.HTML5

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 - command line tool for TCT and DTC technical documents"
		 ]

mainWithCommand :: Command -> IO ()
mainWithCommand (CommandTCT ArgsTCT{..}) =
	readFile input $ \_fp txt ->
		case TCT.readTCT input txt of
		 Left err -> error $ P.parseErrorPretty err
		 Right tct -> do
			when (trace_TCT trace) $ do
				hPutStrLn stderr "### TCT ###"
				hPutStrLn stderr $ Tree.prettyTrees tct
			when (trace_XML trace) $ do
				hPutStrLn stderr "### XML ###"
				let xml = TCT.Write.XML.document tct
				hPutStrLn stderr $ Tree.prettyTrees xml
			case format of
			 TctFormatPlain ->
				TL.putStrLn $
				TCT.Write.Plain.document tct
			 TctFormatHTML5 ->
				Blaze.renderMarkupToByteStringIO BS.putStr $
				TCT.Write.HTML5.document tct
mainWithCommand (CommandDTC ArgsDTC{..}) =
	readFile input $ \_fp txt ->
		case TCT.readTCT input txt of
		 Left err -> error $ P.parseErrorPretty err
		 Right tct -> do
			when (trace_TCT trace) $ do
				hPutStrLn stderr "### TCT ###"
				hPutStrLn stderr $ Tree.prettyTrees tct
			let xml = TCT.Write.XML.document tct
			when (trace_XML trace) $ do
				hPutStrLn stderr "### XML ###"
				hPutStrLn stderr $ Tree.prettyTrees 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.isInlinedElement BS.putStr $
					DTC.Write.XML.document locale dtc
				 DtcFormatHTML5 ->
					Blaze.prettyMarkupIO Blaze.HTML5.isInlinedElement BS.putStr $
					DTC.Write.HTML5.document locale dtc
mainWithCommand (CommandRNC ArgsRNC{}) =
	forM_ DTC.schema $ \rule ->
		Text.hPutStrLn stdout $ RNC.renderWriter rule

-- * Filesystem utilities
readFile :: MonadIO m => FilePath -> (FilePath -> TL.Text -> m a) -> m a
readFile fp f = do
	content <- liftIO $ BSL.readFile fp
	f fp $ TL.decodeUtf8 content

-- * Options utilities

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
 ,   trace  :: Trace
 }

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

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

pTctFormat :: Parser TctFormat
pTctFormat =
	flag TctFormatPlain TctFormatPlain
	 [ long "plain"
	 , help "Render as plain text."
	 ] <|>
	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