{-- Time-stamp: <2007-06-12 00:51:17 ejelly> PRIMREK a PRIMREK interpreter by Julien Oster , written in Summer 2007 in the Haskell programming language. Based on the PRIMREK programming language as described in Prof. Dr. Fred Kroeger's summer semester 2007 course "Informatik IV" at Ludwig-Maximilians-Universität, Munich. --} module Primrek where import System import System.IO import Control.Monad.Error import qualified Control.Monad.State as St import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Language import qualified Text.ParserCombinators.Parsec.Token as P {-- Primitive Recursive Function --} data PrimFun = Zero | Projection Int | Successor | Compose PrimFun [PrimFun] | Recurse PrimFun PrimFun deriving (Show, Eq) evalFun :: PrimFun -> [Int] -> Int evalFun (Zero) args = 0 evalFun (Projection i) args = args!!(i - 1) evalFun (Successor) args = (head args) + 1 evalFun (Compose f g) args = evalFun f (map (flip evalFun $ args) g) evalFun f@(Recurse f0 fn1) args = let n1 = last args n = (last args)-1 in if n1 == 0 then evalFun f0 args else evalFun fn1 $ (init args) ++ (n:[(evalFun f $ (init args) ++ [n])]) {- primAdd(x, 0) = x primAdd(x, y+1) = rec + 1 -} primAdd0 = Projection 1 primAdd1 = Compose Successor [(Projection 3)] primAdd = Recurse primAdd0 primAdd1 {-- Compilation --} data LTerm = LZero | Le Int | LSuccessor SourceTerm | LFn Int SourceTerm SourceTerm | LFnApp SourceTerm [SourceTerm] -- Syntactic Sugar: | Lx Int | Ly | Lrec deriving Show type SourceTerm = (SourcePos, LTerm) type CompileMonad = ErrorT String (St.State [Int]) compileL :: SourceTerm -> CompileMonad PrimFun compileL (_, LZero) = return Zero compileL (p, Le i) = do l <- St.get (if i > (head l) then fail $ argumentError 'e' p i l else return $ Projection i) compileL (_, LSuccessor t) = do { f <- compileL t ; return $ Compose Successor [f] } compileL (_, LFnApp (_, LFn l t t') e) = do push l f0 <- compileL t inc fn1 <- compileL t' pop a <- mapM compileL e return $ Compose (Recurse f0 fn1) a where push l = lift $ St.State $ \s -> ((),(l:s)) pop = lift $ St.State $ \(sh:ss) -> (sh, ss) inc = lift $ St.State $ \(sh:ss) -> ((),((sh+1):ss)) compileL (_, LFnApp (p, t) _) = fail $ (compileError p) ++ "'" ++ show t ++ "' at " ++ posString p ++ "is not a function." -- Syntactic Sugar: compileL (p, Lx i) = do l <- St.get (if i > ((head l)-1) then fail $ argumentError 'x' p i l else return $ Projection i) compileL (p, Ly) = do { l <- St.get ; return $ Projection ((head l)-1) } compileL (p, Lrec) = do { l <- St.get ; return $ Projection (head l) } posString p = ("line " ++ (show . sourceLine) p ++ "/col " ++ (show .sourceColumn) p) compileError p = posString p ++ ": " argumentError c p i l = ((compileError p) ++ "use of " ++ [c] ++ show i ++ ", but only " ++ (show . head) l ++ " arguments declared!") {-- Parser --} lexer = P.makeTokenParser (emptyDef { reservedNames = ["fn", "rec"] }) lexeme = P.lexeme lexer whiteSpace = P.whiteSpace lexer decimal = P.decimal lexer reserved = P.reserved lexer operator = P.operator lexer parens = P.parens lexer colon = P.colon lexer comma = P.comma lexer commaSep = P.commaSep lexer program :: CharParser () SourceTerm program = do { whiteSpace ; t <- lTerm ; eof ; return t } lTerm :: CharParser () SourceTerm lTerm = do { p <- getPosition ; (do reserved "fn" l <- parens argTerm colon (try (do t <- lTerm lexeme $ char '|' t' <- lTerm ap <- getPosition e <- parens $ commaSep lTerm return (ap, LFnApp (p, LFn l t t') e)) <|> (do t <- lTerm ap <- getPosition e <- parens $ commaSep lTerm return (ap, LFnApp (p, LFn l t t) e)))) <|> try (do lexeme $ char '1' lexeme $ char '+' t <- lTerm return $ (p, LSuccessor t)) <|> (do char 'e' i <- lexeme decimal return (p, Le $ fromInteger i)) <|> (do lexeme $ char '0' return (p, LZero)) <|> sugar } argTerm :: CharParser () Int argTerm = do is <- commaSep (do { char 'e'; i <- lexeme decimal; return $ fromInteger i }) if is == [1..(length is)] then return (length is) else fail "invalid argument list" sugar :: CharParser () SourceTerm sugar = do { p <- getPosition ; do { n <- lexeme decimal ; return $ sugarN p $ fromInteger n } <|> do { t <- parens lTerm ; return t } <|> do { try(do { char 'x' ; i <- lexeme decimal ; return (p, Lx $ fromInteger i)}) <|> do { lexeme $ char 'x' ; return (p, Lx 1) } } <|> do { lexeme (char 'y') ; return (p, Ly) } <|> do { reserved "rec" ; return (p, Lrec) } } where sugarN p 0 = (p, LZero) sugarN p y = (p, LSuccessor (sugarN p $ y-1)) {-- invocation --} main :: IO () main = do args <- getArgs file <- (if (length args) > 0 then openFile (head args) ReadMode else return stdin) path <- (if (length args) > 0 then return (head args) else return "stdin") content <- hGetContents file t <- return $ runParser program () path content t <- case t of Left error -> do { hPutStr stderr $ "parse error\n" ; hPutStr stderr $ (show error) ++ "\n" ; exitFailure } Right t -> do { return t } f <- return $ St.runState (runErrorT $ compileL t) [0] f <- case f of (Left error, _) -> do { hPutStr stderr $ "compilation error\n" ; hPutStr stderr $ error ++ "\n" ; exitFailure } (Right f, _) -> do { return f } hPrint stdout $ evalFun f [] return () {-- for Testing --} out (Right t) = t eval = runParser program () "" compile = flip (St.runState . runErrorT . compileL . out . eval) run prog args = let n = [length args] in evalFun ((out . fst . (compile n)) prog) args multProg = "fn(e1,e2):0|fn(e1,e2):e1|1+e3(e3,e1)(e1,e2)" multProgS = "fn(e1,e2):0|fn(e1,e2):x|1+rec(rec,x1)(e1,e2)" multProg1 = " fn(e1,e2):0|fn(e1,e2):x|1+rec(rec,x)(3,5)"