This repository has been archived by the owner on Feb 18, 2020. It is now read-only.
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Browse files
Browse the repository at this point in the history
Merge branch 'feature/compile-pattern-matching' into develop
- Loading branch information
Showing
15 changed files
with
747 additions
and
13 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,26 @@ | ||
{-# LANGUAGE | ||
FlexibleContexts | ||
#-} | ||
|
||
module PatternMatching (compilePatternMatching) where | ||
import PatternMatching.Counters | ||
import PatternMatching.NameWildcards | ||
import PatternMatching.NumbersToIfs | ||
import PatternMatching.ToCases | ||
import PatternMatching.ToHandles | ||
import PatternMatching.SimplifyHandles | ||
|
||
import Control.Monad.State | ||
|
||
import Syntax | ||
|
||
matcherCompiler :: MonadState Counter m => Expr -> m Expr | ||
matcherCompiler e = do | ||
e1 <- nameWildcards e | ||
e2 <- numbersToIfs e1 | ||
e3 <- functionsToHandles e2 | ||
e4 <- handlesToCases e3 | ||
return $ simplifyHandles e4 | ||
|
||
compilePatternMatching :: Expr -> Expr | ||
compilePatternMatching e = fst $ runState (matcherCompiler e) emptyState |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,40 @@ | ||
{-# LANGUAGE | ||
FlexibleContexts | ||
#-} | ||
|
||
module PatternMatching.Counters where | ||
import Control.Monad.State | ||
|
||
data Counter = C { | ||
args :: Integer, | ||
vars :: Integer, | ||
wild :: Integer | ||
} | ||
|
||
emptyState :: Counter | ||
emptyState = C 0 0 0 | ||
|
||
freshArg :: MonadState Counter m => m String | ||
freshArg = do | ||
s <- get | ||
put s { args = args s + 1 } | ||
return $ '_' : 'a' : show (args s) | ||
|
||
genNames :: MonadState Counter m => Int -> m [String] | ||
genNames n = genNames' n [] where | ||
genNames' 0 acc = return $ reverse acc | ||
genNames' x acc = do | ||
a <- freshArg | ||
genNames' (x-1) $ a:acc | ||
|
||
freshVar :: MonadState Counter m => m String | ||
freshVar = do | ||
s <- get | ||
put s { vars = vars s + 1 } | ||
return $ '_' : 'u' : show (vars s) | ||
|
||
freshWildcard :: MonadState Counter m => m String | ||
freshWildcard = do | ||
s <- get | ||
put s { wild = wild s + 1 } | ||
return $ '_' : 'w' : show (wild s) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,81 @@ | ||
{-# LANGUAGE | ||
FlexibleContexts | ||
#-} | ||
|
||
module PatternMatching.NameWildcards (nameWildcards) where | ||
import Syntax | ||
|
||
import PatternMatching.Counters | ||
|
||
import Control.Monad.State | ||
|
||
nameWildcardsPattern :: MonadState Counter m => Pattern -> m Pattern | ||
nameWildcardsPattern Pwildcard = do | ||
v <- freshWildcard | ||
return $ Pvar v | ||
nameWildcardsPattern (Ppair p1 p2) = do | ||
p1' <- nameWildcardsPattern p1 | ||
p2' <- nameWildcardsPattern p2 | ||
return $ Ppair p1' p2' | ||
nameWildcardsPattern (Pcons p1 p2) = do | ||
p1' <- nameWildcardsPattern p1 | ||
p2' <- nameWildcardsPattern p2 | ||
return $ Pcons p1' p2' | ||
nameWildcardsPattern p = | ||
return p | ||
|
||
nameWildcardsFunClause :: MonadState Counter m => FunClause -> m FunClause | ||
nameWildcardsFunClause fc = do | ||
p' <- mapM nameWildcardsPattern $ arguments fc | ||
b' <- nameWildcards $ fbody fc | ||
return FC{ arguments = p', fbody = b' } | ||
|
||
nameWildcardsCaseClause :: MonadState Counter m => CaseClause -> m CaseClause | ||
nameWildcardsCaseClause cc = do | ||
b' <- nameWildcards $ cbody cc | ||
return cc{ cbody = b' } | ||
|
||
nameWildcards :: MonadState Counter m => Expr -> m Expr | ||
nameWildcards (Efun fcs) = do | ||
fcs' <- mapM nameWildcardsFunClause fcs | ||
return $ Efun fcs' | ||
nameWildcards (Elet p e1 e2) = do | ||
p' <- nameWildcardsPattern p | ||
e1' <- nameWildcards e1 | ||
e2' <- nameWildcards e2 | ||
return $ Elet p' e1' e2' | ||
nameWildcards (Eletrec n fcs e) = do | ||
fcs' <- mapM nameWildcardsFunClause fcs | ||
e' <- nameWildcards e | ||
return $ Eletrec n fcs' e' | ||
nameWildcards (Eapply e1 as) = do | ||
e1' <- nameWildcards e1 | ||
as' <- mapM nameWildcards as | ||
return $ Eapply e1' as' | ||
nameWildcards (Epair e1 e2) = do | ||
e1' <- nameWildcards e1 | ||
e2' <- nameWildcards e2 | ||
return $ Epair e1' e2' | ||
nameWildcards (Econs e1 e2) = do | ||
e1' <- nameWildcards e1 | ||
e2' <- nameWildcards e2 | ||
return $ Econs e1' e2' | ||
nameWildcards (Eif e1 e2 e3) = do | ||
e1' <- nameWildcards e1 | ||
e2' <- nameWildcards e2 | ||
e3' <- nameWildcards e3 | ||
return $ Eif e1' e2' e3' | ||
nameWildcards (Eseq e1 e2) = do | ||
e1' <- nameWildcards e1 | ||
e2' <- nameWildcards e2 | ||
return $ Eseq e1' e2' | ||
nameWildcards (Ecase e1 ccs) = do | ||
e1' <- nameWildcards e1 | ||
ccs' <- mapM nameWildcardsCaseClause ccs | ||
return $ Ecase e1' ccs' | ||
nameWildcards (Ehandle e1 e2) = do | ||
e1' <- nameWildcards e1 | ||
e2' <- nameWildcards e2 | ||
return $ Ehandle e1' e2' | ||
nameWildcards e = | ||
return e |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,94 @@ | ||
{-# LANGUAGE | ||
FlexibleContexts | ||
#-} | ||
|
||
module PatternMatching.NumbersToIfs (numbersToIfs) where | ||
import Syntax | ||
|
||
import PatternMatching.Counters | ||
|
||
import Control.Monad.State | ||
|
||
mkAnd :: Expr -> Expr -> Expr | ||
mkAnd (Econst (Cbool True)) e = e | ||
mkAnd e (Econst (Cbool True)) = e | ||
mkAnd e1 e2 = Eapply (Ebprim BPand) [e1, e2] | ||
|
||
numbersToIfsPattern :: MonadState Counter m => Pattern -> m (Pattern, Expr) | ||
numbersToIfsPattern (Pconst n@(Cint _)) = do | ||
a <- freshArg | ||
return (Pvar a, Eapply (Ebprim BPeq) [Evar a, Econst n]) | ||
numbersToIfsPattern (Ppair p1 p2) = do | ||
(p1', a1') <- numbersToIfsPattern p1 | ||
(p2', a2') <- numbersToIfsPattern p2 | ||
return (Ppair p1' p2', mkAnd a1' a2') | ||
numbersToIfsPattern (Pcons p1 p2) = do | ||
(p1', a1') <- numbersToIfsPattern p1 | ||
(p2', a2') <- numbersToIfsPattern p2 | ||
return (Pcons p1' p2', mkAnd a1' a2') | ||
numbersToIfsPattern p = | ||
return (p, Econst $ Cbool True) | ||
|
||
numbersToIfsPatterns :: MonadState Counter m => [Pattern] -> m ([Pattern], Expr) | ||
numbersToIfsPatterns ps = do | ||
pscs <- mapM numbersToIfsPattern ps | ||
let (ps', cs) = unzip pscs | ||
return (ps', foldl mkAnd (Econst $ Cbool True) cs) | ||
|
||
numbersToIfsCaseClause :: MonadState Counter m => CaseClause -> m CaseClause | ||
numbersToIfsCaseClause cc = do | ||
b' <- numbersToIfs $ cbody cc | ||
return cc{ cbody = b' } | ||
|
||
numbersToIfsFunClause :: MonadState Counter m => FunClause -> m FunClause | ||
numbersToIfsFunClause fc = do | ||
(ps, c) <- numbersToIfsPatterns $ arguments fc | ||
b' <- numbersToIfs $ fbody fc | ||
case c of | ||
Econst (Cbool True) -> return fc { fbody = b' } | ||
_ -> return fc { arguments = ps, | ||
fbody = Eif c b' EmatchFailure } | ||
|
||
numbersToIfs :: MonadState Counter m => Expr -> m Expr | ||
numbersToIfs (Efun fcs) = do | ||
fcs' <- mapM numbersToIfsFunClause fcs | ||
return $ Efun fcs' | ||
numbersToIfs (Elet p e1 e2) = do | ||
e1' <- numbersToIfs e1 | ||
e2' <- numbersToIfs e2 | ||
return $ Elet p e1' e2' | ||
numbersToIfs (Eletrec n fcs e1) = do | ||
fcs' <- mapM numbersToIfsFunClause fcs | ||
e1' <- numbersToIfs e1 | ||
return $ Eletrec n fcs' e1' | ||
numbersToIfs (Eapply e1 as) = do | ||
e1' <- numbersToIfs e1 | ||
as' <- mapM numbersToIfs as | ||
return $ Eapply e1' as' | ||
numbersToIfs (Epair e1 e2) = do | ||
e1' <- numbersToIfs e1 | ||
e2' <- numbersToIfs e2 | ||
return $ Epair e1' e2' | ||
numbersToIfs (Econs e1 e2) = do | ||
e1' <- numbersToIfs e1 | ||
e2' <- numbersToIfs e2 | ||
return $ Econs e1' e2' | ||
numbersToIfs (Eif e1 e2 e3) = do | ||
e1' <- numbersToIfs e1 | ||
e2' <- numbersToIfs e2 | ||
e3' <- numbersToIfs e3 | ||
return $ Eif e1' e2' e3' | ||
numbersToIfs (Eseq e1 e2) = do | ||
e1' <- numbersToIfs e1 | ||
e2' <- numbersToIfs e2 | ||
return $ Eseq e1' e2' | ||
numbersToIfs (Ecase e ccs) = do | ||
e' <- numbersToIfs e | ||
ccs' <- mapM numbersToIfsCaseClause ccs | ||
return $ Ecase e' ccs' | ||
numbersToIfs (Ehandle e1 e2) = do | ||
e1' <- numbersToIfs e1 | ||
e2' <- numbersToIfs e2 | ||
return $ Ehandle e1' e2' | ||
numbersToIfs e = | ||
return e |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,84 @@ | ||
module PatternMatching.SimplifyHandles (simplifyHandles) where | ||
import Syntax.Expr | ||
|
||
cannotFailMatchingFunClause :: FunClause -> Bool | ||
cannotFailMatchingFunClause = cannotFailMatching . fbody | ||
|
||
cannotFailMatchingCaseClause :: CaseClause -> Bool | ||
cannotFailMatchingCaseClause = cannotFailMatching . cbody | ||
|
||
cannotFailMatching :: Expr -> Bool | ||
cannotFailMatching (Efun fcs) = | ||
-- at this point we don't have to worry about incomlete matchings | ||
-- thosa have been taken care of in previos passes | ||
all cannotFailMatchingFunClause fcs | ||
cannotFailMatching (Elet _ e1 e2) = | ||
cannotFailMatching e1 && cannotFailMatching e2 | ||
cannotFailMatching (Eletrec _ fcs e) = | ||
all cannotFailMatchingFunClause fcs && cannotFailMatching e | ||
cannotFailMatching (Eapply e1 as) = | ||
cannotFailMatching e1 && all cannotFailMatching as | ||
cannotFailMatching (Epair e1 e2) = | ||
cannotFailMatching e1 && cannotFailMatching e2 | ||
cannotFailMatching (Econs e1 e2) = | ||
cannotFailMatching e1 && cannotFailMatching e2 | ||
cannotFailMatching (Eif e1 e2 e3) = | ||
cannotFailMatching e1 && cannotFailMatching e2 && cannotFailMatching e3 | ||
cannotFailMatching (Eseq e1 e2) = | ||
cannotFailMatching e1 && cannotFailMatching e2 | ||
cannotFailMatching (Ecase e ccs) = | ||
cannotFailMatching e && all cannotFailMatchingCaseClause ccs | ||
cannotFailMatching (Ehandle e1 e2) = | ||
cannotFailMatching e1 && cannotFailMatching e2 | ||
cannotFailMatching EmatchFailure = False | ||
cannotFailMatching _ = True | ||
|
||
simplifyHandles1FunClause :: FunClause -> FunClause | ||
simplifyHandles1FunClause fc = | ||
fc{ fbody = simplifyHandles1 $ fbody fc } | ||
|
||
simplifyHandles1CaseClause :: CaseClause -> CaseClause | ||
simplifyHandles1CaseClause cc = | ||
cc{ cbody = simplifyHandles1 $ cbody cc } | ||
|
||
simplifyHandles1 :: Expr -> Expr | ||
simplifyHandles1 (Efun fcs) = | ||
Efun $ map simplifyHandles1FunClause fcs | ||
simplifyHandles1 (Elet p e1 e2) = | ||
Elet p (simplifyHandles1 e1) $ simplifyHandles1 e2 | ||
simplifyHandles1 (Eletrec n fcs e) = | ||
Eletrec n (map simplifyHandles1FunClause fcs) $ simplifyHandles1 e | ||
simplifyHandles1 (Eapply e1 as) = | ||
Eapply (simplifyHandles1 e1) $ map simplifyHandles1 as | ||
simplifyHandles1 (Epair e1 e2) = | ||
Epair (simplifyHandles1 e1) $ simplifyHandles1 e2 | ||
simplifyHandles1 (Econs e1 e2) = | ||
Econs (simplifyHandles1 e1) $ simplifyHandles1 e2 | ||
simplifyHandles1 (Eif e1 e2 e3) = | ||
Eif (simplifyHandles1 e1) (simplifyHandles1 e2) $ | ||
simplifyHandles1 e3 | ||
simplifyHandles1 (Eseq e1 e2) = | ||
Eseq (simplifyHandles1 e1) $ simplifyHandles1 e2 | ||
simplifyHandles1 (Ecase e1 ccs) = | ||
Ecase (simplifyHandles1 e1) $ map simplifyHandles1CaseClause ccs | ||
simplifyHandles1 (Ehandle EmatchFailure e1) = | ||
simplifyHandles1 e1 | ||
simplifyHandles1 (Ehandle (Eif e1 e2 e3) e4) | ||
| cannotFailMatching (simplifyHandles1 e1) && | ||
cannotFailMatching (simplifyHandles1 e2) = | ||
Eif (simplifyHandles1 e1) (simplifyHandles1 e2) $ | ||
Ehandle (simplifyHandles1 e3) $ simplifyHandles1 e4 | ||
simplifyHandles1 (Ehandle e1 EmatchFailure) = | ||
simplifyHandles1 e1 | ||
simplifyHandles1 (Ehandle e1 e2) | ||
| cannotFailMatching (simplifyHandles1 e1) = | ||
simplifyHandles1 e1 | ||
| otherwise = | ||
Ehandle (simplifyHandles1 e1) $ simplifyHandles1 e2 | ||
simplifyHandles1 e = | ||
e | ||
|
||
simplifyHandles :: Expr -> Expr | ||
simplifyHandles e | ||
| simplifyHandles1 e == e = e | ||
| otherwise = simplifyHandles (simplifyHandles1 e) |
Oops, something went wrong.