module RefacRmCon(refacRmCon) where import PrettyPrint import PosSyntax import AbstractIO import Maybe import TypedIds import UniqueNames hiding (srcLoc) import PNT import TiPNT import List import RefacUtils hiding (getParams) import PFE0 (findFile) import MUtils (( # )) import RefacLocUtils import System import IO {- This refactoring removes a user selected constructor from a data type and resolves all pattern matching. When a constructor is removed, all equations over that value will be commented out; all references to that value within an expression will be replaced with a call to error. Copyright : (c) Christopher Brown 2008 Maintainer : cmb21@kent.ac.uk Stability : provisional Portability : portable -} data Decls = PatBind HsDeclP | MatchBind HsMatchP deriving (Read, Show, Eq) refacRmCon args = do let fileName = ghead "filename" args --fileName'= moduleName fileName --modName = Module fileName' row = read (args!!1)::Int col = read (args!!2)::Int modName <-fileNameToModName fileName (inscps, exps, mod, tokList)<-parseSourceFile fileName case checkCursor fileName row col mod of Left errMsg -> do error errMsg Right dat -> do let pnt = locToPNT fileName (row, col) mod if (pnt /= defaultPNT) then if isDataCon pnt then do let (pnts, defDecl) = pntsToBeRemoved pnt mod if isExported (declToPNT defDecl) exps then do clients <- clientModsAndFiles modName info <- mapM parseSourceFile $ map snd clients ((_,m), (newToks, newMod))<-applyRefac (doRemoving pnt defDecl modName) (Just (inscps, exps, mod, tokList)) fileName refactoredClients<-mapM (removeInClientMod pnt defDecl modName) $ zip info (map snd clients) writeRefactoredFiles False $ ((fileName,m),(newToks,newMod)):refactoredClients AbstractIO.putStrLn "\nCompleted.\n" else do ((_,m), (newToks, newMod))<-applyRefac (doRemoving pnt defDecl modName) (Just (inscps, exps, mod, tokList)) fileName writeRefactoredFiles False [((fileName,m), (newToks,newMod))] AbstractIO.putStrLn "\nCompleted.\n" else error "Please select a constructor!" else error "\nInvalid cursor position!" checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP checkCursor fileName row col mod = case locToTypeDecl of Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the constructor name!") Just decl@(Dec (HsDataDecl loc c tp xs _)) -> Right decl where locToTypeDecl = find (definesTypeCon (locToPNT fileName (row, col) mod)) (hsModDecls mod) -- definesTypeCon pnt (Dec (HsDataDecl loc c tp xs _)) -- = isDataCon pnt && (findPNT pnt tp) definesTypeCon pnt (Dec (HsDataDecl _ _ _ i _)) = isDataCon pnt && (findPNT pnt i) definesTypeCon pnt _ = False removeInClientMod pnt defDecl modName ((inscps, exps, mod,ts), fileName) = do ((_,m), (newToks, newMod))<-applyRefac (doRemoving2 pnt defDecl modName) (Just (inscps, exps, mod, ts)) fileName return ((fileName, m), (newToks, newMod)) doRemoving2 pnt defDecl modName (_, exps, t) = do mod'' <- removePatEquation pnt defDecl modName exps t mod''' <- replaceOrdPats pnt defDecl mod'' return mod''' doRemoving pnt defDecl modName (_, exps, t) = do mod' <- removeConstr pnt defDecl t mod'' <- removePatEquation pnt defDecl modName exps mod' mod''' <- replaceOrdPats pnt defDecl mod'' return mod''' createError :: String -> String -> Int -> HsExpP createError newE typeName line = (Exp (HsApp (nameToExp "error") (nameToExp ("\""++newE++" no longer defined for "++typeName++" at line: "++(show line)++"\"")))) pntToLine pnt = let (SrcLoc fileName _ row col) = (useLoc pnt) in row -- replace normal expression patterns with call to error replaceOrdPats pnt defDecl t = applyTP (stop_tdTP (failTP `adhocTP` rmInExp)) t where rmInExp e@(Exp (HsId (HsCon x))) | defineLoc x == defineLoc pnt = do let newE = (render.ppi) e let typeName = declToName defDecl let line = pntToLine pnt update e (Exp (HsParen (createError newE typeName line))) e rmInExp e@(Exp (HsInfixApp e1 o@(HsCon x) e2 )) | defineLoc x == defineLoc pnt = do let newE = (render.ppi) e let typeName = declToName defDecl let line = pntToLine pnt update e (Exp (HsParen (createError newE typeName line))) e rmInExp x = mzero -- comment out all equations referencing removed -- constructor removePatEquation pnt defDecl modName exps t = applyTP (full_buTP (idTP `adhocTP` rmInMod `adhocTP` rmInMatch `adhocTP` rmInPat `adhocTP` rmInLet `adhocTP` rmInAlt `adhocTP` rmInLetStmt `adhocTP` rmInMonad )) t where -- 1. the equation to comment out is on the top level of a definition... rmInMod (mod@(HsModule loc name exps imps ds):: HsModuleP) | canBeRemoved pnt mod =do let declsToRemove = whatCanBeRemoved pnt mod ds' <- rmDecls declsToRemove ds -- do we need to comment out the type signature -- of any entities? dsCommented <- comTypeSigs ds' (HsModule loc name exps imps ds') ds' -- check for calls to deleted definitions let removedElems = ds \\\ dsCommented dsReplacedCall <- checkCalls removedElems dsCommented -- check that deleted defintion is not exported... return (HsModule loc name exps imps dsReplacedCall) rmInMod x = return x --2. The definition to be removed is a local declaration in a match rmInMatch (match@(HsMatch loc name pats rhs ds)::HsMatchP) | canBeRemoved pnt match =do let declsToRemove = whatCanBeRemoved pnt match ds'<-rmDecls declsToRemove ds dsCommented <- comTypeSigs ds' (HsMatch loc name pats rhs ds') ds' let removedElems = ds \\\ dsCommented rhsReplacedCall <- checkCalls removedElems rhs return (HsMatch loc name pats rhsReplacedCall dsCommented) rmInMatch x =return x --3. The definition to be removed is a local declaration in a pattern binding rmInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP) | canBeRemoved pnt pat =do let declsToRemove = whatCanBeRemoved pnt pat ds'<- rmDecls declsToRemove ds dsCommented <- comTypeSigs ds' (Dec (HsPatBind loc p rhs ds')) ds' let removedElems = ds \\\ dsCommented rhsReplacedCall <- checkCalls removedElems rhs return (Dec (HsPatBind loc p rhsReplacedCall dsCommented)) rmInPat x =return x --4.The definition to be removed is a local declaration in a let expression rmInLet (letExp@(Exp (HsLet ds e))::HsExpP) | canBeRemoved pnt letExp = do let declsToRemove = whatCanBeRemoved pnt letExp ds'<- rmDecls declsToRemove ds if ds'==[] then return e else do dsCommented <- comTypeSigs ds' (Exp (HsLet ds' e)) ds' let removedElems = ds \\\ dsCommented eReplacedCall <- checkCalls removedElems e return (Exp (HsLet dsCommented eReplacedCall)) rmInLet (letExp@(Exp (HsListComp (HsLetStmt ds stmts)))) -- e.g. [0|z=1] => [0] | canBeRemoved pnt letExp =do let declsToRemove = whatCanBeRemoved pnt letExp ds'<- rmDecls declsToRemove ds dsCommented <- comTypeSigs ds' (Exp (HsListComp (HsLetStmt ds' stmts))) ds' let removedElems = ds \\\ dsCommented sReplacedCall <- checkCalls removedElems stmts if ds'/=[] then return (Exp (HsListComp (HsLetStmt dsCommented sReplacedCall))) else if isLast stmts then return (Exp (HsList [fromJust (expInLast sReplacedCall)])) else return (Exp (HsListComp sReplacedCall)) rmInLet x = return x --5. The defintion to be removed is a local decl in a case alternative. rmInAlt (alt@(HsAlt loc p rhs ds)::HsAltP) |canBeRemoved pnt alt =do let declsToRemove = whatCanBeRemoved pnt alt ds'<- rmDecls declsToRemove ds dsCommented <- comTypeSigs ds' (HsAlt loc p rhs ds') ds' let removedElems = ds \\\ dsCommented rhsReplacedCall <- checkCalls removedElems rhs return (HsAlt loc p rhsReplacedCall dsCommented) rmInAlt x = return x --6. The definition to be removed is a local decl in a let statement. rmInLetStmt (letStmt@(HsLetStmt ds stmts)::(HsStmt (HsExpP) (HsPatP) [HsDeclP])) |canBeRemoved pnt letStmt =do let declsToRemove = whatCanBeRemoved pnt letStmt ds'<- rmDecls declsToRemove ds dsCommenting <- comTypeSigs ds' (HsLetStmt ds' stmts) ds' let removedElems = ds \\\ dsCommenting sReplacedCall <- checkCalls removedElems stmts if ds'==[] then return sReplacedCall else return (HsLetStmt dsCommenting sReplacedCall) rmInLetStmt x = return x --7. If the definition occurs within a pattern binding in a monadic expression -- give an error. rmInMonad (letStmt@(HsLetStmt ds stmts)::HsStmtP) |canBeRemoved pnt letStmt =do let declsToRemove = whatCanBeRemoved pnt letStmt ds'<- rmDecls declsToRemove ds dsCommenting <- comTypeSigs ds' (HsLetStmt ds' stmts) ds' let removedElems = ds \\\ dsCommenting sReplacedCall <- checkCalls removedElems stmts if ds'==[] then return sReplacedCall else return (HsLetStmt dsCommenting sReplacedCall) rmInMonad (mon@(HsGenerator s p e stmts)::HsStmtP) | (defineLoc pnt) `elem` flatternPat p = error "Refactoring cannot be performed as constructor is used in a pattern binding!" -- [decl] rmInMonad x = return x -- list1 minus list2 (\\\) :: [HsDeclP] -> [HsDeclP] -> [HsDeclP] (\\\) list1 list2 = convertMatches list1 \\\\ convertMatches list2 (\\\\) [] _ = [] (\\\\) (d@(Dec (HsFunBind loc [HsMatch loc2 name _ _ _])):ls) list2 | name `elem2` list2 = ls \\\\ list2 | otherwise = d : ls \\\\ list2 where elem2 _ [] = False elem2 name (d@(Dec (HsFunBind loc [HsMatch loc2 name2 _ _ _])):ds) | name == name2 = True | otherwise = name `elem2` ds elem2 name (d:ds) = name `elem2` ds (\\\\) (d:ds) list2 | d `elem` list2 = ds \\\\ list2 | otherwise = d : ds \\\\ list2 convertMatches :: [HsDeclP] -> [HsDeclP] convertMatches [] = [] convertMatches ((Dec (HsFunBind loc ms)):ds) = let toFunBind m = Dec (HsFunBind loc [m]) in (map toFunBind ms) ++ (convertMatches ds) convertMatches (d:ds) = d : convertMatches ds -- checkCalls searched for all identifiers and checks whether their -- defining entity still occurs or not. -- if not, the identifier is replaced with a call to error -- (passing in its parameters via a show) checkCalls decs t = applyTP (stop_tdTP (failTP `adhocTP` rmInExp )) t where rmInExp e@(Exp (HsId (HsVar x))) | definingDecls [pNTtoPN x] decs False True /= [] = do let newE = (render.ppi) e let typeName = declToName defDecl let line = pntToLine pnt update e (createError newE typeName line) e rmInExp e@(Exp (HsApp e1 e2)) | concatMap (definingDecls' decs False True) (map expToPN (flatternApp e)) /= [] = do let newE = (render.ppi) e let typeName = declToName defDecl let line = pntToLine pnt update e (createError newE typeName line) e rmInExp x = mzero definingDecls' x y z l = definingDecls [l] x y z flatternApp :: HsExpP -> [HsExpP] flatternApp (Exp (HsApp e1 e2)) = flatternApp e1 ++ flatternApp e2 flatternApp (Exp (HsParen e)) = flatternApp e flatternApp x = [x] -- comTypeSigs :: (MonadState (([PosToken], Bool), t1) m, MonadPlus m) => [HsDeclP] -> [HsDeclP] -> m [HsDeclP] comTypeSigs [] _ _ = return [] comTypeSigs (d@(Dec (HsTypeSig _ _ _ _)):ds) e decs | not (any (isTypeSigOf' d) (map declToPNT' (hsDecls e))) = do -- we must comment out this type signature rest <- comTypeSigs ds e decs ((toks,_),others)<-get let (startPos,(endPosR, endPosC)) = getStartEndLoc toks d (toks', decls') = ((commentToks (startPos, (endPosR, endPosC)) toks),(rest \\ [d])) put ((toks',modified),others) let res = decls' if isExported (declToPNT d) exps then error ("Removing constructor forces " ++ (declToName d) ++ " in module " ++ (modNameToStr modName) ++ " to be removed. Please un-export it first.") else return res -- | otherwise = rmTypeSig ds environ comTypeSigs (d:ds) e decs = do rest <- comTypeSigs ds e decs return (d : rest) -- | Return True if the declaration defines the type signature of the specified identifier. isTypeSigOf' :: HsDeclP -> PNT-> Bool isTypeSigOf' (Dec (HsTypeSig loc is c tp)) pnt = elem (rmLocs pnt) (map rmLocs is) isTypeSigOf' _ _ =False rmDecls :: (MonadState (([PosToken], Bool), t1) m, MonadPlus m) => [Decls] -> [HsDeclP] -> m [HsDeclP] rmDecls [] e = return e rmDecls ((PatBind decl):ds) decls = do rest <- rmDecls ds decls ((toks,_),others)<-get let (startPos,(endPosR, endPosC)) = getStartEndLoc toks decl (toks', decls') = ((commentToks (startPos, (endPosR, endPosC)) toks),(rest \\ [decl])) put ((toks',modified),others) let res = decls' return res rmDecls ((MatchBind match):ds) decls = do rest <- rmDecls ds decls ((toks,_),others)<-get let (startPos,(endPosR, endPosC)) = getStartEndLoc toks match modDecls = removedMatch match rest -- decls (toks', decls') = ((commentToks (startPos, (endPosR, endPosC)) toks), modDecls) put ((toks',modified),others) let res = decls' return res removedMatch match decls = concatMap (removeMatch match) decls removeMatch match decl@(Dec (HsFunBind loc (m:ms))) | removesMatches match (m:ms) == [] = [] | otherwise = [ (Dec (HsFunBind loc (removesMatches match (m:ms)))) ] removeMatch m d = [d] removesMatches match [] = [] removesMatches match (m:ms) | sameOccurrence match m = removesMatches match ms | otherwise = m : removesMatches match ms isLast (HsLast e)=True isLast _=False --returns the expression included in the last statement. expInLast::HsStmtP->Maybe HsExpP expInLast (HsLast e)=Just e expInLast _=Nothing canBeRemoved pn t =let decls=hsDecls t decl=definingDecls2 pnt decls False -- pnames=concatMap definedPNs decl in (decl/=[] && all (not.flip findPNRHS (replaceDecls t (decls \\ decl))) [pNTtoPN pn]) whatCanBeRemoved pn t =let decls=hsDecls t decl=definingDecls1 pnt decls False in decl removeConstr pnt defDecl t = applyTP (once_tdTP (failTP `adhocTP` rmInDat)) t where --1. The constructor is within a data declaration rmInDat (dat@(Dec (HsDataDecl a b t c d))::HsDeclP) | sameOccurrence dat defDecl = do let newConstrs = removeConst c (pNTtoPN pnt) update dat (Dec (HsDataDecl a b t newConstrs d)) dat rmInDat _ = mzero removeConst [] _ = [] removeConst (m@(HsConDecl _ _ _ (PNT pname _ _) _):ms) pn | pname == pn = (removeConst ms pn) | otherwise = m : (removeConst ms pn) removeConst (m@(HsRecDecl _ _ _ (PNT pname _ _) _):ms) pn | pname == pn = (removeConst ms pn) | otherwise = m : (removeConst ms pn) pntsToBeRemoved pnt t = let decls=hsDecls t decl=definingDecls [pNTtoPN pnt] decls False False in (concatMap definedPNsForConstr decl, ghead "pntsToBeRemoved" decl) --Find those declarations(function/pattern binding and type signature) which reference -- the constructor on the LHS of the equation -- if we are removing the last equation then we must also remove the type signature... definingDecls1::PNT->[HsDeclP]->Bool->[Decls] definingDecls1 pnt ds incTypeSig=concatMap (defines pnt) ds where defines pnt decl@(Dec (HsFunBind loc (m:ms))) = nub (definesMatches (m:ms)) where definesMatches [] = [] definesMatches (decl@(HsMatch loc1 (PNT pname ty loc2) pats rhs ds'):ms) | (defineLoc pnt) `elem` (concatMap flatternPat pats) = (MatchBind decl) : definesMatches ms | otherwise = definesMatches ms defines pnt decl@(Dec (HsPatBind loc p rhs ds)) | (defineLoc pnt) `elem` flatternPat p = [PatBind decl] defines pn decl= [] --Find those declarations(function/pattern binding and type signature) which reference -- the constructor on the LHS of the equation definingDecls2::PNT->[HsDeclP]->Bool->[HsDeclP] definingDecls2 pnt ds incTypeSig=concatMap (defines pnt) ds where defines pnt decl@(Dec (HsFunBind loc (m:ms))) | or (definesMatches (m:ms)) = [decl] where definesMatches [] = [False] definesMatches (decl@(HsMatch loc1 (PNT pname ty loc2) pats rhs ds'):ms) | (defineLoc pnt) `elem` (concatMap flatternPat pats) = True : definesMatches ms | otherwise = definesMatches ms defines pnt decl@(Dec (HsPatBind loc p rhs ds)) | (defineLoc pnt) `elem` flatternPat p = error "Refactoring cannot be performed as constructor is used in a pattern binding!" -- [decl] defines pn decl= [] flatternPat :: HsPatP -> [SrcLoc] flatternPat t = inPat t where inPat (Pat (HsPId (HsVar pnt@(PNT _ _ _)))) = [defineLoc pnt] inPat (Pat (HsPInfixApp p1 pnt@(PNT _ _ _) p2)) = addPat (defineLoc pnt) (concatMap flatternPat [p1,p2]) inPat (Pat (HsPApp pnt@(PNT _ _ _) pats))=addPat (defineLoc pnt) (concatMap flatternPat pats) inPat (Pat (HsPRec pnt@(PNT _ _ _) fields))=[defineLoc pnt] inPat (Pat (HsPTuple _ pats)) = concatMap flatternPat pats inPat (Pat (HsPList _ pats)) = concatMap flatternPat pats inPat (Pat (HsPParen pats) ) = flatternPat pats inPat (Pat (HsPAsPat _ pats)) = flatternPat pats inPat (Pat (HsPIrrPat pats)) = flatternPat pats inPat _ = [] addPat pat mfd= ([pat] `union` mfd)