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 =<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 =<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 =<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 =<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))))))