Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'feature/compile-pattern-matching' into develop

  • Loading branch information...
commit 05f0305aa1efd0158f5afcf1f34b49d0634f3a31 2 parents a968e03 + dcc051d
@Averethel authored
View
26 PatternMatching.hs
@@ -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
View
40 PatternMatching/Counters.hs
@@ -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)
View
81 PatternMatching/NameWildcards.hs
@@ -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
View
94 PatternMatching/NumbersToIfs.hs
@@ -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
View
84 PatternMatching/SimplifyHandles.hs
@@ -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)
View
153 PatternMatching/ToCases.hs
@@ -0,0 +1,153 @@
+{-# LANGUAGE
+ FlexibleContexts
+ #-}
+
+module PatternMatching.ToCases (handlesToCases) where
+ import Syntax
+ import Rename
+
+ import PatternMatching.Counters
+
+ import Control.Exception.Base
+ import Control.Monad.State
+
+ type Equation = ([Pattern], Expr)
+
+ isVar :: Equation -> Bool
+ isVar (Pvar _:_, _) = True
+ isVar _ = False
+
+ getCon :: Equation -> Constructor
+ getCon (Pconst Cnil:_, _) = CNnil
+ getCon (Pcons _ _:_, _) = CNcons
+ getCon (Ppair _ _:_, _) = CNpair
+ getCon (Pconst (Cbool True):_, _) = CNtrue
+ getCon (Pconst (Cbool False):_, _) = CNfalse
+ getCon (Pconst Cunit:_, _) = CNunit
+ getCon e = assert False $ getCon e
+
+ subpaterns :: Pattern -> [Pattern]
+ subpaterns (Pcons p1 p2) = [p1, p2]
+ subpaterns (Ppair p1 p2) = [p1, p2]
+ subpaterns _ = []
+
+ partition :: (a -> Bool) -> [a] -> [[a]]
+ partition _ [] = []
+ partition _ [x] = [[x]]
+ partition f (x:y:xs)
+ | f x == f y =
+ tack x $ partition f (y:xs)
+ | otherwise =
+ [x] : partition f (y:xs)
+
+ tack :: a -> [[a]] -> [[a]]
+ tack x xss = (x : head xss) : tail xss
+
+ foldrM :: Monad m => (b -> a -> m a) -> a -> [b] -> m a
+ foldrM _ a [] = return a
+ foldrM f a (x:xs) = do
+ acc' <- foldrM f a xs
+ f x acc'
+
+ getVars :: [Pattern] -> [String]
+ getVars = map (\(Pvar x) -> x)
+
+ matchVar :: MonadState Counter m =>
+ [String] -> [([Pattern], Expr)] -> Expr -> m Expr
+ matchVar (u:us) qs =
+ match us [(ps, rename v u e) | (Pvar v : ps, e) <- qs]
+ matchVar us qs = assert False $ matchVar us qs
+
+ choose :: Constructor -> [Equation] -> [Equation]
+ choose c qs = [q | q <- qs, getCon q == c]
+
+ matchClause :: MonadState Counter m =>
+ Constructor -> [String] -> [Equation] -> Expr -> m CaseClause
+ matchClause c (_:us) qs def = do
+ let k = arity c
+ us' <- mapM (\_ -> freshVar) [1..k]
+ e' <- match (us' ++ us) [(subpaterns p ++ ps, e) | (p : ps, e) <- qs] def
+ return CC { constructor = c, variables = us', cbody = e' }
+ matchClause c us qs def = assert False $ matchClause c us qs def
+
+ matchCon :: MonadState Counter m => [String] -> [Equation] -> Expr -> m Expr
+ matchCon (u:us) qs def = do
+ let cs = constructors $ getCon $ head qs
+ ms' <- mapM (\c -> matchClause c (u:us) (choose c qs) def) cs
+ return $ Ecase (Evar u) ms'
+ matchCon us qs def = assert False $ matchCon us qs def
+
+ matchVarCon :: MonadState Counter m =>
+ [String] -> [Equation] -> Expr -> m Expr
+ matchVarCon us qs def
+ | isVar . head $ qs =
+ matchVar us qs def
+ | otherwise =
+ matchCon us qs def
+
+ match :: MonadState Counter m => [String] -> [Equation] -> Expr -> m Expr
+ match [] qs def =
+ return $ foldr Ehandle def [e | ([], e) <- qs ]
+ match (u:us) qs def =
+ foldrM (matchVarCon (u:us)) def $ partition isVar qs
+
+ decompose :: Expr -> [Equation]
+ decompose (Ehandle (Eapply (Efun [fc]) _) e2) =
+ (arguments fc, fbody fc) : decompose e2
+ decompose _ = []
+
+ handlesToCasesCaseClause :: MonadState Counter m => CaseClause -> m CaseClause
+ handlesToCasesCaseClause cc = do
+ b' <- handlesToCases $ cbody cc
+ return cc{ cbody = b' }
+
+ handlesToCasesFunClauses :: MonadState Counter m => [FunClause] -> m FunClause
+ handlesToCasesFunClauses fcs = do
+ let eqs = concatMap (decompose . fbody) fcs
+ let ags = getVars . arguments . head $ fcs
+ cs' <- match ags eqs EmatchFailure
+ return FC { arguments = map Pvar ags, fbody = cs' }
+
+ handlesToCases :: MonadState Counter m => Expr -> m Expr
+ handlesToCases (Efun fcs) = do
+ cs <- handlesToCasesFunClauses fcs
+ return $ Efun [cs]
+ handlesToCases (Elet p e1 e2) = do
+ e1' <- handlesToCases e1
+ e2' <- handlesToCases e2
+ return $ Elet p e1' e2'
+ handlesToCases (Eletrec n fcs e) = do
+ cs <- handlesToCasesFunClauses fcs
+ e' <- handlesToCases e
+ return $ Eletrec n [cs] e'
+ handlesToCases (Eapply e1 as) = do
+ e1' <- handlesToCases e1
+ as' <- mapM handlesToCases as
+ return $ Eapply e1' as'
+ handlesToCases (Epair e1 e2) = do
+ e1' <- handlesToCases e1
+ e2' <- handlesToCases e2
+ return $ Epair e1' e2'
+ handlesToCases (Econs e1 e2) = do
+ e1' <- handlesToCases e1
+ e2' <- handlesToCases e2
+ return $ Econs e1' e2'
+ handlesToCases (Eif e1 e2 e3) = do
+ e1' <- handlesToCases e1
+ e2' <- handlesToCases e2
+ e3' <- handlesToCases e3
+ return $ Eif e1' e2' e3'
+ handlesToCases (Eseq e1 e2) = do
+ e1' <- handlesToCases e1
+ e2' <- handlesToCases e2
+ return $ Eseq e1' e2'
+ handlesToCases (Ecase e1 ccs) = do
+ e1' <- handlesToCases e1
+ ccs' <- mapM handlesToCasesCaseClause ccs
+ return $ Ecase e1' ccs'
+ handlesToCases (Ehandle e1 e2) = do
+ e1' <- handlesToCases e1
+ e2' <- handlesToCases e2
+ return $ Ehandle e1' e2'
+ handlesToCases e =
+ return e
View
65 PatternMatching/ToHandles.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE
+ FlexibleContexts
+ #-}
+
+module PatternMatching.ToHandles where
+ import Syntax.Expr
+ import Syntax.Pattern
+
+ import PatternMatching.Counters
+
+ import Control.Monad.State
+
+ functionsToHandlesFunClause :: MonadState Counter m => FunClause -> m Expr
+ functionsToHandlesFunClause fc = do
+ b' <- functionsToHandles $ fbody fc
+ return $ Efun [fc { fbody = b' }]
+
+ functionsToHandlesFunClauses :: MonadState Counter m =>
+ [FunClause] -> m [FunClause]
+ functionsToHandlesFunClauses fcs = do
+ fcs' <- mapM functionsToHandlesFunClause fcs
+ ns' <- genNames . length . arguments . head $ fcs
+ let fcs'' = map (`Eapply` map Evar ns') fcs'
+ return [FC {arguments = map Pvar ns',
+ fbody = foldr Ehandle EmatchFailure fcs'' }]
+
+
+ functionsToHandles :: MonadState Counter m => Expr -> m Expr
+ functionsToHandles (Efun fcs) = do
+ fcs' <- functionsToHandlesFunClauses fcs
+ return $ Efun fcs'
+ functionsToHandles (Elet p e1 e2) = do
+ e1' <- functionsToHandles e1
+ e2' <- functionsToHandles e2
+ return $ Elet p e1' e2'
+ functionsToHandles (Eletrec n fcs e) = do
+ fcs' <- functionsToHandlesFunClauses fcs
+ e' <- functionsToHandles e
+ return $ Eletrec n fcs' e'
+ functionsToHandles (Eapply e1 as) = do
+ e1' <- functionsToHandles e1
+ as' <- mapM functionsToHandles as
+ return $ Eapply e1' as'
+ functionsToHandles (Epair e1 e2) = do
+ e1' <- functionsToHandles e1
+ e2' <- functionsToHandles e2
+ return $ Epair e1' e2'
+ functionsToHandles (Econs e1 e2) = do
+ e1' <- functionsToHandles e1
+ e2' <- functionsToHandles e2
+ return $ Econs e1' e2'
+ functionsToHandles (Eif e1 e2 e3) = do
+ e1' <- functionsToHandles e1
+ e2' <- functionsToHandles e2
+ e3' <- functionsToHandles e3
+ return $ Eif e1' e2' e3'
+ functionsToHandles (Eseq e1 e2) = do
+ e1' <- functionsToHandles e1
+ e2' <- functionsToHandles e2
+ return $ Eseq e1' e2'
+ functionsToHandles (Ehandle e1 e2) = do
+ e1' <- functionsToHandles e1
+ e2' <- functionsToHandles e2
+ return $ Ehandle e1' e2'
+ functionsToHandles e = return e
View
44 Rename.hs
@@ -0,0 +1,44 @@
+module Rename (rename) where
+ import Syntax.Expr
+ import Syntax.Pattern
+
+ isBound :: String -> Pattern -> Bool
+ isBound n (Pvar x) = x == n
+ isBound n (Ppair p1 p2) = isBound n p1 || isBound n p2
+ isBound n (Pcons p1 p2) = isBound n p1 || isBound n p2
+ isBound _ _ = False
+
+ renameFunClause :: String -> String -> FunClause -> FunClause
+ renameFunClause n1 n2 fc
+ | any (isBound n1) $ arguments fc = fc
+ | otherwise = fc { fbody = rename n1 n2 $ fbody fc }
+
+ renameCaseClause :: String -> String -> CaseClause -> CaseClause
+ renameCaseClause n1 n2 cc
+ | n1 `elem` variables cc = cc
+ | otherwise = cc { cbody = rename n1 n2 $ cbody cc }
+
+ rename :: String -> String -> Expr -> Expr
+ rename n1 n2 (Evar n)
+ | n == n1 = Evar n2
+ | otherwise = Evar n
+ rename n1 n2 (Efun fcs) =
+ Efun $ map (renameFunClause n1 n2) fcs
+ rename n1 n2 (Elet p e1 e2)
+ | isBound n1 p = Elet p e1 e2
+ | otherwise = Elet p (rename n1 n2 e1) $ rename n1 n2 e2
+ rename n1 n2 (Eletrec s fc e)
+ | s == n1 = Eletrec s fc e
+ | otherwise = Eletrec s (map (renameFunClause n1 n2) fc) $
+ rename n1 n2 e
+ rename n1 n2 (Eapply e1 as) = Eapply (rename n1 n2 e1) $
+ map (rename n1 n2) as
+ rename n1 n2 (Epair e1 e2) = Epair (rename n1 n2 e1) $ rename n1 n2 e2
+ rename n1 n2 (Econs e1 e2) = Econs (rename n1 n2 e1) $ rename n1 n2 e2
+ rename n1 n2 (Eif e1 e2 e3) = Eif (rename n1 n2 e1) (rename n1 n2 e2) $
+ rename n1 n2 e3
+ rename n1 n2 (Eseq e1 e2) = Eseq (rename n1 n2 e1) $ rename n1 n2 e2
+ rename n1 n2 (Ecase e ccs) = Ecase (rename n1 n2 e) $
+ map (renameCaseClause n1 n2) ccs
+ rename n1 n2 (Ehandle e1 e2) = Ehandle (rename n1 n2 e1) $ rename n1 n2 e2
+ rename _ _ e = e
View
7 Syntax.hs
@@ -1,12 +1,17 @@
module Syntax (
+ CaseClause(..),
Constant(..),
+ Constructor(..),
UnaryPrim(..),
BinaryPrim(..),
Pattern(..),
FunClause(..),
- Expr(..)
+ Expr(..),
+ arity,
+ constructors
) where
import Syntax.Constant
+ import Syntax.Constructor
import Syntax.UnaryPrim
import Syntax.BinaryPrim
import Syntax.Pattern
View
38 Syntax/Constructor.hs
@@ -0,0 +1,38 @@
+module Syntax.Constructor where
+ import Utils.Iseq
+
+ data Constructor =
+ CNnil
+ | CNcons
+ | CNpair
+ | CNtrue
+ | CNfalse
+ | CNunit
+ deriving Eq
+
+ pprConstructor :: Constructor -> Iseq
+ pprConstructor CNnil = iStr "NIL"
+ pprConstructor CNcons = iStr "CONS"
+ pprConstructor CNpair = iStr "PAIR"
+ pprConstructor CNtrue = iStr "TRUE"
+ pprConstructor CNfalse = iStr "FALSE"
+ pprConstructor CNunit = iStr "UNIT"
+
+ instance Show Constructor where
+ show = show . pprConstructor
+
+ arity :: Constructor -> Int
+ arity CNnil = 0
+ arity CNcons = 2
+ arity CNpair = 2
+ arity CNtrue = 0
+ arity CNfalse = 0
+ arity CNunit = 0
+
+ constructors :: Constructor -> [Constructor]
+ constructors CNnil = [CNnil, CNcons]
+ constructors CNcons = [CNnil, CNcons]
+ constructors CNpair = [CNpair]
+ constructors CNtrue = [CNtrue, CNfalse]
+ constructors CNfalse = [CNtrue, CNfalse]
+ constructors CNunit = [CNunit]
View
42 Syntax/Expr.hs
@@ -1,22 +1,24 @@
module Syntax.Expr where
import Syntax.BinaryPrim
import Syntax.Constant
+ import Syntax.Constructor
import Syntax.Pattern
import Syntax.UnaryPrim
+ import Utils.Errors
import Utils.Iseq
data FunClause = FC {
arguments :: [Pattern],
- body :: Expr
+ fbody :: Expr
} deriving Eq
pprFunArgs :: [Pattern] -> Iseq
pprFunArgs = iInterleave (iStr " ") . map pprAPattern
pprFunClause :: FunClause -> Iseq
- pprFunClause fc = pprFunArgs (arguments fc) `iAppend` iStr " -> "
- `iAppend` pprExpr (body fc)
+ pprFunClause fc = pprFunArgs (arguments fc) `iAppend` iStr " -> " `iAppend`
+ pprExpr (fbody fc)
pprFunClauses :: [FunClause] -> Iseq
pprFunClauses = iInterleave (iConcat [ iNewline, iStr "| "]) .
@@ -25,6 +27,25 @@ module Syntax.Expr where
instance Show FunClause where
show = show . pprFunClause
+ data CaseClause = CC {
+ constructor :: Constructor,
+ variables :: [String],
+ cbody :: Expr
+ } deriving Eq
+
+ pprCaseClause :: CaseClause -> Iseq
+ pprCaseClause cc = pprConstructor (constructor cc) `iAppend`
+ iStr " " `iAppend`
+ iInterleave (iStr " ") (map iStr $ variables cc) `iAppend`
+ iStr " -> " `iAppend` pprExpr (cbody cc)
+
+ pprCaseClauses :: [CaseClause] -> Iseq
+ pprCaseClauses = iInterleave (iConcat [ iNewline, iStr "| "]) .
+ map pprCaseClause
+
+ instance Show CaseClause where
+ show = show . pprCaseClause
+
data Expr =
Econst Constant
| Euprim UnaryPrim
@@ -38,6 +59,9 @@ module Syntax.Expr where
| Econs Expr Expr
| Eif Expr Expr Expr
| Eseq Expr Expr
+ | Ecase Expr [CaseClause]
+ | Ehandle Expr Expr
+ | EmatchFailure
deriving Eq
isAtomicExpr :: Expr -> Bool
@@ -53,13 +77,14 @@ module Syntax.Expr where
| otherwise = iStr "(" `iAppend` pprExpr e `iAppend` iStr ")"
pprArgs :: [Expr] -> Iseq
- pprArgs = iConcat . map pprAExpr
+ pprArgs = iInterleave (iStr " ") . map pprAExpr
pprApplication :: Expr -> [Expr] -> Iseq
pprApplication (Ebprim p) [e1, e2] = iConcat [ pprAExpr e1, iStr " ",
pprBinaryPrim p, iStr " ",
pprAExpr e2 ]
- pprApplication e args = iConcat [ pprExpr e, pprArgs args ]
+ pprApplication e args = iConcat [ pprExpr e, iStr " ",
+ pprArgs args ]
pprExpr :: Expr -> Iseq
pprExpr (Econst c) = pprConstant c
@@ -87,6 +112,13 @@ module Syntax.Expr where
iStr "}" ]
pprExpr (Eseq e1 e2) = pprAExpr e1 `iAppend` iStr "; "
`iAppend` pprAExpr e2
+ pprExpr (Ecase arg cls) = iConcat [ iStr "case ", pprAExpr arg,
+ iStr " of {", iNewline, indentation,
+ iIndent $ iStr " " `iAppend`
+ pprCaseClauses cls, iNewline, iStr "}" ]
+ pprExpr (Ehandle e1 e2) = iConcat [ pprAExpr e1, iNewline, iStr "rescue",
+ iNewline, pprAExpr e2 ]
+ pprExpr EmatchFailure = iStr matchFailure
instance Show Expr where
show = show . pprExpr
View
4 TypeInference.hs
@@ -1,7 +1,5 @@
module TypeInference where
- import Syntax.Expr
- import Syntax.Pattern
- import Syntax.Constant
+ import Syntax
import Types
import TypeInference.Env
View
35 TypeInference/Constructor.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE
+ FlexibleContexts
+ #-}
+
+module TypeInference.Constructor where
+ import Syntax.Constructor
+ import Types
+
+ import TypeInference.Counter
+ import TypeInference.Env
+
+ import Control.Exception.Base
+ import Control.Monad.Error
+ import Control.Monad.State
+
+ typeAndBindingsOfConstructor :: (MonadState Counter m, MonadError String m) =>
+ Constructor -> [String] -> m (Type, Env)
+ typeAndBindingsOfConstructor CNnil [] = do
+ v <- freshVar
+ return (Tlist v, [])
+ typeAndBindingsOfConstructor CNcons [h, t] = do
+ v <- freshVar
+ return (Tlist v, [(h, v), (t, Tlist v)])
+ typeAndBindingsOfConstructor CNpair [x, y] = do
+ v1 <- freshVar
+ v2 <- freshVar
+ return (Tpair v1 v2, [(x, v1), (y, v2)])
+ typeAndBindingsOfConstructor CNtrue [] =
+ return (Tbool, [])
+ typeAndBindingsOfConstructor CNfalse [] =
+ return (Tbool, [])
+ typeAndBindingsOfConstructor CNunit [] =
+ return (Tunit, [])
+ typeAndBindingsOfConstructor c as =
+ assert (arity c == length as) typeAndBindingsOfConstructor c as
View
41 TypeInference/Expr.hs
@@ -9,6 +9,7 @@ module TypeInference.Expr (typeOfExpr) where
import TypeInference.BinaryPrim
import TypeInference.Constant
import TypeInference.Constraints
+ import TypeInference.Constructor
import TypeInference.Counter
import TypeInference.Env
import TypeInference.Pattern
@@ -23,9 +24,9 @@ module TypeInference.Expr (typeOfExpr) where
typeOfFunClause env cns fc = do
tbcns <- mapM typeAndBindingsOfPattern $ arguments fc
let (tas, bas, cas) = unzip3 tbcns
- (t, s) <- typeOfExpr (concat bas ++ env) (concat cas ++ cns) $ body fc
- s' <- unify (concat cas ++ cns)
- return (Tfun tas t `applySubst` s `applySubst` s', s ++ s')
+ (te, s) <- typeOfExpr (concat bas ++ env) (concat cas ++ cns) $ fbody fc
+ s' <- unify (concat cas ++ cns)
+ return (Tfun tas te `applySubst` s `applySubst` s', s ++ s')
typeOfFunction :: (MonadState Counter m, MonadError String m) =>
Env -> Constraints -> [FunClause] -> m (Type, Subst)
@@ -36,6 +37,26 @@ module TypeInference.Expr (typeOfExpr) where
let subst = foldl (++) s ss
return (t `applySubst` subst, subst)
+ typeOfCaseClause :: (MonadState Counter m, MonadError String m) =>
+ Env -> Constraints -> CaseClause -> m (Type, Type, Subst)
+ typeOfCaseClause env cns cc = do
+ (tp, bs) <- typeAndBindingsOfConstructor (constructor cc) $ variables cc
+ (te, s) <- typeOfExpr (bs ++ env) cns $ cbody cc
+ s' <- unify cns
+ return (tp `applySubst` s' `applySubst` s,
+ te `applySubst` s' `applySubst` s, s' ++ s)
+
+ typeOfCase :: (MonadState Counter m, MonadError String m) =>
+ Env -> Constraints -> [CaseClause] -> m (Type, Type, Subst)
+ typeOfCase env cns cls = do
+ tcls <- mapM (typeOfCaseClause env cns) cls
+ let (ta:tas, tr:trs, ss) = unzip3 tcls
+ s <- unify $ cns `addConstraints`
+ map ((,) ta) tas `addConstraints`
+ map ((,) tr) trs
+ let subst = foldl (++) s ss
+ return (ta `applySubst` subst, tr `applySubst` subst, subst)
+
typeOfExpr :: (MonadState Counter m, MonadError String m) =>
Env -> Constraints -> Expr -> m (Type, Subst)
@@ -99,3 +120,17 @@ module TypeInference.Expr (typeOfExpr) where
(t2, s2) <- typeOfExpr env cns e2
s <- unify $ singleConstraint t1 Tunit `addConstraints` cns
return (t2 `applySubst` s, s ++ s2)
+ typeOfExpr env cns (Ecase e1 cls) = do
+ (t1, s1) <- typeOfExpr env cns e1
+ (ta, tr, s2) <- typeOfCase env cns cls
+ s <- unify $ singleConstraint ta t1 `addConstraints` cns
+ return (tr `applySubst` s `applySubst` s2 `applySubst` s1, s ++ s2 ++ s1)
+ typeOfExpr env cns (Ehandle e1 e2) = do
+ (t1, _) <- typeOfExpr env cns e1
+ (t2, s2) <- typeOfExpr env cns e2
+ s <- unify $ singleConstraint t1 t2 `addConstraints` cns
+ return (t2 `applySubst` s, s ++ s2)
+ typeOfExpr _ cns EmatchFailure = do
+ v <- freshVar
+ s <- unify cns
+ return (v, s)
View
6 Utils/Errors.hs
@@ -1,7 +1,8 @@
module Utils.Errors (
unboundVariable,
overlappingIds,
- cannotUnify
+ cannotUnify,
+ matchFailure
) where
unboundVariable :: String -> String
@@ -12,3 +13,6 @@ module Utils.Errors (
cannotUnify :: Show a => a -> a -> String
cannotUnify t1 t2 = "Cannot unify " ++ show t1 ++ " with " ++ show t2
+
+ matchFailure :: String
+ matchFailure = "Match failure"
Please sign in to comment.
Something went wrong with that request. Please try again.