mjau :)
This commit is contained in:
parent
58e3c8e237
commit
8b19a37d79
39
app/Main.hs
39
app/Main.hs
|
@ -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
6
example/fib
Normal 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
|
|
@ -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
|
||||||
|
|
|
@ -1,4 +0,0 @@
|
||||||
module Core where
|
|
||||||
|
|
||||||
test :: String
|
|
||||||
test = "mjau"
|
|
15
src/Eval.hs
15
src/Eval.hs
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -1,7 +1,6 @@
|
||||||
module TestProg where
|
module TestProg where
|
||||||
|
|
||||||
import Syn
|
import Syn
|
||||||
import Val
|
|
||||||
import Eval
|
import Eval
|
||||||
|
|
||||||
fib :: Syn
|
fib :: Syn
|
||||||
|
|
15
src/Val.hs
15
src/Val.hs
|
@ -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]
|
|
Loading…
Reference in New Issue
Block a user