From 64ee4dc4329cdf41f600bd6dbc60d3d80c4f5efa Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Fri, 20 Jan 2023 14:12:04 +0100 Subject: [PATCH] Implement basic interpreted language --- Grammar.cf | 15 +++++ src/Compiler.hs | 0 src/Grammar/Abs.hs | 26 ++++++++ src/Grammar/Doc.txt | 56 ++++++++++++++++ src/Grammar/ErrM.hs | 91 +++++++++++++++++++++++++ src/Grammar/Print.hs | 153 +++++++++++++++++++++++++++++++++++++++++++ src/Grammar/Skel.hs | 32 +++++++++ src/Grammar/Test.hs | 76 +++++++++++++++++++++ src/Interpreter.hs | 78 ++++++++++++++++++++++ src/Main.hs | 28 +++++++- src/TypeChecker.hs | 0 test_program | 5 ++ 12 files changed, 559 insertions(+), 1 deletion(-) create mode 100644 Grammar.cf create mode 100644 src/Compiler.hs create mode 100644 src/Grammar/Abs.hs create mode 100644 src/Grammar/Doc.txt create mode 100644 src/Grammar/ErrM.hs create mode 100644 src/Grammar/Print.hs create mode 100644 src/Grammar/Skel.hs create mode 100644 src/Grammar/Test.hs create mode 100644 src/Interpreter.hs create mode 100644 src/TypeChecker.hs create mode 100644 test_program diff --git a/Grammar.cf b/Grammar.cf new file mode 100644 index 0000000..b258446 --- /dev/null +++ b/Grammar.cf @@ -0,0 +1,15 @@ + + +Program. Program ::= "main" "=" Exp ; + +EId. Exp3 ::= Ident ; +EInt. Exp3 ::= Integer ; +EApp. Exp2 ::= Exp2 Exp3 ; +EAdd. Exp1 ::= Exp1 "+" Exp2 ; +EAbs. Exp ::= "\\" Ident "->" Exp ; + +coercions Exp 3 ; + +comment "--" ; +comment "{-" "-}" ; + diff --git a/src/Compiler.hs b/src/Compiler.hs new file mode 100644 index 0000000..e69de29 diff --git a/src/Grammar/Abs.hs b/src/Grammar/Abs.hs new file mode 100644 index 0000000..8ed9f3a --- /dev/null +++ b/src/Grammar/Abs.hs @@ -0,0 +1,26 @@ +-- File generated by the BNF Converter (bnfc 2.9.4.1). + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | The abstract syntax of language Grammar. + +module Grammar.Abs where + +import Prelude (Integer, String) +import qualified Prelude as C (Eq, Ord, Show, Read) +import qualified Data.String + +data Program = Program Exp + deriving (C.Eq, C.Ord, C.Show, C.Read) + +data Exp + = EId Ident + | EInt Integer + | EApp Exp Exp + | EAdd Exp Exp + | EAbs Ident Exp + deriving (C.Eq, C.Ord, C.Show, C.Read) + +newtype Ident = Ident String + deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString) + diff --git a/src/Grammar/Doc.txt b/src/Grammar/Doc.txt new file mode 100644 index 0000000..946b390 --- /dev/null +++ b/src/Grammar/Doc.txt @@ -0,0 +1,56 @@ +The Language Grammar +BNF Converter + + +%Process by txt2tags to generate html or latex + + + +This document was automatically generated by the //BNF-Converter//. It was generated together with the lexer, the parser, and the abstract syntax module, which guarantees that the document matches with the implementation of the language (provided no hand-hacking has taken place). + +==The lexical structure of Grammar== +===Identifiers=== +Identifiers //Ident// are unquoted strings beginning with a letter, +followed by any combination of letters, digits, and the characters ``_ '`` +reserved words excluded. + + +===Literals=== +Integer literals //Integer// are nonempty sequences of digits. + + + + +===Reserved words and symbols=== +The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions. + +The reserved words used in Grammar are the following: + | ``main`` | | | + +The symbols used in Grammar are the following: + | = | + | \ | -> + | ( | ) | | + +===Comments=== +Single-line comments begin with --.Multiple-line comments are enclosed with {- and -}. + +==The syntactic structure of Grammar== +Non-terminals are enclosed between < and >. +The symbols -> (production), **|** (union) +and **eps** (empty rule) belong to the BNF notation. +All other symbols are terminals. + + | //Program// | -> | ``main`` ``=`` //Exp// + | //Exp3// | -> | //Ident// + | | **|** | //Integer// + | | **|** | ``(`` //Exp// ``)`` + | //Exp2// | -> | //Exp2// //Exp3// + | | **|** | //Exp3// + | //Exp1// | -> | //Exp1// ``+`` //Exp2// + | | **|** | //Exp2// + | //Exp// | -> | ``\`` //Ident// ``->`` //Exp// + | | **|** | //Exp1// + + + +%% File generated by the BNF Converter (bnfc 2.9.4.1). diff --git a/src/Grammar/ErrM.hs b/src/Grammar/ErrM.hs new file mode 100644 index 0000000..391ba56 --- /dev/null +++ b/src/Grammar/ErrM.hs @@ -0,0 +1,91 @@ +-- File generated by the BNF Converter (bnfc 2.9.4.1). + +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 708 +--------------------------------------------------------------------------- +-- Pattern synonyms exist since ghc 7.8. + +-- | BNF Converter: Error Monad. +-- +-- Module for backwards compatibility. +-- +-- The generated parser now uses @'Either' String@ as error monad. +-- This module defines a type synonym 'Err' and pattern synonyms +-- 'Bad' and 'Ok' for 'Left' and 'Right'. + +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleInstances #-} + +module Grammar.ErrM where + +import Prelude (id, const, Either(..), String) + +import Control.Monad (MonadPlus(..)) +import Control.Applicative (Alternative(..)) +#if __GLASGOW_HASKELL__ >= 808 +import Control.Monad (MonadFail(..)) +#endif + +-- | Error monad with 'String' error messages. +type Err = Either String + +pattern Bad msg = Left msg +pattern Ok a = Right a + +#if __GLASGOW_HASKELL__ >= 808 +instance MonadFail Err where + fail = Bad +#endif + +instance Alternative Err where + empty = Left "Err.empty" + (<|>) Left{} = id + (<|>) x@Right{} = const x + +instance MonadPlus Err where + mzero = empty + mplus = (<|>) + +#else +--------------------------------------------------------------------------- +-- ghc 7.6 and before: use old definition as data type. + +-- | BNF Converter: Error Monad + +-- Copyright (C) 2004 Author: Aarne Ranta +-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE. + +module Grammar.ErrM where + +-- the Error monad: like Maybe type with error msgs + +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Monad (MonadPlus(..), liftM) + +data Err a = Ok a | Bad String + deriving (Read, Show, Eq, Ord) + +instance Monad Err where + return = Ok + Ok a >>= f = f a + Bad s >>= _ = Bad s + +instance Applicative Err where + pure = Ok + (Bad s) <*> _ = Bad s + (Ok f) <*> o = liftM f o + +instance Functor Err where + fmap = liftM + +instance MonadPlus Err where + mzero = Bad "Err.mzero" + mplus (Bad _) y = y + mplus x _ = x + +instance Alternative Err where + empty = mzero + (<|>) = mplus + +#endif diff --git a/src/Grammar/Print.hs b/src/Grammar/Print.hs new file mode 100644 index 0000000..0acef7c --- /dev/null +++ b/src/Grammar/Print.hs @@ -0,0 +1,153 @@ +-- File generated by the BNF Converter (bnfc 2.9.4.1). + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +#if __GLASGOW_HASKELL__ <= 708 +{-# LANGUAGE OverlappingInstances #-} +#endif + +-- | Pretty-printer for Grammar. + +module Grammar.Print where + +import Prelude + ( ($), (.) + , Bool(..), (==), (<) + , Int, Integer, Double, (+), (-), (*) + , String, (++) + , ShowS, showChar, showString + , all, elem, foldr, id, map, null, replicate, shows, span + ) +import Data.Char ( Char, isSpace ) +import qualified Grammar.Abs + +-- | The top-level printing method. + +printTree :: Print a => a -> String +printTree = render . prt 0 + +type Doc = [ShowS] -> [ShowS] + +doc :: ShowS -> Doc +doc = (:) + +render :: Doc -> String +render d = rend 0 False (map ($ "") $ d []) "" + where + rend + :: Int -- ^ Indentation level. + -> Bool -- ^ Pending indentation to be output before next character? + -> [String] + -> ShowS + rend i p = \case + "[" :ts -> char '[' . rend i False ts + "(" :ts -> char '(' . rend i False ts + "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts + "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts + "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts + [";"] -> char ';' + ";" :ts -> char ';' . new i ts + t : ts@(s:_) | closingOrPunctuation s + -> pending . showString t . rend i False ts + t :ts -> pending . space t . rend i False ts + [] -> id + where + -- Output character after pending indentation. + char :: Char -> ShowS + char c = pending . showChar c + + -- Output pending indentation. + pending :: ShowS + pending = if p then indent i else id + + -- Indentation (spaces) for given indentation level. + indent :: Int -> ShowS + indent i = replicateS (2*i) (showChar ' ') + + -- Continue rendering in new line with new indentation. + new :: Int -> [String] -> ShowS + new j ts = showChar '\n' . rend j True ts + + -- Make sure we are on a fresh line. + onNewLine :: Int -> Bool -> ShowS + onNewLine i p = (if p then id else showChar '\n') . indent i + + -- Separate given string from following text by a space (if needed). + space :: String -> ShowS + space t s = + case (all isSpace t', null spc, null rest) of + (True , _ , True ) -> [] -- remove trailing space + (False, _ , True ) -> t' -- remove trailing space + (False, True, False) -> t' ++ ' ' : s -- add space if none + _ -> t' ++ s + where + t' = showString t [] + (spc, rest) = span isSpace s + + closingOrPunctuation :: String -> Bool + closingOrPunctuation [c] = c `elem` closerOrPunct + closingOrPunctuation _ = False + + closerOrPunct :: String + closerOrPunct = ")],;" + +parenth :: Doc -> Doc +parenth ss = doc (showChar '(') . ss . doc (showChar ')') + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +concatD :: [Doc] -> Doc +concatD = foldr (.) id + +replicateS :: Int -> ShowS -> ShowS +replicateS n f = concatS (replicate n f) + +-- | The printer class does the job. + +class Print a where + prt :: Int -> a -> Doc + +instance {-# OVERLAPPABLE #-} Print a => Print [a] where + prt i = concatD . map (prt i) + +instance Print Char where + prt _ c = doc (showChar '\'' . mkEsc '\'' c . showChar '\'') + +instance Print String where + prt _ = printString + +printString :: String -> Doc +printString s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') + +mkEsc :: Char -> Char -> ShowS +mkEsc q = \case + s | s == q -> showChar '\\' . showChar s + '\\' -> showString "\\\\" + '\n' -> showString "\\n" + '\t' -> showString "\\t" + s -> showChar s + +prPrec :: Int -> Int -> Doc -> Doc +prPrec i j = if j < i then parenth else id + +instance Print Integer where + prt _ x = doc (shows x) + +instance Print Double where + prt _ x = doc (shows x) + +instance Print Grammar.Abs.Ident where + prt _ (Grammar.Abs.Ident i) = doc $ showString i +instance Print Grammar.Abs.Program where + prt i = \case + Grammar.Abs.Program exp -> prPrec i 0 (concatD [doc (showString "main"), doc (showString "="), prt 0 exp]) + +instance Print Grammar.Abs.Exp where + prt i = \case + Grammar.Abs.EId id_ -> prPrec i 3 (concatD [prt 0 id_]) + Grammar.Abs.EInt n -> prPrec i 3 (concatD [prt 0 n]) + Grammar.Abs.EApp exp1 exp2 -> prPrec i 2 (concatD [prt 2 exp1, prt 3 exp2]) + Grammar.Abs.EAdd exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, doc (showString "+"), prt 2 exp2]) + Grammar.Abs.EAbs id_ exp -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 id_, doc (showString "->"), prt 0 exp]) diff --git a/src/Grammar/Skel.hs b/src/Grammar/Skel.hs new file mode 100644 index 0000000..89c6233 --- /dev/null +++ b/src/Grammar/Skel.hs @@ -0,0 +1,32 @@ +-- File generated by the BNF Converter (bnfc 2.9.4.1). + +-- Templates for pattern matching on abstract syntax + +{-# OPTIONS_GHC -fno-warn-unused-matches #-} + +module Grammar.Skel where + +import Prelude (($), Either(..), String, (++), Show, show) +import qualified Grammar.Abs + +type Err = Either String +type Result = Err String + +failure :: Show a => a -> Result +failure x = Left $ "Undefined case: " ++ show x + +transIdent :: Grammar.Abs.Ident -> Result +transIdent x = case x of + Grammar.Abs.Ident string -> failure x + +transProgram :: Grammar.Abs.Program -> Result +transProgram x = case x of + Grammar.Abs.Program exp -> failure x + +transExp :: Grammar.Abs.Exp -> Result +transExp x = case x of + Grammar.Abs.EId ident -> failure x + Grammar.Abs.EInt integer -> failure x + Grammar.Abs.EApp exp1 exp2 -> failure x + Grammar.Abs.EAdd exp1 exp2 -> failure x + Grammar.Abs.EAbs ident exp -> failure x diff --git a/src/Grammar/Test.hs b/src/Grammar/Test.hs new file mode 100644 index 0000000..8f0fdf6 --- /dev/null +++ b/src/Grammar/Test.hs @@ -0,0 +1,76 @@ +-- File generated by the BNF Converter (bnfc 2.9.4.1). + +-- | Program to test parser. + +module Main where + +import Prelude + ( ($), (.) + , Either(..) + , Int, (>) + , String, (++), concat, unlines + , Show, show + , IO, (>>), (>>=), mapM_, putStrLn + , FilePath + , getContents, readFile + ) +import System.Environment ( getArgs ) +import System.Exit ( exitFailure ) +import Control.Monad ( when ) + +import Grammar.Abs () +import Grammar.Lex ( Token, mkPosToken ) +import Grammar.Par ( pProgram, myLexer ) +import Grammar.Print ( Print, printTree ) +import Grammar.Skel () + +type Err = Either String +type ParseFun a = [Token] -> Err a +type Verbosity = Int + +putStrV :: Verbosity -> String -> IO () +putStrV v s = when (v > 1) $ putStrLn s + +runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO () +runFile v p f = putStrLn f >> readFile f >>= run v p + +run :: (Print a, Show a) => Verbosity -> ParseFun a -> String -> IO () +run v p s = + case p ts of + Left err -> do + putStrLn "\nParse Failed...\n" + putStrV v "Tokens:" + mapM_ (putStrV v . showPosToken . mkPosToken) ts + putStrLn err + exitFailure + Right tree -> do + putStrLn "\nParse Successful!" + showTree v tree + where + ts = myLexer s + showPosToken ((l,c),t) = concat [ show l, ":", show c, "\t", show t ] + +showTree :: (Show a, Print a) => Int -> a -> IO () +showTree v tree = do + putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree + putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree + +usage :: IO () +usage = do + putStrLn $ unlines + [ "usage: Call with one of the following argument combinations:" + , " --help Display this help message." + , " (no arguments) Parse stdin verbosely." + , " (files) Parse content of files verbosely." + , " -s (files) Silent mode. Parse content of files silently." + ] + +main :: IO () +main = do + args <- getArgs + case args of + ["--help"] -> usage + [] -> getContents >>= run 2 pProgram + "-s":fs -> mapM_ (runFile 0 pProgram) fs + fs -> mapM_ (runFile 2 pProgram) fs + diff --git a/src/Interpreter.hs b/src/Interpreter.hs new file mode 100644 index 0000000..30bdd54 --- /dev/null +++ b/src/Interpreter.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE LambdaCase #-} +module Interpreter where + +import Control.Applicative (Applicative) +import Control.Monad.Except (Except, MonadError (throwError), + liftEither) +import Data.Either.Combinators (maybeToRight) +import Data.Map (Map) +import qualified Data.Map as Map +import Grammar.Abs +import Grammar.Print (printTree) + +interpret :: Program -> Except String Integer +interpret (Program e) = + eval mempty e >>= \case + VClosure {} -> throwError "main evaluated to a function" + VInt i -> pure i + + +data Val = VInt Integer + | VClosure Cxt Ident Exp + +type Cxt = Map Ident Val + +eval :: Cxt -> Exp -> Except String Val +eval cxt = \case + + + -- ------------ x ∈ γ + -- γ ⊢ x ⇓ γ(x) + + EId x -> + maybeToRightM + ("Unbound variable:" ++ printTree x) + $ Map.lookup x cxt + + -- --------- + -- γ ⊢ i ⇓ i + + EInt i -> pure $ VInt i + + -- γ ⊢ e ⇓ let δ in λx → f + -- γ ⊢ e₁ ⇓ v + -- δ,x=v ⊢ f ⇓ v₁ + -- ------------------------------ + -- γ ⊢ e e₁ ⇓ v₁ + + EApp e e1 -> + eval cxt e >>= \case + VInt _ -> throwError "Not a function" + VClosure delta x f -> do + v <- eval cxt e1 + eval (Map.insert x v delta) f + + -- + -- ----------------------------- + -- γ ⊢ λx → f ⇓ let γ in λx → f + + EAbs x e -> pure $ VClosure cxt x e + + + -- γ ⊢ e ⇓ v + -- γ ⊢ e₁ ⇓ v₁ + -- ------------------ + -- γ ⊢ e e₁ ⇓ v + + EAdd e e1 -> do + v <- eval cxt e + v1 <- eval cxt e1 + case (v, v1) of + (VInt i, VInt i1) -> pure $ VInt (i + i1) + _ -> throwError "Can't add a function" + + + +maybeToRightM :: MonadError l m => l -> Maybe r -> m r +maybeToRightM err = liftEither . maybeToRight err + diff --git a/src/Main.hs b/src/Main.hs index 65ae4a0..ed753f2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,30 @@ +{-# LANGUAGE LambdaCase #-} module Main where +import Control.Monad.Except (runExcept) +import Grammar.Par (myLexer, pProgram) +import Interpreter (interpret) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) + main :: IO () -main = putStrLn "Hello, Haskell!" +main = getArgs >>= \case + [] -> print "Required file path missing" + (x:_) -> do + file <- readFile x + case pProgram (myLexer file) of + Left err -> do + putStrLn "SYNTAX ERROR" + putStrLn err + exitFailure + Right prg -> case runExcept $ interpret prg of + Left err -> do + putStrLn "INTERPRETER ERROR" + putStrLn err + exitFailure + Right i -> do + print i + exitSuccess + + + diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs new file mode 100644 index 0000000..e69de29 diff --git a/test_program b/test_program new file mode 100644 index 0000000..83f3e9a --- /dev/null +++ b/test_program @@ -0,0 +1,5 @@ + + + + +main = (\x -> x + x + 3) ((\x -> x) 2)