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 | |
parent | d2729dc9c89f359347fdfe9dcc88cd3a8e258d04 (diff) |
Add simple parser library.
-rw-r--r-- | fun.cabal | 6 | ||||
-rw-r--r-- | src/K/NanoParsec.hs | 72 | ||||
-rw-r--r-- | test/Spec.hs | 24 |
3 files changed, 94 insertions, 8 deletions
@@ -16,7 +16,10 @@ cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Lib + , K.NanoParsec build-depends: base >= 4.7 && < 5 + , text + , lens default-language: Haskell2010 executable fun-exe @@ -33,9 +36,12 @@ test-suite fun-test main-is: Spec.hs build-depends: base , fun + , text + , lens , test-framework , test-framework-quickcheck2 , QuickCheck + , quickcheck-text ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 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 diff --git a/test/Spec.hs b/test/Spec.hs index 0f46756..612fea6 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,19 +2,27 @@ import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck +import K.NanoParsec + +import qualified Data.Text as T +import Data.Text.Arbitrary (Text(..)) main :: IO () main = defaultMain tests tests = [ - testGroup "Sorting Group 1" [ - testProperty "prop1" prop1, - testProperty "prop2" prop2 - ] + testGroup "Parsing" [ + testProperty "empty" prop_empty, + testProperty "correct_item" prop_correct, + testProperty "tooLong_item" prop_tooLong + ] ] -prop1 b = b == False - where types = (b :: Bool) +isRight (Right _) = True +isRight _ = False + +isLeft = not . isRight -prop2 i = i == 42 - where types = (i :: Int) +prop_empty t = T.null t ==> isLeft (runParser item t) +prop_correct t = T.length t == 1 ==> isRight (runParser item t) +prop_tooLong t = T.length t > 1 ==> isLeft (runParser item t) |