diff options
author | Kjetil Orbekk <kjetil.orbekk@gmail.com> | 2016-03-11 05:20:55 +0100 |
---|---|---|
committer | Kjetil Orbekk <kjetil.orbekk@gmail.com> | 2016-03-11 05:21:50 +0100 |
commit | bf6f745595570a3ebaad34b8c4a8a8c827e15178 (patch) | |
tree | d7731846dbe42d3bf1e33a56a727904e8abc891b /src | |
parent | 92c9891946646f0f54a19b7699e128571fbdc4b3 (diff) |
Adds support for a very simple language (described by K.Ast).
Diffstat (limited to 'src')
-rw-r--r-- | src/K/Ast.hs | 11 | ||||
-rw-r--r-- | src/K/Eval.hs | 40 | ||||
-rw-r--r-- | src/K/Parsing.hs | 85 | ||||
-rw-r--r-- | src/K/Repl.hs | 22 |
4 files changed, 158 insertions, 0 deletions
diff --git a/src/K/Ast.hs b/src/K/Ast.hs new file mode 100644 index 0000000..56761f5 --- /dev/null +++ b/src/K/Ast.hs @@ -0,0 +1,11 @@ +module K.Ast where + +data Expr + = Tru + | Fals + | Zero + | IsZero Expr + | Succ Expr + | Pred Expr + | If Expr Expr Expr + deriving (Eq, Show) diff --git a/src/K/Eval.hs b/src/K/Eval.hs new file mode 100644 index 0000000..a7ebcba --- /dev/null +++ b/src/K/Eval.hs @@ -0,0 +1,40 @@ +module K.Eval where + +import K.Ast +import K.Parsing +import Data.Maybe + +isNum Zero = True +isNum (Succ t) = isNum t +isNum _ = False + +isVal :: Expr -> Bool +isVal Tru = True +isVal Fals = True +isVal t | isNum t = True +isVal _ = False + +eval' x = case x of + IsZero Zero -> Just Tru + IsZero (Succ t) | isNum t -> Just Fals + IsZero t -> IsZero <$> eval' t + + Succ t -> Succ <$> eval' t + + Pred Zero -> Just Zero + Pred (Succ t) | isNum t -> Just t + Pred t -> Pred <$> eval' t + + If Tru t _ -> Just t + If Fals _ f -> Just f + If c t f -> (\c' -> If c' t f) <$> eval' c + + _ -> Nothing + +nf x = fromMaybe x (nf <$> eval' x) + +eval :: Expr -> Maybe Expr +eval t = case nf t of + nft | isVal nft -> Just nft + | otherwise -> Nothing + diff --git a/src/K/Parsing.hs b/src/K/Parsing.hs new file mode 100644 index 0000000..32cc526 --- /dev/null +++ b/src/K/Parsing.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module K.Parsing where + +import K.Ast +import Text.Parsec +import Control.Monad.Identity +import qualified Text.Parsec.Token as Token +import qualified Text.Parsec.Expr as Expr + +reservedNames = [] +reservedOps = [] + +type Parser a = Parsec String () a + +langDef :: Token.LanguageDef () +langDef = Token.LanguageDef + { Token.commentStart = "{-" + , Token.commentEnd = "-}" + , Token.commentLine = "--" + , Token.nestedComments = True + , Token.identStart = letter + , Token.identLetter = alphaNum <|> oneOf "_'" + , Token.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~" + , Token.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" + , Token.reservedNames = reservedNames + , Token.reservedOpNames = reservedOps + , Token.caseSensitive = True + } + +lexer :: Token.TokenParser () +lexer = Token.makeTokenParser langDef + +parens :: Parser a -> Parser a +parens = Token.parens lexer + +reserved :: String -> Parser () +reserved = Token.reserved lexer + +semiSep :: Parser a -> Parser [a] +semiSep = Token.semiSep lexer + +reservedOp :: String -> Parser () +reservedOp = Token.reservedOp lexer + +prefixOp :: String -> (a -> a) -> Expr.Operator String () Identity a +prefixOp s f = Expr.Prefix (reservedOp s >> return f) + +table :: Expr.OperatorTable String () Identity Expr +table = [ + [ prefixOp "succ" Succ + , prefixOp "pred" Pred + , prefixOp "iszero" IsZero + ]] + +ifthen :: Parser Expr +ifthen = do + reserved "if" + cond <- expr + reservedOp "then" + true <- expr + reservedOp "else" + false <- expr + return (If cond true false) + +true, false, zero :: Parser Expr +true = reserved "true" >> return Tru +false =reserved "false" >> return Fals +zero = reserved "0" >> return Zero + +factor :: Parser Expr +factor = foldr1 (<|>) [true, false, zero, ifthen, parens expr] + +expr :: Parser Expr +expr = Expr.buildExpressionParser table factor + +contents :: Parser a -> Parser a +contents p = do + Token.whiteSpace lexer + r <- p + eof + return r + +parseExpr s = parse (contents expr) "<stdin>" s diff --git a/src/K/Repl.hs b/src/K/Repl.hs new file mode 100644 index 0000000..26f21e1 --- /dev/null +++ b/src/K/Repl.hs @@ -0,0 +1,22 @@ +module K.Repl where + +import Control.Monad.IO.Class +import K.Parsing +import K.Eval +import System.Console.Haskeline + +process :: String -> IO () +process line = do + let res = parseExpr line + case res of + Left err -> print err + Right ex -> print $ eval ex + +main :: IO () +main = runInputT defaultSettings loop + where + loop = do + minput <- getInputLine "Repl> " + case minput of + Nothing -> outputStrLn "Goodbye." + Just input -> (liftIO $ process input) >> loop |