Merge pull request #2 from bachelor-group-66-systemf/basic

Basic

.gitignore

@@ -1 +1,4 @@
 dist-newstyle
+*.y
+*.x
+*.bak

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 "{-" "-}" ;
+

language.cabal

@@ -1,77 +1,44 @@
 cabal-version:      3.0
--- The cabal-version field refers to the version of the .cabal specification,
--- and can be different from the cabal-install (the tool) version and the
--- Cabal (the library) version you are using. As such, the Cabal (the library)
--- version used must be equal or greater than the version stated in this field.
--- Starting from the specification version 2.2, the cabal-version field must be
--- the first thing in the cabal file.
 
--- Initial package description 'language' generated by
--- 'cabal init'. For further documentation, see:
---   http://haskell.org/cabal/users-guide/
---
--- The name of the package.
 name:               language
 
--- The package version.
--- See the Haskell package versioning policy (PVP) for standards
--- guiding when and how versions should be incremented.
--- https://pvp.haskell.org
--- PVP summary:     +-+------- breaking API changes
---                  | | +----- non-breaking API additions
---                  | | | +--- code changes with no API change
 version:            0.1.0.0
-
--- A short (one-line) description of the package.
--- synopsis:
-
--- A longer description of the package.
--- description:
-
--- The license under which the package is released.
 license:            MIT
-
--- The file containing the license text.
 license-file:       LICENSE
-
--- The package author(s).
 author:             bachelor-group-66-systemf
-
--- An email address to which users can send suggestions, bug reports, and patches.
 maintainer:         sebastian.selander@gmail.com
-
--- A copyright notice.
--- copyright:
 category:           Language
 build-type:         Simple
 
--- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.
 extra-doc-files:    CHANGELOG.md
 
--- Extra source files to be distributed with the package, such as examples, or a tutorial module.
+extra-source-fiels:
--- extra-source-files:
+  Grammar.cf
+
 
 common warnings
     ghc-options: -Wall
 
 executable language
-    -- Import common warning flags.
     import:           warnings
 
-    -- .hs or .lhs file containing the Main module.
     main-is:          Main.hs
 
-    -- Modules included in this executable, other than Main.
+    other-modules:
-    -- other-modules:
+      Grammar.Abs
+      Grammar.Lex
+      Grammar.Par
+      Grammar.Print
+      Grammar.Skel
+      Interpreter
 
-    -- LANGUAGE extensions used by modules in this package.
-    -- other-extensions:
-
-    -- Other library packages from which modules are imported.
-    build-depends:    base ^>=4.16.3.0
-
-    -- Directories containing source files.
     hs-source-dirs:   src
 
-    -- Base language which the package is written in.
+    build-depends:    
+        base ^>=4.16.3.0
+      , mtl
+      , containers
+      , either
+      , array
+
     default-language: GHC2021

shell.nix

@@ -6,9 +6,15 @@ pkgs.haskellPackages.developPackage {
   withHoogle = true;
   modifier = drv:
   pkgs.haskell.lib.addBuildTools drv (
-    (with pkgs; [ hlint haskell-language-server ghc ])
+    (with pkgs; [ hlint haskell-language-server ghc jasmin ])
     ++
-    (with pkgs.haskellPackages; [ cabal-install stylish-haskell ])
+    (with pkgs.haskellPackages; [ 
+      cabal-install
+      stylish-haskell 
+      BNFC 
+      alex
+      happy
+    ])
   );
 }
 

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)
+

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).

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

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])

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

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
+

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 + 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
+

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
+
+
+

test_program

@@ -0,0 +1,5 @@
+
+
+
+
+main = (\x -> x + x + 3) ((\x -> x) 2)