HaRe-0.6: refactorer/RefacAddCon.hs
-----------------------------------------------------------------------------
-- |
-- Module : RefacAddCon
-- Copyright : (c) Christopher Brown 2006
--
-- Maintainer : cmb21@kent.ac.uk
-- Stability : provisional
-- Portability : portable
--
-- This module contains a transformation for HaRe.
-- Add a new constructor to a data type
-----------------------------------------------------------------------------
module RefacAddCon 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
-- | An argument list for a function which of course is a list of paterns.
type FunctionPats = [HsPatP]
-- | A list of declarations used to represent a where or let clause.
type WhereDecls = [HsDeclP]
alphabet :: String
alphabet = "abcdefghijklmnopqrstuvwxyz"
refacAddCon args
= do
let len = length args
if len > 2
then do
let (first,sec) = splitAt ((length args)-2) args
let fileName = first!!0
ans = concat ( map ( ++ " ") (tail first))
row = read (sec!!0)::Int
col = read (sec!!1)::Int
AbstractIO.putStrLn "refacAddCon"
-- let modName = convertModName modName1 -- Parse the input file.
modInfo@(inscps, exps, mod, tokList) <- parseSourceFile (fileName)
let res1 = locToPNT fileName (row, col) mod
res2 = locToPN fileName (row, col) mod
decs = hsDecls mod
datDec = definingDecls [res2] decs False True
datName = (declToName (ghead "datName" datDec))
datPNT = (declToPNT (ghead "datPNT" datDec))
-- add any new type params...
((_,m), (newToks, newMod)) <- applyRefac (addField (ghead "applyRefac" datDec) datPNT datName res1 (drop 1 (tail first)) tokList)
(Just (inscps, exps, mod, tokList)) fileName
writeRefactoredFiles False [((fileName, m), (newToks, newMod))]
(s, col', row', inf) <- doFileStuff fileName row col ans
modName1 <- fileNameToModName fileName
let modName = convertModName modName1 -- Parse the input file.
modInfo@(inscps, exps, mod, tokList) <- parseSourceFile (fileName)
-- Find the datatype that's been highlighted as the refactree
{- case checkCursor fileName row col mod of
Left errMsg -> do AbstractIO.removeFile (fileName ++ ".temp.hs")
error errMsg
Right dat ->
do
-}
let res' = locToPNT fileName (row, col) mod
res = pNTtoPN res'
-- Parse the input file.
AbstractIO.putStrLn ("parsing ..." ++ fileName ++ ".temp.hs")
modInfo2@(inscps', exps', mod', tokList') <- parseSourceFileOld (fileName ++ ".temp.hs")
AbstractIO.putStrLn "parsed."
let decs = hsDecls mod'
-- datDec = definingDecls [res] decs False True
-- get the list of constructors from the data type
decs' = hsDecls mod
datDec'' = definingDecls [res2] decs False True
datDec' = ghead "datDec'" datDec''
-- datName = getDataName [datDec']
pnames = definedPNs datDec'
newPN = locToPN (fileName ++ ".temp.hs") (row', col') mod'
newPNT = locToPNT (fileName ++ ".temp.hs") (row', col') mod'
numParam <- getParams datDec' newPNT
let oldPnames = filter (/= newPN) pnames
position = findPos 0 newPN pnames
((_,m), (newToks, newMod)) <- applyRefac (addCon (fileName) datName pnames newPN newPNT numParam oldPnames position inf (tail first) modName)
(Just (inscps', exps', mod', tokList')) (fileName++"temp.hs")
writeRefactoredFiles True [((fileName, m), (newToks, newMod))]
AbstractIO.removeFile (fileName ++ ".temp.hs")
AbstractIO.putStrLn "Completed.\n"
else do
error "refacAddCon must take a new constructor and a list of arguments."
addField datDec datPNT pnt fName fType tok (_, _, t)
= do
newMod <- addTypeVar datDec datPNT pnt fType tok t
return newMod
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 [] = xs
newRecTypes xs n (a:as)
| n `elem` (map pNTtoName (unFlattern xs)) = error "There is already a field declared with that name!"
| otherwise = ([nameToPNT n], (HsUnBangedType (Typ (HsTyCon (nameToPNT a))))) : (newRecTypes xs n as)
unFlattern :: [([a],b)] -> [a]
unFlattern [] = []
unFlattern ((xs, y):xss) = xs ++ (unFlattern xss)
newTypes xs [] = xs
newTypes xs (a:as) = HsUnBangedType (Typ (HsTyCon (nameToPNT a))) : (newTypes xs as)
addTypeVar datDec datName pnt fType toks t
= applyTP (full_buTP (idTP `adhocTP` (inDatDeclaration datDec))) t
where
inDatDeclaration _ (dat@(Dec (HsDataDecl a b tp c d))::HsDeclP)
| (defineLoc datName == (defineLoc.typToPNT.(ghead "inDatDeclaration").flatternTApp) tp) &&
checkIn fType tp
= update dat (Dec (HsDataDecl a b (createTypFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) tp)
( ((map nameToTyp fType') ++ (tail (flatternTApp tp))) )) c d)) dat
where
fType' = checkInOne2 tp [" "] fType
inDatDeclaration (Dec (HsDataDecl _ _ tp _ _)) (dat@(Dec (HsTypeSig s is c t))::HsDeclP)
| (pNTtoName datName) `elem` (map (pNTtoName.typToPNT) (flatternTApp t) )
= do
let res = changeType t tp
if res == t
then return dat
else update dat (Dec (HsTypeSig s is c res)) dat
inDatDeclaration _ t = return t
checkIn [] tp = True
checkIn (fType:fTypes) tp =
(fType `elem` (map (pNTtoName.typToPNT) (flatternTApp tp))) == False &&
isLower (ghead "checkIn" fType) || (checkIn fTypes tp)
checkInOne t tp n [] = []
checkInOne t tp n (f:fs)
| (f `elem` (map (pNTtoName.typToPNT) (flatternTApp tp))) &&
isLower (ghead "checkInOne" f) = checkInOne t tp n fs
| (f `elem` (map (pNTtoName.typToPNT) (flatternTApp t))) &&
isLower (ghead "checkInOne" f) = newName : checkInOne t tp (n ++ [newName]) fs
| (f `elem` (map (pNTtoName.typToPNT) (flatternTApp t))) == False &&
isLower (ghead "checkInOne" f) = f : (checkInOne t tp n fs)
| otherwise = checkInOne t tp n fs
where
newName = (mkNewName f (n ++ (map (pNTtoName.typToPNT) (flatternTApp tp))) 1)
checkInOne2 tp n [] = []
checkInOne2 tp n (f:fs)
| (f `elem` (map (pNTtoName.typToPNT) (flatternTApp tp))) == False &&
isLower (ghead "checkInOne" f) = f : (checkInOne2 tp n fs)
| otherwise = checkInOne2 tp n fs
changeType :: HsTypeP -> HsTypeP -> HsTypeP
changeType t@(Typ (HsTyFun t1 t2)) tp
= (Typ (HsTyFun (changeType t1 tp) (changeType t2 tp)))
changeType t@(Typ (HsTyApp (Typ (HsTyCon p)) t2)) tp
| (defineLoc datName) == (defineLoc p) &&
checkIn fType t
= createTypFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) t)
( ((map nameToTyp fType') ++ (tail (flatternTApp t))))
where
fType' = checkInOne t tp [" "] fType
changeType t@(Typ (HsTyApp t1 t2)) tp
= (Typ (HsTyApp (changeType t1 tp) (changeType t2 tp)))
-- fType'' = checkNames ftype' t
changeType t@(Typ (HsTyCon p)) tp
| (defineLoc datName) == (defineLoc p) &&
checkIn fType t
= createTypFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) t)
( ((map nameToTyp fType') ++ (tail (flatternTApp t))))
where
fType' = checkInOne t tp [" "] fType
changeType t tp = 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]
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
isDefinedData [] _ = error "Please select the beginning of a constructor!"
isDefinedData ((Dec (HsDataDecl _ _ _ cs i)):ds) c2
| c2 `myIn` cs = True
| otherwise = isDefinedData ds c2
where
myIn _ [] = False
myIn pnt ((HsConDecl _ _ _ i _):cs)
| pnt == i = True
| otherwise = myIn pnt cs
myIn pnt ((HsRecDecl _ _ _ i _):cs)
| pnt == i = True
| otherwise = myIn pnt cs
convertModName (PlainModule s) = s
convertModName m@(MainModule f) = modNameToStr m
findPos _ _ [] = 0
findPos count newPn (x:xs)
| newPn == x = count
| otherwise = findPos (count + 1) newPn xs
getBeforePN _ _ [] = 0
getBeforePN c newPN (x:xs)
| newPN /= x = (c + 1) + (getBeforePN (c + 1)newPN xs)
| otherwise = c
createFun (x:xs) newPN datName
= Dec ( HsPatBind loc0 (pNtoPat funPName) (HsBody (nameToExp ("error \"added " ++ (concat (map ( ++ " ") (x:xs))) ++ "to " ++ datName ++ "\"") )) [] )
where funPName= PN (UnQual ("added" ++ x)) (S loc0)
getParams (Dec (HsDataDecl _ _ _ cons _)) newPNT
= numParam cons
where
numParam [] = return 0
numParam (x@(HsConDecl _ _ _ pnt list):cs)
| newPNT == pnt = do
list' <- countCon x
return $ length list'
| otherwise = do x <- numParam cs
return x
numParam (x@(HsRecDecl _ _ _ pnt list):cs)
| newPNT == pnt = do list' <- countCon' x
return $ length list'
| otherwise = do x <- numParam cs
return x
-- numParam _ = return 0
countCon :: (MonadPlus m, Term t) => t -> m [Int]
countCon co
= applyTU (full_tdTU (constTU [] `adhocTU` inCon)) co
where
inCon a@(HsTyCon _::TI PNT HsTypeP) = return [0]
inCon a@(HsTyVar _::TI PNT HsTypeP) = return [0]
inCon _ = return []
countCon' :: (MonadPlus m, Term t) => t -> m [Int]
countCon' co
= applyTU (full_tdTU (constTU [] `adhocTU` inCon)) co
where
inCon a@((x, _)::([PNT], HsBangType HsTypeP)) = return $ replicate (length x) 0
-- inCon _ = return []
addCon fileName datName pnames newPn newPNT numParam oldPnames position inf xs modName (inscps, exps, mod)
= do
newMod <- addDecl mod Nothing ([createFun xs newPn datName], Nothing) True
-- unsafePerformIO.putStrLn $ show newMod
res <- findFuncs fileName datName newMod pnames newPn newPNT numParam oldPnames position inf xs modName
-- res2 <- findPatterns ses datName res pnames newPn newPNT numParam oldPnames position inf xs
return res
getPNs (Dec (HsFunBind _ (m:ms) ))
= checkMatch (m:ms)
where checkMatch [] = []
checkMatch ((HsMatch _ _ (p:ps) _ _):ms)
| (getPN p) /= defaultPN = (getPN p) : checkMatch ms
| otherwise = checkMatch ms
getPNPats (Exp (HsCase e pats))
= checkAlt pats
where checkAlt [] = []
checkAlt ((HsAlt loc p e2 ds):ps)
| p /= (Pat HsPWildCard) = (getPN p) : checkAlt ps
| otherwise = checkAlt ps
getPN p
= fromMaybe (defaultPN)
(applyTU (once_tdTU (failTU `adhocTU` inPat)) p)
where
inPat (pat::PName)
= Just pat
-- inPat _ = Nothing
findPosBefore newPN [] = []
findPosBefore newPN (x:[]) = [x]
findPosBefore newPN (x:y:ys)
| newPN == y = [x]
| otherwise = findPosBefore newPN (y:ys)
findFuncs fileName datName t pnames newPn newPNT numParam oldPnames position inf (x:xs) modName
= applyTP (stop_tdTP (failTP `adhocTP` inFun)) t
where
inFun dec1
= do
(pat, exp1) <- findCase dec1 modName
if pat /= False
then do
let altPNs = getPNPats exp1
if oldPnames /= altPNs
then do
let posBefore = findPosBefore newPn pnames
update exp1 (newPat3 exp1 (head posBefore)) dec1
else do
update exp1 (newPat2 exp1) dec1
else
do ((match,arity), patar) <- findFun dec1 modName
if match == False
then do --error "not found"
fail ""
else
do let funPNs = getPNs dec1
if oldPnames /= funPNs
then do
let posBefore = findPosBefore newPn pnames
if length posBefore > 1
then do
update dec1 (newMatch3 dec1 (head posBefore) arity patar) dec1
else do
update dec1 (newMatch dec1 arity patar) dec1
else do
update dec1 (newMatch2 dec1 arity patar) dec1
where
newMatch (Dec (HsFunBind loc1 matches@((HsMatch _ pnt p e ds):ms))) arity patar
= Dec (HsFunBind loc1 (newMatches matches pnt arity patar (length p)))
newMatch2 (Dec (HsFunBind loc1 matches@((HsMatch _ pnt p e ds):ms) )) arity patar
= Dec (HsFunBind loc1 (fst ++ (newMatch' pnt arity patar(length p)) ++ snd) )
where
(fst, snd) = splitAt position matches
newMatch3 (Dec (HsFunBind loc1 matches@((HsMatch _ pnt p e ds):ms))) posBefore arity patar
= Dec (HsFunBind loc1 (newMatches' matches pnt posBefore arity patar (length p)))
newMatches [] pnt position arity patar = newMatch' pnt position arity patar
newMatches (m@(HsMatch _ _ pats _ _):ms) pnt position arity patar
| or (map wildOrID pats) = (newMatch' pnt position arity patar) ++ (m : ms)
| otherwise = m : (newMatches ms pnt position arity patar)
newMatches' [] pnt posBefore position arity patar = newMatch' pnt position arity patar
newMatches' (m@(HsMatch _ _ pats _ _):ms) pnt posBefore position arity patar
| (getPN pats) == posBefore = m : ((newMatch' pnt position arity patar) ++ ms)
| or (map wildOrID pats) = (newMatch' pnt position arity patar) ++ (m : ms)
-- | (TiDecorate.Pat HsPWildCard) `elem` pats = (newMatch' pnt) ++ (m : ms)
| otherwise = m : (newMatches' ms pnt posBefore position arity patar)
newMatch' pnt arity patar position
-- | numParam == 0 = [HsMatch loc0 pnt [pNtoPat newPn] (HsBody (nameToExp ("added" ++ x))) [] ]
= createMatch arity ['a'..'z'] patar
where
createMatch arity alpha patar
| elem 1 arity
= (HsMatch loc0 pnt (createPat arity patar alpha) (HsBody (nameToExp ("added" ++ x))) []) : (createMatch (mutatearity arity) alpha patar)
| otherwise = []
mutatearity [] = []
mutatearity (x:xs)
| x == 1 = 0 : xs
| otherwise = x : (mutatearity xs)
createPat [] _ alpha= []
createPat (x:xs) ((y,n):ys) alpha
| x == 1 = newPatt' : (createPat (replicate (length xs) 0) ys ((res4')))
| elem 1 y = (conApps n) : (createPat xs ys (res3))
| otherwise = (createNames 1 alpha) ++ (createPat xs ys (tail alpha))
where
(_, res2) = splitAt numParam alpha
conApps n = conApp y alpha n
(_, res3) = splitAt ((myLength (conApps n)) * numParam -1) alpha
(_, res4') = splitAt ((myLength newPatt') ) alpha
newPatt' = patt alpha
patt alpha
| inf == False = (Pat (HsPParen (Pat (HsPApp newPNT (createNames numParam alpha))))::HsPatP)
| otherwise = (Pat (HsPInfixApp (nameToPat [alpha!!0]) newPNT (nameToPat [alpha!!1]))::HsPatP)
conApp xs alpha name
= (Pat (HsPParen (Pat (HsPApp (nameToPNT name) (createPats xs alpha)))))
myLength (Pat (HsPParen (Pat (HsPApp _ xs)))) = length xs
myLength _ = 0
createPats [] alpha = []
createPats (x:xs) alpha
| x == 1 = newPatt : (createPats xs (res4))
| otherwise = (createNames 1 alpha) ++ (createPats xs (tail alpha))
where
(_, res4) = splitAt ((myLength newPatt)) alpha
newPatt = patt alpha
createNames 0 _ = []
createNames count (x:xs)
= (nameToPat [x]) : (createNames (count-1) xs)
newPat (Exp (HsCase e pats@((HsAlt loc p e2 ds):ps)))
= Exp (HsCase e (newPats pats))
newPat2 (Exp (HsCase e pats))
= Exp (HsCase e (fst ++ newPat' ++ snd))
where
(fst, snd) = splitAt position pats
newPat3 (Exp (HsCase e pats)) posBefore
= Exp (HsCase e (newPats' pats posBefore))
newPats [] = newPat'
newPats(pa@(HsAlt _ p _ _):ps)
| wildOrID p = newPat' ++ (pa:ps)
| otherwise = pa : (newPats ps)
newPats' [] posBefore = newPat'
newPats' (pa@(HsAlt _ p _ _):ps) posBefore
| (getPN p) == posBefore = pa : (newPat' ++ ps)
| wildOrID p = newPat' ++ (pa:ps)
| otherwise = pa : (newPats' ps posBefore)
newPat'
| numParam == 0 = [HsAlt loc0 (pNtoPat newPn) (HsBody (nameToExp ("added" ++ x))) [] ]
| otherwise = [HsAlt loc0 patt (HsBody (nameToExp ("added" ++ x))) []]
where
patt
| inf == False = (Pat (HsPParen (Pat (HsPApp newPNT (createNames numParam ['a'..'z']))))::HsPatP)
| otherwise = (Pat (HsPInfixApp (nameToPat "a") newPNT (nameToPat "b"))::HsPatP)
createNames 0 _ = []
createNames count (x:xs)
= (nameToPat [x]) : (createNames (count-1) xs)
--The selected sub-expression is in the argument list of a match
--and the function only takes 1 parameter
findFun dec@(Dec (HsFunBind loc matches)::HsDeclP) modName
= return $ findMatch matches
where findMatch match
= fromMaybe ((False, []), [([], "")])
(applyTU (once_tdTU (failTU `adhocTU` inMatch)) match)
inMatch (mat@(HsMatch loc1 pnt pats (HsBody e) ds)::HsMatchP)
= do
let (_, y) = checkTypesInPat datName pats modName fileName
-- error $ show y
Just ((checkTypes2 datName (pNTtoName pnt) modName fileName), y)
inMatch x@(_) = Nothing
findFun a@(_) _ = return ((False, []), [([], "")])
findCase dec@(Dec (HsFunBind loc matches)::HsDeclP) modName
= return (findExp matches)
where findExp alt
= fromMaybe ((False, defaultExp))
(applyTU (once_tdTU (failTU `adhocTU` inExp)) alt)
inExp (exp@(Exp e)::HsExpP)
= Just ((findPat e), exp)
where
findPat alt
= fromMaybe (False)
(applyTU (once_tdTU (failTU `adhocTU` inPat)) alt)
inPat (pat@(HsAlt loc (Pat (HsPId (HsCon p))) e ds)::HsAltP)
= (Just (checkTypes datName (pNTtoName p) modName fileName))
inPat e -- (pat@(HsAlt loc (Pat (HsPId (HsVar _))) e ds)::HsAltP)
= do
case exp of
Exp (HsCase (Exp (HsId (HsVar x))) alts)
-> do
-- find where p is defined, and get the type
let decs = hsDecls t
-- error ( show (pNTtoPN x))
let y = definingDecls [(pNTtoPN x)] decs False True
-- error $ show y
if length y /= 0
then do
let b = definedPNs (head y)
Just (checkTypes datName (pNtoName (head b)) modName fileName)
else Nothing
_ -> Nothing
-- inPat e = error (show e) -- Nothing
-- inExp _ = Nothing
findCase pat@(_) _ = return (False, defaultExp)
flatternPat :: HsPatP -> [HsPatP]
flatternPat (Pat (HsPAsPat i p)) = flatternPat p
flatternPat (Pat (HsPApp i p)) = (Pat (HsPId (HsCon i))) : (concatMap flatternPat p)
flatternPat (Pat (HsPTuple _ p)) = p
flatternPat (Pat (HsPList _ p)) = p
flatternPat (Pat (HsPInfixApp p1 i p2)) = (flatternPat p1) ++ (flatternPat p2)
flatternPat (Pat (HsPParen p)) = flatternPat p
flatternPat p@(Pat (HsPId i)) = [p]
flatternPat p = [p]
wildOrID (Pat HsPWildCard) = True
wildOrID (Pat (HsPId (HsVar x))) = True
wildOrID _ = False
doFileStuff fileName r c a = do
s <- AbstractIO.readFile fileName
-- get the first half of the file (up to point user has selected)
let rev = reverse (returnHalf r c (1,1) s)
let rest = returnSndHalf r c (1,1) s
let str = parseIt rest a
let str' = parseIt' rest a
let len = length (myDiff s str')
let (st, fin) = splitAt len s
let new = st ++ str ++ fin
let extraCol = parseTick 0 str
let (col, row) = getRowCol r c (1,1) st
-- Check that the file does not already exist first
-- or else it will lead into strange errors...
AbstractIO.catch (AbstractIO.writeFile (fileName ++ ".temp.hs") new)
(\_ -> do AbstractIO.removeFile (fileName ++ ".temp.hs")
AbstractIO.writeFile (fileName ++ ".temp.hs") new)
if '`' `elem` a
then do return (new, col + extraCol, row, True)
else do return (new, col + extraCol, row, False)
-- function to parse to see if user is placing contructor at the beginning or end of statement...
-- if the user has selected a ' ' or a character
-- parse forwards (which is really backwards) until a '|' or a '=' character is found
parseTick _ [] = 3
parseTick count (x:xs)
| x == '`' = count + 1
| otherwise = parseTick (count+1) xs
myDiff :: String -> String -> String
myDiff [] _ = []
myDiff (y:ys) (x:xs)
| (y:ys) == (x:xs) = ""
| otherwise = y : (myDiff ys (x:xs))
parseIt :: String -> String -> String
parseIt "" str = error "Please select a position on the right hand side of the data type."
parseIt (x:xs) str
| x == '\n' || x == '|' = " | " ++ str ++ " "
| x /= '\n' || x /= '|' = parseIt xs str
| otherwise = " | " ++ str ++ " "
parseIt' :: String -> String -> String
parseIt' "" str = ""
parseIt' (x:xs) str
| x == '\n' || x == '|' = (x:xs)
| x /= '\n' || x /= '|' = parseIt' xs str
| otherwise = (x:xs)
-- perform some primitve parsing. We need to check where abouts the user wants
-- to add the data structure:
-- a) if the it is at the beginning - we need to check that the
-- use has selected at the end of a "=" sign -- if this is the case append "|" to the end
-- of the user string;
-- b) if a "=" does not proceed the position - append a "|" to the end
--
-- we do not need to check for any other cases as Programatica will pick up the errors
-- (if the position of adding the constructor is invalid, for example.)
-- function to return the half of the file that comes before the user position
returnHalf r c (col, row) "" = ""
returnHalf r c (col, row) (x:xs)
| x == '\n' = if (r == row) && (c == col) then [x]
else x : (returnHalf r c (1, row+1) xs)
| otherwise = if c == col && (r == row) then [x]
else x : (returnHalf r c (col+1, row) xs)
returnSndHalf r c (col, row) "" = ""
returnSndHalf r c (col, row) (x:xs)
| x == '\n' = if (r == row) && (c == col) then xs
else (returnSndHalf r c (1, row+1) xs)
| otherwise = if c == col && (r == row) then xs
else (returnSndHalf r c (col+1, row) xs)
getRowCol r c (col, row) "" = (col, row)
getRowCol r c (col, row) (x:xs)
| x == '\n' = getRowCol r c (1, row+1) xs
| otherwise = getRowCol r c (col+1, row) xs
{-|
Takes the position of the highlighted code and returns
the function name, the list of arguments, the expression that has been
highlighted by the user, and any where\/let clauses associated with the
function.
-}
findDefNameAndExp :: Term t => [PosToken] -- ^ The token stream for the
-- file to be
-- refactored.
-> (Int, Int) -- ^ The beginning position of the highlighting.
-> (Int, Int) -- ^ The end position of the highlighting.
-> t -- ^ The abstract syntax tree.
-> [HsConDeclP] -- ^ A tuple of,
-- (the function name, the list of arguments,
-- the expression highlighted, any where\/let clauses
-- associated with the function).
findDefNameAndExp toks beginPos endPos t
= fromMaybe ([])
(applyTU (once_tdTU (failTU `adhocTU` inData)) t)
where
--The selected sub-expression is the rhs of a data type
inData (dat@(HsConDecl loc1 is con i xs)::HsConDeclP)
= error (show res)
where
res = pNtoExp (pNTtoPN i)
inData _ = Nothing