module Language.Noodle.Parsing.Generic where
data Result st tok res
= Success res st [tok]
| Failure String st
instance (Show st, Show tok, Show res) => Show (Result st tok res) where
show (Success res st toks) = "Ok: " ++ show res ++ show st ++ show toks
show (Failure msg st) = "Error: " ++ msg ++ "\n" ++ "state dump: " ++ show st
newtype GParser st tok res = P ((st,[tok]) -> Result st tok res)
instance Monad (GParser s t) where
return value = P (\(state,tokens) -> Success value state tokens)
fail message = P (\(state,_) -> Failure message state)
(>>=) (P f) cont = P body where
body (state,tokens)
= let first = f (state,tokens)
in case first of
(Failure msg fstate) -> Failure msg fstate
(Success result sstate stokens) -> appcont result sstate stokens
appcont result state tokens
= let (P rest) = cont result in rest (state,tokens)
getTok :: GParser st tok tok
getTok = P body
where body (state,c:cs) = Success c state cs
body (fstate,[]) = Failure "unexpected end of input" fstate
lookToks :: GParser st tok [tok]
lookToks = P body
where body (state,cs) = Success cs state cs
getTokIf :: (tok -> Bool) -> GParser st tok tok
getTokIf pred
= do tok <- getTok
case pred tok of
True -> return tok
False -> fail "unexpected token"
inputEnd :: GParser st tok ()
inputEnd = do rest <- lookToks
case rest of
[] -> return ()
_ -> fail "expected end of input"
getSt :: GParser st tok st
getSt = P body where
body (state,tokens) = Success state state tokens
putSt :: st -> GParser st tok ()
putSt st = P body where
body (_,cs) = Success () st cs
modSt :: (st -> st) -> GParser st tok ()
modSt f = do st <- getSt
putSt $ f st
many :: GParser st tok res -> GParser st tok [res]
many p = many1 p <|> return []
many1 :: GParser st tok res -> GParser st tok [res]
many1 p = do first <- p
rest <- many p
return (first:rest)
sepBy1 :: GParser st tok res -> GParser st tok b -> GParser st tok [res]
sepBy1 p sep =
do first <- p
rest <- many (sep >> p)
return (first:rest)
sepBy :: GParser st tok res -> GParser st tok b -> GParser st tok [res]
sepBy p sep = do v <- pMaybe $ sepBy1 p sep
case v of
Just v' -> return v'
Nothing -> return []
(<|>) :: GParser st tok res -> GParser st tok res -> GParser st tok res
(P p) <|> other = P body where
body input = case p input of
Failure m st -> let (P next) = other in next input
success -> success
choice :: [GParser st tok res] -> GParser st tok res
choice [] = error "violation of invariant: 'choice []' has undefined behavior"
choice [p] = p
choice (p:ps) = p <|> choice ps
pMaybe :: GParser st tok res -> GParser st tok (Maybe res)
pMaybe p = pJust <|> return Nothing where
pJust = do v <- p
return $ Just v
pEither :: GParser st tok a -> GParser st tok b -> GParser st tok (Either a b)
pEither p1 p2 =
do v <- pMaybe p1
case v of
Just a -> return $ Left a
Nothing ->
do v <- p2
return $ Right v
runp :: GParser st tok res -> st -> [tok] -> Result st tok res
runp (P parser) state toks = parser (state,toks)