From e9b17b8ab257157f11d9548e20d55eb3472a083a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Stefan=20B=C3=BChler?= <stbuehler@web.de>
Date: Sat, 18 Jun 2011 13:15:49 +0200
Subject: [PATCH] parse terms

---
 Lambda.hs | 43 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 43 insertions(+)

diff --git a/Lambda.hs b/Lambda.hs
index ea6ee84..f1653d7 100644
--- a/Lambda.hs
+++ b/Lambda.hs
@@ -4,8 +4,51 @@ module Lambda where
 import Eval
 import System.IO
 
+import Text.ParserCombinators.ReadP
+import Data.Char
+import Control.Monad
+
 data Term = Const Int | Prim Card | Seq Term Term | Apply Term Term
 
+cardNamesX = map (\(a,b) -> (b,a)) cardNames
+
+ptConst :: ReadP Term
+ptConst = readS_to_P reads >>= return . Const
+ptPrim = do
+	c <- satisfy isAlpha
+	s' <- many (satisfy isAlpha)
+	let s = c:s'
+	case lookup s cardNamesX of
+		Just c -> return $ Prim c
+		Nothing -> pfail
+ptGroup = do
+	char '('
+	t <- ptTerm
+	skipSpaces; char ')'
+	return t
+ptEnd = eof <++ do
+	c:_ <- look
+	when (isAlphaNum c || c == ';' || c == '(') pfail
+ptApply f = do
+	skipSpaces
+	(ptEnd >> return f) <++
+		(char ';' >> ptTerm >>= \g -> return $ Seq f g) <++
+		(ptTerm1 >>= \x -> ptApply (Apply f x))
+ptTerm1 = skipSpaces >> (ptConst <++ ptPrim <++ ptGroup)
+
+ptTerm = ptTerm1 >>= ptApply
+
+instance Show Term where
+	show (Const i) = show i
+	show (Prim c) = show c
+	show (Seq f g) = show f ++ ";" ++ show g
+	show (Apply f (Const i)) = show f ++ " " ++ show i
+	show (Apply f (Prim c)) = show f ++ " " ++ show c
+	show (Apply f x) = show f ++ "(" ++ show x ++ ")"
+
+instance Read Term where
+	readsPrec _ = readP_to_S ptTerm
+
 cI = Prim Card_I
 cGet n = Apply (Prim Card_Get) (Const n)
 cPut = Prim Card_Put