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

Merge branch 'pattern-matching-with-typechecking' of github.com:bachelor-group-66-systemf/churf into pattern-matching-with-typechecking

Browse source
This commit is contained in:
Rakarake 2023-05-05 11:44:17 +02:00
commit 47cbf12cd1
2 changed files with 31 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/Codegen/Emits.hs
View file

@ -15,6 +15,7 @@ import Data.Coerce (coerce)
import Data.Map qualified as Map import Data.Map qualified as Map
import Data.Maybe (fromJust, fromMaybe) import Data.Maybe (fromJust, fromMaybe)
import Data.Tuple.Extra (dupe, first, second) import Data.Tuple.Extra (dupe, first, second)
import Debug.Trace (traceShow)
import Monomorphizer.MonomorphizerIr as MIR import Monomorphizer.MonomorphizerIr as MIR
import TypeChecker.TypeCheckerIr qualified as TIR import TypeChecker.TypeCheckerIr qualified as TIR
@ -268,7 +269,6 @@ emitECased t e cases = do
emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "False"), _) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "False"), _) exp) = do
emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 0, TLit "Bool"), t) exp) emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 0, TLit "Bool"), t) exp)
emitCases rt ty label stackPtr vs (Branch (MIR.PEnum consId, _) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PEnum consId, _) exp) = do
-- //TODO Penum wrong, acts as a catch all
emit $ Comment "Penum" emit $ Comment "Penum"
cons <- gets constructors cons <- gets constructors
let r = fromJust $ Map.lookup consId cons let r = fromJust $ Map.lookup consId cons

33
src/Desugar/Desugar.hs
View file

@ -16,7 +16,7 @@ desugar :: Program -> Program
desugar (Program defs) = Program (map desugarDef defs) desugar (Program defs) = Program (map desugarDef defs)
desugarVarName :: VarName -> LIdent desugarVarName :: VarName -> LIdent
desugarVarName (VSymbol (Symbol i)) = LIdent i desugarVarName (VSymbol (Symbol i)) = LIdent $ fixName i
desugarVarName (VIdent i) = i desugarVarName (VIdent i) = i
desugarDef :: Def -> Def desugarDef :: Def -> Def
@ -68,8 +68,8 @@ desugarExp = \case
ELet b e -> ELet (desugarBind b) (desugarExp e) ELet b e -> ELet (desugarBind b) (desugarExp e)
ECase e br -> ECase (desugarExp e) (map desugarBranch br) ECase e br -> ECase (desugarExp e) (map desugarBranch br)
EAnn e t -> EAnn (desugarExp e) t EAnn e t -> EAnn (desugarExp e) t
EVarS (VSymbol (Symbol symb)) -> EVar (LIdent symb) EVarS (VSymbol (Symbol symb)) -> EVar (LIdent $ fixName symb)
EVarS (VIdent ident) -> EVar ident EVarS (VIdent (LIdent ident)) -> EVar $ LIdent $ fixName ident
EVar i -> EVar i EVar i -> EVar i
ELit l -> ELit l ELit l -> ELit l
EInj i -> EInj i EInj i -> EInj i
@ -88,3 +88,30 @@ desugarPattern = \case
desugarLit :: Lit -> Lit desugarLit :: Lit -> Lit
desugarLit (LInt i) = LInt i desugarLit (LInt i) = LInt i
desugarLit (LChar c) = LChar c desugarLit (LChar c) = LChar c
fixName :: String -> String
fixName = concatMap mapSymbols
where
mapSymbols :: Char -> String
mapSymbols c = case c of
'@' -> "$at$"
'#' -> "$octothorpe$"
'%' -> "$percent$"
'^' -> "$hat$"
'&' -> "$and$"
'*' -> "$star$"
'_' -> "$underscore$"
'-' -> "$minus$"
'+' -> "$plus$"
'=' -> "$equals$"
'|' -> "$pipe$"
'?' -> "$questionmark$"
'/' -> "$fslash$"
'<' -> "$langle$"
'>' -> "$rangle$"
',' -> "$comma$"
'•' -> "$bullet$"
':' -> "$semicolon$"
'[' -> "$lbracket$"
']' -> "$rbracket$"
c -> c : ""