Making progress towards finished product
This commit is contained in:
sebastianselander
parent
d3d173eb59
commit
42c8ebc7b6
5 changed files with 222 additions and 195 deletions
|
|
@ -34,9 +34,9 @@ executable language
|
|||
TypeChecker.TypeChecker
|
||||
TypeChecker.TypeCheckerIr
|
||||
Renamer.Renamer
|
||||
-- LambdaLifter.LambdaLifter
|
||||
-- Codegen.Codegen
|
||||
-- Codegen.LlvmIr
|
||||
LambdaLifter.LambdaLifter
|
||||
Codegen.Codegen
|
||||
Codegen.LlvmIr
|
||||
|
||||
hs-source-dirs: src
|
||||
|
||||
|
|
@ -49,6 +49,7 @@ executable language
|
|||
, array
|
||||
, hspec
|
||||
, QuickCheck
|
||||
, directory
|
||||
|
||||
default-language: GHC2021
|
||||
|
||||
|
|
|
|||
|
|
@ -1,192 +1,194 @@
|
|||
--{-# LANGUAGE LambdaCase #-}
|
||||
--{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module LambdaLifter.LambdaLifter where
|
||||
|
||||
--import Auxiliary (snoc)
|
||||
--import Control.Applicative (Applicative (liftA2))
|
||||
--import Control.Monad.State (MonadState (get, put), State,
|
||||
-- evalState)
|
||||
--import Data.Set (Set)
|
||||
--import qualified Data.Set as Set
|
||||
--import Prelude hiding (exp)
|
||||
--import Renamer.Renamer
|
||||
--import TypeChecker.TypeCheckerIr
|
||||
import Auxiliary (snoc)
|
||||
import Control.Applicative (Applicative (liftA2))
|
||||
import Control.Monad.State (MonadState (get, put), State, evalState)
|
||||
import Data.Set (Set)
|
||||
import Data.Set qualified as Set
|
||||
import Renamer.Renamer
|
||||
import TypeChecker.TypeChecker (partitionType)
|
||||
import TypeChecker.TypeCheckerIr
|
||||
import Prelude hiding (exp)
|
||||
|
||||
{- | Lift lambdas and let expression into supercombinators.
|
||||
Three phases:
|
||||
@freeVars@ annotates all the free variables.
|
||||
@abstract@ converts lambdas into let expressions.
|
||||
@collectScs@ moves every non-constant let expression to a top-level function.
|
||||
-}
|
||||
lambdaLift :: Program -> Program
|
||||
lambdaLift = collectScs . abstract . freeVars
|
||||
|
||||
---- | Lift lambdas and let expression into supercombinators.
|
||||
---- Three phases:
|
||||
---- @freeVars@ annotatss all the free variables.
|
||||
---- @abstract@ converts lambdas into let expressions.
|
||||
---- @collectScs@ moves every non-constant let expression to a top-level function.
|
||||
--lambdaLift :: Program -> Program
|
||||
--lambdaLift = collectScs . abstract . freeVars
|
||||
-- | Annotate free variables
|
||||
freeVars :: Program -> AnnProgram
|
||||
freeVars (Program ds) =
|
||||
[ (n, xs, freeVarsExp (Set.fromList $ map fst xs) e)
|
||||
| Bind n xs e <- ds
|
||||
]
|
||||
|
||||
freeVarsExp :: Set Ident -> ExpT -> AnnExpT
|
||||
freeVarsExp localVars (exp, t) = case exp of
|
||||
EId n
|
||||
| Set.member n localVars -> (Set.singleton n, (AId n, t))
|
||||
| otherwise -> (mempty, (AId n, t))
|
||||
-- EInt i -> (mempty, AInt i)
|
||||
ELit lit -> (mempty, (ALit lit, t))
|
||||
EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AApp e1' e2', t))
|
||||
where
|
||||
e1' = freeVarsExp localVars e1
|
||||
e2' = freeVarsExp localVars e2
|
||||
EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AAdd e1' e2', t))
|
||||
where
|
||||
e1' = freeVarsExp localVars e1
|
||||
e2' = freeVarsExp localVars e2
|
||||
EAbs par e -> (Set.delete par $ freeVarsOf e', (AAbs par e', t))
|
||||
where
|
||||
e' = freeVarsExp (Set.insert par localVars) e
|
||||
|
||||
---- | Annotate free variables
|
||||
--freeVars :: Program -> AnnProgram
|
||||
--freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e)
|
||||
-- | Bind n xs e <- ds
|
||||
-- ]
|
||||
-- Sum free variables present in bind and the expression
|
||||
ELet (Bind (name, t_bind) parms rhs) e -> (Set.union binders_frees e_free, (ALet new_bind e', t))
|
||||
where
|
||||
binders_frees = Set.delete name $ freeVarsOf rhs'
|
||||
e_free = Set.delete name $ freeVarsOf e'
|
||||
|
||||
--freeVarsExp :: Set Id -> Exp -> AnnExp
|
||||
--freeVarsExp localVars = \case
|
||||
-- EId n | Set.member n localVars -> (Set.singleton n, AId n)
|
||||
-- | otherwise -> (mempty, AId n)
|
||||
rhs' = freeVarsExp e_localVars rhs
|
||||
new_bind = ABind (name, t_bind) parms rhs'
|
||||
|
||||
-- ELit _ (LInt i) -> (mempty, AInt i)
|
||||
e' = freeVarsExp e_localVars e
|
||||
e_localVars = Set.insert name localVars
|
||||
|
||||
-- EApp t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp t e1' e2')
|
||||
-- where
|
||||
-- e1' = freeVarsExp localVars e1
|
||||
-- e2' = freeVarsExp localVars e2
|
||||
freeVarsOf :: AnnExpT -> Set Ident
|
||||
freeVarsOf = fst
|
||||
|
||||
-- EAdd t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd t e1' e2')
|
||||
-- where
|
||||
-- e1' = freeVarsExp localVars e1
|
||||
-- e2' = freeVarsExp localVars e2
|
||||
-- AST annotated with free variables
|
||||
type AnnProgram = [(Id, [Id], AnnExpT)]
|
||||
|
||||
-- EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e')
|
||||
-- where
|
||||
-- e' = freeVarsExp (Set.insert par localVars) e
|
||||
type AnnExpT = (Set Ident, AnnExpT')
|
||||
|
||||
-- -- Sum free variables present in bind and the expression
|
||||
-- ELet (Bind name parms rhs) e -> (Set.union binders_frees e_free, ALet new_bind e')
|
||||
-- where
|
||||
-- binders_frees = Set.delete name $ freeVarsOf rhs'
|
||||
-- e_free = Set.delete name $ freeVarsOf e'
|
||||
data ABind = ABind Id [Id] AnnExpT deriving (Show)
|
||||
|
||||
-- rhs' = freeVarsExp e_localVars rhs
|
||||
-- new_bind = ABind name parms rhs'
|
||||
type AnnExpT' = (AnnExp, Type)
|
||||
|
||||
-- e' = freeVarsExp e_localVars e
|
||||
-- e_localVars = Set.insert name localVars
|
||||
data AnnExp
|
||||
= AId Ident
|
||||
| ALit Lit
|
||||
| ALet ABind AnnExpT
|
||||
| AApp AnnExpT AnnExpT
|
||||
| AAdd AnnExpT AnnExpT
|
||||
| AAbs Ident AnnExpT
|
||||
deriving (Show)
|
||||
|
||||
{- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@.
|
||||
Free variables are @v₁ v₂ .. vₙ@ are bound.
|
||||
-}
|
||||
abstract :: AnnProgram -> Program
|
||||
abstract prog = Program $ evalState (mapM go prog) 0
|
||||
where
|
||||
go :: (Id, [Id], AnnExpT) -> State Int Bind
|
||||
go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs'
|
||||
where
|
||||
(rhs', parms1) = flattenLambdasAnn rhs
|
||||
|
||||
--freeVarsOf :: AnnExp -> Set Id
|
||||
--freeVarsOf = fst
|
||||
{- | Flatten nested lambdas and collect the parameters
|
||||
@\x.\y.\z. ae → (ae, [x,y,z])@
|
||||
-}
|
||||
flattenLambdasAnn :: AnnExpT -> (AnnExpT, [Id])
|
||||
flattenLambdasAnn ae = go (ae, [])
|
||||
where
|
||||
go :: (AnnExpT, [Id]) -> (AnnExpT, [Id])
|
||||
go ((free, (e, t)), acc)
|
||||
| AAbs par (free1, e1) <- e
|
||||
, TFun t_par _ <- t =
|
||||
go ((Set.delete par free1, e1), snoc (par, t_par) acc)
|
||||
| otherwise = ((free, (e, t)), acc)
|
||||
|
||||
---- AST annotated with free variables
|
||||
--type AnnProgram = [(Id, [Id], AnnExp)]
|
||||
abstractExp :: AnnExpT -> State Int ExpT
|
||||
abstractExp (free, (exp, t)) = case exp of
|
||||
AId n -> pure (EId n, t)
|
||||
ALit lit -> pure (ELit lit, t)
|
||||
AApp e1 e2 -> (,t) <$> liftA2 EApp (abstractExp e1) (abstractExp e2)
|
||||
AAdd e1 e2 -> (,t) <$> liftA2 EAdd (abstractExp e1) (abstractExp e2)
|
||||
ALet b e -> (,t) <$> liftA2 ELet (go b) (abstractExp e)
|
||||
where
|
||||
go (ABind name parms rhs) = do
|
||||
(rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs
|
||||
pure $ Bind name (parms ++ parms1) rhs'
|
||||
|
||||
--type AnnExp = (Set Id, AnnExp')
|
||||
skipLambdas :: (AnnExpT -> State Int ExpT) -> AnnExpT -> State Int ExpT
|
||||
skipLambdas f (free, (ae, t)) = case ae of
|
||||
AAbs par ae1 -> do
|
||||
ae1' <- skipLambdas f ae1
|
||||
pure (EAbs par ae1', t)
|
||||
_ -> f (free, (ae, t))
|
||||
|
||||
--data ABind = ABind Id [Id] AnnExp deriving Show
|
||||
-- Lift lambda into let and bind free variables
|
||||
AAbs parm e -> do
|
||||
i <- nextNumber
|
||||
rhs <- abstractExp e
|
||||
|
||||
--data AnnExp' = AId Id
|
||||
-- | AInt Integer
|
||||
-- | ALet ABind AnnExp
|
||||
-- | AApp Type AnnExp AnnExp
|
||||
-- | AAdd Type AnnExp AnnExp
|
||||
-- | AAbs Type Id AnnExp
|
||||
-- deriving Show
|
||||
---- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@.
|
||||
---- Free variables are @v₁ v₂ .. vₙ@ are bound.
|
||||
--abstract :: AnnProgram -> Program
|
||||
--abstract prog = Program $ evalState (mapM go prog) 0
|
||||
-- where
|
||||
-- go :: (Id, [Id], AnnExp) -> State Int Bind
|
||||
-- go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs'
|
||||
-- where
|
||||
-- (rhs', parms1) = flattenLambdasAnn rhs
|
||||
let sc_name = Ident ("sc_" ++ show i)
|
||||
sc = (ELet (Bind (sc_name, t) vars rhs) (EId sc_name, t), t)
|
||||
pure $ foldl applyVars sc freeList
|
||||
where
|
||||
freeList = Set.toList free
|
||||
vars = zip names . fst $ partitionType (length names) t
|
||||
names = snoc parm freeList
|
||||
applyVars (e, t) name = (EApp (e, t) (EId name, t_var), t_return)
|
||||
where
|
||||
(t_var : _, t_return) = partitionType 1 t
|
||||
|
||||
nextNumber :: State Int Int
|
||||
nextNumber = do
|
||||
i <- get
|
||||
put $ succ i
|
||||
pure i
|
||||
|
||||
---- | Flatten nested lambdas and collect the parameters
|
||||
---- @\x.\y.\z. ae → (ae, [x,y,z])@
|
||||
--flattenLambdasAnn :: AnnExp -> (AnnExp, [Id])
|
||||
--flattenLambdasAnn ae = go (ae, [])
|
||||
-- where
|
||||
-- go :: (AnnExp, [Id]) -> (AnnExp, [Id])
|
||||
-- go ((free, e), acc) =
|
||||
-- case e of
|
||||
-- AAbs _ par (free1, e1) ->
|
||||
-- go ((Set.delete par free1, e1), snoc par acc)
|
||||
-- _ -> ((free, e), acc)
|
||||
-- | Collects supercombinators by lifting non-constant let expressions
|
||||
collectScs :: Program -> Program
|
||||
collectScs (Program scs) = Program $ concatMap collectFromRhs scs
|
||||
where
|
||||
collectFromRhs (Bind name parms rhs) =
|
||||
let (rhs_scs, rhs') = collectScsExp rhs
|
||||
in Bind name parms rhs' : rhs_scs
|
||||
|
||||
--abstractExp :: AnnExp -> State Int Exp
|
||||
--abstractExp (free, exp) = case exp of
|
||||
-- AId n -> pure $ EId n
|
||||
-- AInt i -> pure $ ELit (TMono "Int") (LInt i)
|
||||
-- AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2)
|
||||
-- AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2)
|
||||
-- ALet b e -> liftA2 ELet (go b) (abstractExp e)
|
||||
-- where
|
||||
-- go (ABind name parms rhs) = do
|
||||
-- (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs
|
||||
-- pure $ Bind name (parms ++ parms1) rhs'
|
||||
collectScsExp :: ExpT -> ([Bind], ExpT)
|
||||
collectScsExp expT@(exp, typ) = case exp of
|
||||
EId _ -> ([], expT)
|
||||
ELit _ -> ([], expT)
|
||||
EApp e1 e2 -> (scs1 ++ scs2, (EApp e1' e2', typ))
|
||||
where
|
||||
(scs1, e1') = collectScsExp e1
|
||||
(scs2, e2') = collectScsExp e2
|
||||
EAdd e1 e2 -> (scs1 ++ scs2, (EAdd e1' e2', typ))
|
||||
where
|
||||
(scs1, e1') = collectScsExp e1
|
||||
(scs2, e2') = collectScsExp e2
|
||||
EAbs par e -> (scs, (EAbs par e', typ))
|
||||
where
|
||||
(scs, e') = collectScsExp e
|
||||
|
||||
-- skipLambdas :: (AnnExp -> State Int Exp) -> AnnExp -> State Int Exp
|
||||
-- skipLambdas f (free, ae) = case ae of
|
||||
-- AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1
|
||||
-- _ -> f (free, ae)
|
||||
|
||||
-- -- Lift lambda into let and bind free variables
|
||||
-- AAbs t parm e -> do
|
||||
-- i <- nextNumber
|
||||
-- rhs <- abstractExp e
|
||||
|
||||
-- let sc_name = Ident ("sc_" ++ show i)
|
||||
-- sc = ELet (Bind (sc_name, t) parms rhs) $ EId (sc_name, t)
|
||||
|
||||
-- pure $ foldl (EApp $ TMono "Int") sc $ map EId freeList
|
||||
-- where
|
||||
-- freeList = Set.toList free
|
||||
-- parms = snoc parm freeList
|
||||
|
||||
|
||||
--nextNumber :: State Int Int
|
||||
--nextNumber = do
|
||||
-- i <- get
|
||||
-- put $ succ i
|
||||
-- pure i
|
||||
|
||||
---- | Collects supercombinators by lifting non-constant let expressions
|
||||
--collectScs :: Program -> Program
|
||||
--collectScs (Program scs) = Program $ concatMap collectFromRhs scs
|
||||
-- where
|
||||
-- collectFromRhs (Bind name parms rhs) =
|
||||
-- let (rhs_scs, rhs') = collectScsExp rhs
|
||||
-- in Bind name parms rhs' : rhs_scs
|
||||
|
||||
|
||||
--collectScsExp :: Exp -> ([Bind], Exp)
|
||||
--collectScsExp = \case
|
||||
-- EId n -> ([], EId n)
|
||||
-- ELit _ (LInt i) -> ([], ELit (TMono "Int") (LInt i))
|
||||
|
||||
-- EApp t e1 e2 -> (scs1 ++ scs2, EApp t e1' e2')
|
||||
-- where
|
||||
-- (scs1, e1') = collectScsExp e1
|
||||
-- (scs2, e2') = collectScsExp e2
|
||||
|
||||
-- EAdd t e1 e2 -> (scs1 ++ scs2, EAdd t e1' e2')
|
||||
-- where
|
||||
-- (scs1, e1') = collectScsExp e1
|
||||
-- (scs2, e2') = collectScsExp e2
|
||||
|
||||
-- EAbs t par e -> (scs, EAbs t par e')
|
||||
-- where
|
||||
-- (scs, e') = collectScsExp e
|
||||
|
||||
-- -- Collect supercombinators from bind, the rhss, and the expression.
|
||||
-- --
|
||||
-- -- > f = let sc x y = rhs in e
|
||||
-- --
|
||||
-- ELet (Bind name parms rhs) e -> if null parms
|
||||
-- then ( rhs_scs ++ e_scs, ELet bind e')
|
||||
-- else (bind : rhs_scs ++ e_scs, e')
|
||||
-- where
|
||||
-- bind = Bind name parms rhs'
|
||||
-- (rhs_scs, rhs') = collectScsExp rhs
|
||||
-- (e_scs, e') = collectScsExp e
|
||||
|
||||
|
||||
---- @\x.\y.\z. e → (e, [x,y,z])@
|
||||
--flattenLambdas :: Exp -> (Exp, [Id])
|
||||
--flattenLambdas = go . (, [])
|
||||
-- where
|
||||
-- go (e, acc) = case e of
|
||||
-- EAbs _ par e1 -> go (e1, snoc par acc)
|
||||
-- _ -> (e, acc)
|
||||
-- Collect supercombinators from bind, the rhss, and the expression.
|
||||
--
|
||||
-- > f = let sc x y = rhs in e
|
||||
--
|
||||
ELet (Bind name parms rhs) e ->
|
||||
if null parms
|
||||
then (rhs_scs ++ et_scs, (ELet bind et', snd et'))
|
||||
else (bind : rhs_scs ++ et_scs, et')
|
||||
where
|
||||
bind = Bind name parms rhs'
|
||||
(rhs_scs, rhs') = collectScsExp rhs
|
||||
(et_scs, et') = collectScsExp e
|
||||
|
||||
-- @\x.\y.\z. e → (e, [x,y,z])@
|
||||
flattenLambdas :: ExpT -> (ExpT, [Id])
|
||||
flattenLambdas = go . (,[])
|
||||
where
|
||||
go ((e, t), acc) = case e of
|
||||
EAbs name e1 -> go (e1, snoc (name, t_var) acc)
|
||||
where
|
||||
t_var : _ = fst $ partitionType 1 t
|
||||
_ -> ((e, t), acc)
|
||||
|
|
|
|||
63
src/Main.hs
63
src/Main.hs
|
|
@ -2,32 +2,36 @@
|
|||
|
||||
module Main where
|
||||
|
||||
--import Codegen.Codegen (generateCode)
|
||||
import GHC.IO.Handle.Text (hPutStrLn)
|
||||
import Grammar.ErrM (Err)
|
||||
import Grammar.Par (myLexer, pProgram)
|
||||
import Grammar.Print (printTree)
|
||||
-- import Codegen.Codegen (generateCode)
|
||||
import GHC.IO.Handle.Text (hPutStrLn)
|
||||
import Grammar.ErrM (Err)
|
||||
import Grammar.Par (myLexer, pProgram)
|
||||
import Grammar.Print (printTree)
|
||||
|
||||
-- import Interpreter (interpret)
|
||||
import Control.Monad (when)
|
||||
import Data.List.Extra (isSuffixOf)
|
||||
--import LambdaLifter.LambdaLifter (lambdaLift)
|
||||
import Renamer.Renamer (rename)
|
||||
import System.Directory (createDirectory, doesPathExist,
|
||||
getDirectoryContents,
|
||||
removeDirectoryRecursive,
|
||||
setCurrentDirectory)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
import System.IO (stderr)
|
||||
import System.Process.Extra (spawnCommand, waitForProcess)
|
||||
import TypeChecker.TypeChecker (typecheck)
|
||||
import Control.Monad (when)
|
||||
import Data.List.Extra (isSuffixOf)
|
||||
|
||||
-- import LambdaLifter.LambdaLifter (lambdaLift)
|
||||
import Renamer.Renamer (rename)
|
||||
import System.Directory (
|
||||
createDirectory,
|
||||
doesPathExist,
|
||||
getDirectoryContents,
|
||||
removeDirectoryRecursive,
|
||||
setCurrentDirectory,
|
||||
)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
import System.IO (stderr)
|
||||
import System.Process.Extra (spawnCommand, waitForProcess)
|
||||
import TypeChecker.TypeChecker (typecheck)
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
getArgs >>= \case
|
||||
[] -> print "Required file path missing"
|
||||
("-d": s : _) -> main' True s
|
||||
("-d" : s : _) -> main' True s
|
||||
(s : _) -> main' False s
|
||||
|
||||
main' :: Bool -> String -> IO ()
|
||||
|
|
@ -39,7 +43,7 @@ main' debug s = do
|
|||
printToErr $ printTree parsed
|
||||
|
||||
printToErr "\n-- Renamer --"
|
||||
let renamed = rename parsed
|
||||
renamed <- fromRenamerErr . rename $ parsed
|
||||
printToErr $ printTree renamed
|
||||
|
||||
printToErr "\n-- TypeChecker --"
|
||||
|
|
@ -49,10 +53,10 @@ main' debug s = do
|
|||
-- printToErr "\n-- Lambda Lifter --"
|
||||
-- let lifted = lambdaLift typechecked
|
||||
-- printToErr $ printTree lifted
|
||||
--
|
||||
--
|
||||
-- printToErr "\n -- Printing compiler output to stdout --"
|
||||
-- compiled <- fromCompilerErr $ generateCode lifted
|
||||
--putStrLn compiled
|
||||
-- putStrLn compiled
|
||||
|
||||
-- check <- doesPathExist "output"
|
||||
-- when check (removeDirectoryRecursive "output")
|
||||
|
|
@ -60,7 +64,6 @@ main' debug s = do
|
|||
-- writeFile "output/llvm.ll" compiled
|
||||
-- if debug then debugDotViz else putStrLn compiled
|
||||
|
||||
|
||||
-- interpred <- fromInterpreterErr $ interpret lifted
|
||||
-- putStrLn "\n-- interpret"
|
||||
-- print interpred
|
||||
|
|
@ -76,8 +79,8 @@ debugDotViz = do
|
|||
mapM_ spawnWait commands
|
||||
setCurrentDirectory ".."
|
||||
return ()
|
||||
where
|
||||
spawnWait s = spawnCommand s >>= waitForProcess
|
||||
where
|
||||
spawnWait s = spawnCommand s >>= waitForProcess
|
||||
printToErr :: String -> IO ()
|
||||
printToErr = hPutStrLn stderr
|
||||
|
||||
|
|
@ -111,6 +114,16 @@ fromTypeCheckerErr =
|
|||
)
|
||||
pure
|
||||
|
||||
fromRenamerErr :: Err a -> IO a
|
||||
fromRenamerErr =
|
||||
either
|
||||
( \err -> do
|
||||
putStrLn "\nRENAMER ERROR"
|
||||
putStrLn err
|
||||
exitFailure
|
||||
)
|
||||
pure
|
||||
|
||||
fromInterpreterErr :: Err a -> IO a
|
||||
fromInterpreterErr =
|
||||
either
|
||||
|
|
|
|||
|
|
@ -517,3 +517,15 @@ litType (LChar _) = char
|
|||
|
||||
int = T.TLit "Int"
|
||||
char = T.TLit "Char"
|
||||
|
||||
partitionType ::
|
||||
Int -> -- Number of parameters to apply
|
||||
Type ->
|
||||
([Type], Type)
|
||||
partitionType = go []
|
||||
where
|
||||
go acc 0 t = (acc, t)
|
||||
go acc i t = case t of
|
||||
TAll tvar t' -> second (TAll tvar) $ go acc i t'
|
||||
TFun t1 t2 -> go (acc ++ [t1]) (i - 1) t2
|
||||
_ -> error "Number of parameters and type doesn't match"
|
||||
|
|
|
|||
|
|
@ -18,7 +18,6 @@ import TypeChecker.TypeCheckerIr (
|
|||
Env (..),
|
||||
Error,
|
||||
Infer,
|
||||
Poly (..),
|
||||
)
|
||||
import TypeChecker.TypeCheckerIr qualified as T
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue