|
documentation:
|
------------------------------------------------------------------------------
--- This module contains an implementation of case completion, i.e.,
--- all case expressions occurring in a FlatCurry program are completed
--- (with calls to `Prelude.failed`) and ordered according to the
--- constructor ordering of the corresponding data definitions.
---
--- @author Michael Hanus
--- @version March 2021
------------------------------------------------------------------------------
|
|
sourcecode:
|
module FlatCurry.CaseCompletion where
import Data.List
import FlatCurry.Files
import FlatCurry.Types
------------------------------------------------------------------------------
--- Type to represent algebraic data declarations
--- (pair of type name and list of constructor names and arities).
type DataDecl = (QName, [(QName,Int)])
--- Options for case completion.
data CaseOptions = CaseOptions
{ dataDecls :: [DataDecl]
}
typeOfConstructor :: CaseOptions -> QName -> DataDecl
typeOfConstructor opts qn =
let ctypes = filter (\ (_,cs) -> qn `elem` map fst cs) (dataDecls opts)
in if null ctypes
then error $ "Type of constructor '" ++ snd qn ++ "' not found!"
else head ctypes
------------------------------------------------------------------------------
--- Complete all nested cases in a FlatCurry program.
completeProg :: CaseOptions -> Prog -> Prog
completeProg opts (Prog mn imps types funs ops) =
Prog mn imps types (map (completeFun opts) funs) ops
--- Complete all nested cases in a FlatCurry function.
completeFun :: CaseOptions -> FuncDecl -> FuncDecl
completeFun opts (Func fn ar vis texp rule) =
Func fn ar vis texp (completeRule opts rule)
completeRule :: CaseOptions -> Rule -> Rule
completeRule _ (External n) = External n
completeRule opts (Rule args rhs) =
Rule args (completeExp opts rhs)
completeExp :: CaseOptions -> Expr -> Expr
completeExp _ (Var v) = Var v
completeExp _ (Lit l) = Lit l
completeExp opts (Comb ct qn es) =
Comb ct qn (map (completeExp opts) es)
completeExp opts (Let bs e) =
Let (zip (map fst bs) (map (completeExp opts . snd) bs)) (completeExp opts e)
completeExp opts (Free vs e) = Free vs (completeExp opts e)
completeExp opts (Or e1 e2) =
Or (completeExp opts e1) (completeExp opts e2)
completeExp opts (Typed e te) = Typed (completeExp opts e) te
completeExp opts (Case ct e brs) = case brs of
[] -> Case ct ce []
Branch (LPattern _) _ : _ -> Case ct ce cbrs
Branch (Pattern cn _) _ : _ ->
let consdecls = snd (typeOfConstructor opts cn)
sbrs = map (\c -> maybe (failedBranch c) id
(find (isBranchForCons c) cbrs))
consdecls
in Case ct ce sbrs
where
isBranchForCons c (Branch pat _) = case pat of Pattern pn _ -> fst c == pn
_ -> False
ce = completeExp opts e
cbrs = map (\ (Branch pat be) -> Branch pat (completeExp opts be)) brs
failedBranch (c,ar) = Branch (Pattern c [101 .. 100+ar])
(Comb FuncCall ("Prelude","failed") [])
------------------------------------------------------------------------------
--- Get all constructors occurring in case expressions in a FlatCurry program.
allConsProg :: Prog -> [QName]
allConsProg (Prog _ _ _ funs _) = unionMap allConsFun funs
--- AllCons all nested cases in a FlatCurry function.
allConsFun :: FuncDecl -> [QName]
allConsFun (Func _ _ _ _ (External _)) = []
allConsFun (Func _ _ _ _ (Rule _ exp)) = allConsExp exp
allConsExp :: Expr -> [QName]
allConsExp (Var _) = []
allConsExp (Lit _) = []
allConsExp (Comb _ _ es) = unionMap allConsExp es
allConsExp (Case _ e brs) =
union (allConsExp e) (unionMap allConsBranch brs)
where
allConsBranch (Branch (LPattern _) be) = allConsExp be
allConsBranch (Branch (Pattern qn _) be) = union [qn] (allConsExp be)
allConsExp (Let bs e) =
union (allConsExp e) (unionMap (allConsExp . snd) bs)
allConsExp (Free _ e) = allConsExp e
allConsExp (Or e1 e2) = union (allConsExp e1) (allConsExp e2)
allConsExp (Typed e _) = allConsExp e
unionMap :: Eq b => (a -> [b]) -> [a] -> [b]
unionMap f = foldr union [] . map f
------------------------------------------------------------------------------
--- Get all data types (pairs of type name and list of constructor names
--- and arities) in a given FlatCurry program.
dataDeclsOf :: Prog -> [DataDecl]
dataDeclsOf (Prog _ _ tdecls _ _) = concatMap dataDeclsOfTypeDecl tdecls
where
dataDeclsOfTypeDecl (TypeSyn _ _ _ _ ) = []
dataDeclsOfTypeDecl (TypeNew tn _ _ (NewCons cn _ _)) =
[(tn, [(cn,1)])] -- should not be relevant since newtypes are eliminated
dataDeclsOfTypeDecl (Type tn _ _ cdecl ) =
[(tn, map (\ (Cons cn ar _ _) -> (cn,ar)) cdecl)]
------------------------------------------------------------------------------
|