HaRe-0.6: refactorer/RefacWhereLet.hs
module RefacWhereLet(whereToLet) 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 converts a where into a let. Could potentially narrow the scrope of those involved bindings.
Copyright : (c) Christopher Brown 2008
Maintainer : cmb21@kent.ac.uk
Stability : provisional
Portability : portable
-}
whereToLet 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
let pnt = locToPNT fileName (row, col) mod
if not (checkInFun pnt mod)
then error "Please select a definition within a where clause!"
else do
if (pnt /= defaultPNT)
then do
((_,m), (newToks, newMod))<-applyRefac (doWhereToLet pnt)
(Just (inscps, exps, mod, tokList)) fileName
writeRefactoredFiles False [((fileName,m), (newToks,newMod))]
AbstractIO.putStrLn "Completed.\n"
else error "\nInvalid cursor position!"
doWhereToLet pnt (_,_,t)
= do
mod <- convertToWhere pnt t
return mod
convertToWhere pnt t
= applyTP (full_tdTP (idTP `adhocTP` conInMatch
`adhocTP` conInPat
`adhocTP` conInAlt
)) t
where
conInMatch (match@(HsMatch loc name pats (HsBody e) ds)::HsMatchP)
| canBeConverted ds pnt
= do
let decl = definingDecls [pNTtoPN pnt] ds True True
let updateRHS = (Exp (HsLet decl e))
ds' <- rmDecl (pNTtoPN pnt) True ds
-- we need to check that nothing else in the where
-- clause depends on this entity...
allDecs <- mapM hsFreeAndDeclaredPNs ds'
if (declToPName2 $ ghead "conInMatch" decl) `elem` (concat (map fst allDecs))
then error "Entity cannot be converted as another declaration in the where clause depends on it!"
else do e' <- update e updateRHS e
return (HsMatch loc name pats (HsBody e') ds')
conInMatch (match@(HsMatch loc name pats g@(HsGuard e) ds)::HsMatchP)
| canBeConverted ds pnt
= do let decl = definingDecls [pNTtoPN pnt] ds True True
let updateRHS = (HsBody (Exp (HsLet decl (rmGuard g))))
ds' <- rmDecl (pNTtoPN pnt) True ds
allDecs <- mapM hsFreeAndDeclaredPNs ds'
if (declToPName2 $ ghead "conInMatch Guard" decl) `elem` (concat (map fst allDecs))
then error "Entity cannot be converted as another declaration in the where clause depends on it!"
else do e' <- update g updateRHS g
return (HsMatch loc name pats e' ds')
conInMatch x = return x
conInPat (pat@(Dec (HsPatBind loc p (HsBody e) ds))::HsDeclP)
| canBeConverted ds pnt
= do
let decl = definingDecls [pNTtoPN pnt] ds True True
let updateRHS = (Exp (HsLet decl e))
ds' <- rmDecl (pNTtoPN pnt) True ds
allDecs <- mapM hsFreeAndDeclaredPNs ds'
if (declToPName2 $ ghead "conInPat" decl) `elem` (concat (map fst allDecs))
then error "Entity cannot be converted as another declaration in the where clause depends on it!"
else do e' <- update e updateRHS e
return (Dec (HsPatBind loc p (HsBody e') ds'))
conInPat (pat@(Dec (HsPatBind loc p g@(HsGuard e) ds))::HsDeclP)
| canBeConverted ds pnt
= do let decl = definingDecls [pNTtoPN pnt] ds True True
let updateRHS = (HsBody (Exp (HsLet decl (rmGuard g))))
ds' <- rmDecl (pNTtoPN pnt) True ds
allDecs <- mapM hsFreeAndDeclaredPNs ds'
if (declToPName2 $ ghead "conInPat" decl) `elem` (concat (map fst allDecs))
then error "Entity cannot be converted as another declaration in the where clause depends on it!"
else do e' <- update g updateRHS g
return (Dec (HsPatBind loc p e' ds'))
conInPat x = return x
conInAlt (alt@(HsAlt loc p (HsBody e) ds)::HsAltP)
| canBeConverted ds pnt
= do let decl = definingDecls [pNTtoPN pnt] ds True True
let updateRHS = (Exp (HsLet decl e))
ds' <- rmDecl (pNTtoPN pnt) True ds
e' <- update e updateRHS e
return (HsAlt loc p (HsBody e') ds')
conInAlt (alt@(HsAlt loc p g@(HsGuard e) ds)::HsAltP)
| canBeConverted ds pnt
= do let decl = definingDecls [pNTtoPN pnt] ds True True
let updateRHS = (HsBody (Exp (HsLet decl (rmGuard g))))
ds' <- rmDecl (pNTtoPN pnt) True ds
e' <- updateGuardAlt g updateRHS g
return (HsAlt loc p e' ds')
conInAlt x = return x
updateGuardAlt oldRhs newRhs t
= applyTP (once_tdTP (failTP `adhocTP` inRhs)) t
where
inRhs (r::RhsP)
| r == oldRhs && srcLocs r == srcLocs oldRhs
= do (newRhs',_) <- updateToks oldRhs newRhs prettyprintGuardsAlt
return newRhs'
inRhs r = mzero
rmGuard ((HsGuard gs)::RhsP)
= let (_,e1,e2)=glast "guardToIfThenElse" gs
in if ((pNtoName.expToPN) e1)=="otherwise"
then (foldl mkIfThenElse e2 (tail(reverse gs)))
else (foldl mkIfThenElse defaultElse (reverse gs))
mkIfThenElse e (_,e1, e2)=(Exp (HsIf e1 e2 e))
defaultElse=(Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "error") (G (PlainModule "Prelude") "error"
(N (Just loc0)))) Value (N (Just loc0)))))) (Exp (HsLit loc0 (HsString "UnMatched Pattern")))))
canBeConverted :: [HsDeclP] -> PNT -> Bool
canBeConverted ds pnt
= pnt `elem` map declToPNT ds
checkInFun :: Term t => PNT -> t -> Bool
checkInFun pnt t
= checkInMatch pnt t || checkInPat pnt t || checkInAlt pnt t
where
checkInAlt pnt t
= fromMaybe (False)
(applyTU (once_tdTU (failTU `adhocTU` inAlt)) t)
checkInPat pnt t
= fromMaybe (False)
(applyTU (once_tdTU (failTU `adhocTU` inPat)) t)
checkInMatch pnt t
= fromMaybe (False)
(applyTU (once_tdTU (failTU `adhocTU` inMatch)) t)
inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)
| findPNT pnt ds = Just True
inAlt _ = Nothing
--The selected sub-expression is in the rhs of a match
inMatch (match@(HsMatch loc1 _ pats rhs ds)::HsMatchP)
| findPNT pnt ds
= Just True
inMatch _ = Nothing
--The selected sub-expression is in the rhs of a pattern-binding
inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)
| findPNT pnt ds
= Just True
inPat _ = Nothing