HaRe-0.6: refactorer/RefacIntroPattern.hs
module RefacIntroPattern(introPattern, introCase, foldPattern) where
import TypeCheck
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, allFiles, allModules)
import MUtils (( # ))
import RefacLocUtils
import System
import IO
import Relations
import Ents
import Data.Set (toList)
import Data.List
-- | 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]
data PatFun = Mat | Patt | Er deriving (Eq, Show)
{- This module contains 3 refactorings for HaRe:
introPattern : introduce a exhaustive pattern match for a
selected pattern variable.
introCase : introduce a case analysis over a selected
pattern variable. Introduces an exhaustive
set of patterns for the type.
foldPattern : allows one to fold a sub expression against a
particular pattern variable
-}
{- Introduces pattern matching over a pattern variable.
Introduces an exhaustive set of patterns for a type
in a case analysis on the lhs of an equation.
Copyright : (c) Christopher Brown 2008
Maintainer : cmb21@kent.ac.uk
Stability : provisional
Portability : portable
-}
introPattern args
= do let fileName = ghead "filename" args
--fileName'= moduleName fileName
--modName = Module fileName'
row = read (args!!1)::Int
col = read (args!!2)::Int
modName <-fileNameToModName fileName
let modName1 = convertModName modName
(inscps, exps, mod, tokList)<-parseSourceFile fileName
-- (inscps3, exps3, mod3, tokList3)<-parsePrelude
let pnt = locToPNT fileName (row, col) mod
if not (checkInPat pnt mod)
then do
-- it's quite possible we are dealing with a sub-pattern
-- let's check that case.
if not (checkInSubPat pnt mod)
then error "Please select a pattern variable on the LHS of an equation!"
else do
AbstractIO.putStrLn "introSubPattern"
((_,m), (newToks, newMod))<-applyRefac (doIntroPatterns' fileName inscps pnt (modNameToStr modName))
(Just (inscps, exps, mod, tokList)) fileName
writeRefactoredFiles False [((fileName,m), (newToks,newMod))]
AbstractIO.putStrLn "Completed.\n"
else do
AbstractIO.putStrLn "introPattern"
((_,m), (newToks, newMod))<-applyRefac (doIntroPatterns pnt)
(Just (inscps, exps, mod, tokList)) fileName
writeRefactoredFiles False [((fileName,m), (newToks,newMod))]
AbstractIO.putStrLn "Completed.\n"
convertModName (PlainModule s) = s
convertModName m@(MainModule f) = modNameToStr m
doIntroPatterns pnt (_,_,t)
= do mod <- introPats pnt t
return mod
doIntroPatterns' fileName inscps pnt modName (_,_,t)
= do mod <- introPats' fileName inscps pnt modName t
return mod
introPats pnt t
= applyTP (full_tdTP (idTP `adhocTP` inDec)) t
where
inDec (dec@(Dec (HsFunBind s matches))::HsDeclP)
| findPNT pnt matches && inMatch pnt matches
= do
-- we need to find the type of the variable in question,
-- and also the implementation of the type. If the type
-- is defined outside of the project, we must error!
let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches
typeSig = getTypeSig (pNTtoPN name) t
(typeOfPat, position) = findPatAndType 0 pnt (flatternType typeSig) pats
constrsOfData = findTypeAndConstrs 0 pnt (flatternType typeSig) pats
-- check that argument position is a variable in all defining
-- equations...
if checkVariableEquation matches position
then do
let newMatches = concatMap (createMatches dec (declToName dec) name pats (position+1) constrsOfData) matches
update dec (Dec (HsFunBind s (newMatches++matches))) dec
else do
return dec
inDec x = return x
typToPNT (Typ (HsTyCon x)) = x
typToPNT x = error "Please select a variable with a type constructor!"
checkVariableEquation [] _ = True
checkVariableEquation ((HsMatch _ _ pats _ _):ms) position
| checkPats (pats !! position) = checkVariableEquation ms position
| otherwise = error "Pattern argument must be a variable in all defining equations!"
checkPats (Pat (HsPIrrPat p)) = checkPats p
checkPats (Pat (HsPParen p)) = checkPats p
checkPats (Pat (HsPId (HsVar x))) = True
checkPats _ = False
createMatches (Dec (HsFunBind loc environment)) funName name pats position constrs match
= let (before, after) = break (==match) environment
newMatches = createMatches2 position (length pats) match constrs
in newMatches
where
createMatches2 _ _ _ [] = []
createMatches2 position arity m@(HsMatch _ _ pats rhs ds) ((ConInfo (PN n _) a _):cs)
= let newPats = replace position pats (createPat pnt n a (pats !! (position-1)) (map pNtoName (hsPNs pats ++ hsPNs ds)))
in (HsMatch loc0 name newPats rhs ds) : createMatches2 position arity m cs
where
myReplicate 0 _ _ = []
myReplicate arity names index
= let newName = mkNewName "a" names index
in (nameToPat newName) : (myReplicate (arity-1) (names ++ [newName]) (index+1))
-- ==========================================================================
-- end of introPattern
-- ==========================================================================
-- ==========================================================================
-- introduce sub pattern
-- ==========================================================================
introPats' fileName inscps pnt modName t
= applyTP (full_tdTP (idTP `adhocTP` inDec)) t
where
inDec (dec@(Dec (HsFunBind s matches))::HsDeclP)
| findPNT pnt matches && inMatch pnt matches
= do
-- we need to find the type of the variable in question,
-- and also the implementation of the type. If the type
-- is defined outside of the project, we must error!
let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches
typeSig = getTypeSig (pNTtoPN name) t
(typeOfPat, position) = findPatAndType 0 pnt (flatternType typeSig) pats
-- we need to check to make sure there are no polymorphic. If they are we
-- can simply replace them with the () type. This seems to be the Haskell
-- equivalent of Null.
newTypeSig <- replacePolymorphicType typeSig
let closureEquation = createClosure ((render.ppi) newTypeSig) (pNTtoName pnt) (pats !! position) position
-- res <- liftIO $ ghcTypeCheckPattern closureEquation "closure___" ses
typeOfPat2 <- getSigAsString fileName closureEquation (force $ ghcTypeCheckPattern closureEquation "closure___" modName fileName)
-- this is necessary to force the evaluation of the GHC compiler,
-- since it's wrapped up in a naughty unsafePerformIO...
lift $ AbstractIO.putStrLn $ (typeOfPat2 \\ typeOfPat2)
let typeOfPat2' = last $ typeAnnot' typeOfPat2
let typeOfPat2Cleaned = cleanPatType typeOfPat2'
constrsOfData = extractConstructors typeOfPat2Cleaned (toList inscps)
let newMatches = createMatches dec (declToName dec) name pats position constrsOfData match
(beforeM, afterM) = break (==match) matches
update dec (Dec (HsFunBind s (beforeM ++ newMatches ++ afterM))) dec
inDec x = return x
replacePolymorphicType typeSig
= applyTP (full_tdTP (idTP `adhocTP` rename)) typeSig
where
rename (Typ (HsTyVar n)) = return (Typ (HsTyVar (nameToPNT "Int")))
rename x = return x
force a = if a==a then a else a
extractConstructors typeName [] = []
extractConstructors typeName ((_,Ent _ (HsCon (SN n _)) (Type (TypeInfo _ cs _))):xs)
| n == typeName && cs == [] = error $ "Cannot instantiate new patterns for the selected pattern. It may be of a polymorphic type, or a Haskell defined type such as Int."
| n == typeName = cs
| otherwise = extractConstructors typeName xs
extractConstructors typeName (x:xs) = extractConstructors typeName xs
cleanPatType [] = []
cleanPatType (' ':xs) = cleanPatType xs
cleanPatType ('[':xs) = "[]"
cleanPatType ('(':xs)
= "(" ++ ( filter (==',') xs) ++ ")"
cleanPatType xs = let (x, s') = break (== ' ') xs
in x
getSigAsString ses closureEquation res
= do
let types = lines2 res
let types1 = cleanTypes (tail types)
let (context, l) = getContext (head types)
let types2 = l : types1
let types3 = map (filter (/= '\n')) types2
let types4 = fold (tail types3)
return (context ++ " => " ++ (head types3) ++ " -> " ++ types4)
where
fold [] = []
fold [x] = x
fold (x:xs) = x ++ (" -> " ++ fold xs)
createClosure :: String -> String -> HsPatP -> Int -> String
createClosure typeSig p pat pos
= "(\\(" ++ ((render.ppi) pat) ++ "::" ++ ((typeAnnot typeSig)!!pos) ++ ") -> " ++ p ++")"
-- = "closure___ " ++ "(" ++ ((render.ppi) pat) ++ "::" ++ ((typeAnnot typeSig)!!pos) ++ ") = " ++ p
where
typeAnnot :: String -> [String]
typeAnnot "" = []
typeAnnot s = let (_, s') = break (== ':') s
in case s' of
{ [] -> [];
(_:s'') -> typeAnnot' (tail s'') }
typeAnnot' :: String -> [String]
typeAnnot' "" = []
typeAnnot' s = let (l, s') = break (== '-') s
in l : case s' of
{[] -> [];
(_:s'') -> typeAnnot' (tail s'')}
getModuleName [] modName = ""
getModuleName (t:ts) modName
| stripFilePath t == modName = t
| otherwise = getModuleName ts modName
where
stripFilePath t
= let (f,_) = break (=='/') (reverse t);
(f',_) = break ( =='.') (reverse f) in f'
createMatches (Dec (HsFunBind loc environment)) funName name pats position constrs match
= let (before, after) = break (==match) environment
newMatches = createMatches2 position (length pats) match constrs
in newMatches
where
createMatches2 _ _ _ [] = []
createMatches2 position arity m@(HsMatch _ _ pats rhs ds) ((ConInfo (SN n _) a _):cs)
= -- only update the pattern we are interested in...
let newPats = replace (position+1) pats (createSubPat pnt n a (pats !! position) (map pNtoName (hsPNs pats ++ hsPNs ds)))
in (HsMatch loc0 name newPats rhs ds) : createMatches2 position arity m cs
-- let newPats = replace position pats (createPat pnt n a (pats !! position) (map pNtoName (hsPNs pats ++ hsPNs ds)))
-- in (HsMatch loc0 name newPats rhs ds) : createMatches2 position arity m cs
where
myReplicate 0 _ _ = []
myReplicate arity names index
= let newName = mkNewName "a" names index
in (nameToPat newName) : (myReplicate (arity-1) (names ++ [newName]) (index+1))
createSubPat :: PNT -> String -> Int -> HsPatP -> [String] -> HsPatP
createSubPat pnt x i (Pat (HsPParen p)) environ = (Pat (HsPParen (createSubPat pnt x i p environ)))
createSubPat pnt x i (Pat (HsPApp n p)) environ
= let myTail [] = []
myTail [x] = []
myTail (x:xs) = xs
(before, a) = break (findPNT pnt) p
in case a of
[] -> createSubPat'' pnt x i environ
after -> (Pat (HsPApp n (before ++ [createSubPat pnt x i (ghead "createSubPat" after) environ] ++ (myTail after))))
createSubPat pnt x i (Pat (HsPTuple s p)) environ
= let myTail [] = []
myTail [x] = []
myTail (x:xs) = xs
(before, a) = break (findPNT pnt) p
in case a of
[] -> createSubPat'' pnt x i environ -- create the sub pattern and get out of here!
after -> (Pat (HsPTuple s (before ++ [createSubPat pnt x i (ghead "createSubPat" after) environ] ++ (myTail after))))
createSubPat pnt x i (Pat (HsPIrrPat p)) environ
= (Pat (HsPIrrPat (createSubPat pnt x i p environ)))
createSubPat pnt x i (Pat (HsPInfixApp p1 i2 p2)) environ
| findPNT pnt p1 = (Pat (HsPInfixApp (createSubPat pnt x i p1 environ) i2 p2))
| findPNT pnt p2 = (Pat (HsPInfixApp p1 i2 (createSubPat pnt x i p2 environ)))
createSubPat pnt x i (Pat (HsPAsPat n p)) environ
= (Pat (HsPAsPat n (createSubPat pnt x i p environ)))
createSubPat pnt x i _ environ = createSubPat' pnt x i environ
createSubPat' pnt i 0 environ = Pat (HsPAsPat pnt (Pat (HsPId (HsCon (nameToPNT i)))))
createSubPat' pnt x@(':':xs) ts environ
= Pat (HsPAsPat pnt (Pat (HsPInfixApp (ghead "createPat" pat1) (nameToPNT x)
(last pat1))))
where
pat1 = reverse $ createId environ ts
createSubPat' pnt x@('(':xs) ts environ
= Pat (HsPAsPat pnt (Pat ( HsPTuple loc0 (reverse (createId environ ts)))))
createSubPat' pnt i ts environ = Pat (HsPAsPat pnt (Pat (HsPApp (nameToPNT i) (reverse (createId environ ts)))))
createSubPat'' pnt i 0 environ = (Pat (HsPId (HsCon (nameToPNT i))))
createSubPat'' pnt x@(':':xs) ts environ
= (Pat (HsPInfixApp (ghead "createPat" pat1) (nameToPNT x)
(last pat1)))
where
pat1 = reverse $ createId environ ts
createSubPat'' pnt x@('(':xs) ts environ
= (Pat ( HsPTuple loc0 (reverse (createId environ ts))))
createSubPat'' pnt i ts environ = (Pat (HsPApp (nameToPNT i) (reverse (createId environ ts))))
findType index _ _ [] = error "No type associated with pattern variable!"
findType index pnt types (p:ps)
| findPNT pnt p = extractTypeName (types !! index)
| otherwise = findType (index+1) pnt types ps
extractTypeName (Typ (HsTyCon (PNT pn (Type (TypeInfo _ cs _)) _ ))) = pn
extractTypeName (Typ (HsTyVar (PNT pn _ _))) = pn
extractTypeName x = error "Please select a variable with a type constructor!"
extractTypeImplem [] typeName = error (typeName ++ " cannot be found in this project!")
extractTypeImplem (d:ds) typeName
| declToName d == typeName = d
| otherwise = extractTypeImplem ds typeName
constrsToModule (PNT (PN _ (G (PlainModule m) _ _)) _ _) = m
constrsToModule (PNT p@(PN _ (G (MainModule m) _ _)) _ _) = "Main"
constrsToModule x = error "Error in constrsToModule!"
findPatAndType index _ _ [] = error "No type associated with pattern variable!"
findPatAndType index pnt types (p:ps)
| findPNT' pnt [p] = (typToPNT (types !! index), index)
| otherwise = findPatAndType (index+1) pnt types ps
findConstrAndType pnt pat typeOfPat
= (positionOfPat, typ)
where
positionOfPat = flatternPat pnt pat
typ = extractType positionOfPat constr typeOfPat
constr = findConstr pnt pat
extractType pos constr d@(Dec (HsDataDecl _ _ _ cs _))
= extractCons cs
where
extractCons [] = error "This is not a valid parameter of the binding constructor!"
extractCons ((HsConDecl _ _ _ n types) : more)
| ghead "extractCons" (pNTtoName constr) == '(' &&
pNTtoName n == pNTtoName constr = removeBang (types !! pos)
| n == constr = removeBang (types !! pos)
| otherwise = extractCons more
where
removeBang (HsBangedType t) = t
removeBang (HsUnBangedType t) = t
findPosition index pnt [] = 0
findPosition index pnt (p:ps)
| findPNT pnt p = index
| otherwise = findPosition (index+1) pnt ps
flatternPat pnt (Pat (HsPAsPat i p)) = flatternPat pnt p
flatternPat pnt (Pat (HsPApp i p))
| findPNT pnt p = findPosition 0 pnt p
flatternPat pnt (Pat (HsPTuple _ p))
| findPNT pnt p = findPosition 0 pnt p
flatternPat pnt (Pat (HsPInfixApp p1 i p2)) = findPosition 0 pnt [p1] + findPosition 1 pnt [p2]
flatternPat pnt (Pat (HsPParen p)) = flatternPat pnt p
-- flatternPat pnt (Pat (HsPId i)) = 1
flatternPat pnt p = error "Selected pattern is not a sub-pattern in flatternPat"
findConstr pnt (Pat (HsPAsPat i p))
= findConstr pnt p
findConstr pnt (Pat (HsPApp i p))
| findPNT' pnt p = i
findConstr pnt (Pat (HsPTuple _ p))
| findPNT' pnt p = nameToPNT "(,)" -- this needs checking for arbitrary sized tuples
findConstr pnt (Pat (HsPInfixApp p1 i p2))
| findPNT pnt p1 || findPNT pnt p2 = i
findConstr pnt (p@(Pat (HsPParen p1)))
= findConstr pnt p1
findConstr pnt (p@(Pat (HsPId (HsCon i))))
| findPNT pnt p = i
findConstr pnt p = error "pattern is not bound to a constructor entity!"
findPNT' pnt [] = False
findPNT' pnt ((Pat (HsPAsPat i p)):ps)
| findPNT pnt i = True
| findPNT' pnt [p] = True
| otherwise = findPNT' pnt ps
findPNT' pnt ((Pat (HsPApp i ps)):pss)
| findPNT' pnt ps = True
| otherwise = findPNT' pnt ps
findPNT' pnt ((Pat (HsPTuple i ps)):pss)
| findPNT' pnt ps = True
| otherwise = findPNT' pnt ps
findPNT' pnt (Pat (HsPInfixApp p1 i p2):ps)
| findPNT pnt p1 || findPNT pnt p2 = True
| otherwise = findPNT' pnt ps
findPNT' pnt (p@(Pat (HsPParen p1)):ps)
| findPNT' pnt [p1] = True
| otherwise = findPNT' pnt ps
findPNT' pnt (p@(Pat (HsPId x)):ps)
| findPNT pnt p = True
| otherwise = findPNT' pnt ps
findPNT' pnt (p:ps) = findPNT' pnt ps
typToPNT (Typ (HsTyCon x)) = x
typToPNT x = error "Please select a variable with a type constructor!"
checkVariableEquation [] _ = True
checkVariableEquation ((HsMatch _ _ pats _ _):ms) position
| checkPats (pats !! position) = checkVariableEquation ms position
| otherwise = error "Pattern argument must be a variable in all defining equations!"
checkPats (Pat (HsPIrrPat p)) = checkPats p
checkPats (Pat (HsPParen p)) = checkPats p
checkPats (Pat (HsPId (HsVar x))) = True
checkPats _ = False
-- ==========================================================================
-- end of introSubPattern
-- ==========================================================================
introCase args
= do let fileName = ghead "filename" args
--fileName'= moduleName fileName
--modName = Module fileName'
row = read (args!!1)::Int
col = read (args!!2)::Int
modName <-fileNameToModName fileName
let modName1 = convertModName modName
(inscps, exps, mod, tokList)<-parseSourceFile fileName
let pnt = locToPNT fileName (row, col) mod
if not (checkInPat pnt mod)
then do
if not (checkInSubPat pnt mod)
then error "Please select a pattern variable on the LHS of an equation!"
else do
AbstractIO.putStrLn "introCaseSubPattern"
((_,m), (newToks, newMod))<-applyRefac (doIntroCasePatterns' fileName inscps pnt (modNameToStr modName))
(Just (inscps, exps, mod, tokList)) fileName
writeRefactoredFiles False [((fileName,m), (newToks,newMod))]
AbstractIO.putStrLn "Completed.\n"
else do
AbstractIO.putStrLn "introCasePattern"
((_,m), (newToks, newMod))<-applyRefac (doIntroCasePatterns pnt)
(Just (inscps, exps, mod, tokList)) fileName
writeRefactoredFiles False [((fileName,m), (newToks,newMod))]
AbstractIO.putStrLn "Completed.\n"
doIntroCasePatterns pnt (_,_,t)
= do mod <- introPatsCase pnt t
return mod
doIntroCasePatterns' fileName inscps pnt modName (_,_,t)
= do mod <- introPatsCase' fileName inscps pnt modName t
return mod
introPatsCase' fileName inscps pnt modName t
= applyTP (full_tdTP (idTP `adhocTP` inDec)) t
where
inDec (dec@(Dec (HsFunBind s matches))::HsDeclP)
| findPNT pnt matches && inMatch pnt matches
= do
-- we need to find the type of the variable in question,
-- and also the implementation of the type. If the type
-- is defined outside of the project, we must error!
let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches
typeSig = getTypeSig (pNTtoPN name) t
(typeOfPat, position) = findPatAndType 0 pnt (flatternType typeSig) pats
-- we need to check to make sure there are no polymorphic. If they are we
-- can simply replace them with the () type. This seems to be the Haskell
-- equivalent of Null.
newTypeSig <- replacePolymorphicType typeSig
let closureEquation = createClosure ((render.ppi) newTypeSig) (pNTtoName pnt) (pats !! position) position
-- res <- liftIO $ ghcTypeCheckPattern closureEquation "closure___" ses
typeOfPat2 <- getSigAsString fileName closureEquation (force $ ghcTypeCheckPattern closureEquation "closure___" modName fileName)
-- this is necessary to force the evaluation of the GHC compiler,
-- since it's wrapped up in a naughty unsafePerformIO...
lift $ AbstractIO.putStrLn $ (typeOfPat2 \\ typeOfPat2)
let typeOfPat2' = last $ typeAnnot' typeOfPat2
let typeOfPat2Cleaned = cleanPatType typeOfPat2'
constrsOfData = extractConstructors typeOfPat2Cleaned (toList inscps)
let newMatches = createMatches dec (declToName dec) pnt name pats position constrsOfData match
(beforeM, afterM) = break (==match) matches
update dec (Dec (HsFunBind s (beforeM ++ newMatches ++ afterM))) dec
inDec x = return x
createMatches (Dec (HsFunBind loc environment)) funName pnt name pats position constrs match
= let (before, after) = break (==match) environment
newMatches = createMatches2 position (length pats) match constrs
in newMatches
where
createMatches2 _ _ _ [] = []
createMatches2 position arity m@(HsMatch _ _ pats rhs ds) constrs@(c:cs)
= [HsMatch loc0 name pats newCase ds]
where
newPats [] = []
newPats ((ConInfo (SN n _) a _):cs) = createPat pnt n a (pats !! position)
(map pNtoName (hsPNs pats ++ hsPNs ds))
: newPats cs
newCase = HsBody (Exp (HsCase (nameToExp (pNTtoName pnt)) (newAlts (newPats constrs))))
newAlts [] = []
newAlts (p:ps) = (HsAlt loc0 p rhs []) : newAlts ps
myReplicate 0 _ _ = []
myReplicate arity names index
= let newName = mkNewName "a" names index
in (nameToPat newName) : (myReplicate (arity-1) (names ++ [newName]) (index+1))
replacePolymorphicType typeSig
= applyTP (full_tdTP (idTP `adhocTP` rename)) typeSig
where
rename (Typ (HsTyVar n)) = return (Typ (HsTyVar (nameToPNT "Int")))
rename x = return x
force a = if a==a then a else a
extractConstructors typeName [] = []
extractConstructors typeName ((_,Ent _ (HsCon (SN n _)) (Type (TypeInfo _ cs _))):xs)
| n == typeName && cs == [] = error $ "Cannot instantiate new patterns for the selected pattern. It may be of a polymorphic type, or a Haskell defined type such as Int."
| n == typeName = cs
| otherwise = extractConstructors typeName xs
extractConstructors typeName (x:xs) = extractConstructors typeName xs
cleanPatType [] = []
cleanPatType (' ':xs) = cleanPatType xs
cleanPatType ('[':xs) = "[]"
cleanPatType ('(':xs)
= "(" ++ ( filter (==',') xs) ++ ")"
cleanPatType xs = let (x, s') = break (== ' ') xs
in x
getSigAsString ses closureEquation res
= do
let types = lines2 res
let types1 = cleanTypes (tail types)
let (context, l) = getContext (head types)
let types2 = l : types1
let types3 = map (filter (/= '\n')) types2
let types4 = fold (tail types3)
return (context ++ " => " ++ (head types3) ++ " -> " ++ types4)
where
fold [] = []
fold [x] = x
fold (x:xs) = x ++ (" -> " ++ fold xs)
createClosure :: String -> String -> HsPatP -> Int -> String
createClosure typeSig p pat pos
= "(\\(" ++ ((render.ppi) pat) ++ "::" ++ ((typeAnnot typeSig)!!pos) ++ ") -> " ++ p ++")"
-- = "closure___ " ++ "(" ++ ((render.ppi) pat) ++ "::" ++ ((typeAnnot typeSig)!!pos) ++ ") = " ++ p
where
typeAnnot :: String -> [String]
typeAnnot "" = []
typeAnnot s = let (_, s') = break (== ':') s
in case s' of
{ [] -> [];
(_:s'') -> typeAnnot' (tail s'') }
typeAnnot' :: String -> [String]
typeAnnot' "" = []
typeAnnot' s = let (l, s') = break (== '-') s
in l : case s' of
{[] -> [];
(_:s'') -> typeAnnot' (tail s'')}
introPatsCase pnt t
= applyTP (full_tdTP (idTP `adhocTP` inDec)) t
where
inDec (dec@(Dec (HsFunBind s matches))::HsDeclP)
| findPNT pnt matches && inMatch pnt matches
= do
-- we need to find the type of the variable in question,
-- and also the implementation of the type. If the type
-- is defined outside of the project, we must error!
let match@(HsMatch loc name pats rhs ds) = getMatch pnt matches
typeSig = getTypeSig (pNTtoPN name) t
(typeOfPat, position) = findPatAndType 0 pnt (flatternType typeSig) pats
constrsOfData = findTypeAndConstrs 0 pnt (flatternType typeSig) pats
-- check that argument position is a variable in all defining
-- equations...
if checkVariableEquation matches position
then do
let newMatches = concatMap (createMatches dec (declToName dec) name pats (position+1) constrsOfData) matches
update dec (Dec (HsFunBind s (newMatches++matches))) dec
else do
return dec
inDec x = return x
typToPNT (Typ (HsTyCon x)) = x
typToPNT x = error "Please select a variable with a type constructor1!"
checkVariableEquation [] _ = True
checkVariableEquation ((HsMatch _ _ pats _ _):ms) position
| checkPats (pats !! position) = checkVariableEquation ms position
| otherwise = error "Pattern argument must be a variable in all defining equations!"
checkPats (Pat (HsPIrrPat p)) = checkPats p
checkPats (Pat (HsPParen p)) = checkPats p
checkPats (Pat (HsPId (HsVar x))) = True
checkPats _ = False
createMatches (Dec (HsFunBind loc environment)) funName name pats position constrs match
= let (before, after) = break (==match) environment
newMatches = createMatches2 position (length pats) match constrs
in newMatches
where
createMatches2 _ _ _ [] = []
createMatches2 position arity m@(HsMatch _ _ pats rhs ds) constrs@(c:cs)
= [HsMatch loc0 name pats newCase ds]
where
newPats [] = []
newPats ((ConInfo (PN n _) a _):cs) = createPat pnt n a (pats !! (position-1))
(map pNtoName (hsPNs pats ++ hsPNs ds))
: newPats cs
newCase = HsBody (Exp (HsCase (nameToExp (pNtoName (patToPN (pats !! (position-1))))) (newAlts (newPats constrs) )))
newAlts [] = []
newAlts (p:ps) = (HsAlt loc0 p rhs []) : newAlts ps
myReplicate 0 _ _ = []
myReplicate arity names index
= let newName = mkNewName "a" names index
in (nameToPat newName) : (myReplicate (arity-1) (names ++ [newName]) (index+1))
-- ==========================================================================
-- end of introCase
-- ==========================================================================
foldPattern args
= do let fileName = ghead "filename" args
--fileName'= moduleName fileName
--modName = Module fileName'
patName = (args!!1)
beginRow = read (args!!2)::Int
beginCol = read (args!!3)::Int
endRow = read (args!!4)::Int
endCol = read (args!!5)::Int
modName <-fileNameToModName fileName
(inscps, exps, mod, tokList)<-parseSourceFile fileName
let (ty, pnt, pats, subExp, wh)
= findDefNameAndExp tokList
(beginRow, beginCol)
(endRow, endCol)
mod
let exp = locToExp (beginRow, beginCol)
(endRow, endCol)
tokList
mod
((_,m), (newToks, newMod))<-applyRefac (doFoldPattern patName pnt exp)
(Just (inscps, exps, mod, tokList)) fileName
writeRefactoredFiles False [((fileName,m), (newToks,newMod))]
AbstractIO.putStrLn "Completed.\n"
doFoldPattern patName pnt exp (_,_,t)
= do
mod <- foldPatterns patName pnt exp t
return mod
foldPatterns patName pnt exp t
= applyTP (stop_tdTP (failTP `adhocTP` inMod
`adhocTP` inMatch)) t
where
inMod (mod@(HsModule loc name exps imps ds):: HsModuleP)
| pnt `elem` (map declToPNT ds)
= do
ds' <- doFoldModule ds
return (HsModule loc name exps imps ds')
where
doFoldModule t
= applyTP (stop_tdTP (failTP `adhocTP` inMatch2)) t
where
inMatch2 (match@(HsMatch loc name pats rhs ds)::HsMatchP)
| useLoc pnt == useLoc name
= do
-- let's check that the pattern name
-- occurs as a variable pattern in pats
if checkPattern patName pats == False
then error "The pattern entered does not occur with the pattern list or is not a pattern variable!"
else do
-- let's replace the highlighted expression with the pattern name
newExp <- replaceExp rhs patName exp
return (HsMatch loc name pats newExp ds)
inMatch2 x = mzero
inMod x = mzero
inMatch (match@(HsMatch loc name pats rhs ds)::HsMatchP)
| useLoc pnt == useLoc name
=do
-- let's check that the pattern name
-- occurs as a variable pattern in pats
if checkPattern patName pats == False
then error "The pattern entered does not occur with the pattern list or is not a pattern variable!"
else do
-- let's replace the highlighted expression with the pattern name
newExp <- replaceExp rhs patName exp
return (HsMatch loc name pats newExp ds)
inMatch x = mzero
replaceExp t patName e
= applyTP (stop_tdTP (failTP `adhocTP` subExp)) t
where
subExp exp@((Exp _)::HsExpP)
| sameOccurrence exp e == True
= update exp (nameToExp patName) exp
| otherwise = mzero
checkPattern :: String -> [HsPatP] -> Bool
checkPattern patName
= (fromMaybe False).applyTU (once_tdTU (failTU `adhocTU` inVar))
where
inVar (Pat (HsPId (HsVar n)))
| pNTtoName n == patName = Just True
inVar (Pat (HsPAsPat n p))
| pNTtoName n == patName = Just True
inVar x = Nothing
-- ==========================================================================
-- end of foldPattern
-- ==========================================================================
-- utility functions
{-|
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.
-> (PatFun, PNT, FunctionPats, HsExpP, WhereDecls) -- ^ 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 (Er, defaultPNT, [], defaultExp, [])
(applyTU (once_buTU (failTU `adhocTU` inMatch `adhocTU` inPat)) t)
where
--The selected sub-expression is in the rhs of a match
inMatch (match@(HsMatch loc1 pnt pats rhs@(HsBody e) ds)::HsMatchP)
| locToExp beginPos endPos toks rhs /= defaultExp
= Just (Mat, pnt, pats, locToExp beginPos endPos toks rhs, ds)
inMatch (match@(HsMatch loc1 pnt pats rhs@(HsGuard e) ds)::HsMatchP)
| locToExp beginPos endPos toks rhs /= defaultExp
= Just (Mat, pnt, pats, rmGuard rhs, ds)
inMatch _ = Nothing
--The selected sub-expression is in the rhs of a pattern-binding
inPat (pat@(Dec (HsPatBind loc1 ps rhs ds))::HsDeclP)
| locToExp beginPos endPos toks rhs /= defaultExp
= error "Cannot fold against a variable within a pattern binding!"
inPat _ = Nothing
rmGuard ((HsGuard gs)::RhsP)
= let (_,e1,e2)=glast "guardToIfThenElse" gs
in if ((pNtoName.expToPN) e1)=="otherwise"
then (foldl mkIfThenElse e2 (tail(reverse gs)))
else (foldl mkIfThenElse defaultElse (reverse gs))
mkIfThenElse e (_,e1, e2)=(Exp (HsIf e1 e2 e))
defaultElse=(Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "error") (G (PlainModule "Prelude") "error"
(N (Just loc0)))) Value (N (Just loc0)))))) (Exp (HsLit loc0 (HsString "UnMatched Pattern")))))
checkInPat :: Term t => PNT -> t -> Bool
checkInPat pnt t
= checkInMatch pnt t
where
checkInMatch pnt t
= fromMaybe (False)
(applyTU (once_tdTU (failTU `adhocTU` inMatch)) t)
--The selected sub-expression is in the rhs of a match
inMatch (match@(HsMatch loc1 _ pats rhs ds)::HsMatchP)
| findPNT' pnt pats
= Just True
where findPNT' pnt [] = False
findPNT' pnt (p@(Pat (HsPIrrPat p1)):ps)
| findPNT pnt p1 = True
| otherwise = findPNT' pnt ps
findPNT' pnt (p@(Pat (HsPParen p1)):ps)
| findPNT' pnt [p1] = True
| otherwise = findPNT' pnt ps
findPNT' pnt (p@(Pat (HsPId x)):ps)
| findPNT pnt p = True
| otherwise = findPNT' pnt ps
findPNT' pnt (p:ps) = findPNT' pnt ps
inMatch _ = Nothing
checkInSubPat :: Term t => PNT -> t -> Bool
checkInSubPat pnt t
= checkInPat pnt t
where
checkInPat pnt t
= fromMaybe (False)
(applyTU (once_tdTU (failTU `adhocTU` inMatch)) t)
--The selected sub-expression is in the rhs of a match
inMatch (match@(HsMatch loc1 _ pats rhs ds)::HsMatchP)
| findPNT' pnt pats
= Just True
where findPNT' pnt [] = False
findPNT' pnt ((Pat (HsPAsPat i p)):ps)
| findPNT pnt i = True
| findPNT' pnt [p] = True
| otherwise = findPNT' pnt ps
findPNT' pnt ((Pat (HsPApp i ps)):pss)
| findPNT' pnt ps = True
| otherwise = findPNT' pnt ps
findPNT' pnt ((Pat (HsPTuple _ ps)):pss)
| findPNT' pnt ps = True
| otherwise = findPNT' pnt ps
findPNT' pnt (Pat (HsPInfixApp p1 i p2):ps)
| findPNT pnt p1 || findPNT pnt p2 = True
| otherwise = findPNT' pnt ps
findPNT' pnt (p@(Pat (HsPParen p1)):ps)
| findPNT' pnt [p1] = True
| otherwise = findPNT' pnt ps
findPNT' pnt (p@(Pat (HsPId x)):ps)
| findPNT pnt p = True
| otherwise = findPNT' pnt ps
findPNT' pnt (p:ps) = findPNT' pnt ps
inMatch _ = Nothing
createPat :: PNT -> String -> Int -> HsPatP -> [String] -> HsPatP
createPat pnt x i (Pat (HsPIrrPat p)) environ
= (Pat (HsPIrrPat (createPat' pnt x i environ)))
createPat pnt x i _ environ = createPat' pnt x i environ
createPat' pnt i 0 environ = Pat (HsPAsPat pnt (Pat (HsPId (HsCon (nameToPNT i)))))
createPat' pnt x@(':':xs) ts environ
= Pat (HsPAsPat pnt (Pat (HsPInfixApp (ghead "createPat" pat1) (nameToPNT x)
(last pat1))))
where
pat1 = reverse $ createId environ ts
createPat' pnt x@('(':xs) ts environ
= Pat (HsPAsPat pnt (Pat ( HsPTuple loc0 (reverse (createId environ ts)))))
createPat' pnt i ts environ = Pat (HsPAsPat pnt (Pat (HsPApp (nameToPNT i) (reverse (createId environ ts)))))
createId _ 0 = []
createId names a
= let newName = mkNewName "b" names a
in (nameToPat newName) : (createId (names ++ [newName]) (a-1))
replace :: Int -> [a] -> a -> [a]
replace pos [] e = []
replace pos list e
= (init (take pos list)) ++ [e] ++ (drop pos list)
inMatch _ [] = False
inMatch pnt (match@(HsMatch loc name pats rhs ds):ms)
| findPNT pnt pats = True
| otherwise = inMatch pnt ms
getMatch _ [] = error "Please select a pattern variable on the LHS of an equation!"
getMatch pnt (match@(HsMatch loc name pats rhs ds):ms)
| findPNT pnt pats = match
| otherwise = getMatch pnt ms
getTypeSig name t
= fromMaybe (error "Please define a type signature for the definition!")
(applyTU (once_tdTU (failTU `adhocTU` inDec)) t)
where
inDec (d@(Dec (HsTypeSig _ _ _ _))::HsDeclP)
| definesTypeSig name d = Just d
inDec _ = Nothing
findTypeAndConstrs index _ _ [] = error "No type associated with pattern variable!"
findTypeAndConstrs index pnt types (p:ps)
| findPNT pnt p = extractConstrs (types !! index)
| otherwise = findTypeAndConstrs (index+1) pnt types ps
findPatAndType index _ _ [] = error "No type associated with pattern variable!"
findPatAndType index pnt types (p:ps)
| findPNT pnt p = (typToPNT (types !! index), index)
| otherwise = findPatAndType (index+1) pnt types ps
-- flatternType :: HsDeclP -> [HsTypeP]
flatternType (Dec (HsTypeSig _ _ _ t))
= flatternT t
flatternT (Typ (HsTyApp t1 t2)) = flatternT t1
flatternT (Typ (HsTyFun t1 t2)) = flatternT t1 ++ flatternT t2
flatternT (Typ (HsTyForall _ _ t)) = flatternT t
flatternT t = [t]
flatternAllType (Dec (HsTypeSig _ _ _ t))
= flatternAllT t
flatternAllT (Typ (HsTyApp t1 t2))
= flatternAllT t1 ++ flatternAllT t2
-- | pNTtoName (typToPNT t1) == "[]" = flatternAllT t1
-- | otherwise = flatternAllT t1 ++ flatternAllT t2
flatternAllT (Typ (HsTyFun t1 t2)) = flatternAllT t1 ++ flatternAllT t2
flatternAllT (Typ (HsTyForall _ _ t)) = flatternAllT t
flatternAllT t = [t]
extractConstrs t@(Typ (HsTyCon (PNT pn (Type (TypeInfo _ [] _)) _ )))
= error "There are no constructors defined for the type of this pattern!"
extractConstrs (Typ (HsTyCon (PNT pn (Type (TypeInfo _ cs _)) _ ))) = cs
extractConstrs x = error "Please select a variable with a type constructor!"
extractConstrs' t@(Typ (HsTyCon (PNT pn (Type (TypeInfo _ [] _)) _ ))) _ _ _ _
= error "There are no constructors defined for the type of this pattern!"
extractConstrs' (Typ (HsTyCon (PNT pn (Type (TypeInfo _ cs _)) _ ))) _ _ _ _ = cs
extractConstrs' (Typ (HsTyVar (PNT pn (Type (TypeInfo _ cs _)) _ ))) types ty pos constrName
= -- if it's a variable, then it must be exposed on the
-- LHS of the type
-- what about existential types?
let posOfVar = findPosOfVar constrName ty
instanceOfVarType = findPosOfInstance posOfVar (declToPNT ty) types
in extractConstrs instanceOfVarType
findPosOfInstance _ _ [] = error "pattern is a variable which is not instantiated within the type signature!"
findPosOfInstance offset pn (t@(Typ (HsTyCon pnt)):ts)
| rmLocs pn == rmLocs pnt = ts !! (offset-1)
| otherwise = findPosOfInstance offset pn ts
findPosOfVar (Typ (HsTyVar pnt)) (Dec (HsDataDecl _ _ t _ _))
= extractPos 0 (flatternAllT t)
where
extractPos i [] = i
extractPos i ((Typ (HsTyCon pnt2)):ts)
= extractPos (i+1) ts
extractPos i ((Typ (HsTyVar pnt2)):ts)
| rmLocs pnt2 == rmLocs pnt = i
| otherwise = extractPos (i+1) ts