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

added debug info

Browse source
This commit is contained in:
sebastianselander 2023-03-24 18:26:59 +01:00
parent 23c174607b
commit b4cae11c0d
2 changed files with 31 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

50
src/Main.hs
View file

@ -2,28 +2,32 @@
module Main where module Main where
import Codegen.Codegen (generateCode) import Codegen.Codegen (generateCode)
import GHC.IO.Handle.Text (hPutStrLn) import Data.Bool (bool)
import Grammar.ErrM (Err) import GHC.IO.Handle.Text (hPutStrLn)
import Grammar.Par (myLexer, pProgram) import Grammar.ErrM (Err)
import Grammar.Print (printTree) import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import Monomorphizer.Monomorphizer (monomorphize) import Monomorphizer.Monomorphizer (monomorphize)
import Control.Monad (when) import Control.Monad (when)
import Data.List.Extra (isSuffixOf) import Data.List.Extra (isSuffixOf)
import Compiler (optimize) import Compiler (optimize)
import Renamer.Renamer (rename) import Renamer.Renamer (rename)
import System.Directory (createDirectory, doesPathExist, import System.Directory (
getDirectoryContents, createDirectory,
removeDirectoryRecursive, doesPathExist,
setCurrentDirectory) getDirectoryContents,
import System.Environment (getArgs) removeDirectoryRecursive,
import System.Exit (exitFailure, exitSuccess) setCurrentDirectory,
import System.IO (stderr) )
import System.Process.Extra (spawnCommand, waitForProcess) import System.Environment (getArgs)
import TypeChecker.TypeChecker (typecheck) import System.Exit (exitFailure, exitSuccess)
import System.IO (stderr)
import System.Process.Extra (spawnCommand, waitForProcess)
import TypeChecker.TypeChecker (typecheck)
main :: IO () main :: IO ()
main = main =
@ -38,15 +42,15 @@ main' debug s = do
printToErr "-- Parse Tree -- " printToErr "-- Parse Tree -- "
parsed <- fromSyntaxErr . pProgram $ myLexer file parsed <- fromSyntaxErr . pProgram $ myLexer file
printToErr $ printTree parsed bool (printToErr $ printTree parsed) (printToErr $ printTree parsed) debug
printToErr "\n-- Renamer --" printToErr "\n-- Renamer --"
renamed <- fromRenamerErr . rename $ parsed renamed <- fromRenamerErr . rename $ parsed
printToErr $ printTree renamed bool (printToErr $ printTree renamed) (printToErr $ show renamed) debug
printToErr "\n-- TypeChecker --" printToErr "\n-- TypeChecker --"
typechecked <- fromTypeCheckerErr $ typecheck renamed typechecked <- fromTypeCheckerErr $ typecheck renamed
printToErr $ printTree typechecked bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) debug
-- printToErr "\n-- Lambda Lifter --" -- printToErr "\n-- Lambda Lifter --"
-- let lifted = lambdaLift typechecked -- let lifted = lambdaLift typechecked
@ -54,7 +58,7 @@ main' debug s = do
-- --
printToErr "\n -- Compiler --" printToErr "\n -- Compiler --"
generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked)
--putStrLn generatedCode -- putStrLn generatedCode
check <- doesPathExist "output" check <- doesPathExist "output"
when check (removeDirectoryRecursive "output") when check (removeDirectoryRecursive "output")

5
src/TypeChecker/TypeChecker.hs
View file

@ -129,7 +129,7 @@ checkBind err@(Bind name args e) = do
sub <- bindErr (unify t lambdaT) err sub <- bindErr (unify t lambdaT) err
let newT = apply sub t let newT = apply sub t
insertSig (coerce name) (Just newT) insertSig (coerce name) (Just newT)
return $ T.Bind (coerce name, newT) (map coerce args) e return $ T.Bind (apply sub (coerce name, newT)) (map coerce args) e
_ -> do _ -> do
insertSig (coerce name) (Just lambdaT) insertSig (coerce name) (Just lambdaT)
return (T.Bind (coerce name, lambdaT) (map coerce args) e) -- (apply s e) return (T.Bind (coerce name, lambdaT) (map coerce args) e) -- (apply s e)
@ -481,6 +481,9 @@ instance SubstType T.Pattern where
instance SubstType a => SubstType [a] where instance SubstType a => SubstType [a] where
apply s = map (apply s) apply s = map (apply s)
instance SubstType T.Id where
apply s (name, t) = (name, apply s t)
-- | Apply substitutions to the environment. -- | Apply substitutions to the environment.
applySt :: Subst -> Infer a -> Infer a applySt :: Subst -> Infer a -> Infer a
applySt s = local (\st -> st{vars = apply s (vars st)}) applySt s = local (\st -> st{vars = apply s (vars st)})