diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x index c236b77fa..d1550dd09 100644 --- a/src/compiler/GF/Grammar/Lexer.x +++ b/src/compiler/GF/Grammar/Lexer.x @@ -2,7 +2,7 @@ { module GF.Grammar.Lexer ( Token(..), Posn(..) - , P, runP, lexer, getPosn, failLoc + , P, runP, runPartial, token, lexer, getPosn, failLoc , isReservedWord ) where @@ -51,7 +51,6 @@ unpack = UTF8.toString ident = res T_Ident . identC . rawIdentC ---tok :: (String->Token) -> Posn -> String -> Token tok f p s = f s data Token @@ -239,6 +238,7 @@ unescapeInitTail = unesc . tail where data Posn = Pn {-# UNPACK #-} !Int {-# UNPACK #-} !Int + deriving (Eq,Show) alexMove :: Posn -> Char -> Posn alexMove (Pn l c) '\n' = Pn (l+1) 1 @@ -250,22 +250,25 @@ alexGetByte (AI p _ s) = Nothing -> Nothing Just (w,s) -> let p' = alexMove p c - c = BS.w2c w + c = BS.w2c w in p' `seq` Just (w, (AI p' c s)) - +{- +-- Not used by this lexer: alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (AI p c s) = c - +-} data AlexInput = AI {-# UNPACK #-} !Posn -- current position, {-# UNPACK #-} !Char -- previous char {-# UNPACK #-} !BS.ByteString -- current input string +type AlexInput2 = (AlexInput,AlexInput) + data ParseResult a - = POk a + = POk AlexInput2 a | PFailed Posn -- The position of the error String -- The error message -newtype P a = P { unP :: AlexInput -> ParseResult a } +newtype P a = P { unP :: AlexInput2 -> ParseResult a } instance Functor P where fmap = liftA @@ -275,33 +278,43 @@ instance Applicative P where (<*>) = ap instance Monad P where - return a = a `seq` (P $ \s -> POk a) + return a = a `seq` (P $ \s -> POk s a) (P m) >>= k = P $ \ s -> case m s of - POk a -> unP (k a) s + POk s a -> unP (k a) s PFailed posn err -> PFailed posn err - fail msg = P $ \(AI posn _ _) -> PFailed posn msg + fail msg = P $ \(_,AI posn _ _) -> PFailed posn msg runP :: P a -> BS.ByteString -> Either (Posn,String) a -runP (P f) txt = - case f (AI (Pn 1 0) ' ' txt) of - POk x -> Right x +runP p bs = snd <$> runP' p (Pn 1 0,bs) + +runPartial p s = conv <$> runP' p (Pn 1 0,UTF8.fromString s) + where conv ((pos,rest),x) = (UTF8.toString rest,x) + +runP' (P f) (pos,txt) = + case f (dup (AI pos ' ' txt)) of + POk (AI pos _ rest,_) x -> Right ((pos,rest),x) PFailed pos msg -> Left (pos,msg) +dup x = (x,x) + failLoc :: Posn -> String -> P a failLoc pos msg = P $ \_ -> PFailed pos msg lexer :: (Token -> P a) -> P a -lexer cont = P go +lexer cont = cont=< unP (cont T_EOF) inp + AlexEOF -> POk (inp,inp) T_EOF AlexError (AI pos _ _) -> PFailed pos "lexical error" - AlexSkip inp' len -> {-trace (show len) $-} go inp' - AlexToken inp' len act -> unP (cont (act pos ({-UTF8.toString-} (UTF8.take len str)))) inp' + AlexSkip inp' len -> {-trace (show len) $-} go (inp,inp') + AlexToken inp' len act -> POk (inp,inp') (act pos ({-UTF8.toString-} (UTF8.take len str))) getPosn :: P Posn -getPosn = P $ \inp@(AI pos _ _) -> POk pos +getPosn = P $ \ai2@(_,inp@(AI pos _ _)) -> POk ai2 pos } diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y index 9f2e7c95a..9377bd7d5 100644 --- a/src/compiler/GF/Grammar/Parser.y +++ b/src/compiler/GF/Grammar/Parser.y @@ -2,9 +2,10 @@ { {-# OPTIONS -fno-warn-overlapping-patterns #-} module GF.Grammar.Parser - ( P, runP + ( P, runP, runPartial , pModDef , pModHeader + , pTerm , pExp , pTopDef , pBNFCRules @@ -30,6 +31,7 @@ import PGF(mkCId) %name pModDef ModDef %name pTopDef TopDef %partial pModHeader ModHeader +%partial pTerm Exp1 %name pExp Exp %name pBNFCRules ListCFRule %name pEBNFRules ListEBNFRule