{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
module Hdoc.TCT.Read.Cell where

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq)
import Data.Function (($))
import Data.Functor ((<$>))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord)
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString)
import Data.Tuple (snd)
import qualified Control.Monad.Trans.Reader as R
import qualified Data.Set as Set
import qualified Data.Text.Lazy as TL
import qualified Text.Megaparsec as P

import Hdoc.TCT.Cell

-- * Type 'Parser'
-- | Convenient alias.
type Parser   e s a =
     Parsable e s a =>
     P.ParsecT e s (R.Reader [Span]) a

-- ** Type 'Parsable'
type Parsable e s a =
 ( P.Stream s
 , P.Token s ~ Char
 , Ord e
 , IsString (P.Tokens s)
 , P.ShowErrorComponent e
 )

-- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
p_satisfyMaybe f = check `P.token` Nothing
	where
	check c =
		case f c of
		 Just a  -> Right a
		 Nothing -> Left (Just $ P.Tokens $ c:|[], Set.empty)

p_Position :: Parser e s Pos
p_Position = do
	pos :| _  <- P.statePos <$> P.getParserState
	return $ Pos (P.unPos $ P.sourceLine pos) (P.unPos $ P.sourceColumn pos)

p_Cell :: Parser e s a -> Parser e s (Cell a)
p_Cell pa = do
	path <- lift R.ask
	b :| _ <- P.statePos <$> P.getParserState
	a <- pa
	span_end <- p_Position
	let span_begin = Pos (P.unPos $ P.sourceLine b) (P.unPos $ P.sourceColumn b)
	let span = Span {span_file=P.sourceName b, span_begin, span_end}
	return $ Cell (span:|path) a

-- | Wrapper around |P.runParserT'|
-- to use given 'Cell' as starting position.
runParserOnCell ::
 Parsable e StreamCell a =>
 Parser e StreamCell a ->
 Cell TL.Text ->
 Either (P.ParseError (P.Token StreamCell) e) a
runParserOnCell p (Cell (Span inp bp _ep :| path) s) =
	snd $
	(`R.runReader` path) $
	P.runParserT' (p <* P.eof)
	 P.State
	 { P.stateInput    = StreamCell s
	 , P.statePos      = pure $ P.SourcePos inp (P.mkPos $ pos_line bp) indent
	 , P.stateTabWidth = indent
	 , P.stateTokensProcessed = 0
	 }
	where indent = P.mkPos $ pos_column bp

-- * Type 'StreamCell'
-- | Wrap 'TL.Text' to have a 'P.Stream' instance
-- whose 'P.advance1' method abuses the tab width state
-- to instead pass the line indent.
-- This in order to report correct 'P.SourcePos'
-- when parsing a 'Cell' containing newlines.
newtype StreamCell = StreamCell { unStreamCell :: TL.Text }
 deriving (IsString,Eq,Ord)
instance P.Stream StreamCell where
	type Token  StreamCell = Char
	type Tokens StreamCell = TL.Text
	take1_       (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
	takeN_     n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t
	takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t
	tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text)
	chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text)
	chunkLength   _s = P.chunkLength   (Proxy::Proxy TL.Text)
	advance1 _s indent (P.SourcePos n line col) c =
		case c of
		 '\n' -> P.SourcePos n (line <> P.pos1) indent
		 _    -> P.SourcePos n line (col <> P.pos1)
	advanceN s indent = TL.foldl' (P.advance1 s indent)