parse terms

This commit is contained in:
Stefan Bühler 2011-06-18 13:15:49 +02:00
parent 9e220ea366
commit e9b17b8ab2
1 changed files with 43 additions and 0 deletions

View File

@ -4,8 +4,51 @@ module Lambda where
import Eval import Eval
import System.IO 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 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 cI = Prim Card_I
cGet n = Apply (Prim Card_Get) (Const n) cGet n = Apply (Prim Card_Get) (Const n)
cPut = Prim Card_Put cPut = Prim Card_Put