From 92c9891946646f0f54a19b7699e128571fbdc4b3 Mon Sep 17 00:00:00 2001
From: Kjetil Orbekk <kjetil.orbekk@gmail.com>
Date: Tue, 8 Mar 2016 02:46:06 +0100
Subject: Add simple parser library.

---
 fun.cabal           |  6 +++++
 src/K/NanoParsec.hs | 72 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 test/Spec.hs        | 24 ++++++++++++------
 3 files changed, 94 insertions(+), 8 deletions(-)
 create mode 100644 src/K/NanoParsec.hs

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)
-- 
cgit v1.2.3