----------------------------------------------------------------------------- -- | -- Module : RefacAddField -- Copyright : (c) Christopher Brown 2007 -- -- Maintainer : cmb21@kent.ac.uk -- Stability : provisional -- Portability : portable -- -- This module contains a transformation for HaRe. -- Add a field to a constructor and resolve -- pattern matching by placing references to said -- field by calls to error; also resolves type signatures (by making them -- more general if necessary). ----------------------------------------------------------------------------- module RefacAddField where import PrettyPrint import PrettyPrint import PosSyntax import AbstractIO import Maybe import TypedIds import UniqueNames hiding (srcLoc) import PNT import TiPNT import List import RefacUtils hiding (getParams) import PFE0 (findFile) import MUtils (( # )) import RefacLocUtils import System import IO import Char refacAddField args = do when (length args /= 5) (error "Please enter a field name ( _ to omit) and a field type!") let fileName = args!!0 fName = args!!1 fType = args!!2 row = read (args!!3)::Int col = read (args!!4)::Int AbstractIO.putStrLn "refacAddField" modInfo@(inscps, exps, mod, tokList) <- parseSourceFile (fileName) case checkCursor fileName row col mod of Left errMsg -> do error errMsg Right dat -> do let res = locToPNT fileName (row, col) mod let res2 = locToPN fileName (row, col) mod let decs = hsDecls mod let datDec = definingDecls [res2] decs False True let datName = (declToName (head datDec)) let datPNT = (declToPNT (head datDec)) -- if the field in question is a record we must get -- the name of the record... ((_,m), (newToks, newMod)) <- applyRefac (addField datPNT datName res fName fType tokList) (Just (inscps, exps, mod, tokList)) fileName writeRefactoredFiles False [((fileName, m), (newToks, newMod))] AbstractIO.putStrLn "Completed.\n" checkCursor :: String -> Int -> Int -> HsModuleP -> Either String HsDeclP checkCursor fileName row col mod = case locToTypeDecl of Nothing -> Left ("Invalid cursor position. Please place cursor at the beginning of the constructor name!") Just decl@(Dec (HsDataDecl loc c tp xs _)) -> Right decl where locToTypeDecl = find (definesTypeCon (locToPNT fileName (row, col) mod)) (hsModDecls mod) -- definesTypeCon pnt (Dec (HsDataDecl loc c tp xs _)) -- = isDataCon pnt && (findPNT pnt tp) definesTypeCon pnt (Dec (HsDataDecl _ _ _ i _)) = isDataCon pnt && (findPNT pnt i) definesTypeCon pnt _ = False getRecordName (Dec (HsDataDecl s c tp recs i)) pos = getRecordName' recs pos 1 where getRecordName' :: [HsConDeclP] -> Int -> Int -> PNT getRecordName' ((HsRecDecl _ _ _ _ recs):cons) pos n = getRecordName'' recs pos n getRecordName'' :: [ ([PNT], HsBangType t)] -> Int -> Int -> PNT getRecordName'' [] _ _ = error "Not a valid field position!" getRecordName'' (([], _): types) pos n = getRecordName'' types pos n getRecordName'' ( ((l:ls), t) :types) pos n | pos == n = error $ show l | otherwise = getRecordName'' ((ls, t):types) pos (n+1) addField datPNT datName pnt fName fType tok (_, _, t) = do newMod <- addingField pnt fName fType t newMod' <- addingFieldInPat datName pnt fType tok newMod newMod'' <- addTypeVar datPNT pnt fType tok newMod return newMod'' addTypeVar datName pnt fType toks t = applyTP (full_buTP (idTP `adhocTP` inDatDeclaration)) t where inDatDeclaration (dat@(Dec (HsDataDecl a b tp c d))::HsDeclP) | (defineLoc datName == (defineLoc.typToPNT.(ghead "inDatDeclaration").flatternTApp) tp) && (fType `elem` (map (pNTtoName.typToPNT) (flatternTApp tp))) == False && isLower (head fType) = update dat (Dec (HsDataDecl a b (createTypFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) tp) ( ((nameToTyp fType) : (tail (flatternTApp tp))) )) c d)) dat inDatDeclaration (dat@(Dec (HsTypeSig s is c t))::HsDeclP) | (pNTtoName datName) `elem` (map (pNTtoName.typToPNT) (flatternTApp t) ) = do let res = changeType t if res == t then return dat else update dat (Dec (HsTypeSig s is c res)) dat inDatDeclaration t = return t changeType :: HsTypeP -> HsTypeP changeType t@(Typ (HsTyFun t1 t2)) = (Typ (HsTyFun (changeType t1) (changeType t2))) changeType t@(Typ (HsTyApp (Typ (HsTyCon p)) t2)) | (defineLoc datName) == (defineLoc p) && (fType `elem` (map (pNTtoName.typToPNT) (flatternTApp t))) == False && isLower (head fType) = (createTypFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) t) ( ((nameToTyp fType) : (tail (flatternTApp t))))) changeType t = t flatternTApp :: HsTypeP -> [HsTypeP] flatternTApp (Typ (HsTyFun t1 t2)) = flatternTApp t1 ++ flatternTApp t2 flatternTApp (Typ (HsTyApp t1 t2)) = flatternTApp t1 ++ flatternTApp t2 flatternTApp x = [x] addingField pnt fName fType t = applyTP (stop_tdTP (failTP `adhocTP` inDat)) t where inDat (dat@(HsConDecl s i c p types)::HsConDeclP) | p == pnt = do r <- update dat (HsConDecl s i c p (newTypes types fType)) dat return r inDat (dat@(HsRecDecl s i c p types)::HsConDeclP) | p == pnt = do r <- update dat (HsRecDecl s i c p (newRecTypes types fName fType)) dat return r inDat _ = fail "" -- newRecTypes must check that the name is not already declared as a field name -- within that constructor. newRecTypes xs n a | n `elem` (map pNTtoName (unFlattern xs)) = error "There is already a field declared with that name!" | otherwise = ([nameToPNT n], (HsUnBangedType (Typ (HsTyCon (nameToPNT a))))) : xs unFlattern :: [([a],b)] -> [a] unFlattern [] = [] unFlattern ((xs, y):xss) = xs ++ (unFlattern xss) newTypes xs a = HsUnBangedType (Typ (HsTyCon (nameToPNT a))) : xs addingFieldInPat datName pnt fType tok t = applyTP (stop_tdTP (failTP `adhocTP` inPat)) t where inPat d@(Dec _::HsDeclP) = do d' <- checkPat1 pnt pos d d'' <- checkCall pnt pos d' return d' where -- checkPat :: (Term t) => PNT -> String -> t -> HsPatP checkPat1 pnt pos t = applyTP (full_buTP (idTP `adhocTP` inP)) t inP pat@(Pat (HsPApp i p)) | (defineLoc i) == (defineLoc pnt) = update pat (Pat (HsPApp i ([nameToPat newName] ++ p))) pat -- RefacUtils.delete (p !! ((read pos::Int)-1)) pat inP x = return x newName = mkNewName (nameLowered (pNTtoName pnt)) (map pNtoName (definedPNs d)) 1 nameLowered (x:xs) = toLower x : xs checkCall pnt pos t = applyTP (stop_tdTP (failTP `adhocTP` conApp)) t -- a constructor application... conApp exp@(Exp (HsApp e1 e2)) | defineLoc pnt == (defineLoc.expToPNT.(ghead "inE").flatternApp) exp = update exp (createFuncFromPat ((expToPNT.(ghead "inE").flatternApp) exp) ([nameToExp "undefined"] ++ ( (tail.flatternApp) exp) )) exp conApp _ = mzero flatternApp :: HsExpP -> [HsExpP] flatternApp (Exp (HsApp e1 e2)) = flatternApp e1 ++ flatternApp e2 flatternApp x = [x] (!-) :: Int -> Int -> [a] -> [a] (!-) _ _ [] = [] (!-) n pos (x:xs) | n == pos = xs | otherwise = x : (!-) n (pos + 1) xs newPats :: [HsPatP] -> Int -> Int -> [HsPatP] newPats (p:ps) pos n | n == pos = ps | otherwise = p : (newPats ps pos (n+1)) -- inPat x = fail "" checkPat2 datName pnt pos t = applyTP (stop_tdTP (failTP `adhocTP` inPat)) t where inPat d@(Dec _::HsDeclP) = do d'' <- addCall (declToName d) pnt pos d return d'' addCall funcName pnt pos t = applyTP (stop_tdTP (failTP `adhocTP` (inE funcName))) t -- a name associated to a pattern binding somewhere... inE funcName exp@(Exp (HsId (HsVar x))) | (findPatBind pnt x (read pos::Int) t) = update exp (Exp (HsApp (Exp (HsApp (Exp (HsApp (nameToExp ("error" ++ datName)) (nameToExp ("\"" ++ (pNTtoName x) ++ "\"")))) (nameToExp ("\"" ++ (pNTtoName pnt) ++ "\"")))) (nameToExp ("\"" ++ funcName ++ "\"")))) exp inE _ x = mzero findPatBind :: (Term t) => PNT -> PNT -> Int -> t -> Bool findPatBind pnt x pos = (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inBind))) where inBind (dat@(Pat (HsPApp i types))::HsPatP) | pnt == i && checkInTypes x (types!!(pos-1)) = Just True inBind _ = Nothing checkInTypes x (Pat (HsPId (HsVar typePnt))) | defineLoc x == defineLoc typePnt = True checkInTypes _ x = False -- thePNT id = (PNT (PN (UnQual id) (G (PlainModule "unknown") id (N (Just loc0)))) (Type (TypeInfo (Just Primitive) [] [])) (N (Just loc0)))