{-# LANGUAGE TypeFamilies #-}
module Language.TCT.Read
 ( module Language.TCT.Read.Tree
 , module Language.TCT.Read.Token
 , module Language.TCT.Read
 ) where

import Control.Applicative (Applicative(..))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.Traversable (Traversable(..))
import Data.Tuple (fst, snd)
import Prelude (fromIntegral)
import System.IO (FilePath)
import qualified Text.Megaparsec as P
import Text.Show (Show(..))

import Language.TCT.Tree
import Language.TCT.Token
import Language.TCT.Read.Tree
import Language.TCT.Read.Token

import Debug.Trace (trace)

readTreeCell ::
 FilePath -> Text ->
 Either (P.ParseError (P.Token Text) P.Dec)
        (Trees (Cell Key) (Cell Tokens))
readTreeCell inp txt = do
	tct <- P.runParser (p_Trees <* P.eof) inp txt
	(`traverse` tct) {- $ (<$> trace (show $ PrettyTree tct) tct)-} $ \tr ->
		sequence $ (`mapTreeWithKey`tr) $ \key (Cell pos posEnd t) ->
			case key of
			 -- Verbatim Keys
			 Just (unCell -> KeyBar{})   -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
			 Just (unCell -> KeyLower{}) -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
			 Just (unCell -> KeyEqual{}) -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
			 -- Token Keys
			 _ ->
				Cell pos posEnd <$>
					P.runParser (do
						P.setTabWidth $ P.unsafePos $ fromIntegral $ columnPos pos
						P.setPosition $ P.SourcePos inp
						 (P.unsafePos $ fromIntegral $ linePos   pos)
						 (P.unsafePos $ fromIntegral $ columnPos pos)
						p_Tokens <* P.eof
					 ) inp (StreamCell t)

readTree ::
 FilePath -> Text ->
 Either (P.ParseError (P.Token Text) P.Dec)
        (Trees Key Tokens)
readTree inp txt = do
	tct <- P.runParser (p_Trees <* P.eof) inp txt
	(`traverse` tct) $ \tr ->
		sequence $ (\f -> mapTreeKey unCell f tr) $ \key (Cell pos _posEnd t) ->
			case unCell <$> key of
			 -- Verbatim Keys
			 Just KeyBar{}   -> Right $ tokens [TokenPlain t]
			 Just KeyLower{} -> Right $ tokens [TokenPlain t]
			 Just KeyEqual{} -> Right $ tokens [TokenPlain t]
			 -- Token Keys
			 _ ->
				P.runParser (do
					P.setTabWidth $ P.unsafePos $ fromIntegral $ columnPos pos
					P.setPosition $ P.SourcePos inp
					 (P.unsafePos $ fromIntegral $ linePos   pos)
					 (P.unsafePos $ fromIntegral $ columnPos pos)
					p_Tokens <* P.eof
				 ) inp (StreamCell t)

-- * Type 'StreamCell'
-- | Wrap 'Text' to have a 'P.Stream' instance
-- whose 'P.updatePos' 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 Text
instance P.Stream StreamCell where
	type Token StreamCell = Char
	uncons (StreamCell t) = (StreamCell <$>) <$> P.uncons t
	updatePos _s indent apos@(P.SourcePos n l c) ch = (apos, npos)
		where
		u = P.unsafePos 1
		npos =
			case ch of
			 '\n' -> P.SourcePos n (l <> u) indent
			 _    -> P.SourcePos n l (c <> u)