This commit is contained in:
Rachel Lambda Samuelsson 2024-06-10 22:14:40 +02:00
parent 58e3c8e237
commit 8b19a37d79
8 changed files with 63 additions and 27 deletions

View File

@ -1,4 +1,41 @@
module Main where module Main where
import Text.Megaparsec.Error (errorBundlePretty)
import System.Environment
import System.IO
import System.Exit
import qualified Data.Text.IO as T
import Control.Monad ((<=<))
import Parse (parseExpr)
import Type (infer)
import CompChez (comp)
import Eval (eval)
main :: IO () main :: IO ()
main = putTextLn "mjau" main = getArgs >>= \case
[] -> processFile "stdin" stdin
xs -> mapM_ (\file -> processFile file =<< openFile file ReadMode) xs
putStyle :: String -> IO () -- bold blue :)
putStyle s = putStrLn ("\x1b[38;5;87m\x1b[1m=>> " ++ s ++ "\x1b[0m")
processFile :: String -> Handle -> IO ()
processFile f h = do
contents <- T.hGetContents h
case parseExpr f contents of
Left e -> putStrLn (errorBundlePretty e)
Right ast -> do
putStyle "Parse Successful"
print ast
putStyle "Type Checking / Inferring"
case infer [] ast of
Nothing -> putStrLn "=> Type error" >> exitWith (ExitFailure 1)
Just t -> print t
putStyle "Compiling to Chez"
putStrLn (comp ast)
putStyle "Evaluating"
print (eval [] ast)

6
example/fib Normal file
View File

@ -0,0 +1,6 @@
let fib : Int -> Int = fix \f.\x.
if 2 > x
then 1
else f (x-1) + f (x-2)
in fib 10

View File

@ -13,6 +13,8 @@ executable gecco
build-depends: base build-depends: base
, gecco , gecco
, megaparsec
, text
hs-source-dirs: app hs-source-dirs: app
default-language: GHC2021 default-language: GHC2021
default-extensions: LambdaCase default-extensions: LambdaCase
@ -20,9 +22,7 @@ executable gecco
library library
exposed-modules: Core exposed-modules: Syn
, Val
, Syn
, Eval , Eval
, Type , Type
, Parse , Parse

View File

@ -1,4 +0,0 @@
module Core where
test :: String
test = "mjau"

View File

@ -1,7 +1,20 @@
module Eval where module Eval where
import Syn import Syn
import Val
data Val
= I Int
| B Bool
| U
| Clos (Val -> Val)
instance Show Val where
show (I i) = "I " ++ show i
show (B b) = "B " ++ show b
show U = "U"
show (Clos _) = "<CLOS>"
type Ctx = [Val]
eval :: Ctx -> Syn -> Val eval :: Ctx -> Syn -> Val
eval ctx (Var i) = ctx !! i eval ctx (Var i) = ctx !! i

View File

@ -25,8 +25,8 @@ instance ShowErrorComponent Text where
skipSpace :: Parser () skipSpace :: Parser ()
skipSpace = L.space space1 (L.skipLineComment "--") (L.skipBlockComment "{-" "-}") skipSpace = L.space space1 (L.skipLineComment "--") (L.skipBlockComment "{-" "-}")
parseExpr :: Text -> Either (ParseErrorBundle Text Text) Syn parseExpr :: String -> Text -> Either (ParseErrorBundle Text Text) Syn
parseExpr = parse (parser []) "<FILE>" parseExpr = parse (parser [])
parser :: Ctx -> Parser Syn parser :: Ctx -> Parser Syn
parser ctx = do parser ctx = do

View File

@ -1,7 +1,6 @@
module TestProg where module TestProg where
import Syn import Syn
import Val
import Eval import Eval
fib :: Syn fib :: Syn

View File

@ -1,15 +0,0 @@
module Val where
data Val
= I Int
| B Bool
| U
| Clos (Val -> Val)
instance Show Val where
show (I i) = "I " ++ show i
show (B b) = "B " ++ show b
show U = "U"
show (Clos _) = "<CLOS>"
type Ctx = [Val]