{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Symantic and LCC grammar instances for Megaparsec
module Hcompta.LCC.Read.Megaparsec where

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Bool
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable
import Data.Function (($), (.))
import Data.Functor (Functor(..), (<$>))
import Data.Int (Int)
import Data.List ((++))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Set (Set)
import Data.String (IsString(..), String)
import Data.Text (Text)
import Data.Typeable ()
import Data.Word (Word)
import Prelude (pred, succ, (-), error)
import System.IO (IO)
import Text.Show (Show(..))
import qualified Control.Applicative as Alt
import qualified Control.Exception.Safe as Exn
import qualified Control.Monad.Classes as MC
import qualified Data.ByteString as BS
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as Set
import qualified Data.Strict as S
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Enc
import qualified System.Directory as IO
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Prim as P

import Language.Symantic.Grammar as Sym
import qualified Language.Symantic as Sym
import qualified Language.Symantic.Document as D

import Hcompta.LCC.Amount
import Hcompta.LCC.Chart
-- import Hcompta.LCC.Compta
import Hcompta.LCC.Write
import Hcompta.LCC.Read.Compta as LCC
import Hcompta.LCC.IO
import Hcompta.LCC.Journal
import Hcompta.LCC.Source

import Debug.Trace (trace)
import Data.Semigroup ((<>))

dbg :: Show a => [Char] -> a -> a
dbg msg x = trace (msg <> " = " <> show x) x

-- | Convenient converter.
sourcePos :: P.SourcePos -> SourcePos
sourcePos (P.SourcePos p l c) = SourcePos p (PosFile $ P.unPos l) (PosFile $ P.unPos c)

-- * Type 'ParsecC'
-- | Convenient alias for defining instances involving 'P.ParsecT'.
type ParsecC e s = (P.Token s ~ Char, P.Stream s, P.ErrorComponent e, P.ShowErrorComponent e)
instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where
	fromString = P.string

--
-- Readers
--

-- NonEmpty SourcePos
instance ParsecC e s => Sym.Gram_Reader (NonEmpty SourcePos) (P.ParsecT e s m) where
	askBefore g = do
		s <- (sourcePos <$>) . P.statePos <$> P.getParserState
		($ s) <$> g
	askAfter g = do
		f <- g
		f . (sourcePos <$>) . P.statePos <$> P.getParserState
type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader (NonEmpty SourcePos)) = 'True
instance ParsecC e s => MC.MonadReaderN 'MC.Zero (NonEmpty SourcePos) (P.ParsecT e s m) where
	askN _n = (sourcePos <$>) . P.statePos <$> P.getParserState
-- SourcePos
instance ParsecC e s => Sym.Gram_Reader SourcePos (P.ParsecT e s m) where
	askBefore g = do
		s <- sourcePos <$> P.getPosition
		($ s) <$> g
	askAfter g = do
		f <- g
		f . sourcePos <$> P.getPosition
type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader SourcePos) = 'True
instance ParsecC e s => MC.MonadReaderN 'MC.Zero SourcePos (P.ParsecT e s m) where
	askN _n = sourcePos <$> P.getPosition
-- ()
instance ParsecC e s => Sym.Gram_Reader () (P.ParsecT e s m) where
	askBefore = fmap ($ ())
	askAfter  = fmap ($ ())
-- S.Either Exn.IOException CanonFile
instance (ParsecC e s, MonadIO m) => Sym.Gram_Reader (S.Either Exn.IOException CanonFile) (P.ParsecT e s m) where
	askBefore g = do
		sn <- P.sourceName <$> P.getPosition
		f <- g
		liftIO $ Exn.catch
		 (f . S.Right . CanonFile . PathFile <$> IO.canonicalizePath sn)
		 (return . f . S.Left)
	askAfter g = do
		f <- g
		sn <- P.sourceName <$> P.getPosition
		liftIO $ Exn.catch
		 (f . S.Right . CanonFile . PathFile <$> IO.canonicalizePath sn)
		 (return . f . S.Left)
type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader (S.Either Exn.IOException CanonFile)) = 'True
instance (ParsecC e s, MonadIO m) => MC.MonadReaderN 'MC.Zero (S.Either Exn.IOException CanonFile) (P.ParsecT e s m) where
	askN _n = do
		sn <- P.sourceName <$> P.getPosition
		liftIO $ Exn.catch
		 (S.Right . CanonFile . PathFile <$> IO.canonicalizePath sn)
		 (return . S.Left)

--
-- States
--

-- st
type instance MC.CanDo (P.ParsecT e s m) (MC.EffState st) = 'False
instance (Monad m, MC.MonadState st m) => Sym.Gram_State st m where
	stateBefore g = do
		s <- MC.get
		f <- g
		let (s', a) = f s
		MC.put s'
		return a
	stateAfter g = do
		f <- g
		s <- MC.get
		let (s_, a) = f s
		MC.put s_
		return a
	getBefore g = do
		s <- MC.get
		f <- g
		return (f s)
	getAfter g = do
		f <- g
		s <- MC.get
		return (f s)
	put g = do
		(s, a) <- g
		MC.put s
		return a

--
-- Sym instances
--
instance (ParsecC e s, Show err) => Sym.Gram_Error err (P.ParsecT e s m) where
	catch me = do
		e <- me
		case e of
		 Left err -> fail $ show err
		 Right a -> return a
newtype NoShow a = NoShow a
instance Show (NoShow a) where show _ = "NoShow"
instance ParsecC e s => Sym.Gram_Rule (P.ParsecT e s m) where
	rule = P.label . Text.unpack
	{-
	rule n g = do
		NoShow a <- P.dbg (Text.unpack n) $ NoShow <$> g
		return a
	-}
instance ParsecC e s => Sym.Gram_Terminal (P.ParsecT e s m) where
	any          = P.anyChar
	eoi          = P.eof
	char         = P.char
	string       = P.string
	unicat cat   = P.satisfy $ (`elem` cats) . Char.generalCategory
		where cats = unicode_categories cat
	range (l, h) = P.satisfy $ \c -> l <= c && c <= h
	Terminal f `but` Terminal p = Terminal $ P.notFollowedBy (P.try p) *> f
instance ParsecC e s => Sym.Gram_Alt (P.ParsecT e s m) where
	empty  = Alt.empty
	(<+>)  = (Alt.<|>)
	choice = P.choice
instance ParsecC e s => Sym.Gram_Try (P.ParsecT e s m) where
	try = P.try
instance ParsecC e s => Sym.Gram_RegR (P.ParsecT e s m) where
	Terminal f .*> Reg x = Reg $ f <*> x
instance ParsecC e s => Sym.Gram_RegL (P.ParsecT e s m) where
	Reg f <*. Terminal x = Reg $ f <*> x
instance ParsecC e s => Sym.Gram_App (P.ParsecT e s m) where
	between = P.between
instance ParsecC e s => Sym.Gram_AltApp (P.ParsecT e s m) where
	option   = P.option
	optional = P.optional
	many     = P.many
	some     = P.some
	manySkip = P.skipMany
instance ParsecC e s => Sym.Gram_CF (P.ParsecT e s m) where
	CF f <& Reg p        = CF $ P.lookAhead f <*> p
	Reg f &> CF p        = CF $ P.lookAhead f <*> p
	minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
instance ParsecC e s => Sym.Gram_Comment (P.ParsecT e s m)
instance ParsecC e s => Sym.Gram_Op (P.ParsecT e s m)
instance ParsecC e s => Sym.Gram_Mod (P.ParsecT e s m)
instance ParsecC e s => Sym.Gram_Type_Name (P.ParsecT e s m)
instance ParsecC e s => Sym.Gram_Term_Name (P.ParsecT e s m)
instance -- Sym.Gram_Type
 ( ParsecC e s
 , Show src
 , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src)  (P.ParsecT e s m)
 , Gram_Source src      (P.ParsecT e s m)
 ) => Sym.Gram_Type src (P.ParsecT e s m)
instance -- Sym.Gram_Term_Type
 ( ParsecC e s
 , Show src
 , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src)  (P.ParsecT e s m)
 , Gram_Source src           (P.ParsecT e s m)
 ) => Sym.Gram_Term_Type src (P.ParsecT e s m)
instance -- Sym.Gram_Term
 ( ParsecC e s
 , Show src
 , MC.MonadState (Sym.Imports Sym.NameTe, Sym.Modules src ss) (P.ParsecT e s m)
 , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src)  (P.ParsecT e s m)
 , Gram_Source src            (P.ParsecT e s m)
 , Sym.Gram_Term_Atoms src ss (P.ParsecT e s m)
 ) => Sym.Gram_Term src ss    (P.ParsecT e s m)

--
-- LCC instances
--
instance ParsecC e s => LCC.Gram_Count   (P.ParsecT e s m)
instance ParsecC e s => LCC.Gram_Char    (P.ParsecT e s m)
instance ParsecC e s => LCC.Gram_Comment (P.ParsecT e s m)
instance ParsecC e s => LCC.Gram_Tag     (P.ParsecT e s m)
instance ParsecC e s => LCC.Gram_Account (P.ParsecT e s m)
instance ParsecC e s => LCC.Gram_Amount  (P.ParsecT e s m)
instance ParsecC e s => LCC.Gram_File    (P.ParsecT e s m)
instance -- LCC.Gram_Date
 ( ParsecC e s
 , MC.MonadState Year (P.ParsecT e s m)
 ) => Gram_Date       (P.ParsecT e s m)
instance -- LCC.Gram_Posting
 ( ParsecC e s
 , MC.MonadState Chart          (P.ParsecT e s m)
 , MC.MonadState Style_Amounts  (P.ParsecT e s m)
 , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
 ) => Gram_Posting              (P.ParsecT e s m)
instance -- LCC.Gram_Transaction
 ( ParsecC e s
 , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
 , MC.MonadState Chart          (P.ParsecT e s m)
 , MC.MonadState Section        (P.ParsecT e s m)
 , MC.MonadState Style_Amounts  (P.ParsecT e s m)
 , MC.MonadState Year           (P.ParsecT e s m)
 ) => Gram_Transaction          (P.ParsecT e s m)
instance -- LCC.Gram_Chart
 ( ParsecC e s
 , MC.MonadState Chart          (P.ParsecT e s m)
 , MC.MonadState Section        (P.ParsecT e s m)
 ) => Gram_Chart                (P.ParsecT e s m)
instance -- LCC.Gram_Path
 ( ParsecC e s
 , MonadIO m
 ) => Gram_Path                 (P.ParsecT e s m) where
	g_canonfile g = do
		pf@(PathFile fp) <- g
		liftIO $ (pf,) <$> Exn.catch
		 (Right . CanonFile . PathFile <$> IO.canonicalizePath fp)
		 (return . Left)
instance -- LCC.Gram_IO
 ( ParsecC e s
 , MonadIO m
 , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
 , MC.MonadState Chart          (P.ParsecT e s m)
 , MC.MonadState Style_Amounts  (P.ParsecT e s m)
 , MC.MonadState Year           (P.ParsecT e s m)
 , Gram_Source src              (P.ParsecT e s m)
 , P.MonadParsec e Text         (P.ParsecT e s m)
 ) => Gram_IO src               (P.ParsecT e s m) where
	g_read g_path g = do
		lr <- source $ do
			lr_path <- g_path
			case lr_path of
			 S.Left (e::Error_Compta src) ->
				return $ \(src::src) ->
					S.Left $ At src e
			 S.Right (PathFile fp) ->
				liftIO $ Exn.catch
				 ((\inp _src -> S.Right $ (fp,) $ Enc.decodeUtf8 inp) <$> BS.readFile fp)
				 (\exn -> return $ \src -> S.Left $ At src $ Error_Compta_Read (PathFile fp) exn)
		case lr of
		 S.Left e -> return $ S.Left [e]
		 S.Right (fp_new, s_new) -> do
			P.pushPosition $ P.initialPos fp_new
			s_old <- P.getInput; P.setInput s_new
			
			lr_a <- g
				{-
				P.observing g >>= \case
				 Left err -> do
					MC.put jf_old
					P.setInput s_old
					P.popPosition
					P.updateParserState (\st -> st{P.statePos=P.errorPos $ trace ("ERROR: " <> show err) err})
					P.failure
					 (P.errorUnexpected err)
					 (P.errorExpected err)
					 (P.errorCustom err)
				 Right a -> return a
				-}
			
			P.setInput s_old
			P.popPosition
			
			return lr_a
instance -- LCC.Gram_Compta
 ( ParsecC e s
 , MonadIO m
 -- , MC.MonadState (Sym.Imports Sym.NameTe, Sym.Modules src ss) m
 -- , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src) m
 , MC.MonadState (Terms src) m
 , Gram_Input (P.ParsecT e s m)
 -- , Monoid j
 -- , Show j
 -- , Show src
 -- , SourceInj (NonEmpty SourcePos) src
 -- , SourceInj (Sym.AST_Type src) src
 -- , SourceInj (Sym.KindK    src) src
 -- , SourceInj (Sym.TypeVT   src) src
 , P.MonadParsec e Text                                (P.ParsecT e s m)
 , Gram_Source src                                     (P.ParsecT e s m)
 -- , Sym.Gram_Term_Atoms src ss                          (P.ParsecT e s m)
 , MC.MonadReader (S.Either Exn.IOException CanonFile) (P.ParsecT e s m)
 , MC.MonadState (Context_Read src)                    (P.ParsecT e s m)
 , MC.MonadState (S.Maybe Unit)                        (P.ParsecT e s m)
 , MC.MonadState Chart                                 (P.ParsecT e s m)
 , MC.MonadState Section                               (P.ParsecT e s m)
 , MC.MonadState Style_Amounts                         (P.ParsecT e s m)
 , MC.MonadState Year                                  (P.ParsecT e s m)
 ) => Gram_Compta {-ss-} src (P.ParsecT e s m)
instance -- LCC.Gram_Term_Def
 ( ParsecC e s
 -- , MC.MonadState (Env src ss) m
 -- , MC.MonadState (Sym.Imports Sym.NameTe, Sym.Modules src ss) m
 -- , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src) m
 , Monad m
 -- , Show src
 -- , SourceInj (Sym.AST_Type src) src
 -- , SourceInj (Sym.KindK    src) src
 -- , SourceInj (Sym.TypeVT   src) src
 -- , Gram_Source src            (P.ParsecT e s m)
 , P.MonadParsec e Text       (P.ParsecT e s m)
 -- , Sym.Gram_Term_Atoms src ss (P.ParsecT e s m)
 ) => LCC.Gram_Term_Def src {-ss-}    (P.ParsecT e s m)

instance ParsecC e Text => Gram_Input (P.ParsecT e Text m) where
	g_input g = do
		P.State {P.stateInput=ib, P.statePos=P.SourcePos _ lb bc:|_} <- P.getParserState
		f <- g
		P.State {P.statePos=P.SourcePos _ le ce:|_} <- P.getParserState
		return $ f $ (`Text.take` ib) $ sizeInput 0 ib
		 (P.unPos le - P.unPos lb)
		 (if lb == le then P.unPos ce - P.unPos bc else pred (P.unPos ce))
		where
		sizeInput :: Int -> Text -> Word -> Word -> Int
		sizeInput s _i 0 0 = s
		sizeInput s i 0 c =
			case Text.uncons i of
			 Nothing -> error "[BUG] sizeInput"
			 Just (_c, i') -> sizeInput (succ s) i' 0 (pred c)
		sizeInput s i l c =
			case Text.uncons i of
			 Nothing -> error "[BUG] sizeInput"
			 Just ('\n', i') -> sizeInput (succ s) i' (pred l) c
			 Just (_c, i')   -> sizeInput (succ s) i' l c

-- syntaxError :: P.ParseError Char P.Dec -> Text
-- syntaxError 

parseErrorPretty ::
 ( Ord t
 , P.ShowToken t
 , P.ShowErrorComponent e
 ) => P.ParseError t e -> String
parseErrorPretty e =
	sourcePosStackPretty (P.errorPos e) ++ ":\n"
	 ++ parseErrorTextPretty e

-- | Pretty-print stack of source positions.
sourcePosStackPretty :: NonEmpty P.SourcePos -> String
sourcePosStackPretty ms = concatMap f rest ++ P.sourcePosPretty pos
	where
	(pos :| rest') = ms
	rest           = List.reverse rest'
	f p = "in file included from " ++ P.sourcePosPretty p ++ ",\n"

showParseError ::
 ( Ord t
 , P.ShowToken t
 , P.ShowErrorComponent e
 , D.Doc_Text d
 , D.Doc_Color d
 , D.Doc_Decoration d
 ) => P.ParseError t e -> IO d
showParseError err = do
	let (pos:|_) = P.errorPos err
	q <- write $ sourcePos pos
	return $ D.catV
	 [ D.stringH (sourcePosStackPretty $ P.errorPos err) <> ":"
	 , D.stringH $ parseErrorTextPretty err
	 , q
	 ]

-- | Transforms list of error messages into their textual representation.
messageItemsPretty :: P.ShowErrorComponent a => String -> Set a -> String
messageItemsPretty prefix ts
 | Set.null ts = ""
 | otherwise = prefix ++ f ts ++ "\n"
	where f = orList . NE.fromList . Set.toAscList . Set.map P.showErrorComponent

orList :: NonEmpty String -> String
orList (x:|[])  = x
orList (x:|[y]) = x ++ " or " ++ y
orList xs       = List.intercalate ", " (NE.init xs) ++ ", or " ++ NE.last xs

-- | Pretty-print textual part of a 'ParseError', that is, everything except
-- stack of source positions. The rendered staring always ends with a new line.
parseErrorTextPretty ::
 ( Ord t
 , P.ShowToken t
 , P.ShowErrorComponent e )
 => P.ParseError t e
 -> String
parseErrorTextPretty (P.ParseError _ us ps xs) =
	if Set.null us && Set.null ps && Set.null xs
	then "unknown parse error\n"
	else concat
	 [ messageItemsPretty "unexpected " us
	 , messageItemsPretty "expecting "  ps
	 , List.unlines (P.showErrorComponent <$> Set.toAscList xs)
	 ]