{-# OPTIONS  -fglasgow-exts #-}

{-| 
    Alternative approach of 'read' that composes grammars instead 
    of parsers. Grammars describing the data types are composed
    dynamically, removing possible left-recursion and combining
    common prefixes of alternatives.   

    The function 'gread' defined here is able to handle the 
    associativities defined for infix operators.

    The function 'gread' reads data in linear time, while the 
    function 'read' has an exponential behavior in some cases 
    of data types with infix operators.

    Non uniform data types are not supported, because they
    generate infinite grammars.

    The library is documented in the paper: /Haskell, do you read me?: constructing and composing efficient top-down parsers at runtime/

    Bibtex entry: <http://www.cs.uu.nl/wiki/bin/viewfile/Center/TTTAS?rev=1;filename=GRead.bib>

    For more documentation see the TTTAS webpage: <http://www.cs.uu.nl/wiki/bin/view/Center/TTTAS> .
 -}

module Text.GRead ( 
               -- * Grammar Description 
               module Text.GRead.Grammar, 

               -- * Reading Functions
               gread, 

               -- * Types
               GReadMsg, GReadResult(..) 

             ) where

import Language.TTTAS
import Text.GRead.Grammar
import Text.GRead.Transformations.LeftFact
import Text.GRead.Transformations.LeftCorner
import Text.GRead.Transformations.Group
import UU.Parsing hiding (Symbol,parse,Ok)
import qualified UU.Parsing as UU
import List (findIndex)


-- | Type of error repair messages.
type GReadMsg = Message Token (Maybe Token)


-- | Type of 'gread' results.
data GReadResult a = Ok  a
                   | Rep a [GReadMsg] 
      deriving Show


-- | The 'gread' reads input from a string, which must be 
--   completely consumed by the input process.
--   Returns @Ok value@ on a successful parse.
--   Otherwise returns @Rep value msgs@, where the @value@
--   results of parsing a repaired input. The list @msgs@ 
--   contains the \"corrections\" done to the input.
--
--   For example, a 'read'-like implementation can be:
--
-- > read :: (Gram a) => String -> a
-- > read input = case gread input of
-- >                  Ok  a       -> a
-- >                  Rep _ (m:_) -> error $ show m


gread ::  (Gram a) => String -> GReadResult a
gread =   (  parse . compile 
          .  leftfactoring . leftcorner 
          .  group ) grammar



-- COMPILE --------------------------------------------------------------------

newtype Const f a s = C {unC :: f a}

compile :: forall a . Grammar a -> Parser Token a
compile (Grammar (start :: Ref a env) rules) 
                       = unC (lookupEnv start result)
  where  result  =  
          mapEnv 
          (\ (PS ps) -> C (foldr1 (<|>) [ comp p | p <- ps]))
          rules
         comp :: forall t . Prod t env -> Parser Token t
         comp (End x)   = pLow x 
         comp (Seq (Term t) ss) 
                       = (flip ($))  <$> pSym t <*> comp ss 
         comp (Seq (Nont n) ss) 
                       = (flip ($))  <$> unC (lookupEnv n result)
                                     <*> comp ss

mapEnv  ::  (forall a . f a s -> g a s)  
        ->  Env f s env -> Env g s env
mapEnv  _ Empty       = Empty
mapEnv  f (Ext r v)   = Ext (mapEnv f r) (f v)


instance Show Token where
    show (Keyw s) = s
    show Open     = "("
    show Close    = ")"

instance UU.Symbol Token where
  deleteCost _ = 5#


-- PARSE ----------------------------------------------------------------------

parse :: Parser Token a -> String -> GReadResult a
parse p input = case rparse p input of
                  (a,[]  ) -> Ok a
                  (a,msgs) -> Rep a msgs


rparse :: Parser Token a -> String -> (a, [GReadMsg])
rparse p input = let ((Pair a _),msgs) =  eval (UU.parse p (tokenize input))
                 in (a,msgs)
 where eval :: Steps a Token (Maybe Token) -> (a, [GReadMsg])
       eval (OkVal v        r) = let (a,msgs) = v `seq` (eval r) 
                                 in  (v a,msgs)
       eval (UU.Ok          r) = eval r
       eval (Cost  _        r) = eval  r
       eval (StRepair _ msg r) = let (v,msgs) = eval r 
                                 in  (v,msg:msgs)
       eval (Best _   r     _) = eval  r
       eval (NoMoreSteps v   ) = (v,[]) 

       tokenize []       = []
       tokenize ('(':xs) = Open  : (tokenize xs)
       tokenize (')':xs) = Close : (tokenize xs) 
       tokenize (' ':xs) = tokenize xs
       tokenize l        = case findIndex endTok l of
                            Just i -> let (ky,rs) = splitAt i l
                                      in  Keyw ky : (tokenize rs) 
                            Nothing -> [Keyw l] 
       
       endTok t = t == ')' || t == ' ' || t == '('