diff options
| -rw-r--r-- | fun.cabal | 8 | ||||
| -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 | ||||
| -rw-r--r-- | test/Spec.hs | 10 |
6 files changed, 175 insertions, 1 deletions
@@ -17,9 +17,17 @@ library hs-source-dirs: src exposed-modules: Lib , K.NanoParsec + , K.Parsing + , K.Ast + , K.Eval + , K.Repl build-depends: base >= 4.7 && < 5 , text + , mtl + , transformers + , haskeline , lens + , parsec default-language: Haskell2010 executable fun-exe 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 diff --git a/test/Spec.hs b/test/Spec.hs index 612fea6..4a90862 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) @@ -6,6 +7,7 @@ import K.NanoParsec import qualified Data.Text as T import Data.Text.Arbitrary (Text(..)) +import Control.Lens ((^?), _Right) main :: IO () main = defaultMain tests @@ -14,7 +16,8 @@ tests = [ testGroup "Parsing" [ testProperty "empty" prop_empty, testProperty "correct_item" prop_correct, - testProperty "tooLong_item" prop_tooLong + testProperty "tooLong_item" prop_tooLong, + testProperty "applicative" prop_applicative ] ] @@ -26,3 +29,8 @@ isLeft = not . isRight prop_empty t = T.null t ==> isLeft (runParser item t) prop_correct t = T.length t == 1 ==> isRight (runParser item t) prop_tooLong t = T.length t > 1 ==> isLeft (runParser item t) + +prop_applicative x = result == Just (x+1) + where x' :: Parser Integer + x' = unit x + result = runParser (pure (+1) <*> x') "" ^? _Right |