From 787dbd85dbd8d9005e3d0f0be171f30503e11c7a Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 21 Jan 2023 19:44:22 +0100 Subject: [PATCH 01/20] Add Makefile, add remove Grammar dir --- .gitignore | 1 + Makefile | 25 +++++++ 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 --------------------- 8 files changed, 26 insertions(+), 434 deletions(-) create mode 100644 Makefile delete mode 100644 src/Grammar/Abs.hs delete mode 100644 src/Grammar/Doc.txt delete mode 100644 src/Grammar/ErrM.hs delete mode 100644 src/Grammar/Print.hs delete mode 100644 src/Grammar/Skel.hs delete mode 100644 src/Grammar/Test.hs diff --git a/.gitignore b/.gitignore index db000d0..5aa7a08 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ dist-newstyle *.y *.x *.bak +src/Grammar diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..16b753d --- /dev/null +++ b/Makefile @@ -0,0 +1,25 @@ +.PHONY : sdist clean + +language : src/Grammar/Test + cabal install --installdir=. + +src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y : Grammar.cf + bnfc -o src -d $< + +src/Grammar/Par.hs : src/Grammar/Par.y + happy --ghc --coerce --array --info $< + +src/Grammar/Lex.hs : src/Grammar/Lex.x + alex --ghc $< + +src/Grammar/%.y : Grammar.cf + bnfc -o src -d $< + +src/Grammar/Test : src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs + ghc src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs src/Grammar/Abs.hs src/Grammar/Skel.hs src/Grammar/Print.hs -o src/Grammar/test + +clean : + rm -r src/Grammar + rm language + +# EOF diff --git a/src/Grammar/Abs.hs b/src/Grammar/Abs.hs deleted file mode 100644 index 8ed9f3a..0000000 --- a/src/Grammar/Abs.hs +++ /dev/null @@ -1,26 +0,0 @@ --- 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 deleted file mode 100644 index 946b390..0000000 --- a/src/Grammar/Doc.txt +++ /dev/null @@ -1,56 +0,0 @@ -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 deleted file mode 100644 index 391ba56..0000000 --- a/src/Grammar/ErrM.hs +++ /dev/null @@ -1,91 +0,0 @@ --- 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 deleted file mode 100644 index 0acef7c..0000000 --- a/src/Grammar/Print.hs +++ /dev/null @@ -1,153 +0,0 @@ --- 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 deleted file mode 100644 index 89c6233..0000000 --- a/src/Grammar/Skel.hs +++ /dev/null @@ -1,32 +0,0 @@ --- 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 deleted file mode 100644 index 8f0fdf6..0000000 --- a/src/Grammar/Test.hs +++ /dev/null @@ -1,76 +0,0 @@ --- 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 - From 8fd7966fd9f652a88ea0555fcc95d71a4ca7205d Mon Sep 17 00:00:00 2001 From: Patrik Jansson Date: Fri, 3 Feb 2023 11:12:44 +0100 Subject: [PATCH 02/20] Typo fix (to check access). --- .gitignore | 1 + language.cabal | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 5aa7a08..5112877 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ dist-newstyle *.x *.bak src/Grammar +/language diff --git a/language.cabal b/language.cabal index fc1c2fe..aac5d02 100644 --- a/language.cabal +++ b/language.cabal @@ -12,7 +12,7 @@ build-type: Simple extra-doc-files: CHANGELOG.md -extra-source-fiels: +extra-source-files: Grammar.cf From 2a3757f3914209cf289d825de9d6a97dcbe5990a Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 3 Feb 2023 11:29:42 +0100 Subject: [PATCH 03/20] relaxed base dependency and added overwrite --- language.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/language.cabal b/language.cabal index aac5d02..5734655 100644 --- a/language.cabal +++ b/language.cabal @@ -35,7 +35,7 @@ executable language hs-source-dirs: src build-depends: - base ^>=4.16.3.0 + base >=4.16 , mtl , containers , either From 61efcebc64039dd5bfb13f74a525441f448d2217 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sun, 22 Jan 2023 20:16:03 +0100 Subject: [PATCH 04/20] Fix conflict --- Grammar.cf | 2 +- src/Grammar/Doc.txt | 56 ++++++++++++++++ src/Grammar/Print.hs | 153 +++++++++++++++++++++++++++++++++++++++++++ src/Interpreter.hs | 4 +- test_program | 2 +- 5 files changed, 213 insertions(+), 4 deletions(-) create mode 100644 src/Grammar/Doc.txt create mode 100644 src/Grammar/Print.hs diff --git a/Grammar.cf b/Grammar.cf index b258446..d880ed2 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -6,7 +6,7 @@ EId. Exp3 ::= Ident ; EInt. Exp3 ::= Integer ; EApp. Exp2 ::= Exp2 Exp3 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; -EAbs. Exp ::= "\\" Ident "->" Exp ; +EAbs. Exp ::= "\\" Ident "." Exp ; coercions Exp 3 ; diff --git a/src/Grammar/Doc.txt b/src/Grammar/Doc.txt new file mode 100644 index 0000000..18a68c9 --- /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/Print.hs b/src/Grammar/Print.hs new file mode 100644 index 0000000..377a3cf --- /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/Interpreter.hs b/src/Interpreter.hs index bdbd8d2..378c95b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -39,7 +39,7 @@ eval cxt = \case EInt i -> pure $ VInt i - -- γ ⊢ e ⇓ let δ in λx → f + -- γ ⊢ e ⇓ let δ in λx. f -- γ ⊢ e₁ ⇓ v -- δ,x=v ⊢ f ⇓ v₁ -- ------------------------------ @@ -54,7 +54,7 @@ eval cxt = \case -- -- ----------------------------- - -- γ ⊢ λx → f ⇓ let γ in λx → f + -- γ ⊢ λx. f ⇓ let γ in λx. f EAbs x e -> pure $ VClosure cxt x e diff --git a/test_program b/test_program index 83f3e9a..95235e4 100644 --- a/test_program +++ b/test_program @@ -2,4 +2,4 @@ -main = (\x -> x + x + 3) ((\x -> x) 2) +main = (\x. x + x + 3) ((\x. x) 2) From b64b49b1ebf27e4ea3e6f3a19af7b5af8dbd82f0 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 05:18:49 +0100 Subject: [PATCH 05/20] Remove files from git --- src/Grammar/Doc.txt | 56 ---------------- src/Grammar/Print.hs | 153 ------------------------------------------- 2 files changed, 209 deletions(-) delete mode 100644 src/Grammar/Doc.txt delete mode 100644 src/Grammar/Print.hs diff --git a/src/Grammar/Doc.txt b/src/Grammar/Doc.txt deleted file mode 100644 index 18a68c9..0000000 --- a/src/Grammar/Doc.txt +++ /dev/null @@ -1,56 +0,0 @@ -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/Print.hs b/src/Grammar/Print.hs deleted file mode 100644 index 377a3cf..0000000 --- a/src/Grammar/Print.hs +++ /dev/null @@ -1,153 +0,0 @@ --- 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]) From 2a48b7477e37443a7302bb41f7edec9d390ecd2a Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 05:19:51 +0100 Subject: [PATCH 06/20] Implement lambda lifting passes: freeVars, abstract, and rename --- Grammar.cf | 28 ++++--- language.cabal | 4 +- src/LambdaLifter.hs | 173 ++++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 29 ++++---- 4 files changed, 211 insertions(+), 23 deletions(-) create mode 100644 src/LambdaLifter.hs diff --git a/Grammar.cf b/Grammar.cf index d880ed2..9dba2f5 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,15 +1,25 @@ -Program. Program ::= "main" "=" Exp ; +Program. Program ::= [ScDef]; -EId. Exp3 ::= Ident ; -EInt. Exp3 ::= Integer ; -EApp. Exp2 ::= Exp2 Exp3 ; -EAdd. Exp1 ::= Exp1 "+" Exp2 ; -EAbs. Exp ::= "\\" Ident "." Exp ; +ScDef. ScDef ::= Bind; +separator ScDef ";"; -coercions Exp 3 ; +separator Ident " "; -comment "--" ; -comment "{-" "-}" ; + +EId. Exp3 ::= Ident; +EInt. Exp3 ::= Integer; +ELet. Exp3 ::= "let" [Bind] "in" Exp; +EApp. Exp2 ::= Exp2 Exp3; +EAdd. Exp1 ::= Exp1 "+" Exp2; +EAbs. Exp ::= "\\" Ident "." Exp; + +Bind. Bind ::= Ident [Ident] "=" Exp; +separator Bind ";"; + +coercions Exp 3; + +comment "--"; +comment "{-" "-}"; diff --git a/language.cabal b/language.cabal index 5734655..3f4860c 100644 --- a/language.cabal +++ b/language.cabal @@ -30,7 +30,8 @@ executable language Grammar.Par Grammar.Print Grammar.Skel - Interpreter + LambdaLifter + -- Interpreter hs-source-dirs: src @@ -40,5 +41,6 @@ executable language , containers , either , array + , extra default-language: GHC2021 diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs new file mode 100644 index 0000000..6e1463d --- /dev/null +++ b/src/LambdaLifter.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + + +module LambdaLifter (lambdaLift, freeVars, abstract) where + +import Data.List (mapAccumL) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Data.Set (Set, (\\)) +import qualified Data.Set as Set +import Data.Tuple.Extra (uncurry3) +import Grammar.Abs +import Prelude hiding (exp) + +pattern Sc :: Ident -> [Ident] -> Exp -> ScDef +pattern Sc n xs e = ScDef (Bind n xs e) + + + +lambdaLift :: Program -> Program +lambdaLift = rename . abstract . freeVars + + +-- Annotate free variables + +freeVars :: Program -> AnnProgram +freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) + | Sc n xs e <- ds + ] + + +freeVarsExp :: Set Ident -> Exp -> AnnExp +freeVarsExp lv = \case + + EId n | Set.member n lv -> (Set.singleton n, AId n) + | otherwise -> (mempty, AId n) + + EInt i -> (mempty, AInt i) + + EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp e1' e2') + where e1' = freeVarsExp lv e1 + e2' = freeVarsExp lv e2 + + EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd e1' e2') + where e1' = freeVarsExp lv e1 + e2' = freeVarsExp lv e2 + + EAbs n e -> (Set.delete n $ freeVarsOf e', AAbs n e') + where e' = freeVarsExp (Set.insert n lv) e + + ELet bs e -> (Set.union bsFree eFree, ALet bs' e') + where + bsFree = freeInValues \\ nsSet + eFree = freeVarsOf e' \\ nsSet + bs' = zipWith3 ABind ns xs es' + e' = freeVarsExp e_lv e + (ns, xs, es) = fromBinders bs + nsSet = Set.fromList ns + e_lv = Set.union lv nsSet + es' = map (freeVarsExp e_lv) es + freeInValues = foldr1 Set.union (map freeVarsOf es') + + + +freeVarsOf :: AnnExp -> Set Ident +freeVarsOf = fst + +fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp]) +fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ] + +-- Lift lambda expression into let with binder "sc" + +abstract :: AnnProgram -> Program +abstract p = Program + [ Sc sc_name xs $ abstractExp rhs + | (sc_name, xs, rhs) <- p + ] + + +abstractExp :: AnnExp -> Exp +abstractExp (free, exp) = case exp of + AId n -> EId n + AInt i -> EInt i + AApp e1 e2 -> EApp (abstractExp e1) (abstractExp e2) + AAdd e1 e2 -> EAdd (abstractExp e1) (abstractExp e2) + ALet bs e -> ELet [Bind n xs (abstractExp e1) | ABind n xs e1 <- bs ] $ abstractExp e + AAbs n e -> foldl EApp sc (map EId fvList) + where + fvList = Set.toList free + bind = Bind "sc" [] e' + e' = foldr EAbs (abstractExp e) (fvList ++ [n]) + sc = ELet [bind] (EId (Ident "sc")) + +-- rename pass + +rename :: Program -> Program +rename (Program ds) = Program $ map (uncurry3 Sc) tuples + where + tuples = snd (mapAccumL renameSc 0 ds) + renameSc i (Sc n xs e) = (i2, (n, xs', e')) + where + (i1, xs', env) = newNames i xs + (i2, e') = renameExp env i1 e + +renameExp :: Map Ident Ident -> Int -> Exp -> (Int, Exp) +renameExp env i = \case + + + EId n -> (i, maybe (error "no") EId $ Map.lookup n env) + + + EInt i1 -> (i, EInt i1) + + EApp e1 e2 -> (i2, EApp e1' e2') + where + (i1, e1') = renameExp env i e1 + (i2, e2') = renameExp env i1 e2 + + EAdd e1 e2 -> (i2, EAdd e1' e2') + where + (i1, e1') = renameExp env i e1 + (i2, e2') = renameExp env i1 e2 + + ELet bs e -> (i3, ELet (zipWith3 Bind ns' xs es') e') + where + (i1, e') = renameExp e_env i e + (ns, xs, es) = fromBinders bs + (i2, ns', env') = newNames i1 ns + e_env = Map.union env' env + (i3, es') = mapAccumL (renameExp e_env) i2 es + + + EAbs n e -> (i2, EAbs (head ns) e') + where + (i1, ns, env') = newNames i [n] + (i2, e') = renameExp (Map.union env' env ) i1 e + + +newNames :: Int -> [Ident] -> (Int, [Ident], Map Ident Ident) +newNames i old_names = (i', new_names, env) + where + (i', new_names) = getNames i old_names + env = Map.fromList $ zip old_names new_names + + +getName :: Int -> Ident -> (Int, Ident) +getName i (Ident s) = (i + 1, makeName s i) + +getNames :: Int -> [Ident] -> (Int, [Ident]) +getNames i ns = (i + length ss, zipWith makeName ss [i..]) + where + ss = map (\(Ident s) -> s) ns + +makeName :: String -> Int -> Ident +makeName prefix i = Ident (prefix ++ "_" ++ show i) + +-- Annotated AST + +type AnnProgram = [(Ident, [Ident], AnnExp)] +type AnnExp = (Set Ident, AnnExp') + +data ABind = ABind Ident [Ident] AnnExp deriving Show + +data AnnExp' = AId Ident + | AInt Integer + | AApp AnnExp AnnExp + | AAdd AnnExp AnnExp + | AAbs Ident AnnExp + | ALet [ABind] AnnExp + deriving Show diff --git a/src/Main.hs b/src/Main.hs index ed753f2..58aafe5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,11 +1,11 @@ {-# 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) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (abstract, freeVars, lambdaLift) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) main :: IO () main = getArgs >>= \case @@ -17,14 +17,17 @@ main = getArgs >>= \case 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 + Right prg -> do + putStrLn "-- Parser" + putStrLn $ printTree prg + putStrLn "\n--Lamda lifter" + putStrLn "\n--freevars" + print $ freeVars prg + putStrLn "\n--abstract" + putStrLn . printTree $ (abstract . freeVars) prg + putStrLn "\n--renamed" + putStrLn . printTree $ lambdaLift prg + exitSuccess From 69254f803203918e39cc3eeb9aeafa44e961234d Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 06:19:58 +0100 Subject: [PATCH 07/20] Finish Lambda Lifter --- basic-2 | 4 +++ src/LambdaLifter.hs | 76 ++++++++++++++++++++++++++++++++++++++++----- src/Main.hs | 7 +---- 3 files changed, 74 insertions(+), 13 deletions(-) create mode 100644 basic-2 diff --git a/basic-2 b/basic-2 new file mode 100644 index 0000000..8afd060 --- /dev/null +++ b/basic-2 @@ -0,0 +1,4 @@ +add x = \y. x + y; + +main = (\z. z + z) ((add 4) 6); + diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 6e1463d..512155d 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -3,12 +3,12 @@ {-# LANGUAGE PatternSynonyms #-} -module LambdaLifter (lambdaLift, freeVars, abstract) where +module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where import Data.List (mapAccumL) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromMaybe) import Data.Set (Set, (\\)) import qualified Data.Set as Set import Data.Tuple.Extra (uncurry3) @@ -21,7 +21,7 @@ pattern Sc n xs e = ScDef (Bind n xs e) lambdaLift :: Program -> Program -lambdaLift = rename . abstract . freeVars +lambdaLift = collectScs . rename . abstract . freeVars -- Annotate free variables @@ -94,7 +94,7 @@ abstractExp (free, exp) = case exp of e' = foldr EAbs (abstractExp e) (fvList ++ [n]) sc = ELet [bind] (EId (Ident "sc")) --- rename pass +-- Rename rename :: Program -> Program rename (Program ds) = Program $ map (uncurry3 Sc) tuples @@ -108,9 +108,7 @@ rename (Program ds) = Program $ map (uncurry3 Sc) tuples renameExp :: Map Ident Ident -> Int -> Exp -> (Int, Exp) renameExp env i = \case - - EId n -> (i, maybe (error "no") EId $ Map.lookup n env) - + EId n -> (i, EId . fromMaybe n $ Map.lookup n env) EInt i1 -> (i, EInt i1) @@ -157,6 +155,70 @@ getNames i ns = (i + length ss, zipWith makeName ss [i..]) makeName :: String -> Int -> Ident makeName prefix i = Ident (prefix ++ "_" ++ show i) + +-- Collect supercombinators + +collectScs :: Program -> Program +collectScs (Program ds) = Program $ concatMap collect_one_sc ds + where + collect_one_sc (Sc n xs e) = Sc n xs e' : scs + where (scs, e') = collectScsExp e + + + +collectScsExp :: Exp -> ([ScDef], Exp) +collectScsExp = \case + + EId n -> ([], EId n) + + EInt i -> ([], EInt i) + + EApp e1 e2 -> (scs1 ++ scs2, EApp e1' e2') + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + + EAdd e1 e2 -> (scs1 ++ scs2, EAdd e1' e2') + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + + EAbs x e -> (scs, EAbs x e') + where + (scs, e') = collectScsExp e + + ELet bs e -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e') + where + (rhss_scs, bs') = mapAccumL collectScs_d [] bs + scs' = [ Sc n xs rhs | Sc n xs rhs <- bs', isEAbs rhs] + non_scs' = [ Bind n xs rhs | Sc n xs rhs <- bs', not $ isEAbs rhs] + local_scs = map peelLambda scs' + -- local_scs = [ Sc n (xs ++ [x]) e1 | Sc n xs (EAbs x e1) <- scs'] + (e_scs, e') = collectScsExp e + + collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Sc n xs rhs') + where + (rhs_scs1, rhs') = collectScsExp rhs + + + +peelLambda :: ScDef -> ScDef +peelLambda sc@(Sc n xs e) = case e of + EAbs x e1 -> peelLambda (Sc n (xs ++ [x]) e1) + _ -> sc + + + +isEAbs :: Exp -> Bool +isEAbs = \case + EAbs {} -> True + _ -> False + +mkEAbs :: [Bind] -> Exp -> Exp +mkEAbs [] e = e +mkEAbs bs e = ELet bs e + + -- Annotated AST type AnnProgram = [(Ident, [Ident], AnnExp)] diff --git a/src/Main.hs b/src/Main.hs index 58aafe5..ee5a0a1 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,7 @@ module Main where import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) -import LambdaLifter (abstract, freeVars, lambdaLift) +import LambdaLifter (abstract, freeVars, lambdaLift, rename) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) @@ -21,11 +21,6 @@ main = getArgs >>= \case putStrLn "-- Parser" putStrLn $ printTree prg putStrLn "\n--Lamda lifter" - putStrLn "\n--freevars" - print $ freeVars prg - putStrLn "\n--abstract" - putStrLn . printTree $ (abstract . freeVars) prg - putStrLn "\n--renamed" putStrLn . printTree $ lambdaLift prg exitSuccess From 08917be1c6890bd2a760b15713d7d9c6600916d2 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 17:53:39 +0100 Subject: [PATCH 08/20] Fix first unnecessary supercombinator --- Grammar.cf | 9 ++---- basic-2 | 4 --- sample-programs/basic-1 | 2 ++ sample-programs/basic-2 | 4 +++ sample-programs/basic-3 | 2 ++ sample-programs/basic-4 | 2 ++ sample-programs/basic-5 | 9 ++++++ src/LambdaLifter.hs | 72 ++++++++++++++++++++++------------------- src/Main.hs | 8 +++-- test_program | 5 --- 10 files changed, 66 insertions(+), 51 deletions(-) delete mode 100644 basic-2 create mode 100644 sample-programs/basic-1 create mode 100644 sample-programs/basic-2 create mode 100644 sample-programs/basic-3 create mode 100644 sample-programs/basic-4 create mode 100644 sample-programs/basic-5 delete mode 100644 test_program diff --git a/Grammar.cf b/Grammar.cf index 9dba2f5..410d11d 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,12 +1,6 @@ -Program. Program ::= [ScDef]; - -ScDef. ScDef ::= Bind; -separator ScDef ";"; - -separator Ident " "; - +Program. Program ::= [Bind]; EId. Exp3 ::= Ident; EInt. Exp3 ::= Integer; @@ -17,6 +11,7 @@ EAbs. Exp ::= "\\" Ident "." Exp; Bind. Bind ::= Ident [Ident] "=" Exp; separator Bind ";"; +separator Ident " "; coercions Exp 3; diff --git a/basic-2 b/basic-2 deleted file mode 100644 index 8afd060..0000000 --- a/basic-2 +++ /dev/null @@ -1,4 +0,0 @@ -add x = \y. x + y; - -main = (\z. z + z) ((add 4) 6); - diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 new file mode 100644 index 0000000..f109950 --- /dev/null +++ b/sample-programs/basic-1 @@ -0,0 +1,2 @@ + +f = \x. x+1; diff --git a/sample-programs/basic-2 b/sample-programs/basic-2 new file mode 100644 index 0000000..4b8ead0 --- /dev/null +++ b/sample-programs/basic-2 @@ -0,0 +1,4 @@ +add x = \y. x+y; + +main = (\z. z+z) ((add 4) 6); + diff --git a/sample-programs/basic-3 b/sample-programs/basic-3 new file mode 100644 index 0000000..9443439 --- /dev/null +++ b/sample-programs/basic-3 @@ -0,0 +1,2 @@ + +main = (\x. x+x+3) ((\x. x) 2) diff --git a/sample-programs/basic-4 b/sample-programs/basic-4 new file mode 100644 index 0000000..1de7a8c --- /dev/null +++ b/sample-programs/basic-4 @@ -0,0 +1,2 @@ + +f x = let g = (\y. y+1) in g (g x) diff --git a/sample-programs/basic-5 b/sample-programs/basic-5 new file mode 100644 index 0000000..3168484 --- /dev/null +++ b/sample-programs/basic-5 @@ -0,0 +1,9 @@ +id x = x; + +add x y = x + y; + +double n = n + n; + +apply f x = \y -> f x y; + +main = apply (id add) ((\x. x + 1) 1) (double 3); diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 512155d..c9253b6 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where @@ -15,20 +14,14 @@ import Data.Tuple.Extra (uncurry3) import Grammar.Abs import Prelude hiding (exp) -pattern Sc :: Ident -> [Ident] -> Exp -> ScDef -pattern Sc n xs e = ScDef (Bind n xs e) - - - lambdaLift :: Program -> Program lambdaLift = collectScs . rename . abstract . freeVars - -- Annotate free variables freeVars :: Program -> AnnProgram freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) - | Sc n xs e <- ds + | Bind n xs e <- ds ] @@ -64,7 +57,6 @@ freeVarsExp lv = \case freeInValues = foldr1 Set.union (map freeVarsOf es') - freeVarsOf :: AnnExp -> Set Ident freeVarsOf = fst @@ -74,10 +66,21 @@ fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ] -- Lift lambda expression into let with binder "sc" abstract :: AnnProgram -> Program -abstract p = Program - [ Sc sc_name xs $ abstractExp rhs - | (sc_name, xs, rhs) <- p - ] +abstract prog = Program $ map f prog + where + f :: (Ident, [Ident], AnnExp) -> Bind + f (name, pars, rhs@(_, e)) = + case e of + AAbs par body -> Bind name (snoc par pars) $ abstractExp body + _ -> Bind name pars $ abstractExp rhs + + + +-- [ case rhs of +-- EAbs par body -> Bind name (snoc par pars) body +-- _ -> Bind name pars rhs +-- +-- | (name, pars, rhs) <- prog abstractExp :: AnnExp -> Exp @@ -94,13 +97,17 @@ abstractExp (free, exp) = case exp of e' = foldr EAbs (abstractExp e) (fvList ++ [n]) sc = ELet [bind] (EId (Ident "sc")) + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] + -- Rename rename :: Program -> Program -rename (Program ds) = Program $ map (uncurry3 Sc) tuples +rename (Program ds) = Program $ map (uncurry3 Bind) tuples where tuples = snd (mapAccumL renameSc 0 ds) - renameSc i (Sc n xs e) = (i2, (n, xs', e')) + renameSc i (Bind n xs e) = (i2, (n, xs', e')) where (i1, xs', env) = newNames i xs (i2, e') = renameExp env i1 e @@ -159,14 +166,23 @@ makeName prefix i = Ident (prefix ++ "_" ++ show i) -- Collect supercombinators collectScs :: Program -> Program -collectScs (Program ds) = Program $ concatMap collect_one_sc ds +collectScs (Program ds) = Program $ concatMap collectOneSc ds where - collect_one_sc (Sc n xs e) = Sc n xs e' : scs - where (scs, e') = collectScsExp e + collectOneSc (Bind name args rhs) = Bind name args rhs' : scs + where (scs, rhs') = collectScsExp rhs + {- -collectScsExp :: Exp -> ([ScDef], Exp) +Bind (Ident "f") [] + + (ELet [Bind (Ident "sc") [] (EAbs (Ident "x") (EAdd (EId (Ident "x")) (EInt 1)))] (EId (Ident "sc"))) + + + -} + + +collectScsExp :: Exp -> ([Bind], Exp) collectScsExp = \case EId n -> ([], EId n) @@ -190,25 +206,15 @@ collectScsExp = \case ELet bs e -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e') where (rhss_scs, bs') = mapAccumL collectScs_d [] bs - scs' = [ Sc n xs rhs | Sc n xs rhs <- bs', isEAbs rhs] - non_scs' = [ Bind n xs rhs | Sc n xs rhs <- bs', not $ isEAbs rhs] - local_scs = map peelLambda scs' - -- local_scs = [ Sc n (xs ++ [x]) e1 | Sc n xs (EAbs x e1) <- scs'] + scs' = [ Bind n xs rhs | Bind n xs rhs <- bs', isEAbs rhs] + non_scs' = [ Bind n xs rhs | Bind n xs rhs <- bs', not $ isEAbs rhs] + local_scs = [ Bind n (xs ++ [x]) e1 | Bind n xs (EAbs x e1) <- scs'] (e_scs, e') = collectScsExp e - collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Sc n xs rhs') + collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Bind n xs rhs') where (rhs_scs1, rhs') = collectScsExp rhs - - -peelLambda :: ScDef -> ScDef -peelLambda sc@(Sc n xs e) = case e of - EAbs x e1 -> peelLambda (Sc n (xs ++ [x]) e1) - _ -> sc - - - isEAbs :: Exp -> Bool isEAbs = \case EAbs {} -> True diff --git a/src/Main.hs b/src/Main.hs index ee5a0a1..211bf3a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -18,9 +18,13 @@ main = getArgs >>= \case putStrLn err exitFailure Right prg -> do - putStrLn "-- Parser" + putStrLn "-- Parse" putStrLn $ printTree prg - putStrLn "\n--Lamda lifter" + putStrLn "\n-- Abstract" + putStrLn . printTree $ (abstract . freeVars) prg + putStrLn "\n-- Rename" + putStrLn . printTree $ (rename . abstract . freeVars) prg + putStrLn "\n-- Lamda lifter" putStrLn . printTree $ lambdaLift prg exitSuccess diff --git a/test_program b/test_program deleted file mode 100644 index 95235e4..0000000 --- a/test_program +++ /dev/null @@ -1,5 +0,0 @@ - - - - -main = (\x. x + x + 3) ((\x. x) 2) From bd792f7785f0a11a54d64c6ebd7b921a83cd3637 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 20:23:20 +0100 Subject: [PATCH 09/20] Add llvm dep --- shell.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/shell.nix b/shell.nix index 0c7624a..2eaf1cd 100644 --- a/shell.nix +++ b/shell.nix @@ -6,7 +6,7 @@ pkgs.haskellPackages.developPackage { withHoogle = true; modifier = drv: pkgs.haskell.lib.addBuildTools drv ( - (with pkgs; [ hlint haskell-language-server ghc jasmin ]) + (with pkgs; [ hlint haskell-language-server ghc jasmin llvmPackages_15.libllvm]) ++ (with pkgs.haskellPackages; [ cabal-install From 3d8bd24c7bb970e3558d90d97266642119336723 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 20:23:49 +0100 Subject: [PATCH 10/20] Fix basic tests --- Makefile | 7 +++++++ sample-programs/basic-5 | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 16b753d..6e8a54d 100644 --- a/Makefile +++ b/Makefile @@ -22,4 +22,11 @@ clean : rm -r src/Grammar rm language +test : + ./language ./sample-programs/basic-1 + ./language ./sample-programs/basic-2 + ./language ./sample-programs/basic-3 + ./language ./sample-programs/basic-4 + ./language ./sample-programs/basic-5 + # EOF diff --git a/sample-programs/basic-5 b/sample-programs/basic-5 index 3168484..9984ddd 100644 --- a/sample-programs/basic-5 +++ b/sample-programs/basic-5 @@ -4,6 +4,6 @@ add x y = x + y; double n = n + n; -apply f x = \y -> f x y; +apply f x = \y. f x y; main = apply (id add) ((\x. x + 1) 1) (double 3); From 8c094236aafd11e7d4e728a6efaef23c4e815862 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 20:24:06 +0100 Subject: [PATCH 11/20] Add auxiliary module --- Auxiliary.hs | 5 +++++ language.cabal | 1 + 2 files changed, 6 insertions(+) create mode 100644 Auxiliary.hs diff --git a/Auxiliary.hs b/Auxiliary.hs new file mode 100644 index 0000000..cd844d7 --- /dev/null +++ b/Auxiliary.hs @@ -0,0 +1,5 @@ + +module Auxiliary (module Auxiliary) where + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] diff --git a/language.cabal b/language.cabal index 3f4860c..52b2577 100644 --- a/language.cabal +++ b/language.cabal @@ -31,6 +31,7 @@ executable language Grammar.Print Grammar.Skel LambdaLifter + Auxiliary -- Interpreter hs-source-dirs: src From 8663f2ea50197da1f0d2688eaf80734f27ac3e1e Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 20:24:25 +0100 Subject: [PATCH 12/20] Some clean up and documenting --- src/LambdaLifter.hs | 62 +++++++++++++++------------------------------ src/Main.hs | 9 ++++--- 2 files changed, 26 insertions(+), 45 deletions(-) diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index c9253b6..ac9cee0 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -14,17 +14,19 @@ import Data.Tuple.Extra (uncurry3) import Grammar.Abs import Prelude hiding (exp) + + +-- | Lift lambdas and let expression into supercombinators. lambdaLift :: Program -> Program lambdaLift = collectScs . rename . abstract . freeVars --- Annotate free variables +-- | Annotate free variables freeVars :: Program -> AnnProgram freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) | Bind n xs e <- ds ] - freeVarsExp :: Set Ident -> Exp -> AnnExp freeVarsExp lv = \case @@ -63,8 +65,22 @@ freeVarsOf = fst fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp]) fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ] --- Lift lambda expression into let with binder "sc" +-- AST annotated with free variables +type AnnProgram = [(Ident, [Ident], AnnExp)] +type AnnExp = (Set Ident, AnnExp') + +data ABind = ABind Ident [Ident] AnnExp deriving Show + +data AnnExp' = AId Ident + | AInt Integer + | AApp AnnExp AnnExp + | AAdd AnnExp AnnExp + | AAbs Ident AnnExp + | ALet [ABind] AnnExp + deriving Show + +-- | Lift lambdas to let expression of the form @let sc = \x -> rhs@ abstract :: AnnProgram -> Program abstract prog = Program $ map f prog where @@ -74,15 +90,6 @@ abstract prog = Program $ map f prog AAbs par body -> Bind name (snoc par pars) $ abstractExp body _ -> Bind name pars $ abstractExp rhs - - --- [ case rhs of --- EAbs par body -> Bind name (snoc par pars) body --- _ -> Bind name pars rhs --- --- | (name, pars, rhs) <- prog - - abstractExp :: AnnExp -> Exp abstractExp (free, exp) = case exp of AId n -> EId n @@ -101,8 +108,7 @@ abstractExp (free, exp) = case exp of snoc :: a -> [a] -> [a] snoc x xs = xs ++ [x] --- Rename - +-- | Rename all supercombinators and variables rename :: Program -> Program rename (Program ds) = Program $ map (uncurry3 Bind) tuples where @@ -163,24 +169,12 @@ makeName :: String -> Int -> Ident makeName prefix i = Ident (prefix ++ "_" ++ show i) --- Collect supercombinators - +-- | Collects supercombinators by lifting appropriate let expressions collectScs :: Program -> Program collectScs (Program ds) = Program $ concatMap collectOneSc ds where collectOneSc (Bind name args rhs) = Bind name args rhs' : scs where (scs, rhs') = collectScsExp rhs - {- - - - -Bind (Ident "f") [] - - (ELet [Bind (Ident "sc") [] (EAbs (Ident "x") (EAdd (EId (Ident "x")) (EInt 1)))] (EId (Ident "sc"))) - - - -} - collectScsExp :: Exp -> ([Bind], Exp) collectScsExp = \case @@ -225,17 +219,3 @@ mkEAbs [] e = e mkEAbs bs e = ELet bs e --- Annotated AST - -type AnnProgram = [(Ident, [Ident], AnnExp)] -type AnnExp = (Set Ident, AnnExp') - -data ABind = ABind Ident [Ident] AnnExp deriving Show - -data AnnExp' = AId Ident - | AInt Integer - | AApp AnnExp AnnExp - | AAdd AnnExp AnnExp - | AAbs Ident AnnExp - | ALet [ABind] AnnExp - deriving Show diff --git a/src/Main.hs b/src/Main.hs index 211bf3a..9af1753 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -20,12 +20,13 @@ main = getArgs >>= \case Right prg -> do putStrLn "-- Parse" putStrLn $ printTree prg - putStrLn "\n-- Abstract" - putStrLn . printTree $ (abstract . freeVars) prg - putStrLn "\n-- Rename" - putStrLn . printTree $ (rename . abstract . freeVars) prg + -- putStrLn "\n-- Abstract" + -- putStrLn . printTree $ (abstract . freeVars) prg + -- putStrLn "\n-- Rename" + -- putStrLn . printTree $ (rename . abstract . freeVars) prg putStrLn "\n-- Lamda lifter" putStrLn . printTree $ lambdaLift prg + putStrLn "" exitSuccess From ece621b0aa9ee3f331e4226687e045379992e336 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 20:25:00 +0100 Subject: [PATCH 13/20] Fix auxiliary path --- Auxiliary.hs => src/Auxiliary.hs | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename Auxiliary.hs => src/Auxiliary.hs (100%) diff --git a/Auxiliary.hs b/src/Auxiliary.hs similarity index 100% rename from Auxiliary.hs rename to src/Auxiliary.hs From 8688b303ac9593f3dc107c3778f6392b18ca8aef Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Fri, 10 Feb 2023 11:47:07 +0100 Subject: [PATCH 14/20] Fix unnecessary supercombinator issue --- Grammar.cf | 2 +- sample-programs/basic-6 | 3 ++ sample-programs/basic-7 | 5 +++ src/LambdaLifter.hs | 89 ++++++++++++++++++++++++----------------- src/Main.hs | 6 +-- 5 files changed, 62 insertions(+), 43 deletions(-) create mode 100644 sample-programs/basic-6 create mode 100644 sample-programs/basic-7 diff --git a/Grammar.cf b/Grammar.cf index 410d11d..72e01da 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -7,7 +7,7 @@ EInt. Exp3 ::= Integer; ELet. Exp3 ::= "let" [Bind] "in" Exp; EApp. Exp2 ::= Exp2 Exp3; EAdd. Exp1 ::= Exp1 "+" Exp2; -EAbs. Exp ::= "\\" Ident "." Exp; +EAbs. Exp ::= "\\" [Ident] "." Exp; Bind. Bind ::= Ident [Ident] "=" Exp; separator Bind ";"; diff --git a/sample-programs/basic-6 b/sample-programs/basic-6 new file mode 100644 index 0000000..511ae10 --- /dev/null +++ b/sample-programs/basic-6 @@ -0,0 +1,3 @@ + + +f = \x.\y. x+y diff --git a/sample-programs/basic-7 b/sample-programs/basic-7 new file mode 100644 index 0000000..b3769b9 --- /dev/null +++ b/sample-programs/basic-7 @@ -0,0 +1,5 @@ +add x y = x + y; + +apply f x = f x; + +main = apply (add 4) 6; diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index ac9cee0..e8862a2 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -4,7 +4,7 @@ module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where -import Data.List (mapAccumL) +import Data.List (mapAccumL, partition) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) @@ -33,7 +33,7 @@ freeVarsExp lv = \case EId n | Set.member n lv -> (Set.singleton n, AId n) | otherwise -> (mempty, AId n) - EInt i -> (mempty, AInt i) + EInt i -> (mempty, AInt i) EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp e1' e2') where e1' = freeVarsExp lv e1 @@ -43,8 +43,8 @@ freeVarsExp lv = \case where e1' = freeVarsExp lv e1 e2' = freeVarsExp lv e2 - EAbs n e -> (Set.delete n $ freeVarsOf e', AAbs n e') - where e' = freeVarsExp (Set.insert n lv) e + EAbs parms e -> (freeVarsOf e' \\ Set.fromList parms, AAbs parms e') + where e' = freeVarsExp (foldr Set.insert lv parms) e ELet bs e -> (Set.union bsFree eFree, ALet bs' e') where @@ -76,18 +76,20 @@ data AnnExp' = AId Ident | AInt Integer | AApp AnnExp AnnExp | AAdd AnnExp AnnExp - | AAbs Ident AnnExp + | AAbs [Ident] AnnExp | ALet [ABind] AnnExp deriving Show --- | Lift lambdas to let expression of the form @let sc = \x -> rhs@ +-- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. +-- Free variables are @v₁ v₂ .. vₙ@ are bound. abstract :: AnnProgram -> Program -abstract prog = Program $ map f prog +abstract prog = Program $ map go prog where - f :: (Ident, [Ident], AnnExp) -> Bind - f (name, pars, rhs@(_, e)) = + go :: (Ident, [Ident], AnnExp) -> Bind + go (name, pars, rhs@(_, e)) = + case e of - AAbs par body -> Bind name (snoc par pars) $ abstractExp body + AAbs pars1 e1 -> Bind name (pars ++ pars1) $ abstractExp e1 _ -> Bind name pars $ abstractExp rhs abstractExp :: AnnExp -> Exp @@ -96,17 +98,21 @@ abstractExp (free, exp) = case exp of AInt i -> EInt i AApp e1 e2 -> EApp (abstractExp e1) (abstractExp e2) AAdd e1 e2 -> EAdd (abstractExp e1) (abstractExp e2) - ALet bs e -> ELet [Bind n xs (abstractExp e1) | ABind n xs e1 <- bs ] $ abstractExp e - AAbs n e -> foldl EApp sc (map EId fvList) + ALet bs e -> ELet (map go bs) $ abstractExp e where - fvList = Set.toList free - bind = Bind "sc" [] e' - e' = foldr EAbs (abstractExp e) (fvList ++ [n]) - sc = ELet [bind] (EId (Ident "sc")) + go (ABind name parms rhs) = Bind name parms $ skipLambdas abstractExp rhs + skipLambdas :: (AnnExp -> Exp) -> AnnExp -> Exp + skipLambdas f (free, ae) = case ae of + AAbs name ae1 -> EAbs name $ skipLambdas f ae1 + _ -> f (free, ae) -snoc :: a -> [a] -> [a] -snoc x xs = xs ++ [x] + -- Lift lambda into let and bind free variables + AAbs parms e -> foldl EApp sc $ map EId freeList + where + freeList = Set.toList free + sc = ELet [Bind "sc" [] rhs] $ EId "sc" + rhs = EAbs (freeList ++ parms) $ abstractExp e -- | Rename all supercombinators and variables rename :: Program -> Program @@ -144,9 +150,9 @@ renameExp env i = \case (i3, es') = mapAccumL (renameExp e_env) i2 es - EAbs n e -> (i2, EAbs (head ns) e') + EAbs parms e -> (i2, EAbs ns e') where - (i1, ns, env') = newNames i [n] + (i1, ns, env') = newNames i parms (i2, e') = renameExp (Map.union env' env ) i1 e @@ -156,10 +162,6 @@ newNames i old_names = (i', new_names, env) (i', new_names) = getNames i old_names env = Map.fromList $ zip old_names new_names - -getName :: Int -> Ident -> (Int, Ident) -getName i (Ident s) = (i + 1, makeName s i) - getNames :: Int -> [Ident] -> (Int, [Ident]) getNames i ns = (i + length ss, zipWith makeName ss [i..]) where @@ -171,16 +173,16 @@ makeName prefix i = Ident (prefix ++ "_" ++ show i) -- | Collects supercombinators by lifting appropriate let expressions collectScs :: Program -> Program -collectScs (Program ds) = Program $ concatMap collectOneSc ds +collectScs (Program scs) = Program $ concatMap collectFromRhs scs where - collectOneSc (Bind name args rhs) = Bind name args rhs' : scs - where (scs, rhs') = collectScsExp rhs + collectFromRhs (Bind name parms rhs) = + let (rhs_scs, rhs') = collectScsExp rhs + in Bind name parms rhs' : rhs_scs + collectScsExp :: Exp -> ([Bind], Exp) collectScsExp = \case - EId n -> ([], EId n) - EInt i -> ([], EInt i) EApp e1 e2 -> (scs1 ++ scs2, EApp e1' e2') @@ -197,17 +199,30 @@ collectScsExp = \case where (scs, e') = collectScsExp e - ELet bs e -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e') + -- Collect supercombinators from binds, the rhss, and the expression, + -- and the rhss. + -- + -- > f = let + -- > sc = rhs + -- > sc1 = rhs1 + -- > ... + -- > in e + -- + ELet binds e -> (binds_scs ++ rhss_scs ++ e_scs, mkEAbs non_scs' e') where - (rhss_scs, bs') = mapAccumL collectScs_d [] bs - scs' = [ Bind n xs rhs | Bind n xs rhs <- bs', isEAbs rhs] - non_scs' = [ Bind n xs rhs | Bind n xs rhs <- bs', not $ isEAbs rhs] - local_scs = [ Bind n (xs ++ [x]) e1 | Bind n xs (EAbs x e1) <- scs'] - (e_scs, e') = collectScsExp e + binds_scs = [ Bind n (parms ++ parms1) e1 + | Bind n parms (EAbs parms1 e1) <- scs' + ] + (rhss_scs, binds') = mapAccumL collectScsRhs [] binds + (e_scs, e') = collectScsExp e - collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Bind n xs rhs') + (scs', non_scs') = partition (\(Bind _ _ rhs) -> isEAbs rhs) binds' + + collectScsRhs acc (Bind n xs rhs) = (acc ++ rhs_scs, Bind n xs rhs') where - (rhs_scs1, rhs') = collectScsExp rhs + (rhs_scs, rhs') = collectScsExp rhs + + isEAbs :: Exp -> Bool isEAbs = \case diff --git a/src/Main.hs b/src/Main.hs index 9af1753..570ac1a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,7 @@ module Main where import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) -import LambdaLifter (abstract, freeVars, lambdaLift, rename) +import LambdaLifter (lambdaLift) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) @@ -20,10 +20,6 @@ main = getArgs >>= \case Right prg -> do putStrLn "-- Parse" putStrLn $ printTree prg - -- putStrLn "\n-- Abstract" - -- putStrLn . printTree $ (abstract . freeVars) prg - -- putStrLn "\n-- Rename" - -- putStrLn . printTree $ (rename . abstract . freeVars) prg putStrLn "\n-- Lamda lifter" putStrLn . printTree $ lambdaLift prg putStrLn "" From 5956cdf121c51053ad5353aa01996bad19be1a34 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Fri, 10 Feb 2023 11:49:17 +0100 Subject: [PATCH 15/20] Fix typo --- src/LambdaLifter.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index e8862a2..79f8230 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -199,8 +199,7 @@ collectScsExp = \case where (scs, e') = collectScsExp e - -- Collect supercombinators from binds, the rhss, and the expression, - -- and the rhss. + -- Collect supercombinators from binds, the rhss, and the expression. -- -- > f = let -- > sc = rhs From f3600ffdf8825e7252888ac8a5df747e04469c0c Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Fri, 10 Feb 2023 16:44:55 +0100 Subject: [PATCH 16/20] Fix documentation and small things --- src/LambdaLifter.hs | 50 +++++++++++++++++++++++---------------------- 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 79f8230..625041c 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -15,7 +15,6 @@ import Grammar.Abs import Prelude hiding (exp) - -- | Lift lambdas and let expression into supercombinators. lambdaLift :: Program -> Program lambdaLift = collectScs . rename . abstract . freeVars @@ -28,42 +27,49 @@ freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) ] freeVarsExp :: Set Ident -> Exp -> AnnExp -freeVarsExp lv = \case +freeVarsExp localVars = \case - EId n | Set.member n lv -> (Set.singleton n, AId n) + EId n | Set.member n localVars -> (Set.singleton n, AId n) | otherwise -> (mempty, AId n) EInt i -> (mempty, AInt i) EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp e1' e2') - where e1' = freeVarsExp lv e1 - e2' = freeVarsExp lv e2 + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd e1' e2') - where e1' = freeVarsExp lv e1 - e2' = freeVarsExp lv e2 + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 EAbs parms e -> (freeVarsOf e' \\ Set.fromList parms, AAbs parms e') - where e' = freeVarsExp (foldr Set.insert lv parms) e - - ELet bs e -> (Set.union bsFree eFree, ALet bs' e') where - bsFree = freeInValues \\ nsSet - eFree = freeVarsOf e' \\ nsSet - bs' = zipWith3 ABind ns xs es' - e' = freeVarsExp e_lv e - (ns, xs, es) = fromBinders bs - nsSet = Set.fromList ns - e_lv = Set.union lv nsSet - es' = map (freeVarsExp e_lv) es - freeInValues = foldr1 Set.union (map freeVarsOf es') + e' = freeVarsExp (foldr Set.insert localVars parms) e + + -- Sum free variables present in binders and the expression + ELet binders e -> (Set.union binders_frees e_free, ALet binders' e') + where + binders_frees = rhss_frees \\ names_set + e_free = freeVarsOf e' \\ names_set + + rhss_frees = foldr1 Set.union (map freeVarsOf rhss') + names_set = Set.fromList names + + (names, parms, rhss) = fromBinders binders + rhss' = map (freeVarsExp e_localVars) rhss + e_localVars = Set.union localVars names_set + + binders' = zipWith3 ABind names parms rhss' + e' = freeVarsExp e_localVars e freeVarsOf :: AnnExp -> Set Ident freeVarsOf = fst fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp]) -fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ] +fromBinders bs = unzip3 [ (name, parms, rhs) | Bind name parms rhs <- bs ] -- AST annotated with free variables type AnnProgram = [(Ident, [Ident], AnnExp)] @@ -221,8 +227,6 @@ collectScsExp = \case where (rhs_scs, rhs') = collectScsExp rhs - - isEAbs :: Exp -> Bool isEAbs = \case EAbs {} -> True @@ -231,5 +235,3 @@ isEAbs = \case mkEAbs :: [Bind] -> Exp -> Exp mkEAbs [] e = e mkEAbs bs e = ELet bs e - - From 78a3ed56ea8285a50406960c3564e702f790ee7c Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Fri, 10 Feb 2023 16:55:56 +0100 Subject: [PATCH 17/20] Add test --- sample-programs/basic-8 | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 sample-programs/basic-8 diff --git a/sample-programs/basic-8 b/sample-programs/basic-8 new file mode 100644 index 0000000..59abdac --- /dev/null +++ b/sample-programs/basic-8 @@ -0,0 +1,2 @@ + +f x = let double = \y. y+y in (\x. x+y) 4; From e212c79a4448d3b7d2b92b7cb464b6a1da04514a Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 11 Feb 2023 09:59:26 +0100 Subject: [PATCH 18/20] Revert back to one lambda par, and fix issues with lambda lifter --- Grammar.cf | 2 +- src/Auxiliary.hs | 6 +++ src/LambdaLifter.hs | 96 ++++++++++++++++++++++++++++++--------------- src/Main.hs | 4 +- 4 files changed, 73 insertions(+), 35 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 72e01da..410d11d 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -7,7 +7,7 @@ EInt. Exp3 ::= Integer; ELet. Exp3 ::= "let" [Bind] "in" Exp; EApp. Exp2 ::= Exp2 Exp3; EAdd. Exp1 ::= Exp1 "+" Exp2; -EAbs. Exp ::= "\\" [Ident] "." Exp; +EAbs. Exp ::= "\\" Ident "." Exp; Bind. Bind ::= Ident [Ident] "=" Exp; separator Bind ";"; diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs index cd844d7..2de36a7 100644 --- a/src/Auxiliary.hs +++ b/src/Auxiliary.hs @@ -1,5 +1,11 @@ module Auxiliary (module Auxiliary) where +import Control.Monad.Error.Class (liftEither) +import Control.Monad.Except (MonadError) +import Data.Either.Combinators (maybeToRight) snoc :: a -> [a] -> [a] snoc x xs = xs ++ [x] + +maybeToRightM :: MonadError l m => l -> Maybe r -> m r +maybeToRightM err = liftEither . maybeToRight err diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 625041c..3d9595d 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -4,15 +4,17 @@ module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where -import Data.List (mapAccumL, partition) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Set (Set, (\\)) -import qualified Data.Set as Set -import Data.Tuple.Extra (uncurry3) +import Auxiliary (snoc) +import Data.Foldable.Extra (notNull) +import Data.List (mapAccumL, mapAccumR, partition) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Set (Set, (\\)) +import qualified Data.Set as Set +import Data.Tuple.Extra (uncurry3) import Grammar.Abs -import Prelude hiding (exp) +import Prelude hiding (exp) -- | Lift lambdas and let expression into supercombinators. @@ -44,9 +46,9 @@ freeVarsExp localVars = \case e1' = freeVarsExp localVars e1 e2' = freeVarsExp localVars e2 - EAbs parms e -> (freeVarsOf e' \\ Set.fromList parms, AAbs parms e') + EAbs par e -> (Set.delete par $ freeVarsOf e', AAbs par e') where - e' = freeVarsExp (foldr Set.insert localVars parms) e + e' = freeVarsExp (Set.insert par localVars) e -- Sum free variables present in binders and the expression ELet binders e -> (Set.union binders_frees e_free, ALet binders' e') @@ -82,7 +84,7 @@ data AnnExp' = AId Ident | AInt Integer | AApp AnnExp AnnExp | AAdd AnnExp AnnExp - | AAbs [Ident] AnnExp + | AAbs Ident AnnExp | ALet [ABind] AnnExp deriving Show @@ -93,10 +95,24 @@ abstract prog = Program $ map go prog where go :: (Ident, [Ident], AnnExp) -> Bind go (name, pars, rhs@(_, e)) = - case e of - AAbs pars1 e1 -> Bind name (pars ++ pars1) $ abstractExp e1 - _ -> Bind name pars $ abstractExp rhs + AAbs par e1 -> Bind name (snoc par pars ++ pars2) $ abstractExp e2 + where + (e2, pars2) = flattenLambdasAnn e1 + _ -> Bind name pars $ abstractExp rhs + + +-- | Flatten nested lambdas and collect the parameters +-- @\x.\y.\z. ae → (ae, [x,y,z])@ +flattenLambdasAnn :: AnnExp -> (AnnExp, [Ident]) +flattenLambdasAnn ae = go (ae, []) + where + go :: (AnnExp, [Ident]) -> (AnnExp, [Ident]) + go ((free, e), acc) = + case e of + AAbs par (free1, e1) -> go ((Set.delete par free1, e1), snoc par acc) + _ -> ((free, e), acc) + abstractExp :: AnnExp -> Exp abstractExp (free, exp) = case exp of @@ -106,7 +122,11 @@ abstractExp (free, exp) = case exp of AAdd e1 e2 -> EAdd (abstractExp e1) (abstractExp e2) ALet bs e -> ELet (map go bs) $ abstractExp e where - go (ABind name parms rhs) = Bind name parms $ skipLambdas abstractExp rhs + go (ABind name parms rhs) = + let + (rhs', parms1) = flattenLambdas $ skipLambdas abstractExp rhs + in + Bind name (parms ++ parms1) rhs' skipLambdas :: (AnnExp -> Exp) -> AnnExp -> Exp skipLambdas f (free, ae) = case ae of @@ -114,11 +134,10 @@ abstractExp (free, exp) = case exp of _ -> f (free, ae) -- Lift lambda into let and bind free variables - AAbs parms e -> foldl EApp sc $ map EId freeList + AAbs par e -> foldl EApp sc $ map EId freeList where freeList = Set.toList free - sc = ELet [Bind "sc" [] rhs] $ EId "sc" - rhs = EAbs (freeList ++ parms) $ abstractExp e + sc = ELet [Bind "sc" (snoc par freeList) $ abstractExp e] $ EId "sc" -- | Rename all supercombinators and variables rename :: Program -> Program @@ -147,21 +166,30 @@ renameExp env i = \case (i1, e1') = renameExp env i e1 (i2, e2') = renameExp env i1 e2 - ELet bs e -> (i3, ELet (zipWith3 Bind ns' xs es') e') + ELet bs e -> (i3, ELet (zipWith3 Bind ns' pars' es') e') where (i1, e') = renameExp e_env i e - (ns, xs, es) = fromBinders bs - (i2, ns', env') = newNames i1 ns + (names, pars, rhss) = fromBinders bs + (i2, ns', env') = newNames i1 (names ++ concat pars) + pars' = (map . map) renamePar pars e_env = Map.union env' env - (i3, es') = mapAccumL (renameExp e_env) i2 es + (i3, es') = mapAccumL (renameExp e_env) i2 rhss + + renamePar p = case Map.lookup p env' of + Just p' -> p' + Nothing -> error ("Can't find name for " ++ show p) - EAbs parms e -> (i2, EAbs ns e') + EAbs par e -> (i2, EAbs par' e') where - (i1, ns, env') = newNames i parms - (i2, e') = renameExp (Map.union env' env ) i1 e + (i1, par', env') = newName par + (i2, e') = renameExp (Map.union env' env ) i1 e +newName :: Ident -> (Int, Ident, Map Ident Ident) +newName old_name = (i, head names, env) + where (i, names, env) = newNames 1 [old_name] + newNames :: Int -> [Ident] -> (Int, [Ident], Map Ident Ident) newNames i old_names = (i', new_names, env) where @@ -215,22 +243,26 @@ collectScsExp = \case -- ELet binds e -> (binds_scs ++ rhss_scs ++ e_scs, mkEAbs non_scs' e') where - binds_scs = [ Bind n (parms ++ parms1) e1 - | Bind n parms (EAbs parms1 e1) <- scs' + binds_scs = [ let (rhs', parms1) = flattenLambdas rhs in + Bind n (parms ++ parms1) rhs' + | Bind n parms rhs <- scs' ] (rhss_scs, binds') = mapAccumL collectScsRhs [] binds (e_scs, e') = collectScsExp e - (scs', non_scs') = partition (\(Bind _ _ rhs) -> isEAbs rhs) binds' + (scs', non_scs') = partition (\(Bind _ pars _) -> notNull pars) binds' collectScsRhs acc (Bind n xs rhs) = (acc ++ rhs_scs, Bind n xs rhs') where (rhs_scs, rhs') = collectScsExp rhs -isEAbs :: Exp -> Bool -isEAbs = \case - EAbs {} -> True - _ -> False +-- @\x.\y.\z. e → (e, [x,y,z])@ +flattenLambdas :: Exp -> (Exp, [Ident]) +flattenLambdas e = go (e, []) + where + go (e, acc) = case e of + EAbs par e1 -> go (e1, snoc par acc) + _ -> (e, acc) mkEAbs :: [Bind] -> Exp -> Exp mkEAbs [] e = e diff --git a/src/Main.hs b/src/Main.hs index 570ac1a..ba6edf2 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,7 @@ module Main where import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) -import LambdaLifter (lambdaLift) +import LambdaLifter (abstract, freeVars, lambdaLift) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) @@ -20,7 +20,7 @@ main = getArgs >>= \case Right prg -> do putStrLn "-- Parse" putStrLn $ printTree prg - putStrLn "\n-- Lamda lifter" + putStrLn "\n-- Lambda lifter" putStrLn . printTree $ lambdaLift prg putStrLn "" exitSuccess From d67eddcf0fb8a542f1b644a2b80c5fe0fd47efe2 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 11 Feb 2023 11:04:39 +0100 Subject: [PATCH 19/20] Fix interpreter --- Makefile | 5 +++ language.cabal | 3 +- sample-programs/basic-9 | 4 +++ src/Interpreter.hs | 75 +++++++++++++++++++++++++++++++---------- src/Main.hs | 51 ++++++++++++++++++++-------- 5 files changed, 105 insertions(+), 33 deletions(-) create mode 100644 sample-programs/basic-9 diff --git a/Makefile b/Makefile index 6e8a54d..d9098d1 100644 --- a/Makefile +++ b/Makefile @@ -28,5 +28,10 @@ test : ./language ./sample-programs/basic-3 ./language ./sample-programs/basic-4 ./language ./sample-programs/basic-5 + ./language ./sample-programs/basic-5 + ./language ./sample-programs/basic-6 + ./language ./sample-programs/basic-7 + ./language ./sample-programs/basic-8 + ./language ./sample-programs/basic-9 # EOF diff --git a/language.cabal b/language.cabal index 52b2577..0577abe 100644 --- a/language.cabal +++ b/language.cabal @@ -30,9 +30,10 @@ executable language Grammar.Par Grammar.Print Grammar.Skel + Grammar.ErrM LambdaLifter Auxiliary - -- Interpreter + Interpreter hs-source-dirs: src diff --git a/sample-programs/basic-9 b/sample-programs/basic-9 new file mode 100644 index 0000000..ba9ebdc --- /dev/null +++ b/sample-programs/basic-9 @@ -0,0 +1,4 @@ + + + +main = (\f.\x.\y. f x + f y) (\x. x+x) ((\x. x+1) ((\x. x+3) 2)) 4 diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 378c95b..3503a7c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,38 +1,72 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} module Interpreter where +import Auxiliary (maybeToRightM) import Control.Applicative (Applicative) import Control.Monad.Except (Except, MonadError (throwError), liftEither) +import Control.Monad.State (MonadState, StateT, evalStateT) import Data.Either.Combinators (maybeToRight) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (maybe) import Grammar.Abs +import Grammar.ErrM (Err) 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 +interpret :: Program -> Err Integer +interpret (Program scs) = do + main <- findMain scs + eval (initCxt scs) main >>= + \case + VClosure {} -> throwError "main evaluated to a function" + VInt i -> pure i +initCxt :: [Bind] -> Cxt +initCxt scs = + Cxt { env = mempty + , sig = foldr insert mempty $ map expandLambdas scs + } + where insert (Bind name _ rhs) = Map.insert name rhs + +expandLambdas :: Bind -> Bind +expandLambdas (Bind name parms rhs) = Bind name [] $ foldr EAbs rhs parms + + +findMain :: [Bind] -> Err Exp +findMain [] = throwError "No main!" +findMain (sc:scs) = case sc of + Bind "main" _ rhs -> pure rhs + _ -> findMain scs + data Val = VInt Integer - | VClosure Cxt Ident Exp + | VClosure Env Ident Exp + deriving (Show, Eq) -type Cxt = Map Ident Val +type Env = Map Ident Val +type Sig = Map Ident Exp -eval :: Cxt -> Exp -> Except String Val +data Cxt = Cxt + { env :: Map Ident Val + , sig :: Map Ident Exp + } deriving (Show, Eq) + +eval :: Cxt -> Exp -> Err Val eval cxt = \case - -- ------------ x ∈ γ -- γ ⊢ x ⇓ γ(x) - EId x -> - maybeToRightM - ("Unbound variable:" ++ printTree x) - $ Map.lookup x cxt + EId x -> do + case Map.lookup x cxt.env of + Just e -> pure e + Nothing -> + case Map.lookup x cxt.sig of + Just e -> eval (emptyEnv cxt) e + Nothing -> throwError ("Unbound variable: " ++ printTree x) -- --------- -- γ ⊢ i ⇓ i @@ -50,13 +84,15 @@ eval cxt = \case VInt _ -> throwError "Not a function" VClosure delta x f -> do v <- eval cxt e1 - eval (Map.insert x v delta) f + let cxt' = putEnv (Map.insert x v delta) cxt + eval cxt' f + -- -- ----------------------------- -- γ ⊢ λx. f ⇓ let γ in λx. f - EAbs x e -> pure $ VClosure cxt x e + EAbs par e -> pure $ VClosure cxt.env par e -- γ ⊢ e ⇓ v @@ -71,8 +107,11 @@ eval cxt = \case (VInt i, VInt i1) -> pure $ VInt (i + i1) _ -> throwError "Can't add a function" + ELet _ _ -> throwError "ELet pattern match should never occur!" -maybeToRightM :: MonadError l m => l -> Maybe r -> m r -maybeToRightM err = liftEither . maybeToRight err +emptyEnv :: Cxt -> Cxt +emptyEnv cxt = cxt { env = mempty } +putEnv :: Env -> Cxt -> Cxt +putEnv env cxt = cxt { env = env } diff --git a/src/Main.hs b/src/Main.hs index ba6edf2..0602f6e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,8 +1,10 @@ {-# LANGUAGE LambdaCase #-} module Main where +import Grammar.ErrM (Err) import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) +import Interpreter (interpret) import LambdaLifter (abstract, freeVars, lambdaLift) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) @@ -10,20 +12,41 @@ import System.Exit (exitFailure, exitSuccess) main :: IO () 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 -> do - putStrLn "-- Parse" - putStrLn $ printTree prg - putStrLn "\n-- Lambda lifter" - putStrLn . printTree $ lambdaLift prg - putStrLn "" - exitSuccess + (s:_) -> main' s + +main' :: String -> IO () +main' s = do + file <- readFile s + + putStrLn "\n-- parse" + parsed <- fromSyntaxErr . pProgram $ myLexer file + putStrLn $ printTree parsed + + putStrLn "\n-- Lambda Lifter" + let lifted = lambdaLift parsed + putStrLn $ printTree lifted + + interpred <- fromInterpreterErr $ interpret lifted + putStrLn "\n-- interpret" + print interpred + + exitSuccess +fromSyntaxErr :: Err a -> IO a +fromSyntaxErr = either + (\err -> do + putStrLn "\nSYNTAX ERROR" + putStrLn err + exitFailure) + pure + +fromInterpreterErr :: Err a -> IO a +fromInterpreterErr = either + (\err -> do + putStrLn "\nINTERPRETER ERROR" + putStrLn err + exitFailure) + pure + From 3fe990ceaa8d30968eba616b70b1c63e70223791 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sun, 12 Feb 2023 13:01:12 +0100 Subject: [PATCH 20/20] Don't run interpreter by default --- src/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 0602f6e..41379fc 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -26,9 +26,9 @@ main' s = do let lifted = lambdaLift parsed putStrLn $ printTree lifted - interpred <- fromInterpreterErr $ interpret lifted - putStrLn "\n-- interpret" - print interpred + -- interpred <- fromInterpreterErr $ interpret lifted + -- putStrLn "\n-- interpret" + -- print interpred exitSuccess