module FreeC.Pass.CompletePatternPass
( completePatternPass
, checkPatternFuncDecl
) where
import Control.Monad ( unless )
import Data.Maybe ( fromJust )
import FreeC.Environment.Entry
import FreeC.Environment.LookupOrFail
import FreeC.IR.SrcSpan
import qualified FreeC.IR.Syntax as IR
import FreeC.IR.TypeSynExpansion
import FreeC.Monad.Converter
import FreeC.Monad.Reporter
import FreeC.Pass
import FreeC.Pretty ( showPretty )
completePatternPass :: Pass IR.Module IR.Module
completePatternPass ast = do
mapM_ checkPatternFuncDecl (IR.modFuncDecls ast)
return ast
checkPatternFuncDecl :: IR.FuncDecl -> Converter ()
checkPatternFuncDecl funcDecl = checkPatternExpr (IR.funcDeclRhs funcDecl)
where
checkPatternExpr :: IR.Expr -> Converter ()
checkPatternExpr (IR.Case srcSpan exprScrutinee exprAlts _) = do
checkPatternExpr exprScrutinee
mapM_ (checkPatternExpr . IR.altRhs) exprAlts
let tau = fromJust $ IR.exprType exprScrutinee
tau' <- expandAllTypeSynonyms tau
case IR.getTypeConName tau' of
Nothing -> failedPatternCheck srcSpan
Just typeName -> do
entry <- lookupEntryOrFail srcSpan IR.TypeScope typeName
let altConNames = map (IR.conPatName . IR.altConPat) exprAlts
performCheck (entryConsNames entry) altConNames srcSpan
checkPatternExpr (IR.App _ lhr rhs _)
= checkPatternExpr lhr >> checkPatternExpr rhs
checkPatternExpr (IR.TypeAppExpr _ lhr _ _) = checkPatternExpr lhr
checkPatternExpr (IR.If _ exprCond exprThen exprElse _) = checkPatternExpr
exprCond
>> checkPatternExpr exprThen
>> checkPatternExpr exprElse
checkPatternExpr (IR.Lambda _ _ lambdaRhs _) = checkPatternExpr lambdaRhs
checkPatternExpr (IR.Let _ binds e _)
= mapM_ (checkPatternExpr . IR.bindExpr) binds >> checkPatternExpr e
checkPatternExpr IR.Con {} = return ()
checkPatternExpr IR.Var {} = return ()
checkPatternExpr IR.Undefined {} = return ()
checkPatternExpr IR.ErrorExpr {} = return ()
checkPatternExpr (IR.Trace _ _ expr _) = checkPatternExpr expr
checkPatternExpr IR.IntLiteral {} = return ()
performCheck :: [IR.ConName] -> [IR.ConName] -> SrcSpan -> Converter ()
performCheck typeConNames altConNames srcSpan = unless
(all (`elem` typeConNames) typeConNames
&& length typeConNames == length altConNames) (failedPatternCheck srcSpan)
failedPatternCheck :: SrcSpan -> Converter ()
failedPatternCheck srcSpan = reportFatal
$ Message srcSpan Error
$ "Incomplete pattern in function: "
++ showPretty (IR.funcDeclName funcDecl)