HaRe-0.6: refactorer/RefacTypeAddCon.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 RefacTypeAddCon where
import PrettyPrint
import PrettyPrint
import PosSyntax
import AbstractIO
import Maybe
import TypedIds
import UniqueNames hiding (srcLoc)
import PNT
import TiPNT
import List
import RefacTypeUtils
import PFE0 (findFile)
import MUtils (( # ))
import RefacTypeLocUtils
import System
import IO
import TiDecorate
-- | 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"
refacTypeAddCon 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"
(s, col', row', inf) <- doFileStuff fileName row col ans
modInfo2@(inscps', exps', mod', tokList') <- parseSourceFile (fileName ++ ".temp")
-- Find the datatype that's been highlighted as the refactree
let res = locToPN (fileName ++ ".temp") (row, col) mod'
if res == defaultPN
then do s <- AbstractIO.readFile (fileName ++ ".temp")
AbstractIO.writeFile fileName s
AbstractIO.removeFile (fileName ++ ".temp")
error "You must select the beginning of a constructor"
else do
let decs = hsDecls mod'
let datDec = definingDecls [res] decs False True
-- get the list of constructors from the data type
let datDec' = head datDec
let datName = getDataName [datDec']
let pnames = definedPNs datDec'
-- ==================
let newPN = locToPN (fileName ++ ".temp") (row', col') mod'
let newPNT = locToPNT (fileName ++ ".temp") (row', col') mod'
-- ==================
numParam <- getParams datDec' newPNT
let oldPnames = filter (/= newPN) pnames
let position = findPos 0 newPN pnames
-- newMod <- removeFromInts mod'
((_,m), (newToks, newMod)) <- applyRefac (addCon pnames newPN newPNT numParam oldPnames position inf datName (tail first)) (Just (inscps', exps', mod', tokList')) (fileName ++ ".temp")
writeRefactoredFiles False [((fileName, m), (newToks, newMod))]
AbstractIO.removeFile (fileName ++ ".temp")
AbstractIO.putStrLn "Completed.\n"
else do
error "refacAddCon must take a new constructor and a list of arguments."
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 name (x:xs) newPN
= TiDecorate.Dec ( HsPatBind loc0 (pNtoPat funPName) (HsBody (nameToExp ("error \"added " ++ (concat (map ( ++ " ") (x:xs))) ++ " to " ++ name ++ " \"") )) (Decs [] ([],[])) )
where funPName= PN (UnQual ("added" ++ x)) (S loc0)
getParams (TiDecorate.Dec (HsDataDecl _ _ _ cons _)) newPNT
= numParam cons
where
-- numParam :: (MonadPlus m) => [HsConDeclP] -> m Int
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 :: (Monad m) => HsTypeP -> m [Int]
inCon a@(HsTyCon _::TI PNT (HsTypeI PNT)) = 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 (HsTypeI PNT))) = return $ replicate (length x) 0
inCon _ = return []
addCon pnames newPn newPNT numParam oldPnames position inf datName xs (inscps, exps, mod)
= do
newMod <- addDecl mod Nothing ([createFun datName xs newPn], Nothing) True
res <- findFuncs newMod pnames newPn newPNT numParam oldPnames position datName inf xs
return res
findPosBefore newPN [] = []
findPosBefore newPN (x:[]) = [x]
findPosBefore newPN (x:y:ys)
| newPN == y = [x]
| otherwise = findPosBefore newPN (y:ys)
findFuncs t pnames newPn newPNT numParam oldPnames position datName inf (x:xs)
= applyTP (stop_tdTP ( failTP `adhocTP` inFun)) t
where
inFun dec1
= do
(pat, exp1) <- findCase dec1
-- error $ show dec1
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
-- update exp1 (newPat exp1) exp1
else do
update exp1 (newPat2 exp1) dec1
else
do match <- findFun dec1
if match == False
then do --error "not found"
fail ""
else
do let funPNs = getPNs dec1
-- error $ show funPNs
if oldPnames /= funPNs
then do
let posBefore = findPosBefore newPn pnames
if length posBefore > 1
then do
update dec1 (newMatch3 dec1 (head posBefore)) dec1
else do
-- error $ show posBefore
update dec1 (newMatch dec1) dec1
else do
-- error $ show position
update dec1 (newMatch2 dec1) dec1
where
newMatch (TiDecorate.Dec (HsFunBind loc1 matches@((HsMatch _ pnt _ e ds):ms)))
= TiDecorate.Dec (HsFunBind loc1 (newMatches matches pnt))
newMatch2 (TiDecorate.Dec (HsFunBind loc1 matches@((HsMatch _ pnt _ e ds):ms) ))
= TiDecorate.Dec (HsFunBind loc1 (fst ++ (newMatch' pnt) ++ snd) )
where
(fst, snd) = splitAt position matches
newMatch3 (TiDecorate.Dec (HsFunBind loc1 matches@((HsMatch _ pnt _ e ds):ms))) posBefore
= TiDecorate.Dec (HsFunBind loc1 (newMatches' matches pnt posBefore))
newMatches [] pnt = newMatch' pnt
newMatches (m@(HsMatch _ _ pats _ _):ms) pnt
| or (map wildOrID pats) = (newMatch' pnt) ++ (m : ms)
| otherwise = m : (newMatches ms pnt)
newMatches' [] pnt posBefore = newMatch' pnt
newMatches' (m@(HsMatch _ _ pats _ _):ms) pnt posBefore
| (getPN pats) == posBefore = m : ((newMatch' pnt) ++ ms)
| or (map wildOrID pats) = (newMatch' pnt) ++ (m : ms)
-- | (TiDecorate.Pat HsPWildCard) `elem` pats = (newMatch' pnt) ++ (m : ms)
| otherwise = m : (newMatches' ms pnt posBefore)
newMatch' pnt
| numParam == 0 = [HsMatch loc0 pnt [pNtoPat newPn] (HsBody (nameToExp ("added" ++ x))) (Decs [] ([], []))]
| otherwise = [HsMatch loc0 pnt [patt] (HsBody (nameToExp ("added" ++ x))) (Decs [] ([], []))]
where
patt
| inf == False = (TiDecorate.Pat (HsPParen (TiDecorate.Pat (HsPApp newPNT (createNames numParam ['a'..'z']))))::HsPatP)
| otherwise = (TiDecorate.Pat (HsPInfixApp (nameToPat "a") newPNT (nameToPat "b"))::HsPatP)
createNames 0 _ = []
createNames count (x:xs)
= (nameToPat [x]) : (createNames (count-1) xs)
newPat (TiDecorate.Exp (HsCase e pats@((HsAlt loc p e2 ds):ps)))
= TiDecorate.Exp (HsCase e (newPats pats))
newPat2 (TiDecorate.Exp (HsCase e pats))
= TiDecorate.Exp (HsCase e (fst ++ newPat' ++ snd))
where
(fst, snd) = splitAt position pats
newPat3 (TiDecorate.Exp (HsCase e pats)) posBefore
= TiDecorate.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))) (Decs [] ([], []))]
| otherwise = [HsAlt loc0 patt (HsBody (nameToExp ("added" ++ x))) (Decs [] ([], []))]
where
patt
| inf == False = (TiDecorate.Pat (HsPParen (TiDecorate.Pat (HsPApp newPNT (createNames numParam ['a'..'z']))))::HsPatP)
| otherwise = (TiDecorate.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@(TiDecorate.Dec (HsFunBind loc matches)::HsDeclP)
= 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)
= Just (checkTypes datName [mat])
inMatch x@(_) = Nothing
findFun a@(_) = return False
findCase dec@(TiDecorate.Dec (HsFunBind loc matches)::HsDeclP)
= return $ findExp matches
where findExp alt
= fromMaybe ((False, defaultExp))
(applyTU (once_tdTU (failTU `adhocTU` inExp)) alt)
inExp (exp@(TiDecorate.Exp e)::HsExpP)
= Just ((findPat e), exp)
inExp _ = Nothing
findPat alt
= fromMaybe (False)
(applyTU (once_tdTU (failTU `adhocTU` inPat)) alt)
inPat (pat@(HsAlt loc p e ds)::HsAltP)
= Just (checkTypes datName [pat])
inPat _ = Nothing
findCase pat@(_) = return (False, defaultExp)
wildOrID (TiDecorate.Pat HsPWildCard) = True
wildOrID (TiDecorate.TiPSpec _ _ _ ) = 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
AbstractIO.catch (AbstractIO.writeFile (fileName ++ ".temp") new)
(\_ -> do AbstractIO.removeFile (fileName ++ ".temp")
AbstractIO.writeFile (fileName ++ ".temp") new)
-- AbstractIO.writeFile fileName 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