----------------------------------------------------------------------------- -- | -- Module : RefacLetWhere -- Copyright : (c) Christopher Brown 2008 -- -- Maintainer : cmb21@kent.ac.uk -- Stability : provisional -- Portability : portable -- -- This module contains a transformation for HaRe. -- Let to Where and its converse. Apart from the pure syntactic change, -- A where is an equation where a let is an expression. Therefore, one must -- take into account guards and patterns as well as scoped entities. -- -- Let also binds closer than Where. -- ----------------------------------------------------------------------------- module RefacLetWhere where import PrettyPrint import PrettyPrint import PosSyntax import AbstractIO import Maybe import TypedIds import UniqueNames hiding (srcLoc) import PNT import TiPNT import List import RefacUtils import PFE0 (findFile) import MUtils (( # )) import RefacLocUtils -- | Binds an exp to another e.g. (HsID x, HsLit 5) says x is bound to 5. -- and it continues until the next non-comment line type Binding = (HsExpP, HsExpP) -- | An environment is a *set* of bindings. type Environment = [Binding] {- | An environment that is not yet a set - should be processed into an 'Environment'. -} type NonSetEnv = [Maybe Binding] -- | An argument list for a function which of course is a list of paterns. type FunctionPats = [HsPatP] -- | A list of declarations used to represent a where or let clause. type WhereDecls = [HsDeclP] data LetType = LetExp HsExpP | MonExp HsStmtP | Gen [HsDeclP] letToWhere args = do let fileName = ghead "filename" args row = read (args!!1)::Int col = read (args!!2)::Int -- f <- MT.lift $ getCurrentDirectory modName <- fileNameToModName fileName (inscps, _, mod, toks) <- parseSourceFile fileName let pnt = locToPNT fileName (row, col) mod pn = pNTtoPN pnt if pn /= defaultPN then liftToWhere modName fileName (inscps, mod, toks) pnt else error "\nInvalid cursor position!\n" {-| Takes the position of the highlighted code and returns the function name, the list of arguments, the expression that has been highlighted by the user, and any where\/let clauses associated with the function. -} findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the -- file to be -- refactored. -> (Int, Int) -- ^ The beginning position of the highlighting. -> (Int, Int) -- ^ The end position of the highlighting. -> t -- ^ The abstract syntax tree. -> (PNT, FunctionPats, HsExpP, WhereDecls) -- ^ A tuple of, -- (the function name, the list of arguments, -- the expression highlighted, any where\/let clauses -- associated with the function). findDefNameAndExp toks beginPos endPos t = fromMaybe (defaultPNT, [], defaultExp, []) (applyTU (once_tdTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t) where --The selected sub-expression is in the rhs of a match inMatch (match@(HsMatch loc1 pnt pats rhs ds)::HsMatchP) | locToExp beginPos endPos toks rhs /= defaultExp = Just (pnt, pats, locToExp beginPos endPos toks rhs, ds) inMatch _ = Nothing --The selected sub-expression is in the rhs of a pattern-binding inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP) | locToExp beginPos endPos toks rhs /= defaultExp = Just (patToPNT ps, [], locToExp beginPos endPos toks rhs, ds) inPat _ = Nothing convertLets d e (_,_,mod) = do t' <- addLetInWhere d e mod t'' <- doLetToWhere d e t' return t'' liftToWhere modName fileName (inscps, mod, toks) pnt@(PNT pn _ _) = if isLocalFunOrPatName pn mod then do (mod', ((toks',m),_))<-liftWhereLevel writeRefactoredFiles False [((fileName,m),(toks',mod'))] else error "\nThe identifer is not a function/pattern name!" where liftWhereLevel = runStateT (applyTP ((once_tdTP (failTP `adhocTP` liftToWhere' `adhocTP` liftToWhere2 )) `choiceTP` failure) mod) ((toks,unmodified),(-1000,0)) where liftToWhere' (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP) | definingDecls [pn] (hsDecls rhs) False False /=[] =doLifting2 pat pn liftToWhere' _=mzero liftToWhere2 (match@(HsMatch loc1 name pats rhs ds)::HsMatchP) | definingDecls [pn] (hsDecls rhs) False False /=[] =doLifting3 match pn liftToWhere2 _=mzero doLifting2 dest@(Dec (HsPatBind loc p parent ds)) pn = do let liftedDecls=definingDecls [pn] (hsDecls parent) True False declaredPns=nub $ concatMap definedPNs liftedDecls pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns (_, dd)<-hsFreeAndDeclaredPNs dest if pns==[] then do (parent',liftedDecls',paramAdded)<-addParamsToDef pn dd parent liftedDecls let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls' else liftedDecls' moveDecl1 (Dec (HsPatBind loc p parent' ds)) Nothing [pn] False else askRenamingMsg pns "lifting" doLifting3 (match@(HsMatch loc1 name pats parent ds)::HsMatchP) pn = do let liftedDecls=definingDecls [pn] (hsDecls parent) True False declaredPns=nub $ concatMap definedPNs liftedDecls pns<-pnsNeedRenaming inscps match parent liftedDecls declaredPns (_, dd)<-hsFreeAndDeclaredPNs match if pns==[] then do (parent',liftedDecls',paramAdded)<-addParamsToDef pn dd parent liftedDecls let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls' else liftedDecls' moveDecl1 (HsMatch loc1 name pats parent' ds) Nothing [pn] False else askRenamingMsg pns "lifting" worker dest ds pn =do let (before, parent,after)=divideDecls ds pnt liftedDecls=definingDecls [pn] (hsDecls parent) True False declaredPns=nub $ concatMap definedPNs liftedDecls (_, dd)<-hsFreeAndDeclaredPNs dest pns<-pnsNeedRenaming inscps dest parent liftedDecls declaredPns if pns==[] then do (parent',liftedDecls',paramAdded)<-addParamsToDef pn dd parent liftedDecls let liftedDecls''=if paramAdded then filter isFunOrPatBind liftedDecls' else liftedDecls' --True means the new decl will be at the same level with its parant. dest'<-moveDecl1 (replaceDecls dest (before++parent'++after)) (Just (ghead "liftToWhere" (definedPNs (ghead "worker" parent')))) [pn] False return (hsDecls dest') --parent'<-doMoving declaredPns (ghead "worker" parent) True paramAdded parent' --return (before++parent'++liftedDecls''++after) else askRenamingMsg pns "lifting" failure=idTP `adhocTP` mod where mod (m::HsModuleP) = error ( "Lifting this definition failed. "++ " This might be because that the definition to be lifted is defined in a class/instance declaration.") --return True if pn is a local function/pattern name isLocalFunOrPatName pn scope =isLocalPN pn && isFunOrPatName pn scope -- |Divide a declaration list into three parts (before, parent, after) according to the PNT, -- where 'parent' is the first decl containing the PNT, 'before' are those decls before 'parent' -- and 'after' are those decls after 'parent'. divideDecls::[HsDeclP]->PNT->([HsDeclP],[HsDeclP],[HsDeclP]) divideDecls ds pnt = let (before,after)=break (\x->findPNT pnt x) ds in if (after/=[]) then (before, [ghead "divideDecls" after], tail after) else (ds,[],[]) --Get the subset of 'pns' that need to be renamed before lifting. pnsNeedRenaming inscps dest parent liftedDecls pns =do r<-mapM pnsNeedRenaming' pns return (concat r) where pnsNeedRenaming' pn = do (f,d)<-hsFDsFromInside dest --f: free variable names that may be shadowed by pn --d: declaread variables names that may clash with pn vs<-hsVisiblePNs pn parent --vs: declarad varaibles that may shadow pn let inscpNames = map (\(x,_,_,_)->x) $ inScopeInfo inscps vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames if elem (pNtoName pn) vars || isInScopeAndUnqualified (pNtoName pn) inscps && findEntity pn dest then return [pn] else return [] --This pNtoName takes into account the qualifier. pNtoName (PN (UnQual i) orig)=i pNtoName (PN (Qual (PlainModule modName) i ) orig)=modName ++ "." ++ i askRenamingMsg pns str = error ("The identifier(s):" ++ showEntities showPNwithLoc pns ++ " will cause name clash/capture or ambiguity occurrence problem after " ++ str ++", please do renaming first!") moveDecl1 t defName pns topLevel = do ((toks, _),_)<-get let (declToMove, toksToMove) = getDeclAndToks (ghead "moveDecl1" pns) True toks t --error$ show (declToMove, toksToMove) t' <- rmDecl (ghead "moveDecl3" pns) False =< 1) (error ("Please rename " ++ (declToName d) ++ "before this refactoring to resolve scoping issues.")) (free, decs) <- freeDecs ds if (declToName d) `elem` decs then do error ("Lifting " ++ (declToName d) ++ " conflicts with a declared entity in the where clause. Please rename the entity first.") else do -- then we pass in the dependencies as parameters! :) let liftedDecls=definingDecls [(declToPName2 d)] [dec] True True (_,dd)<-hsFreeAndDeclaredPNs t op@(declToLift, ds', md) <- addParamsToDef (declToPName2 d) dd dec liftedDecls error $ show op {- let freeDec' = filterDecs freeDec (freeLet ++ decLet) error ( (concat (map pNtoName freeDec')) ++ " is/are not in scope within in the where clause.") -} | otherwise = return dec where funcCheck (dec@(Dec (HsFunBind loc matches))::HsDeclP) = do result <- checkMatches matches return (Dec (HsFunBind loc result)) where checkMatches [] = return matches checkMatches (m@(HsMatch _ _ _ rhs ds):ms) | findEntity le rhs = do decsRHS <- (decsInRHS rhs) when (length (filter (==(declToName d)) decsRHS) > 1) (error ("Please rename " ++ (declToName d) ++ "before this refactoring to resolve scoping issues.")) (free, decs) <- freeDecs ds if (declToName d) `elem` decs then do error ("Lifting " ++ (declToName d) ++ " conflicts with a declared entity in the where clause. Please rename the entity first.") else do (freeDec, _) <- freeDecs' d (freeLet, decLet) <- freeDecs' (xs \\ [d]) (free', decs') <- freeDecs' ds if and (freeDec `myElem` decLet) && and (freeDec `myElem` (freeLet ++ decLet)) then do ds' <- addDecl m Nothing ([d], Nothing) False return (ds':ms) else do let freeDec' = filterDecs freeDec (freeLet ++ decLet) error ( (concat (map pNtoName freeDec')) ++ " is/are not in scope within in the where clause.") | otherwise = do rest <- checkMatches ms return (m:rest) where freeDecs m = hsFreeAndDeclaredNames m funcCheck x = return x decsInRHS rhs = do (_, res) <- hsFreeAndDeclaredNames rhs return res freeDecs m = hsFreeAndDeclaredNames m freeDecs' m = hsFreeAndDeclaredPNs m filterDecs [] [] = [] filterDecs [] _ = [] filterDecs _ [] = [] filterDecs (x:xs) list | x `elem` list = x : filterDecs xs list | otherwise = filterDecs xs list myElem [] [] = [True] myElem [] _ = [True] myElem _ [] = [True] myElem (x:xs) list = (x `elem` xs) : myElem xs list -} addLetInWhere d (MonExp le@(HsLetStmt xs r)) t = applyTP (stop_tdTP (failTP `adhocTP` funcCheck)) t where funcCheck (dec@(Dec (HsPatBind l ps rhs ds))::HsDeclP) | findEntity le rhs = do (free, decs) <- freeDecs ds if (declToName d) `elem` decs then do error ("Lifting " ++ (declToName d) ++ " conflicts with a declared entity in the where clause. Please rename the entity first.") else do (freeDec, _) <- freeDecs' d (freeLet, decLet) <- freeDecs' (xs \\ [d]) (free', decs') <- freeDecs' ds if and (freeDec `myElem` decLet) && and (freeDec `myElem` (freeLet ++ decLet)) then do ds' <- addDecl dec Nothing ([d], Nothing) False return ds' else do let freeDec' = filterDecs freeDec (freeLet ++ decLet) error ( (concat (map pNtoName freeDec')) ++ " is/are not in scope within in the where clause.") | otherwise = return dec where funcCheck (dec@(Dec (HsFunBind loc matches))::HsDeclP) = do result <- checkMatches matches return (Dec (HsFunBind loc result)) where checkMatches [] = return matches checkMatches (m@(HsMatch _ _ _ rhs ds):ms) | findEntity le rhs = do (free, decs) <- freeDecs ds if (declToName d) `elem` decs then do error ("Lifting " ++ (declToName d) ++ " conflicts with a declared entity in the where clause. Please rename the entity first.") else do (freeDec, _) <- freeDecs' d (freeLet, decLet) <- freeDecs' (xs \\ [d]) (free', decs') <- freeDecs' ds if and (freeDec `myElem` decLet) && and (freeDec `myElem` (freeLet ++ decLet)) then do ds' <- addDecl m Nothing ([d], Nothing) False return (ds':ms) else do let freeDec' = filterDecs freeDec (freeLet ++ decLet) error ( (concat (map pNtoName freeDec')) ++ " is/are not in scope within in the where clause.") | otherwise = do rest <- checkMatches ms return (m:rest) where freeDecs m = hsFreeAndDeclaredNames m funcCheck x = return x freeDecs m = hsFreeAndDeclaredNames m freeDecs' m = hsFreeAndDeclaredPNs m filterDecs [] [] = [] filterDecs [] _ = [] filterDecs _ [] = [] filterDecs (x:xs) list | x `elem` list = x : filterDecs xs list | otherwise = filterDecs xs list myElem [] [] = [True] myElem [] _ = [True] myElem _ [] = [True] myElem (x:xs) list = (x `elem` xs) : myElem xs list addLetInWhere _ _ _ = error "Please highlight a let expression!" addParamsToDef pn dd parent liftedDecls =do (ef,_)<-hsFreeAndDeclaredPNs parent (lf,_)<-hsFreeAndDeclaredPNs liftedDecls let newParams=((nub lf)\\ (nub ef)) \\ dd --parameters (in PName format) to be added to pn because of lifting if newParams/=[] then if (any isComplexPatBind liftedDecls) then error "This pattern binding cannot be lifted, as it uses some other local bindings!" else do parent'<-{-addParamsToDecls parent pn newParams True-} addParamsToParent pn newParams parent liftedDecls'<-addParamsToDecls liftedDecls pn newParams True return (parent', liftedDecls',True) else return (parent,liftedDecls,False) addParamsToParent pn [] t = return t addParamsToParent pn params t =applyTP(full_buTP (idTP `adhocTP` inExp)) t where inExp (exp@(Exp (HsId (HsVar (PNT pname ty loc))))::HsExpP) | pname==pn = do let newExp=Exp (HsParen (foldl addParamToExp exp (map pNtoExp params))) update exp newExp exp inExp x =return x addParamToExp exp param =(Exp (HsApp exp param)) doLetToWhere :: (MonadPlus m, Term t, MonadState (([PosToken], Bool), (Int, Int)) m) => HsDeclP -> LetType -> t -> m t doLetToWhere d (LetExp e@(Exp (HsLet xs e1))) t = applyTP (stop_tdTP (failTP `adhocTP` (expCheck e))) t where expCheck (exp1::HsExpP) (exp2::HsExpP) | sameOccurrence exp1 exp2 == True = do if (length xs) > 1 then do ds <- rmDecl (pNTtoPN (declToPNT d)) False xs return (Exp (HsLet ds e1)) else do update exp2 e1 exp2 | otherwise = mzero doLetToWhere d (MonExp m@(HsLetStmt xs r)) t = applyTP (stop_tdTP (failTP `adhocTP` (expCheck m))) t where expCheck (stmt1::HsStmtP) (stmt2::HsStmtP) | sameOccurrence stmt1 stmt2 == True = do if (length xs) > 1 then do ds <- rmDecl (pNTtoPN (declToPNT d)) False xs return (HsLetStmt ds r) else do update stmt1 r stmt1 | otherwise = mzero doLetToWhere _ _ _ = error "Please highlight a let expression!" checkLet :: (Term t) => t -> PName -> LetType checkLet t name = (fromMaybe (error "Please select a definition within a let clause")) (applyTU (once_buTU (failTU `adhocTU` inExp `adhocTU` inMon)) t) where inExp exp@(Exp (HsLet ds e)::HsExpP) | or (map (defines name) ds) = Just (LetExp exp) inExp _ = Nothing inMon mon@((HsLetStmt ds rest)::HsStmtP) | or (map (defines name) ds) = Just (MonExp mon) inMon _ = Nothing -- inMonad mon@( checkCursor :: String -> Int -> Int -> HsModuleP -> HsDeclP checkCursor fileName row col mod = (fromMaybe (error "Please select a definition!")) $ (locToDec fileName (row, col) mod) -- |Find the declaration(in PNT format) whose start position is (row,col) in the -- file specified by the fileName, and returns Nothing if such an identifier does not exist. locToDec::(Term t)=>String -- ^ The file name ->(Int,Int) -- ^ The row and column number ->t -- ^ The syntax phrase ->Maybe HsDeclP -- ^ The result locToDec fileName (row, col) t =applyTU (once_buTU (failTU `adhocTU` worker)) t where worker dec@(Dec (HsFunBind loc ((HsMatch loc0 name p rhs ds):ms))::HsDeclP) | locToPNT' name fileName (row, col) = Just dec worker dec@(Dec (HsPatBind loc0 name rhs ds)) | locToPNT' (patToPNT name) fileName (row, col) = Just dec worker _ = Nothing locToPNT' name fileName (row, col) = (fromMaybe False) $ (applyTU (once_buTU (failTU `adhocTU` worker)) name) where worker pnt@(PNT pname ty (N (Just (SrcLoc fileName1 _ row1 col1)))) |fileName1==fileName && (row1,col1) == (row,col) = Just True worker _ =Nothing