PatternMatch.hs

import Control.Monad.State
import Data.List (partition)

-- Definitions

data Pattern = PVar Variable | PCon Constructor [Pattern]

newtype Constructor = Constructor { unConstructor :: String } deriving (Eq, Show)
newtype Variable = Variable { unVariable :: String } deriving (Eq, Show)

data Expression = ECase Variable [Destruction] -- case v of
                | EAlt Expression Expression   -- E || E'

data Destruction = Destruction Constructor [Variable] Expression -- CONS vs => e

data Equation = Equation {
    _patterns :: [Pattern],
    _expr     :: Expression
}

-- Namer

type Env = Int

type Compiler = State Env

newVar :: Compiler Variable
newVar = do
    i <- get
    modify (+ 1)
    return $ Variable ("x" ++ show i)


-- Compiler

match :: [Variable] -> [Equation] -> Expression -> Compiler Expression
match []        qs def = return $ foldl EAlt def [e | Equation [] e <- qs]
match vs@(u:us) qs def = let (varqs, conqs) = partition isVarFirst qs
                         in  matchCon vs conqs def >>= matchVar vs varqs

matchVar :: [Variable] -> [Equation] -> Expression -> Compiler Expression
matchVar (u:us) qs def = match us qs' def
    where
        qs' = [ Equation ps (subst e u v) | Equation (PVar v : ps) e <- qs]

matchCon :: [Variable] -> [Equation] -> Expression -> Compiler Expression
matchCon (u:us) qs def = do
    let Equation (PCon con _ : _) _ = head qs
    clauses <- mapM (\c -> matchDes c us (choose c qs) def) $ getConstructors con
    return $ ECase u clauses

matchDes :: Constructor -> [Variable] -> [Equation] -> Expression -> Compiler Destruction
matchDes c us qs def = do
    let k = getArity c
    us' <- sequence $ take k $ repeat newVar
    expr <- match (us' ++ us) [ Equation (ps' ++ ps) e | Equation (PCon _ ps' : ps) e <- qs] def
    return $ Destruction c us' expr

isVarFirst :: Equation -> Bool
isVarFirst (Equation (PVar _ : _) _) = True
isVarFirst _ = False

subst (ECase x deses) u v = ECase x [ Destruction c vs (subst e u v) | Destruction c vs e <- deses]
subst (EAlt e1 e2) u v = EAlt (subst e1 u v) (subst e2 u v)
-- e[u/v]

choose = undefined
getArity = undefined
getConstructors = undefined