From: Tomáš Musil <tomik.musil@gmail.com>
Date: Tue, 30 Dec 2014 00:26:29 +0000 (+0100)
Subject: simple parser
X-Git-Url: http://git.tomasm.cz/fp.git/commitdiff_plain/dbb3af7ea8341e87b254dc94a613aec837b676b8

simple parser
---

diff --git a/fp.cabal b/fp.cabal
index 363a35c..018b0d6 100644
--- a/fp.cabal
+++ b/fp.cabal
@@ -18,6 +18,7 @@ cabal-version:       >=1.10
 library 
   exposed-modules: Lambda
                    Lambda.Parser.Fancy
+                   Lambda.Parser.Simple
   other-modules:   Lambda.Term
   build-depends:       base >=4.7 && <4.8
                      , text >=1.2 && <1.3
diff --git a/src/Lambda/Parser/Fancy.hs b/src/Lambda/Parser/Fancy.hs
index b0f0c2d..10231b8 100644
--- a/src/Lambda/Parser/Fancy.hs
+++ b/src/Lambda/Parser/Fancy.hs
@@ -1,7 +1,4 @@
-{-# OPTIONS_GHC
-    -fno-warn-unused-do-bind
-    -fno-warn-orphans
-#-}
+{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-orphans #-}
 {-# LANGUAGE PatternSynonyms #-}
 
 -- |
diff --git a/src/Lambda/Parser/Simple.hs b/src/Lambda/Parser/Simple.hs
new file mode 100644
index 0000000..7c60639
--- /dev/null
+++ b/src/Lambda/Parser/Simple.hs
@@ -0,0 +1,73 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind -fno-warn-orphans #-}
+
+-- |
+-- Module      :  Lambda.Parser.Simple
+-- Copyright   :  Tomáš Musil 2014
+-- License     :  BSD-3
+--
+-- Maintainer  :  tomik.musil@gmail.com
+-- Stability   :  experimental
+--
+-- Simple parser for λ-terms. Corresponds to the recursive λ-term definition. Application is always in brackets, nothing else is.
+
+
+module Lambda.Parser.Simple
+  ( tRead
+  , parseTerm
+  )  where
+
+import Data.Text as T
+import Data.Attoparsec.Text
+import Control.Applicative
+
+import Lambda.Term
+
+-- $setup
+-- >>> import Test.QuickCheck
+-- >>> import Test.Term hiding (tRead, parseTerm)
+
+-- | 
+-- >>> tShow $ Lambda "x" (Var "x")
+-- "\\x.x"
+-- >>> tShow $ App (Var "x") (Var "y")
+-- "(x y)"
+
+tShow :: Term -> String
+tShow (Var x) = x
+tShow (Lambda x t) = "\\" ++ x ++ "." ++ tShow t
+tShow (App t r) = "(" ++ tShow t ++ " " ++ tShow r ++ ")"
+
+-- |
+-- prop> t == tRead (tShow t)
+
+tRead :: String -> Term
+tRead s = case parseOnly (parseTerm <* endOfInput) (T.pack s) of
+    (Right t) -> t
+    (Left e) -> error e
+
+parseVar :: Parser Term
+parseVar = do
+  x <- many1 letter
+  return $! Var x
+
+parseLambda :: Parser Term
+parseLambda = do
+  char '\\'
+  (Var x) <- parseVar
+  char '.'
+  t <- parseTerm
+  return $! Lambda x t
+
+parseApp :: Parser Term
+parseApp = do
+  char '('
+  t <- parseTerm
+  char ' '
+  r <- parseTerm
+  char ')'
+  return $! App t r
+
+parseTerm :: Parser Term
+parseTerm = parseVar <|> parseLambda <|> parseApp
+
+
diff --git a/tests/doctest.hs b/tests/doctest.hs
index 258b4dd..3f60e6d 100644
--- a/tests/doctest.hs
+++ b/tests/doctest.hs
@@ -1,4 +1,6 @@
 import Test.DocTest
 
 main :: IO ()
-main = doctest ["-isrc", "src/Main.hs", "tests/Test/Term.hs"]
+main = do
+  doctest ["-isrc", "src/Main.hs", "tests/Test/Term.hs"]
+  doctest ["-isrc", "src/Lambda/Parser/Simple.hs", "tests/Test/Term.hs"]