module Text.GRead (
module Text.GRead.Grammar,
gread,
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 GReadMsg = Message Token (Maybe Token)
data GReadResult a = Ok a
| Rep a [GReadMsg]
deriving Show
gread :: (Gram a) => String -> GReadResult a
gread = ( parse . compile
. leftfactoring . leftcorner
. group ) grammar
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 :: 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 == '('