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

import Control.Applicative (Applicative(..))
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 (String, IsString)
import Data.Tuple (snd)
import System.FilePath (FilePath)
import Text.Show (Show)
import qualified Data.Set as Set
import qualified Data.Text.Lazy as TL
import qualified Text.Megaparsec as P

import Language.TCT.Cell

-- * Type 'Parser'
-- | Convenient alias.
type Parser   e s a =
     Parsable e s a =>
     P.Parsec e s 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 = (<$> P.getPosition) $ \p ->
	Pos
	 { pos_line   = P.unPos $ P.sourceLine p
	 , pos_column = P.unPos $ P.sourceColumn p
	 }

p_Cell :: Parser e s a -> Parser e s (Cell a)
p_Cell pa =
	(\b a e -> Cell b e a)
	 <$> p_Position
	 <*> pa
	 <*> p_Position

p_LineNum :: Parser e s LineNum
p_LineNum = P.unPos . P.sourceLine <$> P.getPosition

p_ColNum :: Parser e s ColNum
p_ColNum = P.unPos . P.sourceColumn <$> P.getPosition

-- | Wrapper around |P.runParser'|
-- to use given 'Cell' as starting position.
runParserOnCell ::
 Parsable e StreamCell a =>
 FilePath ->
 Parser e StreamCell a ->
 Cell TL.Text ->
 Either (P.ParseError (P.Token StreamCell) e) a
runParserOnCell inp p (Cell bp _ep s) =
	snd $ P.runParser' (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)


-- * Debug
pdbg :: Show a => String -> Parser e s a -> Parser e s a
pdbg = P.dbg
-- pdbg _m p = p
{-# INLINE pdbg #-}