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

import Control.Monad (Monad(..), forM_, when)
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Locale
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Data.String (String)
import Data.Tuple (fst)
import GHC.Exts (IsList(..))
import Options.Applicative as Opt
import Prelude (error)
import System.FilePath as FilePath
import System.IO (IO, FilePath)
import Text.Show (Show(..))
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.Set as Set
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.TreeSeq.Strict as Tree
import qualified System.Environment as Env
import qualified System.IO as IO
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{..}) = do
	TCT.readFile input >>= \case
	 Left err -> IO.hPrint IO.stderr err
	 Right txt ->
		case TCT.readTCTWithoutIncludes input txt of
		 Left err -> error $ show err
		 Right tct -> do
			when (DumpTCT_TCT`elem`dump) $
				writeFile (output`FilePath.replaceExtension`".tct.dump") $
					TL.pack $ Tree.prettyTrees tct
			when (DumpTCT_XML`elem`dump) $
				let xml = TCT.Write.XML.document tct in
				writeFile (output`FilePath.replaceExtension`".xml.dump") $
					TL.pack $ Tree.prettyTrees xml
			case format of
			 FormatTCT_Plain ->
				writeFile output $
				TCT.Write.Plain.document tct
			 FormatTCT_HTML5 ->
				withFile output IO.WriteMode $ \h ->
					Blaze.renderMarkupToByteStringIO (BS.hPutStr h) $
					TCT.Write.HTML5.document tct
mainWithCommand (CommandDTC ArgsDTC{..}) =
	TCT.readTCT input >>= \case
	 Left err -> error $ show err
	 Right tct -> do
		when (DumpDTC_TCT`elem`dump) $ do
			writeFile (input`FilePath.replaceExtension`".tct.dump") $
				TL.pack $ Tree.prettyTrees tct
		let xml = TCT.Write.XML.document tct
		when (DumpDTC_XML`elem`dump) $ do
			writeFile (input`FilePath.replaceExtension`".xml.dump") $
				TL.pack $ Tree.prettyTrees xml
		case DTC.Read.TCT.readDTC xml of
		 Left err -> error $ P.parseErrorPretty err
		 Right dtc -> do
			when (DumpDTC_DTC`elem`dump) $ do
				writeFile (input`FilePath.replaceExtension`".dtc.dump") $
					TL.pack $ show dtc
			case format of
			 FormatDTC_XML ->
				withFile output IO.WriteMode $ \h ->
					Blaze.prettyMarkupIO Blaze.DTC.isInlinedElement (BS.hPutStr h) $
					DTC.Write.XML.document locale dtc
			 FormatDTC_HTML5 ->
				withFile output IO.WriteMode $ \h ->
					Blaze.prettyMarkupIO Blaze.HTML5.isInlinedElement (BS.hPutStr h) $
					DTC.Write.HTML5.document locale dtc
mainWithCommand (CommandRNC ArgsRNC{}) =
	forM_ DTC.schema $ \rule ->
		Text.hPutStrLn IO.stdout $ RNC.renderWriter rule

-- * Filesystem utilities
writeFile :: FilePath -> TL.Text -> IO ()
writeFile fp s = BSL.writeFile fp $ TL.encodeUtf8 s

withFile :: FilePath -> IO.IOMode -> (IO.Handle -> IO a) -> IO a
withFile = IO.withFile

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

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

-- * 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."
	 ]

pDump :: Ord a => [(String, a)] -> Parser (Set a)
pDump formats =
	(mconcat <$>) $
	many $
	option
	 (Set.singleton <$> readList formats)
	 [ long "dump"
	 , help $ "Dump an intermediate format. (choices: "
		 <> List.intercalate ", " (fst <$> formats) <> ")"
	 ]

-- ** Type 'ArgsTCT'
data ArgsTCT
 =   ArgsTCT
 {   input  :: FilePath
 ,   output :: FilePath
 ,   format :: FormatTCT
 ,   dump   :: Set DumpTCT
 }

pArgsTCT :: Parser ArgsTCT
pArgsTCT =
	(setDefault <$>) $
	ArgsTCT
	 <$> argument str (metavar "FILE")
	 <*> strOption [ long "output"
	               , metavar "FILE"
	               , value ""
	               , help "write output to FILE"
	               ]
	 <*> pFormatTCT
	 <*> pDump [ ("tct", DumpTCT_TCT)
	           , ("xml", DumpTCT_XML) ]
	where
	setDefault a@ArgsTCT{..}
	 | null output = (a::ArgsTCT){output=input`FilePath.replaceExtension`ext format}
	 | otherwise   = a
	ext = \case
	 FormatTCT_Plain -> ".txt"
	 FormatTCT_HTML5 -> ".html"

-- *** Type 'FormatTCT'
data FormatTCT
 =   FormatTCT_Plain
 |   FormatTCT_HTML5

pFormatTCT :: Parser FormatTCT
pFormatTCT =
	flag FormatTCT_Plain FormatTCT_Plain
	 [ long "plain"
	 , help "Render as plain text."
	 ] <|>
	flag FormatTCT_HTML5 FormatTCT_HTML5
	 [ long "html5"
	 , help "Render as HTML5."
	 ]

-- *** Type 'DumpTCT'
data DumpTCT
 =   DumpTCT_TCT
 |   DumpTCT_XML
 deriving (Eq, Ord, Show)

-- ** Type 'ArgsDTC'
data ArgsDTC
 =   ArgsDTC
 {   input  :: FilePath
 ,   output :: FilePath
 ,   format :: FormatDTC
 ,   locale :: Lang
 ,   dump   :: Set DumpDTC
 }
pArgsDTC :: Lang -> Parser ArgsDTC
pArgsDTC lang =
	(setDefault <$>) $
	ArgsDTC
	 <$> argument str (metavar "FILE")
	 <*> strOption [ long "output"
	               , metavar "FILE"
	               , value ""
	               , help "write output to FILE"
	               ]
	 <*> pFormatDTC
	 <*> pLocale lang
	 <*> pDump [ ("tct", DumpDTC_TCT)
	           , ("xml", DumpDTC_XML)
	           , ("dtc", DumpDTC_DTC) ]
	where
	setDefault a@ArgsDTC{..}
	 | null output = (a::ArgsDTC){output=input`FilePath.replaceExtension`fmt format}
	 | otherwise   = a
	fmt = \case
	 FormatDTC_XML   -> ".xml"
	 FormatDTC_HTML5 -> ".html"

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 'FormatDTC'
data FormatDTC
 =   FormatDTC_HTML5
 |   FormatDTC_XML

pFormatDTC :: Parser FormatDTC
pFormatDTC =
	flag FormatDTC_HTML5 FormatDTC_HTML5
	 [ long "html5"
	 , help "Render as HTML5."
	 ] <|>
	flag FormatDTC_HTML5 FormatDTC_XML
	 [ long "xml"
	 , help "Render as XML."
	 ]

-- *** Type 'DumpDTC'
data DumpDTC
 =   DumpDTC_TCT
 |   DumpDTC_XML
 |   DumpDTC_DTC
 deriving (Eq, Ord, Show)

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

pArgsRNC :: Parser ArgsRNC
pArgsRNC = pure ArgsRNC