Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

introduced lt in prelude

Browse source
This commit is contained in:
sebastianselander 2023-04-27 12:18:56 +02:00
parent 2cb8527848
commit fd418faa5f
1 changed files with 83 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

155
src/Main.hs
View file

@ -1,39 +1,47 @@
{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedRecordDot #-}
module Main where module Main where
import AnnForall (annotateForall) import AnnForall (annotateForall)
import Codegen.Codegen (generateCode) import Codegen.Codegen (generateCode)
import Compiler (compile) import Compiler (compile)
import Control.Monad (when, (<=<)) import Control.Monad (when, (<=<))
import Data.List.Extra (isSuffixOf) import Data.List.Extra (isSuffixOf)
import Data.Maybe (fromJust, isNothing) import Data.Maybe (fromJust, isNothing)
import Desugar.Desugar (desugar) import Desugar.Desugar (desugar)
import GHC.IO.Handle.Text (hPutStrLn) import GHC.IO.Handle.Text (hPutStrLn)
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import Grammar.Layout (resolveLayout) import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
import Grammar.Print (Print, printTree) import Grammar.Print (Print, printTree)
import LambdaLifter (lambdaLift) import LambdaLifter (lambdaLift)
import Monomorphizer.Monomorphizer (monomorphize) import Monomorphizer.Monomorphizer (monomorphize)
import Renamer.Renamer (rename) import Renamer.Renamer (rename)
import ReportForall (reportForall) import ReportForall (reportForall)
import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), import System.Console.GetOpt (
ArgOrder (RequireOrder), ArgDescr (NoArg, ReqArg),
OptDescr (Option), getOpt, ArgOrder (RequireOrder),
usageInfo) OptDescr (Option),
import System.Directory (createDirectory, doesPathExist, getOpt,
getDirectoryContents, usageInfo,
removeDirectoryRecursive, )
setCurrentDirectory) import System.Directory (
import System.Environment (getArgs) createDirectory,
import System.Exit (ExitCode (ExitFailure), doesPathExist,
exitFailure, exitSuccess, getDirectoryContents,
exitWith) removeDirectoryRecursive,
import System.IO (stderr) setCurrentDirectory,
import System.Process (spawnCommand, waitForProcess) )
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) import System.Environment (getArgs)
import System.Exit (
ExitCode (ExitFailure),
exitFailure,
exitSuccess,
exitWith,
)
import System.IO (stderr)
import System.Process (spawnCommand, waitForProcess)
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck)
main :: IO () main :: IO ()
main = getArgs >>= parseArgs >>= uncurry main' main = getArgs >>= parseArgs >>= uncurry main'
@ -80,63 +88,64 @@ chooseTypechecker s options = options{typechecker = tc}
tc = case s of tc = case s of
"hm" -> pure Hm "hm" -> pure Hm
"bi" -> pure Bi "bi" -> pure Bi
_ -> Nothing _ -> Nothing
data Options = Options data Options = Options
{ help :: Bool { help :: Bool
, debug :: Bool , debug :: Bool
, typechecker :: Maybe TypeChecker , typechecker :: Maybe TypeChecker
} }
main' :: Options -> String -> IO () main' :: Options -> String -> IO ()
main' opts s = main' opts s =
let let
log :: (Print a, Show a) => a -> IO () log :: (Print a, Show a) => a -> IO ()
log = printToErr . if opts.debug then show else printTree log = printToErr . if opts.debug then show else printTree
in do in
file <- readFile s do
file <- readFile s
printToErr "-- Parse Tree -- " printToErr "-- Parse Tree -- "
parsed <- fromErr . pProgram . resolveLayout True $ myLexer file parsed <- fromErr . pProgram . resolveLayout True $ myLexer (file ++ prelude)
log parsed log parsed
printToErr "-- Desugar --" printToErr "-- Desugar --"
let desugared = desugar parsed let desugared = desugar parsed
log desugared log desugared
printToErr "\n-- Renamer --" printToErr "\n-- Renamer --"
_ <- fromErr $ reportForall (fromJust opts.typechecker) desugared _ <- fromErr $ reportForall (fromJust opts.typechecker) desugared
renamed <- fromErr $ (rename <=< annotateForall) desugared renamed <- fromErr $ (rename <=< annotateForall) desugared
log renamed log renamed
printToErr "\n-- TypeChecker --" printToErr "\n-- TypeChecker --"
typechecked <- fromErr $ typecheck (fromJust opts.typechecker) renamed typechecked <- fromErr $ typecheck (fromJust opts.typechecker) renamed
log typechecked log typechecked
printToErr "\n-- Lambda Lifter --" printToErr "\n-- Lambda Lifter --"
let lifted = lambdaLift typechecked let lifted = lambdaLift typechecked
log lifted log lifted
printToErr "\n -- Monomorphizer --" printToErr "\n -- Monomorphizer --"
let monomorphized = monomorphize lifted let monomorphized = monomorphize lifted
log monomorphized log monomorphized
printToErr "\n -- Compiler --" printToErr "\n -- Compiler --"
generatedCode <- fromErr $ generateCode monomorphized generatedCode <- fromErr $ generateCode monomorphized
check <- doesPathExist "output" check <- doesPathExist "output"
when check (removeDirectoryRecursive "output") when check (removeDirectoryRecursive "output")
createDirectory "output" createDirectory "output"
when opts.debug $ do when opts.debug $ do
writeFile "output/llvm.ll" generatedCode writeFile "output/llvm.ll" generatedCode
debugDotViz debugDotViz
compile generatedCode compile generatedCode
printToErr "Compilation done!" printToErr "Compilation done!"
printToErr "\n-- Program output --" printToErr "\n-- Program output --"
print =<< spawnWait "./output/hello_world" print =<< spawnWait "./output/hello_world"
exitSuccess exitSuccess
debugDotViz :: IO () debugDotViz :: IO ()
debugDotViz = do debugDotViz = do
@ -156,3 +165,5 @@ printToErr = hPutStrLn stderr
fromErr :: Err a -> IO a fromErr :: Err a -> IO a
fromErr = either (\s -> printToErr s >> exitFailure) pure fromErr = either (\s -> printToErr s >> exitFailure) pure
prelude = "const x y = x\n\ndata Bool () where\n True : Bool ()\n False : Bool ()\n\nlt : Int -> Int -> Bool ()\nlt = \\x. \\y. const True (x + y)"