diff options
author | Kjetil Orbekk <kjetil.orbekk@gmail.com> | 2016-03-08 02:46:06 +0100 |
---|---|---|
committer | Kjetil Orbekk <kjetil.orbekk@gmail.com> | 2016-03-11 05:21:50 +0100 |
commit | 92c9891946646f0f54a19b7699e128571fbdc4b3 (patch) | |
tree | a03963e95f787d083079bc6b41fc7876f68fe560 /src/K/NanoParsec.hs | |
parent | d2729dc9c89f359347fdfe9dcc88cd3a8e258d04 (diff) |
Add simple parser library.
Diffstat (limited to 'src/K/NanoParsec.hs')
-rw-r--r-- | src/K/NanoParsec.hs | 72 |
1 files changed, 72 insertions, 0 deletions
diff --git a/src/K/NanoParsec.hs b/src/K/NanoParsec.hs new file mode 100644 index 0000000..864b79f --- /dev/null +++ b/src/K/NanoParsec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +module K.NanoParsec where + +import qualified Data.Text as T +import Control.Monad (when, MonadPlus(..)) +import Control.Applicative ((<$>), Alternative(..)) +import Control.Lens (_1, (&), (%~)) + +newtype Parser a = Parser { parse :: T.Text -> [(a, T.Text)] } + +runParser :: Parser a -> T.Text -> Either T.Text a +runParser m t = case parse m t of + [(r, t')] -> do + when (not (T.null t')) (consumptionError t') + return r + _ -> Left "Parser error." + + where consumptionError t = + Left ("Parser did not consume input: " `T.append` t) + +bind :: Parser a -> (a -> Parser b) -> Parser b +bind p f = Parser $ \t -> (concat . fmap fp) (parse p t) + where fp (x, t') = parse (f x) t' + +unit :: a -> Parser a +unit x = Parser (\t -> [(x, t)]) + +failure :: Parser a +failure = Parser (const []) + +combine :: Parser a -> Parser a -> Parser a +combine p q = Parser $ \t -> parse p t ++ parse q t + +option :: Parser a -> Parser a -> Parser a +option p q = Parser $ \t -> + case parse p t of + [] -> parse q t + res -> res + +instance Functor Parser where + fmap f p = Parser $ \t -> f' <$> parse p t + where f' (x, t) = (f x, t) + +instance Applicative Parser where + pure = unit + (Parser p1) <*> (Parser p2) = Parser $ \t -> + [(f x, t'') | (f, t') <- p1 t, (x, t'') <- p2 t'] + +instance Monad Parser where + return = unit + (>>=) = bind + +instance Alternative Parser where + empty = mzero + (<|>) = option + +instance MonadPlus Parser where + mzero = failure + mplus = combine + +item :: Parser Char +item = Parser $ \t -> case T.uncons t of + Nothing -> [] + Just (c, t) -> [(c, t)] + +satisfy :: (Char -> Bool) -> Parser Char +satisfy p = do + c <- item + if p c + then unit c + else failure |