summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKjetil Orbekk <kjetil.orbekk@gmail.com>2016-03-08 02:46:06 +0100
committerKjetil Orbekk <kjetil.orbekk@gmail.com>2016-03-11 05:21:50 +0100
commit92c9891946646f0f54a19b7699e128571fbdc4b3 (patch)
treea03963e95f787d083079bc6b41fc7876f68fe560
parentd2729dc9c89f359347fdfe9dcc88cd3a8e258d04 (diff)
Add simple parser library.
-rw-r--r--fun.cabal6
-rw-r--r--src/K/NanoParsec.hs72
-rw-r--r--test/Spec.hs24
3 files changed, 94 insertions, 8 deletions
diff --git a/fun.cabal b/fun.cabal
index 4112596..e9eb3c1 100644
--- a/fun.cabal
+++ b/fun.cabal
@@ -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)