HaRe-0.6: refactorer/RefacADT.hs
module RefacADT(addFieldLabels,addDiscriminators,addConstructors,
elimNestedPatterns,elimPatterns,createADTMod,fromAlgebraicToADT,
fromAlgebraicToADT1) where
import Prelude hiding (putStrLn)
import Maybe
import List
import Char
import PrettyPrint
import Prelude hiding (putStrLn)
import AbstractIO (putStrLn)
import PFE0 (allModules)
import RefacUtils hiding (mkNewName, conName)
-----------------------------------------------------------------------------------------------------
{-- This refactoring transforms an algebraic data type into an abstract datatype. This is done by
composing the invloved primitive refactorings in a correct order.
-}
-----------------------------------------------------------------------------------------------------
-- two versions of 'fromAlgebraicToADT' with different user-interfaces.
fromAlgebraicToADT1 args
= do let fileName = ghead "filename" args
typeCon = (args!!1)
seqRefac [addFieldLabels1 typeCon fileName
,addDiscriminators1 typeCon fileName
,addConstructors1 typeCon fileName
,elimNestedPatterns1 typeCon fileName
,elimPatterns1 typeCon fileName
,createADT1 typeCon fileName
]
putStrLn "Refactoring completed."
fromAlgebraicToADT args
= do let fileName = ghead "filename" args
row = read (args!!1)::Int
col = read (args!!2)::Int
info@(_, _, mod, _)<-parseSourceFile fileName
case checkCursor fileName row col mod of
Left errMsg ->do putStrLn errMsg
Right decl ->
do let typeCon = pNtoName $ getTypeCon decl
seqRefac [addFieldLabels1 typeCon fileName
,addDiscriminators1 typeCon fileName
,addConstructors1 typeCon fileName
,elimNestedPatterns1 typeCon fileName
,elimPatterns1 typeCon fileName
,createADT1 typeCon fileName
]
putStrLn "Refactoring completed."
--------------------------------------------------------
--This refactoring does not confined this refactoring.
seqRefac=seqRefac'.addFlagParam
where
addFlagParam [] = []
addFlagParam (r:rs) = (r False): (map (\r'->r' True) rs)
seqRefac' []= return ()
seqRefac' (r:rs) = do r
seqRefac' rs
-----------------------------------------------------------------
addFieldLabels1 typeCon fileName isSubRefactor
= do info@(_, _, mod,_) <-parseSourceFile fileName
case findDataTypeDecl typeCon mod of
Left errMsg ->do putStrLn errMsg
Right decl ->addFieldLabels' info decl fileName isSubRefactor
addDiscriminators1 typeCon fileName isSubRefactor
= do info@(_,_, mod,_) <- parseSourceFile fileName
case findDataTypeDecl typeCon mod of
Left errMsg -> putStrLn errMsg
Right decl ->addDiscriminators' info decl fileName isSubRefactor
addConstructors1 typeCon fileName isSubRefactor
= do info@(_, _,mod,_) <- parseSourceFile fileName
case findDataTypeDecl typeCon mod of
Left errMsg -> putStrLn errMsg
Right decl -> addConstructors' info decl fileName isSubRefactor
elimNestedPatterns1 typeCon fileName isSubRefactor
= do info@(_,_,mod,_) <- parseSourceFile fileName
case findDataTypeDecl typeCon mod of
Left errMsg -> putStrLn errMsg
Right decl -> elimNestedPatterns' decl info fileName isSubRefactor
elimPatterns1 typeCon fileName isSubRefactor
= do info@(_,_,mod,_) <- parseSourceFile fileName
case findDataTypeDecl typeCon mod of
Left errMsg -> putStrLn errMsg
Right decl -> elimPatterns' decl info fileName isSubRefactor
createADT1 typeCon fileName isSubRefactor
= do info@(_,_,mod,_) <- parseSourceFile fileName
case findDataTypeDecl typeCon mod of
Left errMsg -> putStrLn errMsg
Right decl -> createADT' decl info fileName isSubRefactor
findDataTypeDecl::String->HsModuleP->Either String HsDeclP
findDataTypeDecl typeCon mod
= case find definesTypeCon (hsModDecls mod) of
Nothing -> Left "The refactorer could not find the datatype declaration."
Just decl'-> Right decl'
where
definesTypeCon (Dec (HsDataDecl loc c tp _ _))
= typeCon == pNTtoName (head (hsPNTs tp))
definesTypeCon _ = False
-------------------------------------------------------------------------------------------------------------
{- This refactoring creates the module interface for the ADT. The pre-condition for the
refactoring is that there are no uses of the related data constructors in the importing modules.
If this refactoring is only used as a basic step in the refactoring 'fromAlgebraicToADT', then there
is no need to modify the client modules. However, if it is applied individully, there is a need to
check the client modules to make sure the exporting does not cause name clash/conflict problems.
-}
createADTMod args
=do let fileName= ghead "filename" args
row = read (args!!1)::Int
col = read (args!!2)::Int
info@(_,_,mod,_) <- parseSourceFile fileName
case checkCursor fileName row col mod of
Left errMsg ->putStrLn errMsg
Right decl ->
do isUsed<-useOfDataCons decl fileName
case isUsed of
True ->putStrLn ("Some of the data constructors declared by this datatype are used by at"
++" least one of the client modules, please apply the 'eliminate patterns' refactoring first.")
False->createADT' decl info fileName False
-- check whether any of the declared constructors is used by client modules.
-- useOfDataCons::HsDeclP->ModuleName->HsModuleP->Maybe Bool
useOfDataCons decl fileName
= do clients <-clientModsAndFiles =<<RefacUtils.fileNameToModName fileName
info <-mapM parseSourceFile (map snd clients)
let pns =concatMap (findPNames (conName decl)) (map (\ (_,_,mod,_)->hsModDecls mod) info)
return (pns/=[])
where
-- CHECK THIS LATER, WHY USING findPNames from the API does not work.
findPNames pns=head.(applyTU (once_tdTU (failTU `adhocTU` worker)))
where
worker (pn1::PNT)
|elem (pNTtoPN pn1) pns =return [pn1]
worker _ =return []
createADT' decl (_, exps, mod, toks) fileName isSubRefactor
= do (mod', ((toks',m),_)) <-runStateT (doCreateADTMod decl exps mod) ((toks, unmodified), (-1000, 0))
serverModName<- RefacUtils.fileNameToModName fileName
clients<-clientModsAndFiles serverModName
let typeCon = getTypeCon decl
refactoredClients <- mapM (createADTInClientMod typeCon) clients
writeRefactoredFiles isSubRefactor $ ((fileName,True),(toks', mod')):refactoredClients
createADTInClientMod typeCon (m, fileName)
= do (_,_,mod,toks)<-parseSourceFile fileName
(mod',((toks',modified),_))
<-runStateT (rmSubEntsFromExport typeCon mod) ((toks,unmodified), (-1000,0))
return ((fileName, modified),(toks',mod'))
doCreateADTMod decl@(Dec (HsDataDecl _ _ _ cons _)) exps mod
= mkADTInterface exps typeCon (typeCon:(selectors++discriminators++constructors)) mod
where
typeCon = getTypeCon decl
discriminators = map (fromJust.snd) $ existingDiscriminators mod decl
constructors = map (fromJust.snd) $ filter (\(x,y)->isJust y) $ existingConstructors mod decl
selectors = concatMap selectors' cons
where selectors' ((HsRecDecl _ _ _ i ts):: HsConDeclP) = map pNTtoPN (concatMap fst ts)
selectors' ((HsConDecl _ _ _ i _) ::HsConDeclP) = []
mkADTInterface exps typeCon pns mod
= case hsModExports mod of
-- The whole module is implicitly exported.
Nothing -> addItemsToExport mod Nothing True (Right entsToBeExported)
-- There are explicitly exported entities.
Just exports ->
case isJust (find (==(ModuleE (hsModName mod))) exports) of
-- The module name is explicitly exported.
True -> do mod'<-rmItemsFromExport mod (Left ([sNtoName (hsModName mod)], pns))
addItemsToExport mod' Nothing True (Right entsToBeExported)
--individual entities are explicitly exported
False ->do let entsToAdd =map pNtoVarEnt $ (pns \\(findEnts pns exports))
-- remove the type constructor
mod'<-rmItemsFromExport mod (Left ([], [typeCon]))
addItemsToExport mod' Nothing True (Right ((pNtoVarEnt typeCon):entsToAdd))
where
-- entities need to be exported.
entsToBeExported = nub $ map fromJust $ filter isJust (map fromEntToEntE exps)
fromEntToEntE (_, Ent modName (HsCon con) (Type _))
= if sNtoName con == pNtoName typeCon
then -- only export type constructor.
Just $ EntE (Abs (nameToPNT (sNtoName con)))
-- export both type constructor and data constructor.
else Just $ EntE (AllSubs (nameToPNT (sNtoName con)))
fromEntToEntE (_, Ent modName (HsVar var) _)
= Just $ EntE (Var (nameToPNT (sNtoName var)))
fromEntToEntE _ = Nothing
findEnts pns ents
=filter (\pn->any (\e->case e of
ModuleE _ -> False
EntE e' -> match pn e') ents) pns
where match pn (Var pnt) = pNTtoPN pnt == pn
match pn (Abs pnt) = pNTtoPN pnt == pn
match pn (AllSubs pnt) = pNTtoPN pnt == pn
match pn (ListSubs pnt _) = pNTtoPN pnt == pn
------------------------------------End of createADTMod------------------------------------------------------
doCreateADTMod1 decl@(Dec (HsDataDecl _ _ _ cons _)) mod exps
= addToExport mod exps typeCon (typeCon:(selectors++discriminators++constructors))
where
typeCon = getTypeCon decl
discriminators = map (fromJust.snd) $ existingDiscriminators mod decl
constructors = map (fromJust.snd) $ filter (\(x,y)->isJust y) $ existingConstructors mod decl
selectors = concatMap selectors' cons
selectors' ((HsRecDecl _ _ _ i ts):: HsConDeclP) = map pNTtoPN (concatMap fst ts)
selectors' ((HsConDecl _ _ _ i _)::HsConDeclP) = []
addToExport mod exps typeCon pns
=let filteredExps =map fromJust $ filter isJust (map fromEntToEntE exps)
exports = hsModExports mod
modName =ModuleE $ hsModName mod
in case isNothing exports of
True -> return mod
-- There are explicitly exported entities.
False -> case isJust (find (==modName) (fromJust exports))
of -- The whole module is exported.
True -> return mod
-- individual entities are explicitly exported
False ->do let entsToAdd =map pNtoVarEnt $ (pns \\(findEnts pns (fromJust exports)))
addItemsToExport mod Nothing False (Right entsToAdd)
where
fromEntToEntE (_, Ent modName (HsCon con) (Type _))
= if sNtoName con == pNtoName typeCon
then Just $ EntE (Abs (nameToPNT (sNtoName con)))
else Just $ EntE (AllSubs (nameToPNT (sNtoName con)))
fromEntToEntE (_, Ent modName (HsVar var) _)
= Just $ EntE (Var (nameToPNT (sNtoName var)))
fromEntToEntE _ = Nothing
findEnts pns ents
=filter (\pn->any (\e->case e of
ModuleE _ -> False
EntE e' -> match pn e') ents) pns
where match pn (Var pnt) = pNTtoPN pnt == pn
match pn (Abs pnt) = pNTtoPN pnt == pn
match pn (AllSubs pnt) = pNTtoPN pnt == pn
match pn (ListSubs pnt _) = pNTtoPN pnt == pn
exportEnts (HsModule _ _ (Just ents) _ _)
= map fromJust $ filter isJust
( map (\e ->case e of
(EntE ent) ->Just ent
_ ->Nothing) ents)
exportEnts (HsModule _ _ Nothing _ _) = []
findEntsToAdd typeConPN selectors discriminators constructors ents
= nub $ concatMap (match typeConPN) ents
where
match typeConPN (AllSubs pnt)
| pNTtoPN pnt == typeConPN
= concatMap snd selectors ++ map snd (discriminators++constructors)
match typeConPN (ListSubs pnt idents) -- refactor this
| pNTtoPN pnt == typeConPN
= let r1 = concatMap (\(dataCon, funs)->if elem (pNtoName dataCon) identNames
then funs
else []) selectors
r2 = concatMap (\(dataCon, fun)->if elem (pNtoName dataCon) identNames
then [fun]
else []) (discriminators++constructors)
in r1++r2
where
identNames= map identToName idents
identToName (HsVar i) = pNTtoName i
identToName (HsCon i) = pNTtoName i
match _ _ = []
getTypeCon::HsDeclP->PName
getTypeCon decl@(Dec (HsDataDecl l c tp cons d))
= pNTtoPN $ ghead "getTypeCon" $ filter (\(PNT _ (Type _) _)->True) (hsPNTs tp)
----------------------------------------------------------------------------------------------
{- This refactoring eliminate the affected patterns by using selectors/discriminators/constructors.
The condition for this refactoring is that there shoudn't be any nested patterns using other data
constructors in the pattern to be eliminated, and the selectors/discriminators/constructors should
be available. So there is a need to modify the imports/exports interfaces to make sure these
special functions are available. -}
----------------------------------------------------------------------------------------------
elimPatterns args
=do let fileName= ghead "filename" args
row = read (args!!1)::Int
col = read (args!!2)::Int
info@(_,_,mod,_) <- parseSourceFile fileName
case checkCursor fileName row col mod of
Left errMsg -> putStrLn errMsg
Right decl -> elimPatterns' decl info fileName False
elimPatterns' decl (_, exps, mod, toks) fileName isSubRefactor
= do (mod',((toks',modified),_))<-runStateT (do mod'<-doCreateADTMod1 decl mod exps
rmPatterns mod')
((toks,unmodified),(-1000,0))
if (any (flip isExported exps) (conPNT decl)) -- check whether any of the data constructors are exported.
then do
serverModName<- RefacUtils.fileNameToModName fileName
clients<-clientModsAndFiles serverModName
refactoredClients <- mapM (elimPatternsInClientMod serverModName) clients
writeRefactoredFiles isSubRefactor $ ((fileName,True),(toks', mod')):refactoredClients
else writeRefactoredFiles isSubRefactor $ [((fileName,True),(toks', mod'))]
where
typeCon = getTypeCon decl
conNames = conName decl
selectors = gatherSelectors decl
discriminators = gatherDiscriminators decl mod
constructors = gatherConstructors decl mod
elimPatternsInClientMod serverModName (m, fileName)
= do (_,_,mod,toks)<-parseSourceFile fileName
(mod',((toks',modified),_))
<-runStateT (do -- replace exports of data constructors by exports of associated special functions.
let entsToAdd= map (\x->(EntE (Var (nameToPNT x))))
$ findEntsToAdd typeCon selectors discriminators constructors (exportEnts mod)
mod'<- addItemsToExport mod Nothing False (Right entsToAdd)
-- replace imports of data constructors by imports of associated special functions.
mod''<-addToImport serverModName typeCon selectors discriminators constructors mod'
rmPatterns mod'')
((toks,unmodified), (-1000,0))
return ((fileName, modified),(toks',mod'))
rmPatterns = applyTP (full_tdTP (idTP `adhocTP` inMatch -- full_buTP and full_tdTP make difference in this function.
`adhocTP` inPatBinding
`adhocTP` inExp))
where
inMatch (match@(HsMatch loc i ps rhs ds)::HsMatchP)
|isNothing (find (==(pNTtoName i)) (map snd (discriminators++constructors)))
--the condition ensures that those special funs are not affected.
= do (ps', sels, guards) <-rmPatternsInParams conNames match ps
rhs'<-replaceVarsBySels sels rhs
rhs''<-replacePatsByConstructors conNames constructors rhs'
rhs'''<-if guards/=[] then addGuardsToRhs rhs'' $ fromJust (mkGuard guards)
else return rhs''
ds'<-replacePatsByConstructors conNames constructors =<<replaceVarsBySels sels ds
return $ (HsMatch loc i ps' rhs''' ds')
inMatch m = return m
inPatBinding (pat@(Dec (HsPatBind loc i rhs ds)::HsDeclP))
|isNothing (find (==(pNTtoName.patToPNT) i) (map snd (discriminators++constructors)))
--the condition ensures that those special funs are not affected.
= do rhs'<-replacePatsByConstructors conNames constructors rhs
ds'<-replacePatsByConstructors conNames constructors ds
return $ (Dec (HsPatBind loc i rhs' ds'))
inPatBinding m = return m
inExp (exp@(Exp (HsLambda ps e))::HsExpP)
=do (ps', sels, guards) <-rmPatternsInParams conNames exp ps
e'<-replaceVarsBySels sels e
let e''= if guards/=[] then (Exp (HsCase (fromJust (mkGuard guards))
[HsAlt loc0 fakeTruePat (HsBody e') []]))
else e'
exp'= Exp (HsLambda ps' e'')
if (exp/=exp') then update exp exp' exp
else return exp'
inExp exp@(Exp (HsListComp stmts))
= do exp'<-applyTP (full_buTP (idTP `adhocTP` inStmt)) exp
if (exp/=exp') then update exp exp' exp
else return exp'
where
inStmt (stmt@(HsGenerator loc p e stmts)::HsStmtP)
= do (p', sels, guards) <-rmPatternsInParams conNames stmt p
e'<-replaceVarsBySels sels e
stmts'<-replaceVarsBySels sels stmts
let stmts''=if guards/=[] then (HsQualifier (fromJust (mkGuard guards)) stmts')
else stmts'
return $ HsGenerator loc p' e' stmts''
inStmt m = return m
inExp exp@(Exp (HsDo stmts))
= do exp' <-applyTP (full_buTP (idTP `adhocTP` inStmt)) exp
if (exp/=exp') then update exp exp' exp
else return exp'
where
inStmt (stmt@(HsGenerator loc p e stmts)::HsStmtP)
=do (p', sels, guards) <-rmPatternsInParams conNames stmt p
e'<-replaceVarsBySels sels e
stmts'<-replaceVarsBySels sels stmts
let stmts''=if guards/=[] then (HsLast (Exp (HsCase (fromJust (mkGuard guards))
[HsAlt loc0 fakeTruePat (HsBody (Exp (HsDo stmts'))) []])))
else stmts'
return (HsGenerator loc p' e' stmts'')
inStmt m = return m
inExp exp@(Exp (HsCase e alts))
= do exp'<-applyTP (full_buTP (idTP `adhocTP` inAlt)) exp
if (exp/=exp') then update exp exp' exp
else return exp'
where
inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)
= do (p', sels, guards) <-rmPatternsInParams conNames alt p
rhs'<- replaceVarsBySels sels rhs
rhs''<-if guards/=[] then addGuardsToRhs rhs' $ fromJust (mkGuard guards)
else return rhs'
ds'<-replaceVarsBySels sels ds
return (HsAlt loc p' rhs'' ds')
inExp m = return m
rmPatternsInParams conNames ast ps
= do fds <-existingVbls ast
ps' <- rmPatternInParams1 fds conNames ps
resetVal
(sels, guards) <-rmPatternInParams2 fds conNames ps
resetVal
return (ps',sels, guards)
where
-- Two versions of `rmPatternInParams`, one for transformation, one for collecting information.
rmPatternInParams1 d conNames
=applyTP (stop_tdTP (failTP `adhocTP` inPat))
where
inPat pat@(Pat (HsPParen (Pat (HsPApp i is))))
| isJust (find (==pNTtoPN i) conNames)
= inPat' pat Nothing
inPat pat@(Pat (HsPAsPat i1 (Pat (HsPParen (Pat (HsPApp i2 is))))))
| isJust (find (==pNTtoPN i2) conNames)
= inPat' pat (Just (pNTtoName i1))
inPat (pat@(Pat (HsPApp i is))::HsPatP)
| isJust (find (==pNTtoPN i) conNames)
= inPat' pat Nothing
inPat pat@(Pat (HsPAsPat i1 (Pat (HsPApp i2 is))))
| isJust (find (==pNTtoPN i2) conNames)
= inPat' pat (Just (pNTtoName i1))
inPat pat@(Pat (HsPId (HsCon i)))
| isJust (find (==pNTtoPN i) conNames)
=inPat' pat Nothing
inPat pat@(Pat (HsPParen (Pat (HsPId (HsCon i)))))
| isJust (find (==pNTtoPN i) conNames)
= inPat' pat Nothing
inPat pat@(Pat (HsPAsPat i1 (Pat (HsPId (HsCon i2)))))
| isJust (find (==pNTtoPN i2) conNames)
=inPat' pat (Just (pNTtoName i1))
inPat pat@(Pat (HsPAsPat i1 (Pat (HsPParen (Pat (HsPId (HsCon i2)))))))
| isJust (find (==pNTtoPN i2) conNames)
=inPat' pat (Just (pNTtoName i2))
inPat _ = mzero
inPat' pat varName
= do unless (not (isNestedPattern conNames pat))
$ error "Nested patterns exist, please apply the 'eliminate nested patterns' refactoring first!"
(_,d') <- hsFreeAndDeclaredPNs pat
(tm,(v,val)) <- get
let newVarName =if isJust varName then fromJust varName
else mkNewName "p" (map pNtoName (d\\d')) "" val
nextVal' =(ord (glast "rmPatternInParams'" newVarName) - ord '0') +1
nextVal = if nextVal' >10 then 1 else nextVal'
put (tm, (v,nextVal))
update pat (Pat (HsPId (HsVar (nameToPNT newVarName)))) pat
rmPatternInParams2 d conNames ps
=do r<-applyTU (stop_tdTU (failTU `adhocTU` inPat)) ps
return (concatMap fst r, concatMap snd r)
where
inPat (pat@(Pat (HsPApp i is))::HsPatP)
| isJust (find (==pNTtoPN i) conNames)
= inPat' (pNTtoPN i) pat Nothing
inPat (pat@(Pat (HsPId (HsCon i)))::HsPatP)
| isJust (find (==pNTtoPN i) conNames)
= inPat' (pNTtoPN i) pat Nothing
inPat (pat@(Pat (HsPAsPat i1 i2)))
| case rmPParen i2 of
(Pat (HsPApp i2' _)) ->isJust (find (==pNTtoPN i2') conNames)
(Pat (HsPId (HsCon i2'))) ->isJust (find (==pNTtoPN i2') conNames)
_ ->False
= (\pat -> case pat of
(Pat (HsPApp i2' ps)) ->inPat' (pNTtoPN i2') pat (Just (pNTtoName i1))
(Pat (HsPId (HsCon i2')))->inPat' (pNTtoPN i2') pat (Just (pNTtoName i1))) (rmPParen i2)
inPat _ =mzero
inPat' conPN pat varName
= do (_,d') <- hsFreeAndDeclaredPNs pat
(tm,(v,val)) <- get
let (newVarName,nextVal')
=if isJust varName
then (fromJust varName, val)
else (mkNewName "p" (map pNtoName (d\\d')) "" val,
(ord (glast "rmPatternInParams'" newVarName) - ord '0') +1)
nextVal = if nextVal' >10 then 1 else nextVal'
put (tm, (v,nextVal))
let sels = findSelectors conPN selectors
selectorFuns =mkSelectorFuns conPN newVarName "" sels pat
guardExps = mkGuardExps newVarName discriminators pat
return [(selectorFuns, guardExps)]
isNestedPattern conNames appPat
= isJust $ find (==True) (ghead "isNestedPattern" (isNestedPattern' appPat))
where
isNestedPattern'= applyTU (full_tdTU (constTU [] `adhocTU` inAppPat))
where
inAppPat pat
| isVarPat pat =return []
inAppPat pat@(Pat (HsPApp i ps))
|isJust (find (==pNTtoPN i) conNames)
= return []
inAppPat pat@(Pat (HsPId (HsCon i)))
|isJust (find (==pNTtoPN i) conNames)
=return []
inAppPat pat@(Pat (HsPInfixApp _ i _))
|isJust (find (==pNTtoPN i) conNames)
= return []
inAppPat pat@(Pat (HsPRec i _))
|isJust (find (==pNTtoPN i) conNames)
= return []
inAppPat pat@(Pat (HsPAsPat i1 i2))
=isNestedPattern' i2
inAppPat pat@(Pat (HsPParen p))
=isNestedPattern' p
inAppPat _ = return [True]
repalceVarsBySels [] p = return p
replaceVarsBySels sels p =applyTP (full_buTP (idTP `adhocTP` inExp)) p
where
inExp exp@(Exp (HsId (HsVar (PNT pn ty src@(N (Just (SrcLoc fileName c row col)))))))
|isJust (find (==pn) pnsToBeReplaced)
= do let sel = (snd.fromJust) (find (\(x,y)-> x==pn) sels)
--pn' = replaceNameInPN Nothing pn sel
update exp sel exp
--update pnt (PNT pn' ty src) pnt
inExp e = return e
pnsToBeReplaced =map fst sels
replacePatsByConstructors conNames constructors
= applyTP (full_tdTP (idTP `adhocTP` inExp))
-- `adhocTP` inPNT))
where
inExp exp@(Exp (HsRecConstr _ i fields))
| isJust (find (==pNTtoPN i) conNames)
= do let entry = find (\(x,y)->x==(pNTtoPN i)) constructors
con = if isJust entry
then (snd.fromJust) entry
else error $ "Constructor function does not exist for the data constructor:" ++ pNTtoName i
es = map (\(HsField _ e ) -> e) fields
exp'= (Exp (HsParen (foldl (\e1 e2->(Exp (HsApp e1 e2))) (nameToExp con) es)))
update exp exp' exp
inExp e
| isJust (find (==(pNTtoPN.expToPNT) e) conNames)
= do let (PNT pn ty src)=expToPNT e
entry = find (\(x,y)->x==pn) constructors
constructor
=if isJust entry
then (snd.fromJust) entry
else error $ "Constructor function does not exist for the data constructor:"++ pNtoName pn
renamePN pn Nothing constructor True e
inExp e = return e
{-
inPNT pnt@(PNT pn ty src@(N (Just (SrcLoc fileName c row col))))
| isJust (find (== pn) conNames) && not (isTypeCon pnt)
= do let entry = find (\(x,y)->x==pn) constructors
constructor = if isJust entry
then (snd.fromJust) entry
else error $ "Constructor function does not exist for the data constructor:"++ pNtoName pn
pn' = replaceNameInPN Nothing pn constructor
updateExpToks pnt constructor
return (PNT pn' ty src)
inPNT pnt = return pnt
-}
mkGuardExps newVarName discriminators (Pat (HsPApp i ps))
= let discr =findDiscriminator (pNTtoPN i) discriminators
guardExp=Exp (HsApp (Exp (HsId (HsVar (nameToPNT discr))))
(Exp (HsId (HsVar (nameToPNT newVarName)))))
in [guardExp]
mkGuardExps newVarName discriminators (Pat (HsPId (HsCon i)))
= let discr =findDiscriminator (pNTtoPN i) discriminators
guardExp=Exp (HsApp (Exp (HsId (HsVar (nameToPNT discr))))
(Exp (HsId (HsVar (nameToPNT newVarName)))))
in [guardExp]
mkGuard [] = Nothing
mkGuard (e:es)
= Just (foldl (\e1 e2 -> (Exp (HsInfixApp e1 (HsVar (nameToPNT "&&")) e2))) e es)
-- What is poxfix for?
mkSelectorFuns con newVarName posfix selectors (Pat (HsPApp i ps))
= concatMap mkSelectorFuns' (zip selectors ps)
where mkSelectorFuns' (sel, pat@(Pat (HsPId (HsVar i))))
=[(pNTtoPN i, if posfix ==[]
then (Exp (HsParen (Exp (HsApp (Exp (HsId (HsVar (nameToPNT sel))))
(Exp (HsId (HsVar (nameToPNT newVarName))))))))
else (Exp (HsParen (Exp (HsApp (Exp (HsId (HsVar (nameToPNT (sel++"."++posfix)))))
(Exp (HsId (HsVar (nameToPNT newVarName)))))))))]
{-
if posfix=="" then "("++sel++" "++ newVarName++")"
else "(("++sel++"."++posfix++") "++newVarName++")")] -}
mkSelectorFuns' (sel, (Pat (HsPParen p)))
= mkSelectorFuns' (sel, p)
mkSelectorFuns' (sel, pat@(Pat (HsPApp i ps)))
= mkSelectorFuns con newVarName
(if posfix=="" then sel else sel++"."++posfix) selectors pat
mkSelectorFuns' (sel, _) = []
mkSelectorFuns _ _ _ _ _ = []
---- This function is only used by the 'RefacADT.hs' module, I haven't work out a way to refactor it.
addToImport serverModName typeCon selectors discriminators constructors mod
=applyTP (full_buTP (idTP `adhocTP` inImport)) mod
where
inImport (imp@(HsImportDecl loc m@(SN modName _) qual as h):: HsImportDeclP)
| serverModName == modName && findPN typeCon h
= case h of
Nothing -> return imp
Just (b, ents) -> do let funs=findEntsToAdd typeCon selectors discriminators constructors ents
if (funs==[]) then return imp
else addItemsToImport serverModName Nothing (Left funs) imp
inImport imp = return imp
findEntsToAdd typeConPN selectors discriminators constructors ents
= nub $ concatMap (match typeConPN) ents
where
match typeConPN (AllSubs pnt)
| pNTtoPN pnt == typeConPN
= concatMap snd selectors ++ map snd (discriminators++constructors)
match typeConPN (ListSubs pnt idents) -- refactor this
| pNTtoPN pnt == typeConPN
= let r1 = concatMap (\(dataCon, funs)->if elem (pNtoName dataCon) identNames
then funs
else []) selectors
r2 = concatMap (\(dataCon, fun)->if elem (pNtoName dataCon) identNames
then [fun]
else []) (discriminators++constructors)
in r1++r2
where
identNames= map identToName idents
identToName (HsVar i) = pNTtoName i
identToName (HsCon i) = pNTtoName i
match _ _ = []
------------------------------------------------------------------------------------------------------------------------
{- This refactoring removes the explict uses of specific data constructors by using selectors/disriminators/constructors.
To do this refactoring, put the cursor at beginning of the data type declaration, then select the `elimNestedPatterns`
in Refactor menu. There is no pre-condition for this refactoring. -}
------------------------------------------------------------------------------------------------------------------------
elimNestedPatterns args
=do let fileName= ghead "filename" args
row = read (args!!1)::Int
col = read (args!!2)::Int
info@(inscps, exps, mod, toks) <- parseSourceFile fileName
case checkCursor fileName row col mod of
Left errMsg -> putStrLn errMsg
Right decl -> elimNestedPatterns' decl info fileName False
elimNestedPatterns' decl (_,_,mod,toks) fileName isSubRefactor
= do (mod',((toks',modified),_))<-runStateT (elimNestedPatterns'' mod)
((toks,unmodified), (-1000,0))
modName <- RefacUtils.fileNameToModName fileName
clients<-clientModsAndFiles modName
refactoredClients <- mapM elimNestedPatternsInClientMod clients
writeRefactoredFiles isSubRefactor $ ((fileName,True),(toks', mod')):refactoredClients
where
conNames = conName decl
elimNestedPatternsInClientMod (m,fileName)
= do (_,_,mod,toks)<-parseSourceFile fileName
(mod',((toks',modified),_))<-runStateT (elimNestedPatterns'' mod)
((toks,unmodified), (-1000,0))
return ((fileName, modified),(toks',mod'))
{- This function removes those nested patterns in the formal parameters of a function declaration
by introducing guards and case expression. -}
elimNestedPatterns'' = applyTP (full_buTP (idTP `adhocTP` inMatch
`adhocTP` inExp))
where
inMatch (match@(HsMatch loc i ps rhs ds)::HsMatchP)
= do newMatch <-mkNewAST mkNewMatch conNames match ps
if (match/=newMatch) then update match newMatch match
else return newMatch
inExp (exp@(Exp (HsLambda ps e))::HsExpP)
=do newLambdaExp <-mkNewAST mkNewLambdaExp conNames exp ps
if (exp/=newLambdaExp) then update exp newLambdaExp exp
else return newLambdaExp
inExp exp@(Exp (HsListComp stmts))
= do exp'<-applyTP (full_buTP (idTP `adhocTP` inStmt)) exp
if (exp/=exp') then update exp exp' exp
else return exp'
where
inStmt (stmt@(HsGenerator loc p e stmts)::HsStmtP)
= mkNewAST mkNewListStmt conNames stmt p
inStmt m = return m
inExp exp@(Exp (HsDo stmts))
= do exp' <-applyTP (full_buTP (idTP `adhocTP` inStmt)) exp
if (exp/=exp') then update exp exp' exp
else return exp'
where
inStmt (stmt@(HsGenerator loc p e stmts)::HsStmtP)
= mkNewAST mkNewDoStmt conNames stmt p
inStmt m = return m
inExp exp@(Exp (HsCase e alts))
= do exp'<-applyTP (full_buTP (idTP `adhocTP` inAlt)) exp
if (exp/=exp') then update exp exp' exp
else return exp'
where
inAlt (alt@(HsAlt loc p rhs ds)::HsAltP)
= mkNewAST mkNewAlt conNames alt p
inExp m = return m
mkNewAST fun conNames ast p
= do fds <-existingVbls ast
p' <-rmNestedPatternInParams2 fds conNames p
resetVal
varsAndPats <- getExpPatPairs fds conNames p
resetVal
return (fun ast p' varsAndPats)
mkNewDoStmt stmt@(HsGenerator loc p e stmts) p' varsAndPats
=case varsAndPats of
Nothing -> stmt
Just (caseVars, casePats) -> (HsGenerator loc p' e (HsLast (Exp (HsCase caseVars
[HsAlt loc0 casePats (HsBody (Exp (HsDo stmts))) []]))))
mkNewListStmt stmt@(HsGenerator loc p e stmts) p' varsAndPats
= case varsAndPats of
Nothing -> stmt
Just (caseVars,casePats) ->(HsGenerator loc p' e (HsGenerator loc casePats (Exp (HsList [caseVars])) stmts))
mkNewLambdaExp exp@(Exp (HsLambda ps e)) ps' varsAndPats
= case varsAndPats of
Nothing -> exp
Just (caseVars,casePats) -> (Exp (HsLambda ps' (Exp (HsCase caseVars [HsAlt loc0 casePats (HsBody e) []]))))
mkNewAlt alt@(HsAlt loc p rhs@(HsBody e) ds) p' expsAndPats
= case expsAndPats of
Nothing -> alt
Just (exps, pats)->(HsAlt loc p' (HsGuard [(loc0, (Exp (HsCase exps
[HsAlt loc0 pats (HsBody fakeTrueExp) [],
HsAlt loc0 (Pat HsPWildCard) (HsBody fakeFalseExp) []])),
(Exp (HsApp (Exp (HsParen (Exp (HsLambda [pats] e)))) exps)))]) ds)
mkNewAlt alt@(HsAlt loc p rhs@(HsGuard es) ds) p' expsAndPats
= case expsAndPats of
Nothing -> alt
Just (exps, pats) -> let rhs'= HsGuard $ map (addToGuards (exps, pats)) es
in (HsAlt loc p' rhs' ds)
mkNewMatch ((HsMatch loc i ps rhs@(HsBody e) ds)::HsMatchP) ps' expsAndPats
= case expsAndPats of
Nothing -> HsMatch loc i ps' rhs ds
Just (exps, pats) -> (HsMatch loc i ps' (HsGuard [(loc0, (Exp (HsCase exps
[HsAlt loc0 pats (HsBody fakeTrueExp) [],
HsAlt loc0 (Pat HsPWildCard) (HsBody fakeFalseExp) []])),
(Exp (HsApp (Exp (HsParen (Exp (HsLambda [pats] e)))) exps)))]) ds)
mkNewMatch (HsMatch loc i ps rhs@(HsGuard es) ds) ps' expsAndPats
= case expsAndPats of
Nothing-> HsMatch loc i ps' rhs ds
Just (exps, pats)-> let rhs'= HsGuard $ map (addToGuards (exps,pats)) es
in (HsMatch loc i ps' rhs' ds)
addToGuards (exp, pat) (loc, e1, e2)
= let g1 = Exp (HsCase exp
[HsAlt loc0 pat (HsBody fakeTrueExp) [],
HsAlt loc0 (Pat HsPWildCard) (HsBody fakeFalseExp) []])
e1'= Exp (HsInfixApp g1 (HsVar (nameToPNT "&&")) e1)
e2'= Exp (HsApp (Exp (HsParen (Exp (HsLambda [pat] e2)))) exp)
in (loc, e1', e2')
getExpPatPairs d conNames ps
= do r <- applyTU (stop_tdTU (failTU `adhocTU` inPat)) ps
let r' = filter (\(x,y) -> isJust x) r
r''= map (\(x,y)->(patVarToExpVar (fromJust x),y)) r'
(exps, pats) = (map fst r'', map snd r'')
return (if length exps ==0 then Nothing
else if length exps==1 then Just (head exps, head pats)
else Just (Exp (HsTuple exps), Pat (HsPTuple loc0 pats)))
where
inPat (pat@(Pat (HsPApp i is))::HsPatP)
| isJust (find (==pNTtoPN i) conNames)
= do is'<-rmNestedPatternInParams1 d conNames is
let caseExps = filter (\(x,y) ->isJust x) is'
return caseExps
inPat _ = mzero
patVarToExpVar (Pat (HsPId (HsVar id))) = (Exp (HsId (HsVar id)))
{-There are two versions of 'rmNestedPatternsInParams'. These two functions have different
purspose: 'rmNestedPatternInParams1' aims to collect info, whereas 'rmNestedPatternInParams2'
aims to modify the syntax tree and token stream. The reason for this is because of the
limitation of Strafunski's combinators-}
rmNestedPatternInParams1 d conNames
= applyTU (stop_tdTU (failTU `adhocTU` inAppPat))
where
inAppPat pat
| isVarPat pat = return [(Nothing, pat)]
inAppPat pat@(Pat (HsPApp i ps))
|isNothing (find (==pNTtoPN i) conNames)
= replacePatByVar pat Nothing
inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPApp i2 ps))))
|isNothing (find (==pNTtoPN i2) conNames)
= replacePatByVar pat (Just (pNTtoName i1))
inAppPat pat@(Pat (HsPInfixApp _ i _))
|isNothing (find (==pNTtoPN i) conNames)
= replacePatByVar pat Nothing
inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPInfixApp _ i2 _))))
|isNothing (find (==pNTtoPN i2) conNames)
= replacePatByVar pat (Just (pNTtoName i1))
inAppPat pat@(Pat (HsPRec i _))
|isNothing (find (==pNTtoPN i) conNames)
= replacePatByVar pat Nothing
inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPRec i2 _))))
|isNothing (find (==pNTtoPN i2) conNames)
= replacePatByVar pat (Just (pNTtoName i1))
inAppPat pat
= replacePatByVar pat Nothing
replacePatByVar pat varName
= do (_,d') <- hsFreeAndDeclaredPNs pat
(t,(v,val)) <- get
let (newVarName,nextVal')
=if isJust varName
then (fromJust varName, val)
else (mkNewName "p" (map pNtoName (d\\d')) "" val,
(ord (glast "rmPatternInParams'" newVarName) - ord '0') +1)
nextVal = if nextVal' >10 then 1 else nextVal'
put (t, (v,nextVal))
return [(Just (Pat (HsPId (HsVar (nameToPNT newVarName)))), pat)]
rmNestedPatternInParams2 d conNames
= applyTP (stop_tdTP (failTP `adhocTP` inPat))
where
inPat (pat@(Pat (HsPApp i is))::HsPatP)
| isJust (find (==pNTtoPN i) conNames)
= do is'<-rmNestedPatternInParams' is
return (Pat (HsPApp i is'))
inPat _ = mzero
-- replace the nested patterns by variables.
rmNestedPatternInParams'
= applyTP (stop_tdTP (failTP `adhocTP` inAppPat))
where
inAppPat pat
| isVarPat pat = mzero
inAppPat pat@(Pat (HsPApp i ps))
|isNothing (find (==pNTtoPN i) conNames)
= replacePatByVar pat Nothing
inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPApp i2 ps))))
|isNothing (find (==pNTtoPN i2) conNames)
= replacePatByVar pat (Just (pNTtoName i1))
inAppPat pat@(Pat (HsPInfixApp _ i _))
|isNothing (find (==pNTtoPN i) conNames)
= replacePatByVar pat Nothing
inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPInfixApp _ i2 _))))
|isNothing (find (==pNTtoPN i2) conNames)
= replacePatByVar pat (Just (pNTtoName i1))
inAppPat pat@(Pat (HsPRec i _))
|isNothing (find (==pNTtoPN i) conNames)
= replacePatByVar pat Nothing
inAppPat pat@(Pat (HsPAsPat i1 (Pat (HsPRec i2 _))))
|isNothing (find (==pNTtoPN i2) conNames)
= replacePatByVar pat (Just (pNTtoName i1))
inAppPat pat
= replacePatByVar pat Nothing
replacePatByVar pat varName
= do (_,d') <- hsFreeAndDeclaredPNs pat
(t,(v,val)) <- get
let (newVarName,nextVal')
=if isJust varName
then (fromJust varName, val)
else (mkNewName "p" (map pNtoName (d\\d')) "" val,
(ord (glast "rmPatternInParams'" newVarName) - ord '0') +1)
nextVal = if nextVal' >10 then 1 else nextVal'
put (t,(v,nextVal))
update pat (Pat (HsPId (HsVar (nameToPNT newVarName)))) pat
---------------------------------------------------------------------------------
{- This refactoring adds field labels to a data type declaration, the label names will
be created by the refactorer automatically, however the user can rename them afterwards.
The refactoring does nothing if all the field labels already exisit.
No pre-condition for this refactoring.
-}
addFieldLabels args
=do let fileName= ghead "filename" args
row = read (args!!1)::Int
col = read (args!!2)::Int
info@(inscps, exps, mod, toks) <- parseSourceFile fileName
case checkCursor fileName row col mod of
Left errMsg -> putStrLn errMsg
Right decl -> addFieldLabels' info decl fileName False
addFieldLabels' (inscps,_, mod, toks) decl fileName isSubRefactor
= do clients <-clientModsAndFiles =<<RefacUtils.fileNameToModName fileName
-- make sure the new name does not cause any problems in the current and client modules.
-- By doing this, the refactor does not need to check the clients.
clientInfo <- mapM parseSourceFile (map snd clients)
let inscpNames =map (\ (x,_,_,_)->x) (concatMap inScopeInfo (inscps:(map (\ (a,_,_,_)->a) clientInfo)))
(mod',((toks',modified),_))<-runStateT (addFieldLabels'' inscpNames decl mod) ((toks, unmodified), (-1000,0))
writeRefactoredFiles isSubRefactor $ [((fileName,True),(toks', mod'))]
addFieldLabels'' inscpNames decl mod
= do let (decls1, decls2) = break (==decl) (hsModDecls mod)
newDecl <-conDeclToRecDecl inscpNames decl
decl'<-update decl newDecl decl
return $ mod {hsModDecls=decls1++(decl':(tail decls2))}
-- Add field labels to each data constructor declaration.
conDeclToRecDecl inscpeNames = applyTP (full_buTP (idTP `adhocTP` inConDecl))
where
inConDecl (decl@(HsConDecl loc is c i ts):: HsConDeclP)
|ts /= []
= do ts'<-createFieldLabel 1 i ts
return (HsRecDecl loc is c i ts')
inConDecl x = return x -- already has field labels.
-- create a field label by attaching a number to the end of the data constructor name.
createFieldLabel val dataCon [] = return []
createFieldLabel val dataCon (t:ts)
= do let name = mkNewName (map toLower (pNTtoName dataCon)) inscpeNames "" val
fieldLabelPNT =(PNT (PN (UnQual name) (G (PlainModule "unknown") name
(N (Just loc0)))) Value (N (Just loc0)))
-- only allowing one digit is too restrictive.
nextVal = (ord (glast "createFieldLabel" name) - ord '0') + 1
ds' <- createFieldLabel nextVal dataCon ts
return $ ([fieldLabelPNT], t):ds'
--------------------------------------------------------------------------------------
{- This refactoring adds discriminator functions to a data type declaration. The function names
will be created by the refactorer automatically, however the user can rename them afterwards.
No pre-condition for this refactoring.
-}
addDiscriminators args
=do let fileName= ghead "filename" args
row = read (args!!1)::Int
col = read (args!!2)::Int
info@(inscps, exps, mod, toks) <- parseSourceFile fileName
case checkCursor fileName row col mod of
Left errMsg -> putStrLn errMsg
Right decl -> addDiscriminators' info decl fileName False
addDiscriminators' (inscps,_,mod,toks) decl fileName isSubRefactor
= do clients <-clientModsAndFiles =<< RefacUtils.fileNameToModName fileName
clientInfo <- mapM parseSourceFile (map snd clients)
let inscpNames= map (\(x,_,_,_)->x) (concatMap inScopeInfo (inscps:(map (\(a,_,_,_)->a) clientInfo)))
(mod',((toks',modified),_))<-runStateT (addDiscriminators'' inscpNames decl mod)((toks, unmodified), (-1000,0))
-- no need to modify the client module.
writeRefactoredFiles isSubRefactor $ [((fileName,True),(toks',mod'))]
addDiscriminators'' inscpNames decl@(Dec (HsDataDecl (SrcLoc _ _ _ col) c tp conDecls _)) mod
= do let consWithDiscrs = existingDiscriminators mod decl
if (length conDecls == length consWithDiscrs)
then return mod -- all the discriminators already exist.
else do -- those data constructor decls without discriminators.
let conDecls' = filter (\x->isNothing (find (conName' x==) (map fst consWithDiscrs))) conDecls
funs= concatMap (mkDiscriminator col tp inscpNames (length conDecls) mod) conDecls'
addDecl mod Nothing (funs,Nothing) True
where
mkDiscriminator startCol tp existingNames cons mod (decl@(HsRecDecl _ _ _ i ts):: HsConDeclP)
= mkDiscriminator' startCol tp existingNames cons mod i ts
mkDiscriminator startCol tp existingNames cons mod (decl@(HsConDecl _ _ _ i ts):: HsConDeclP)
= mkDiscriminator' startCol tp existingNames cons mod i ts
mkDiscriminator' startCol tp existingNames cons mod i ts
= let funNamePNT =nameToPNT $ mkNewName (pNTtoName i) existingNames "is" 0
typeSig = (Dec (HsTypeSig loc0 [funNamePNT] [] (Typ (HsTyFun tp (Typ (HsTyCon (PNT (PN
(UnQual "Bool") (G (PlainModule "Prelude") "Bool" (N (Just loc0))))
(Type blankTypeInfo) (N (Just loc0 )))))))))
-- if only one data constructor is declared, only one match is needed.
match1 =let pats= if length ts ==0 then [Pat (HsPId (HsCon i))]
else [Pat (HsPParen (Pat (HsPApp i (mkWildCards (length ts)))))]
in [HsMatch loc0 funNamePNT pats (HsBody (Exp (HsId (HsCon (PNT (PN (UnQual "True")
(G (PlainModule "Prelude") "True" (N (Just loc0))))(Type blankTypeInfo) (N (Just loc0)))))))[]]
match2 = if cons ==1 then []
else [HsMatch loc0 funNamePNT [Pat HsPWildCard] (HsBody (Exp (HsId (HsCon (PNT (PN
(UnQual "False") (G (PlainModule "Prelude") "False" (N (Just loc0)))) (Type blankTypeInfo)
(N (Just loc0))))))) []]
fun = (Dec (HsFunBind loc0 (match1 ++ match2)))
in ([typeSig, fun])
mkWildCards 0 = []
mkWildCards n = (Pat HsPWildCard) : mkWildCards (n-1)
-- collect the exisiting discriminators
existingDiscriminators mod (Dec (HsDataDecl _ c tp conDecls _))
=filter (\x -> isJust (snd x)) $ map (findDiscriminator (hsModDecls mod)) conDecls
where
findDiscriminator decls (conDecl:: HsConDeclP)
= let (dataCon,numOfFields)= case conDecl of
(HsRecDecl _ _ _ i ts) -> (pNTtoPN i, length ts)
(HsConDecl _ _ _ i ts) -> (pNTtoPN i, length ts)
decls' = filter (\x -> isDiscriminator x (dataCon, numOfFields)) decls
in if decls'==[] then (dataCon, Nothing)
else (dataCon, Just (ghead "findDiscriminator" (definedPNs (head decls'))))
isDiscriminator (Dec (HsFunBind _ (match1@(HsMatch _ _ [p] _ _):matches))) (dataCon,numOfFields)
= let conAndArity = getConAndArity p
in if isJust conAndArity
then let (con, arity) = fromJust conAndArity
in (con, arity) == (dataCon, numOfFields)
&& ((render.ppi) (rhsExp match1)) =="True"
&& (if matches==[] then True
else length matches==1 && ((render.ppi) (rhsExp (head matches))) == "False")
else False
where
getConAndArity (Pat (HsPApp i ps)) = Just ((pNTtoPN i), length ps)
getConAndArity (Pat (HsPId (HsCon i))) = Just ((pNTtoPN i),0)
getConAndArity (Pat (HsPParen p)) = getConAndArity p
getConAndArity (Pat (HsPAsPat i p)) = getConAndArity p
getConAndArity _ = Nothing
rhsExp (HsMatch _ _ _ (HsBody e) _) = Just e
rhsExp _ = Nothing
isDiscriminator _ _ = False
----------------------------------------------------------------------------------------------
{- This refactoring adds constructor functions to a data type declaration. The function names
will be created by the refactorer automatically, however the user can rename them afterwards.
No pre-condition for this refactoring.
-}
addConstructors args
=do let fileName= ghead "filename" args
row = read (args!!1)::Int
col = read (args!!2)::Int
info@(_,_,mod,_) <- parseSourceFile fileName
case checkCursor fileName row col mod of
Left errMsg -> putStrLn errMsg
Right decl -> addConstructors' info decl fileName False
addConstructors' (inscps,_, mod, toks) decl fileName isSubRefactor
= do clients <-clientModsAndFiles =<<RefacUtils.fileNameToModName fileName
clientInfo <- mapM parseSourceFile (map snd clients)
let inscpNames= map (\(x,_,_,_)->x) (concatMap inScopeInfo (inscps:(map (\(a,_,_,_)->a) clientInfo)))
(mod',((toks',modified),_))<-runStateT (addConstructors'' inscpNames decl mod) ((toks, unmodified), (-1000,0))
-- no need to modify the client modules, as the new name won't cause problems.
writeRefactoredFiles isSubRefactor $ [((fileName,modified),(toks', mod'))]
addConstructors'' inscpNames decl@(Dec (HsDataDecl (SrcLoc _ _ _ col) c tp conDecls _)) mod
= do let consWithConstrs = existingConstructors mod decl
if (length conDecls == length consWithConstrs)
then return mod -- all constructors already exist, so do nothing.
else do let conDecls' = filter (\x->isNothing (find (conName' x==) (map fst consWithConstrs))) conDecls
funs =concatMap (mkConstructor col tp inscpNames mod) conDecls'
addDecl mod Nothing (funs,Nothing) True
where
mkConstructor startCol tp existingNames mod (decl@(HsRecDecl _ _ _ i ts):: HsConDeclP)
= mkConstructor' startCol tp existingNames mod i (map (typeFromBangType.snd) ts)
mkConstructor startCol tp existingNames mod (decl@(HsConDecl _ _ _ i ts):: HsConDeclP)
= mkConstructor' startCol tp existingNames mod i (map typeFromBangType ts)
mkConstructor' startCol tp existingNames mod i ts
= let funNamePNT =nameToPNT $ mkNewName (pNTtoName i) existingNames "mk" 0
numOfParams = length ts
typeSig = (Dec (HsTypeSig loc0 [funNamePNT] [] (mkTypeFun tp ts)))
fun = (Dec (HsFunBind loc0 [HsMatch loc0 funNamePNT [] (HsBody (Exp (HsId (HsCon i)))) []]))
in ([typeSig, fun])
mkTypeFun t ts = foldr (\ t1 t2 ->(Typ (HsTyFun t1 t2))) t ts
typeFromBangType (HsBangedType t) = t
typeFromBangType (HsUnBangedType t) = t
--existingConstructors:: HsModuleP -> HsDeclP ->(PName, Maybe PName)
existingConstructors mod (Dec (HsDataDecl _ c tp conDecls _))
=filter (\x -> isJust (snd x)) $ map (findConstructors (hsModDecls mod)) conDecls
where
findConstructors decls (conDecl:: HsConDeclP)
= let (dataCon,numOfFields)= case conDecl of
(HsRecDecl _ _ _ i ts) -> (pNTtoPN i, length ts)
(HsConDecl _ _ _ i ts) -> (pNTtoPN i, length ts)
decls' = filter (\x -> isConstructor x (dataCon, numOfFields)) decls
in if decls'==[] then (dataCon, Nothing)
else (dataCon, Just (ghead "findConstructors" (definedPNs (head decls'))))
isConstructor (Dec (HsFunBind _ [match1@(HsMatch _ _ ps (HsBody e) _ )])) (dataCon,numOfFields)
| length ps== numOfFields && all isVarPat ps
=hsPNs e ==dataCon : (hsPNs ps)
isConstructor (Dec (HsPatBind _ f (HsBody e) _)) (dataCon, numOfFileds)
= (render.ppi) e == pNtoName dataCon
isConstructor _ _ = False
--------------------Some utility functions --------------------------------------
-- check whether the cursor points to the beginning of the datatype declaration.
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 type constructor name!")
Just decl ->Right decl
where
locToTypeDecl =find (definesTypeCon (locToPNT fileName (row,col) mod)) (hsModDecls mod)
definesTypeCon pnt (Dec (HsDataDecl loc c tp _ _))= isTypeCon pnt && (findPNT pnt tp)
definesTypeCon pnt _ = False
-- Create a new name from the oldName, and the new name should not conflict with the exisiting names.
mkNewName oldName exisitingNames prefix init
= let newName = if init==0 then prefix++oldName
else prefix++oldName++ show init
in if elem newName exisitingNames
then mkNewName oldName exisitingNames prefix (init+1)
else newName
--get the list of free and declared variables.
existingVbls t = do (f,d)<-hsFDsFromInside t
return (f++d)
-- returns True if a pat is a variable.
isVarPat pat = case pat of
(Pat (HsPId (HsVar i))) -> True
(Pat (HsPAsPat i p)) -> isVarPat p
(Pat (HsPIrrPat p)) -> True
(Pat (HsPParen p)) -> isVarPat p
(Pat (HsPWildCard)) -> True
_ -> False
-- get the data constructor name.
conName (Dec (HsDataDecl _ _ _ cons _))
= map conName' cons
conName _ = []
getCons (Dec (HsDataDecl _ _ _ cons _))
= cons
getCons _ =[]
conName' (HsRecDecl _ _ _ i _) = pNTtoPN i
conName' (HsConDecl _ _ _ i _) = pNTtoPN i
conPNT (Dec (HsDataDecl _ _ _ cons _))
= map conPNT' cons
where
conPNT' (HsRecDecl _ _ _ i _) = i
conPNT' (HsConDecl _ _ _ i _) = i
-- remove the enclosing parenthesis.
rmPParen p = case p of (Pat (HsPParen p')) -> rmPParen p'
_ -> p
sNtoName (SN i _) = i
pNtoVarEnt pn = EntE (Var (PNT pn Value (N (Just loc0))))
-- find the selector associated with the constructor name specified by 'conName'
findSelectors conName allSelectors
= let r = find (\(x,y)->x==conName) allSelectors
in if isNothing r then error $ "Selectors do not exist for data constructor " ++ pNtoName conName
else (snd.fromJust) r
-- find the discriminator associated with the constructor name specified by `conName`
findDiscriminator conName allDiscrs
= let r = find (\(x,y) -> x == conName) allDiscrs
in if isNothing r then error $ "Discriminator does not exist for data constructor: " ++ pNtoName conName
else (snd.fromJust) r
--Collect all the field labels associated with the data declaration.
gatherSelectors::HsDeclP->[(PName,[String])]
gatherSelectors (Dec (HsDataDecl _ _ _ cons _))
=map selectors cons
where -- data constructor decl with field labels
selectors ((HsRecDecl _ _ _ i ts):: HsConDeclP)
= (pNTtoPN i, map pNTtoName (concatMap fst ts))
-- data constructors decl without field labels
selectors ((HsConDecl _ _ _ i _)::HsConDeclP)
= (pNTtoPN i, [])
--Collect all the discriminators associated with the data declaration in the current module.
gatherDiscriminators::HsDeclP->HsModuleP->[(PName,String)]
gatherDiscriminators decl mod
= map (\(x,y)->(x, pNtoName (fromJust y))) $ existingDiscriminators mod decl
--Collect all the constructors associated with the data declatation in the current module.
gatherConstructors::HsDeclP->HsModuleP->[(PName,String)]
gatherConstructors decl mod
= map (\(x,y) -> (x, pNtoName (fromJust y)))
$ filter (\(x,y)->isJust y) $ existingConstructors mod decl
resetVal = do (t,(v,_)) <- get
put (t, (v,0))
fakeTrueExp =(Exp (HsId (HsCon (PNT (PN (UnQual "True") (G (PlainModule "Prelude") "True" (N (Just loc0))))
(Type blankTypeInfo) (N (Just loc0))))))
fakeTruePat=(Pat (HsPId (HsCon (PNT (PN (UnQual "True") (G (PlainModule "Prelude") "True" (N (Just loc0))))
(Type blankTypeInfo) (N (Just loc0))))))
fakeFalseExp =(Exp (HsId (HsCon (PNT (PN (UnQual "False") (G (PlainModule "Prelude") "False" (N (Just loc0))))
(Type blankTypeInfo) (N (Just loc0))))))