----------------------------------------------------------------------------------------------------------------
-- Module : RefacUtils
-- Maintainer : refactor-fp\@kent.ac.uk
-- |
--
-- This module contains a collection of program analysis and transformation functions(the API). In general,
-- a program analysis function returns some information about the program, but does NOT modify the program; whereas a
-- program transformation function transforms the program from one state to another state. This API is built
-- on top of Programatica's abstract syntax for Haskell and Strafunski's traversal API for large abstract syntax
-- trees, and is used extensively in the implementation of primitive refactorings. In HaRe, in order to preserve the
-- comments and layout of refactored programs, a refactoring modifies not only the AST but also the token stream, and
-- the program source after the refactoring is extracted from the token stream rather than the AST, for the comments
-- and layout information is kept in the token steam instead of the AST. As a consequence, a program transformation
-- function from this API modifies both the AST and the token stream (unless explicitly stated). So when you build
-- your own program transformations, try to use the API to do the transformation, as this can liberate you from
-- caring about the token stream.--
-- As the API is based on Programatica's abstract syntax for Haskell, we have re-exported those related module from
-- Programatica, so that you can browse the datatypes for the abstract syntax. Alternatively, you can go to
-- Programatica's webpage at: . For Strafunski, you can find it
-- at: .
--
-- This API is still in development. Any suggestions and comments are very much welcome.
------------------------------------------------------------------------------------------------------------------
module RefacUtils(module Control.Monad.State, module StrategyLib, module RefacTypeSyn, module PosSyntax,
module SourceNames, module UniqueNames, module PNT,
module Ents, module Relations, module QualNames, module TypedIds
-- * Program Analysis
-- ** Imports and exports
,inScopeInfo, isInScopeAndUnqualified, hsQualifier, hsQualifier2, isQuald, {-This function should be removed-} rmPrelude
,exportInfo, isExported, isExplicitlyExported, modIsExported, parseSourceFileOld
-- ** Variable analysis
,hsPNs,hsPNTs,hsDataConstrs,hsTypeConstrsAndClasses, hsTypeVbls
,hsClassMembers, HsDecls(hsDecls,isDeclaredIn, replaceDecls)
,hsFreeAndDeclaredPNs,hsFreeAndDeclaredNames
,hsVisiblePNs, hsVisibleNames
,hsFDsFromInside, hsFDNamesFromInside
-- ** Property checking
,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isTopLevelPNT
,isQualifiedPN,isFunPNT, isFunName, isPatName, isDataCon, isFunOrPatName,isTypeCon,isTypeSig,isFunBind,isPatBind,isSimplePatBind
,isComplexPatBind,isFunOrPatBind,isClassDecl,isInstDecl,isDirectRecursiveDef
,usedWithoutQual,canBeQualified, hasFreeVars,isUsedInRhs, isUsedInRhsName, returnRHS, returnRHS2, getParams
,findPNT,findPN, findPN', findPNRHS -- Try to remove this.
,findPNs, findEntity, findEntityWithLocation
,sameOccurrence, sameOccurrence2
,defines,definesTypeSig, isTypeSigOf, defines2, defines3, defines', definesPNT
,HasModName(hasModName), HasNameSpace(hasNameSpace)
-- ** Modules and files
,clientModsAndFiles,serverModsAndFiles,isAnExistingMod
,fileNameToModName, strToModName, modNameToStr, newProj, addFile, chase
-- ** Locations
,defineLoc, useLoc,locToPNT,locToPN,locToExp, locToExp2, locToPat, locToLocalPat, getStartEndLoc , isLocalPNT
-- * Program transformation
-- ** Adding
,addDecl ,addItemsToImport, addHiding, rmItemsFromImport, addItemsToExport, addTypeSigDecl
,addParamsToDecls, addGuardsToRhs, addImportDecl, duplicateDecl, moveDecl
-- ** Rmoving
,rmDecl, rmTypeSig, commentOutTypeSig, insertComment, extractComment, insertTerm, rmParams
,rmItemsFromExport, rmSubEntsFromExport, Delete(delete)
-- ** Updating
,Update(update)
,qualifyPName,rmQualifier,renamePN,replaceNameInPN,autoRenameLocalVar
-- * Miscellous
-- ** Parsing, writing and showing
,parseSourceFile, {-parseSourceFile2,-} writeRefactoredFiles, showEntities ,showPNwithLoc, parsePrelude
-- ** Locations
,toRelativeLocs, rmLocs, rmAllLocs
-- ** Default values
,defaultPN,defaultPNT,defaultModName,defaultExp,defaultPat
-- ** Identifiers, expressions, patterns and declarations
,pNTtoPN,pNTtoName,pNtoName,nameToPNT, nameToPN,pNtoPNT, declToName, declToName2,declToPNT, declToPNT', declToPName, declToPName2
,expToPNT, expToPN, nameToExp, nameToIdent,pNtoExp,patToPNT, patToPN, nameToPat,pNtoPat, typToPNT, nameToTyp
,definingDecls, definedPNs, definedPNsForConstr
,simplifyDecl, createFunc, createFunc', createFuncFromPat, createTypFunc, createTypFunc', createDataFunc
-- ** Others
,mkNewName, applyRefac, applyRefacToClientMods
-- The following functions are not in the the API yet.
,getDeclToks, causeNameClashInExports, inRegion , ghead, glast, gfromJust, unmodified, prettyprint, prettyprintGuardsAlt,
getDeclAndToks, wildCardAllPNs
-- Type checker stuff
,checkTypes, getDataName, checkTypes2, checkTypesInPat, getTypes, getContext, cleanTypes, addTypeDecl, getSig, getSigAsString, getSigOmitLast, lines2
)
where
import Prelude hiding (putStr,putStrLn,writeFile,readFile)
import Maybe
import List hiding (delete)
import Char
--------------------------------
import PfeChase
import PFE0
import PFE2
import PFE3(parseModule,parseModule', parseSourceFile', parseScopeSourceFile)
import PosSyntax hiding (ModuleName, HsName, SN)
import SourceNames
import ScopeModule
import UniqueNames hiding (srcLoc)
import HsName
import HsLexerPass1
import AbstractIO
import PNT
import TiPNT
import SimpleGraphs(reverseGraph,reachable)
import Ents hiding (isValue)
import Relations
import QualNames
import TypedIds hiding (NameSpace, HasNameSpace)
import WorkModule
import PrettyPrint
import Unlit(readHaskellFile,writeHaskellFile)
import MUtils hiding (swap)
import EditorCommands(sendEditorModified)
import qualified MT(lift)
import HsTokens
-------------------------
import RefacTypeSyn
import RefacLocUtils
import LocalSettings
-------------------------
--import DriftStructUtils
import StrategyLib hiding (findFile, fail, (>>=), (>>), return, mfix, Monad, Functor, MonadFix, MonadPlus, fmap, (=<<),
sequence_, sequence, mapM_, mapM, liftM5, liftM4, liftM3, mzero, mplus, guard, filterM, msum,
join, mapAndUnzipM, zipWithM, zipWithM_, foldM, when, unless, liftM, liftM2, ap, MonadTrans, MonadIO,
fix, lift, liftIO, StateT, runStateT, State, runState )
import Control.Monad.State
import TypeCheck
#if __GLASGOW_HASKELL__ <604
instance (Monoid a, Monoid b) => Monoid (a,b) where
mappend (a,b) (a',b') = (mappend a a', mappend b b')
mempty = (mempty, mempty)
#endif
------------------------------------------------------------------------------------------
{- | The Delete class. -}
class (Term t, Term t1)=>Delete t t1 where
-- | Delete the occurrence of a syntax phrase in a given context.
delete::(MonadPlus m, MonadState (([PosToken],Bool),t2) m)=> t -- ^ The syntax phrase to delete.
->t1 -- ^ The contex where the syntax phrase occurs.
->m t1 -- ^ The result.
-- An expression can only be deleted in certain circumstances.
instance (Term t) => Delete HsExpP t where
delete e t
= applyTP (once_tdTP (failTP `adhocTP` inExp)`choiceTP` failure) t
where
{- inExp ((Exp (HsApp e1 e2))::HsExpP)
| sameOccurrence e e1
= do deleteFromToks e1
return e2 -}
inExp (Exp (HsApp e1 e2)::HsExpP)
| sameOccurrence e e2
= do deleteFromToks e2 getStartEndLoc
return e1
inExp (Exp (HsList es))
|isJust $ find (\x->sameOccurrence e x) es
= do ((toks,_),others)<-get
let toks'=deleteEnt toks $ getStartEndLoc toks e
put ((toks',modified),others)
return (Exp (HsList (es \\[e])))
inExp _ = mzero
sameOccurrence t1 t2
= rmParen t1== rmParen t2 && srcLocs t1 == srcLocs t2
rmParen (Exp (HsParen e)) = rmParen e
rmParen e = e
failure = error "Delete: This expression can not be deleted!"
instance (Term t) => Delete HsPatP t where
delete p t
= applyTP (once_tdTP (failTP `adhocTP` inPats)) t
where
inPats (ps::[HsPatP])
|isJust $ find(\x->sameOccurrence p x) ps
= do deleteFromToks p getStartEndLoc
return (ps\\[p])
inPats _ = mzero
instance (Term t) => Delete HsTypeP t where
delete p t
= applyTP (once_tdTP (failTP `adhocTP` inTypes)) t
where
inTypes (t::HsTypeP)
|isJust $ find(\x-> (rmAllLocs p)== (rmAllLocs x)) (flatternTApp t)
= do deleteFromToks p getStartEndLoc
return (createDataFunc ((typToPNT.(ghead "inDatDeclaration").flatternTApp) t)
( ( (tail (flatternTApp t)) <-> p )))
inTypes _ = mzero
(<->) [] _ = []
(<->) (x:xs) y
| (rmAllLocs x) == (rmAllLocs y) = xs <-> y
| otherwise = x : (xs <-> y)
flatternTApp :: HsTypeP -> [HsTypeP]
flatternTApp (Typ (HsTyFun t1 t2)) = flatternTApp t1 ++ flatternTApp t2
flatternTApp (Typ (HsTyApp t1 t2)) = flatternTApp t1 ++ flatternTApp t2
flatternTApp x = [x]
instance (Term t) => Delete HsImportDeclP t where
delete imp t
= applyTP (once_tdTP (failTP `adhocTP` inImps)) t
where
inImps (imps::[HsImportDeclP])
| isJust $ find (\x->sameOccurrence imp x) imps
= do deleteFromToks imp startEndLocIncFowNewLn
return (imps \\ [imp])
inImps _ = mzero
{- | The Update class, -}
class (Term t, Term t1)=>Update t t1 where
-- | Update the occurrence of one syntax phrase in a given scope by another syntax phrase of the same type.
update::(MonadPlus m, MonadState (([PosToken],Bool),(Int,Int)) m)=> t -- ^ The syntax phrase to be updated.
-> t -- ^ The new syntax phrase.
-> t1 -- ^ The contex where the old syntax phrase occurs.
-> m t1 -- ^ The result.
instance (Term t) =>Update RhsP t where
update oldRhs newRhs t
= applyTP (once_tdTP (failTP `adhocTP` inRhs)) t
where
inRhs (r::RhsP)
| r == oldRhs && srcLocs r == srcLocs oldRhs
= do (newRhs',_) <- updateToks oldRhs newRhs prettyprint
return newRhs'
inRhs r = mzero
instance (Term t) =>Update HsExpP t where
update oldExp newExp t
= applyTP (once_tdTP (failTP `adhocTP` inExp)) t
where
inExp (e::HsExpP)
| e == oldExp && srcLocs e == srcLocs oldExp
= do (newExp', _) <-updateToks oldExp newExp prettyprint
return newExp'
inExp e = mzero
instance (Term t) =>Update HsStmtP t where
update oldStmt newStmt t
= applyTP (once_tdTP (failTP `adhocTP` inStmt)) t
where
inStmt (s::HsStmtP)
| s == oldStmt && srcLocs s == srcLocs oldStmt
= do (newStmt', _) <-updateToks oldStmt newStmt prettyprint
return newStmt'
inStmt s = mzero
instance (Term t) => Update HsAltP t where
update oldExp newExp t
= applyTP (once_tdTP (failTP `adhocTP` inExp)) t
where
inExp (e::HsAltP)
| e == oldExp && srcLocs e == srcLocs oldExp
= do (newExp', _) <-updateToks oldExp newExp prettyprint
return newExp'
inExp e = mzero
instance (Term t) =>Update PNT t where
update oldExp newExp t
= applyTP (once_tdTP (failTP `adhocTP` inExp)) t
where
inExp (e::PNT)
| e == oldExp && srcLocs e == srcLocs oldExp
= do (newExp',_) <- updateToks oldExp newExp prettyprint
return newExp'
inExp e = mzero
instance (Term t) =>Update HsMatchP t where
update oldExp newExp t
= applyTP (once_tdTP (failTP `adhocTP` inExp)) t
where
inExp (e::HsMatchP)
| e == oldExp && srcLocs e == srcLocs oldExp
= do (newExp',_) <- updateToks oldExp newExp prettyprint
return newExp'
inExp e = mzero
instance (Term t) =>Update HsPatP t where
update oldPat newPat t
= applyTP (once_tdTP (failTP `adhocTP` inPat)) t
where
inPat (p::HsPatP)
| p == oldPat && srcLocs p == srcLocs oldPat
= do (newPat', _) <- updateToks [oldPat] [newPat] (prettyprintPatList False)
return $ ghead "update" newPat'
inPat e = mzero
instance (Term t) =>Update [HsPatP] t where
update oldPat newPat t
= applyTP (once_tdTP (failTP `adhocTP` inPat)) t
where
inPat (p::[HsPatP])
| sameOccurrence p oldPat
= do (newPat', _) <- updateToks oldPat newPat (prettyprintPatList False)
return newPat'
inPat e = mzero
instance (Term t) =>Update [HsDeclP] t where
update oldDecl newDecl t
= applyTP (once_tdTP (failTP `adhocTP` inDecl)) t
where
inDecl (d::[HsDeclP])
| sameOccurrence d oldDecl
= do
(newDecl',_) <- updateToks oldDecl newDecl prettyprint
return newDecl'
inDecl e = mzero
instance (Term t) =>Update HsDeclP t where
update oldDecl newDecl t
= applyTP (once_tdTP (failTP `adhocTP` inDecl)) t
where
inDecl (d::HsDeclP)
| sameOccurrence d oldDecl
= do (newDecl',_) <- updateToks oldDecl newDecl prettyprint
return newDecl'
inDecl e = mzero
instance (Term t) =>Update HsImportDeclP t where
update oldImpDecl newImpDecl t
= applyTP (once_tdTP (failTP `adhocTP` inDecl)) t
where
inDecl (d::HsImportDeclP)
| sameOccurrence d oldImpDecl
=do (newImpDecl', _) <-updateToks oldImpDecl newImpDecl prettyprint
return newImpDecl'
inDecl e = mzero
instance (Term t) => Update HsExportEntP t where
update oldEnt@(EntE s) newEnt@(EntE s1) t
= applyTP (once_tdTP (failTP `adhocTP` inEnt)) t
where
inEnt (e::HsExportEntP)
| sameOccurrence e oldEnt
= do (s1',_) <- updateToks s s1 prettyprint
return (EntE s1')
inEnt e = mzero
instance (Term t) => Update HsTypeP t where
update oldType newType t
= applyTP (once_tdTP (failTP `adhocTP` inType)) t
where
inType (t::HsTypeP)
| sameOccurrence t oldType
= do (newType', _) <- updateToks oldType newType prettyprint
return newType'
inType t = mzero
instance (Term t) => Update HsConDeclP t where
update oldType newType t
= applyTP (once_tdTP (failTP `adhocTP` inType)) t
where
inType (t::HsConDeclP)
| sameOccurrence t oldType
= do (newType', _) <- updateToks oldType newType prettyprint
return newType'
inType t = mzero
{-
{- | The Swap Class. The instances may be not complete, tell us what you need so that we can add it.-}
class (Term t, Term t1 ) => Swap t t1 where
-- | Swap the occurrences of two syntax phrases( of the same type) in a given scope.
swap :: (MonadState (([PosToken],Bool),t2) m)=> t -- ^ The first syntax phrase.
-> t -- ^ The second syntax phrase.
->t1 -- ^ The context where the two syntax phrases occur.
->m t1 -- ^ The result.
instance (Term t)=>Swap HsExpP t where
swap e1 e2 t
= do swapInToks e1 e2
applyTP (full_tdTP (idTP `adhocTP` inExp)) t -- both full_td and full_bu should wor
where
inExp (e ::HsExpP)
| sameOccurrence e e1
= return e2
inExp (e::HsExpP)
| e == e2 && srcLocs e == srcLocs e2
= return e1
inExp x = return x
instance (Term t) => Swap HsPatP t where
swap p1 p2 t
= do swapInToks p1 p2
applyTP (full_tdTP (idTP `adhocTP` inPat)) t
where
inPat (p::HsPatP)
| sameOccurrence p p1
= return p2
inPat (p::HsPatP)
| sameOccurrence p p2
= return p1
inPat x = return x
instance (Term t) => Swap HsTypeP t where
swap t1 t2 t
= do swapInToks t1 t2
applyTP (full_tdTP (idTP `adhocTP` inType)) t
where
inType (t::HsTypeP)
| sameOccurrence t t1
= return t2
inType (t::HsTypeP)
| sameOccurrence t t2
= return t1
inType t = return t
-}
class (DeclStartLoc t) =>CanHaveWhereClause t where
canHaveWhereClause:: t-> Bool
instance CanHaveWhereClause HsMatchP where
canHaveWhereClause t = True
instance CanHaveWhereClause HsDeclP where
canHaveWhereClause t = isPatBind t
instance CanHaveWhereClause HsAltP where
canHaveWhereClause t = True
{-
instance CanHaveWhereClause HsModuleP where
canHaveWhereClause t = True
-}
instance CanHaveWhereClause HsExpP where
canHaveWhereClause t = False
instance CanHaveWhereClause HsStmtP where
canHaveWhereClause t = False
class (StartEndLoc t) =>DeclStartLoc t where
-- | Given a syntax phrase, get the start location of enclosed top-level declaration list.
declStartLoc:: [PosToken]->t->Maybe SimpPos
instance DeclStartLoc HsMatchP where
declStartLoc toks (HsMatch loc1 name pats rhs ds)
= if ds/=[] then Just $ fst (getStartEndLoc toks (ghead "declStartLoc" ds))
else Nothing
instance DeclStartLoc HsDeclP where
declStartLoc toks (Dec (HsPatBind loc p rhs ds))
= if ds/=[] then Just$ (fst (getStartEndLoc toks (ghead "declStartLoc" ds)))
else Nothing
declStartLoc toks _ = Nothing
instance DeclStartLoc HsExpP where
declStartLoc toks letExp@(Exp (HsLet ds e))
= if ds/=[] then Just $ fst (getStartEndLoc toks (ghead "declStartLoc" ds))
else let (startPos,endPos)=getStartEndLoc toks letExp
expToks= getToks (startPos,endPos) toks
in Just $ ((tokenPos.(ghead "declStartLoc")) $ dropWhile (not.isIn) expToks)
instance DeclStartLoc HsAltP where
declStartLoc toks (HsAlt loc p rhs ds)
=if ds/=[] then Just $ (fst (getStartEndLoc toks (ghead "declStartLoc" ds)))
else Nothing
instance DeclStartLoc HsStmtP where
declStartLoc toks (HsLetStmt ds stmts)
= if ds/=[] then Just $ fst (getStartEndLoc toks (ghead "declStartLoc" ds))
else Just $ fst (getStartEndLoc toks stmts) -- Qn: Is this possible?
-- | Return True if syntax phrases t1 and t2 refer to the same one.
sameOccurrence:: (Term t, Eq t) => t -> t -> Bool
sameOccurrence t1 t2
= t1==t2 && srcLocs t1 == srcLocs t2
-- | Return True if syntax phrases t1 and t2 refer to the same one.
sameOccurrence2:: (Term t, Eq t) => t -> t -> Bool
sameOccurrence2 t1 t2
= srcLocs t1 == srcLocs t2
sameName :: PNT -> PNT -> Bool
sameName (PNT (PN (UnQual n) _)_ _) (PNT (PN (UnQual n2) _)_ _)
= isPrefixOf n n2 || n == n2
{- | The 'HasNameSpace' class. -}
class HasNameSpace t where
hasNameSpace::t->NameSpace
instance HasNameSpace PNT where
hasNameSpace (PNT _ Value _) = ValueName
hasNameSpace (PNT _ (ConstrOf _ _ ) _) = DataCon
hasNameSpace (PNT _ (FieldOf _ _ ) _) = ValueName
hasNameSpace (PNT _ (MethodOf _ _ _) _) = ValueName
hasNameSpace (PNT _ (Class _ _) _) = ClassName
hasNameSpace (PNT _ (Type _) _ ) = TypeCon -- It is also possible that it is a type variable.
hasNameSpace _ = Other -- We don't care about Assertion & Property so far.
instance HasNameSpace ENT where
hasNameSpace (Ent _ _ Value) = ValueName
hasNameSpace (Ent _ _ (ConstrOf _ _ )) = DataCon
hasNameSpace (Ent _ _ (FieldOf _ _ )) = ValueName
hasNameSpace (Ent _ _ (MethodOf _ _ _)) = ValueName
hasNameSpace (Ent _ _ (Class _ _)) = ClassName
hasNameSpace (Ent _ _ (Type _)) = TypeCon
hasNameSpace _ = Other
----------------------------------------------------------------------------------------------
-- |Create a new project
newProj args = do
newProject
addPaths True args
-- |Add new file to a project
addFile fileName
= addPaths False fileName
-- |Chase filenames
chase fileNames
= findMissing fileNames
-- |Compose ModuleName from String.
strToModName::String->ModuleName
strToModName name = if name =="Main" then MainModule "Main.hs" -- THIS IS BASED ON ASSUMPTION.
else PlainModule name
-- |From ModuleName to string.
modNameToStr::ModuleName->String
modNameToStr (PlainModule name) = name
modNameToStr (MainModule _) = "Main"
-- | From file name to module name.
--fileNameToModName::( )=>String->PFE0MT n i ds ext m ModuleName
fileNameToModName::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>
String->PFE0MT n i ds ext m ModuleName
fileNameToModName fileName =
do gf <- getCurrentModuleGraph
let fileAndMods = [(m,f)|(f,(m,ms))<-gf]
f = filter (\(m,f) -> f==fileName) fileAndMods
if f ==[] then error $ "Can't find module name"
else return $ (fst.head) f
-- | Return the client module and file names. The client modules of module, say m, are those modules
-- which import m directly or indirectly.
-- clientModsAndFiles::( ) =>ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]
clientModsAndFiles::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>
ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]
clientModsAndFiles m =
do gf <- getCurrentModuleGraph
let fileAndMods = [(m,f)|(f,(m,ms))<-gf]
g = (reverseGraph.(map snd)) gf
clientMods = reachable g [m] \\ [m]
clients = concatMap (\m'->[(m,f)|(m,f)<-fileAndMods, m==m']) clientMods
return clients
-- | Return the server module and file names. The server modules of module, say m, are those modules
-- which are directly or indirectly imported by module m.
--serverModsAndFiles::( )=>ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]
serverModsAndFiles::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>
ModuleName->PFE0MT n i ds ext m [(ModuleName, String)]
serverModsAndFiles m =
do gf <- getCurrentModuleGraph
let fileAndMods = [(m,f)|(f,(m,ms))<-gf]
g = (map snd) gf
serverMods = reachable g [m] \\ [m]
servers = concatMap (\m'->[(m,f)|(m,f)<-fileAndMods, m==m']) serverMods
return servers
-- | Return True if the given module name exists in the project.
--isAnExistingMod::( ) =>ModuleName->PFE0MT n i ds ext m Bool
isAnExistingMod::(PFE0_IO err m,IOErr err,HasInfixDecls i ds,QualNames i m1 n, Read n,Show n)=>
ModuleName->PFE0MT n i ds ext m Bool
isAnExistingMod m
= do ms<-allModules
return (elem m ms)
{-Whenever an identifier is imported, the qualified name is imported, whereas the unqualified name
may or may not be imported. -}
-- | Return all the possible qualifiers for the identifier. The identifier is not inscope if the
-- result is an empty list.
hsQualifier::PNT -- ^ The identifier.
->InScopes -- ^ The in-scope relation.
->[ModuleName] -- ^ The result.
hsQualifier pnt@(PNT pname _ _ ) inScopeRel
= let r = filter ( \ ( name, nameSpace, modName, qual) -> pNtoName pname == name
&& hasModName pname == Just modName && hasNameSpace pnt == nameSpace
&& isJust qual) $ inScopeInfo inScopeRel
in map (\ (_,_,_,qual) -> fromJust qual ) r
hsQualifier2::PNT -- ^ The identifier.
->InScopes -- ^ The in-scope relation.
->[ModuleName] -- ^ The result.
hsQualifier2 pnt@(PNT pname _ _ ) inScopeRel
= let r = filter ( \ ( name, nameSpace, modName, qual) -> pNtoName pname == name && isJust qual) $ inScopeInfo inScopeRel
in map (\ (_,_,_,qual) -> fromJust qual ) r
isQuald :: [ModuleName] -> String -> Bool
isQuald [] _ = False
isQuald ((PlainModule s):xs) n
| s == n = True
| otherwise = isQuald xs n
isQuald (x:xs) n = isQuald xs n
-- |Process the inscope relation returned from the parsing and module analysis pass, and
-- return a list of four-element tuples. Each tuple contains an identifier name, the identifier's namespace
-- info, the identifier's defining module name and its qualifier name. The same identifier may have multiple
-- entries in the result because it may have different qualifiers. This makes it easier to decide whether the
-- identifier can be used unqualifiedly by just checking whether there is an entry for it with the qualifier field
-- being Nothing.
--
inScopeInfo::InScopes -- ^ The inscope relation .
->[(String, NameSpace, ModuleName, Maybe ModuleName)] -- ^ The result
inScopeInfo inScopeRel =nub $ map getEntInfo $ relToList inScopeRel
where
getEntInfo (qual, ent@(Ent modName ident _))
=(identToName ident, hasNameSpace ent, modName, getQualifier qual)
-- | Process the export relation returned from the parsing and module analysis pass, and
-- return a list of trhee-element tuples. Each tuple contains an identifier name, the
-- identifier's namespace info, and the identifier's define module.
exportInfo::Exports -- ^ The export relation.
-> [(String, NameSpace, ModuleName)] -- ^ The result
exportInfo exports = nub $ map getEntInfo exports
where
getEntInfo (_, ent@(Ent modName ident _))
=(identToName ident, hasNameSpace ent, modName)
-- | Return True if the identifier is inscope and can be used without a qualifier.
isInScopeAndUnqualified::String -- ^ The identifier name.
->InScopes -- ^ The inscope relation
->Bool -- ^ The result.
isInScopeAndUnqualified id inScopeRel
= isJust $ find (\ (x, _,_, qual) -> x == id && isNothing qual ) $ inScopeInfo inScopeRel
--Id is defined in two modules: HsNames.hs (type Id = String) and PosName.hs (type Id = SN HsNames.Id)
identToName (HsVar (SN i _)) = i
identToName (HsCon (SN i _)) = i
-- | Return True if the current module is exported either by default or by specifying the module name in the export.
modIsExported::HsModuleP -- ^ The AST of the module
->Bool -- ^ The result
modIsExported mod
= let exps = hsModExports mod
modName = hsModName mod
in if isNothing exps
then True
else isJust $ find (==(ModuleE modName)) (fromJust exps)
-- | Return True if the identifier is exported either implicitly or explicitly.
isExported::PNT -- ^ The identifier.
->Exports -- ^ The export relation.
->Bool -- ^ The result.
isExported pnt@(PNT pn t1 _) exps
= if isTopLevelPNT pnt
then case hasModName pn of
Just modName -> isJust (find (\(name, nameSpace, modName1) -> name == pNtoName pn
&& modName == modName1 && hasNameSpace pnt == nameSpace) $ exportInfo exps)
Nothing -> False
else False
-- | Return True if an identifier is explicitly exported by the module.
isExplicitlyExported::PName -- ^ The identifier
->HsModuleP -- ^ The AST of the module
->Bool -- ^ The result
isExplicitlyExported pn mod
= findEntity pn $ hsModExports mod
{-
causeNameClashInExports::String -- ^ The identifier name
->HsModuleP -- ^ The AST of the module
->Exports -- ^ The export relation of the module
->Bool -- ^ The result -}
-- Note that in the abstract representation of exps, there is no qualified entities.
causeNameClashInExports pn newName mod exps
= let modNames=nub (concatMap (\(x, Ent modName _ _)->if show x==show newName
then [modName]
else []) exps)
in (isExplicitlyExported pn mod) &&
( any (modIsUnQualifedImported mod) modNames
|| elem (let (SN modName1 _) =hsModName mod
in modName1) modNames)
where
modIsUnQualifedImported mod modName
=let imps =hsModImports mod
in isJust $ find (\(HsImportDecl _ (SN modName1 _) qualify _ h)->modName==modName1 && (not qualify)) imps
-------------------------------------------------------------------------------------------------
{-append an import declaration to the end of the import list in the module, this functions
modifies both the token stream and the AST
-}
-------------------------------------------------------------------------------------
addImportDecl mod@(HsModule _ _ _ imp decls) moduleName qualify alias hide idNames
= do ((toks, _),(v,v1)) <- get
let (toks1, toks2)
=if imps' /= []
then let (startLoc, endLoc) = startEndLocIncComments toks (last imps')
(toks1, toks2)= break (\t->tokenPos t==endLoc) toks
in (toks1 ++ [ghead "addImportDecl1" toks2], tail toks2)
else if decls /=[]
then let startLoc = fst $ startEndLocIncComments toks (ghead "addImportDecl1" decls)
(toks1, toks2) = break (\t ->tokenPos t==startLoc) toks
in (toks1, toks2)
else (toks,[])
before = if toks1/=[] && endsWithNewLn (glast "addImportDecl1" toks1) then "" else "\n"
after = if (toks2 /=[] && startsWithNewLn (ghead "addImportDecl1" toks2)) then "" else "\n"
colOffset = if imps'==[] && decls==[]
then 1
else getOffset toks
$ if imps'/=[] then fst $ startEndLoc toks (ghead "addImportDecl1" imps')
else fst $ startEndLoc toks (ghead "addImportDecl1" decls)
impToks =tokenise (Pos 0 v1 1) (colOffset-1) True
$ before++(render.ppi) impDecl++"\n" ++ after --- refactorer this
(impDecl', _) <- addLocInfo (impDecl,impToks)
let toks' = toks1++impToks++toks2
put ((toks',modified), ((tokenRow (glast "addImportDecl1" impToks) - 10,v1))) -- 10: step ; generalise this.
return (mod {hsModImports = imp ++ [impDecl']})
where
alias' = case alias of
Just m -> Just $ SN (PlainModule m) loc0
_ -> Nothing
impDecl = HsImportDecl loc0 (SN (PlainModule moduleName) loc0) qualify alias'
(if idNames==[] && hide==False
then Nothing
else (Just (hide, map nameToEnt idNames))) -- what about "Main"
imps' = imp \\ prelimps
nameToEnt name = Var (nameToPNT name)
---------------------------------------------------------------------------------------
-- | Adding a declaration to the declaration list of the given syntax phrase(so far only adding function\/pattern binding
-- has been tested). If the second argument is Nothing, then the declaration will be added to the beginning of the
-- declaration list, but after the data type declarations is there is any.
{-addDecl::( ) =>t -- ^ The AST.
-> Maybe PName -- ^ If this is Just, then the declaration will be added right after this identifier's definition.
->([HsDeclP], Maybe [PosToken]) -- ^ The declaration to be added, in both AST and Token stream format (optional).
->Bool -- ^ True means the declaration is a toplevel declaration.
->m t
-}
addDecl::((MonadState (([PosToken],Bool),(Int,Int)) m), StartEndLoc t, HsDecls t, Printable t)
=>t-> Maybe PName
->([HsDeclP], Maybe [PosToken])
->Bool
->m t
addDecl parent pn (decl, declToks) topLevel
= if isJust pn
then appendDecl parent (fromJust pn) (decl, declToks)
else if topLevel
then addTopLevelDecl (decl, declToks) parent
else addLocalDecl parent (decl,declToks)
where
{- Add a definition to the beginning of the definition declaration list, but after the data type declarations
if there is any. The definition will be pretty-printed if its token stream is not provided. -}
addTopLevelDecl (decl, declToks) parent
= do let decls = hsDecls parent
(decls1,decls2)=break (\x->isFunOrPatBind x || isTypeSig x) decls
((toks,_),(v1, v2))<-get
let loc1 = if decls2/=[] -- there are function/pattern binding decls.
then let ((startRow,_),_) = startEndLocIncComments toks (ghead "addTopLevelDecl" decls2)
in (startRow, 1)
else simpPos0 -- no function/pattern binding decls in the module.
(toks1, toks2) = if loc1==simpPos0 then (toks, [])
else break (\t->tokenPos t==loc1) toks
declStr = case declToks of
Just ts -> concatMap tokenCon ts ++"\n"
Nothing -> prettyprint decl++"\n\n"
colOffset = if decls ==[] then 1 else getOffset toks $ fst (getStartEndLoc toks (head decls))
newToks = tokenise (Pos 0 v1 1) colOffset True declStr
toks' = toks1 ++ newToks ++ toks2
put ((toks',modified),((tokenRow (glast "addTopLevelDecl" newToks) -10), v2))
-- (decl',_) <- addLocInfo (decl, newToks)
-- error "after"
return (replaceDecls parent (decls1++decl++decls2))
appendDecl parent pn (decl, declToks)
= do ((toks,_),(v1, v2))<-get
-- error (show parent ++ "----" ++ show pn ++ "-----" ++ show (decl, declToks))
let (startPos,endPos) = startEndLocIncFowComment toks (ghead "appendDecl1" after)
-- divide the toks into three parts.
(toks1, toks2, toks3) = splitToks' (startPos, endPos) toks
--get the toks defining pn
defToks = dropWhile (\t->tokenPos t /=startPos) toks2
offset = getOffset toks $ fst (getStartEndLoc toks (ghead "appendDecl2" decls))
declStr = case declToks of
Just ts -> concatMap tokenCon ts
Nothing -> prettyprint decl
newToks = tokenise (Pos 0 v1 1) offset True declStr
toks' = if endsWithNewLn (glast "appendDecl2" toks2)
then toks1++ toks2 ++ (newLnToken: newToks) ++ [newLnToken]++ compressPreNewLns toks3
else replaceToks toks startPos endPos (defToks++[newLnToken,newLnToken]++newToks) -- ++[newLnToken])
-- (decl',_) <- addLocInfo (decl, newToks)
put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))
return (replaceDecls parent (before ++ [ghead "appendDecl14" after]++decl++ tail after))
where
decls = hsDecls parent
(before,after) = break (defines pn) decls -- Need to handle the case that 'after' is empty?
splitToks' (startPos, endPos) toks
= let (ts1, ts2, ts3) = splitToks ( startPos, endPos) toks
(ts11, ts12) = break hasNewLn (reverse ts1)
in (reverse ts12, reverse ts11++ts2, ts3)
-- This function need to be tested.
addLocalDecl parent (newFun, newFunToks)
=do
((toks,_), (v1, v2))<-get
let (startPos@(_,startCol),endPos'@(endRow',_)) --endPos' does not include the following newline or comment.
=if localDecls==[] then startEndLocIncFowComment toks parent --The 'where' clause is empty
else startEndLocIncFowComment toks localDecls
toks1=gtail "addLocalDecl1" $ dropWhile (\t->tokenPos t/=endPos') toks
ts1=takeWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t) toks1
--nextTokPos is only used to test whether there is a 'In' or a nested comment.
nextToks = (dropWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t) toks1)
nextTokPos= case nextToks of
[] -> simpPos0
l -> (tokenPos.ghead "addLocalDecl:0") l
oldToks'=getToks (startPos,endPos') toks
needNewLn=if nextTokPos==simpPos0 --used to decide whether add a new line character before a introduced fun.
then if toks1==[] then (not.endsWithNewLn) (glast "addLocalDecl:1" oldToks')
else (not.endsWithNewLn) (last ts1)
else endRow'==fst nextTokPos || (not.endsWithNewLn) (glast "addLocalDecl:2" oldToks')
--endPos@(endRow,_)=if ts1==[] then endPos'
-- else tokenPos (last ts1)
offset = if localDecls == [] then getOffset toks startPos + 2 else getOffset toks startPos
newToks = tokenise (Pos 0 v1 1) offset True
$ if needNewLn then "\n"++newSource else newSource -- ++"\n"
toks'=replaceToks toks startPos endPos' (oldToks'++newToks) -- ++[newLnToken])
(newFun',_) <- addLocInfo (newFun, newToks) -- This function calles problems because of the lexer.
put ((toks',modified),((tokenRow (glast "addLocalDecl:3" newToks) -10), v2))
return (replaceDecls parent (hsDecls parent ++ newFun'))
where
localDecls = hsDecls parent
newSource = if localDecls == []
then "where\n"++ concatMap (\l-> " "++l++"\n") (lines newFun')
else newFun'
where
offset1 = case newFunToks of
Just ts -> lengthOfToks (takeWhile isWhiteSpace ts)
Nothing -> 0
newFun' = case newFunToks of
Just ts ->let offset = lengthOfToks (takeWhile isWhiteSpace ts)
in concatMap tokenCon (removeOffset offset ts)
Nothing -> prettyprint newFun
removeOffset offset toks
= let groupedToks = groupTokensByLine toks
in concatMap (doRmWhites offset) groupedToks
addTypeSigDecl parent pn (decl, declToks) topLevel
= if isJust pn
then appendDecl parent (fromJust pn) (decl, declToks)
else if topLevel
then addTopLevelDecl (decl, declToks) parent
else addLocalDecl parent (decl,declToks)
where
{- Add a definition to the beginning of the definition declaration list, but after the data type declarations
if there is any. The definition will be pretty-printed if its token stream is not provided. -}
addTopLevelDecl (decl, declToks) parent
= do let decls = hsDecls parent
(decls1,decls2)=break (\x->isFunOrPatBind x || isTypeSig x) decls
((toks,_),(v1, v2))<-get
-- error "blah"
let loc1 = if decls2/=[] -- there are function/pattern binding decls.
then let ((startRow,_),_) = startEndLocIncComments toks (ghead "addTopLevelDecl" decls2)
in (startRow, 1)
else simpPos0 -- no function/pattern binding decls in the module.
(toks1, toks2) = if loc1==simpPos0 then (toks, [])
else break (\t->tokenPos t==loc1) toks
declStr = case declToks of
Just ts -> concatMap tokenCon ts
Nothing -> prettyprint decl++"\n\n"
colOffset = if decls ==[] then 1 else getOffset toks $ fst (getStartEndLoc toks (head decls))
newToks = tokenise (Pos 0 v1 1) colOffset True declStr
toks' = toks1 ++ newToks ++ toks2
put ((toks',modified),((tokenRow (glast "addTopLevelDecl" newToks) -10), v2))
return (replaceDecls parent (decl ++ decls1 ++decls2))
appendDecl parent pn (decl, declToks)
= do ((toks,_),(v1, v2))<-get
-- error (show parent ++ "----" ++ show pn ++ "-----" ++ show (decl, declToks))
let (startPos,endPos) = startEndLocIncFowComment toks (ghead "appendDecl1" after)
-- divide the toks into three parts.
(toks1, toks2, toks3) = splitToks' (startPos, endPos) toks
--get the toks defining pn
defToks = dropWhile (\t->tokenPos t /=startPos) toks2
offset = getOffset toks $ fst (getStartEndLoc toks (ghead "appendDecl2" decls))
declStr = case declToks of
Just ts -> concatMap tokenCon ts
Nothing -> prettyprint decl
newToks = tokenise (Pos 0 v1 1) offset True declStr
toks' = if endsWithNewLn (glast "appendDecl2" toks2)
then toks1++ (newLnToken: newToks) ++ [newLnToken]++ toks2 ++ compressPreNewLns toks3
else replaceToks toks startPos endPos ((newToks ++ [newLnToken]) ++ defToks++[newLnToken,newLnToken])
-- error $ show newToks
-- (decl',_) <- addLocInfo (decl, newToks)
put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))
return (replaceDecls parent (decl ++ [ghead "appendDecl14" after]++ before ++ tail after))
where
decls = hsDecls parent
(before,after) = break (defines pn) decls -- Need to handle the case that 'after' is empty?
splitToks' (startPos, endPos) toks
= let (ts1, ts2, ts3) = splitToks ( startPos, endPos) toks
(ts11, ts12) = break hasNewLn (reverse ts1)
in (reverse ts12, reverse ts11++ts2, ts3)
-- This function need to be tested.
addLocalDecl parent (newFun, newFunToks)
=do
((toks,_), (v1, v2))<-get
let (startPos@(_,startCol),endPos'@(endRow',_)) --endPos' does not include the following newline or comment.
=if localDecls==[] then startEndLocIncFowComment toks parent --The 'where' clause is empty
else startEndLocIncFowComment toks localDecls
toks1=gtail "addLocalDecl1" $ dropWhile (\t->tokenPos t/=endPos') toks
ts1=takeWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t) toks1
--nextTokPos is only used to test whether there is a 'In' or a nested comment.
nextTokPos= case (dropWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t) toks1) of
[] -> simpPos0
l -> (tokenPos.ghead "addLocalFunInToks") l
needNewLn=if nextTokPos==simpPos0 --used to decide whether add a new line character before a introduced fun.
then if toks1==[] then True
else (not.endsWithNewLn) (last ts1)
else endRow'==fst nextTokPos
--endPos@(endRow,_)=if ts1==[] then endPos'
-- else tokenPos (last ts1)
offset = if localDecls == [] then getOffset toks startPos + 4 else getOffset toks startPos
newToks = tokenise (Pos 0 v1 1) offset True
$ if needNewLn then "\n"++newSource else newSource++"\n"
oldToks'=getToks (startPos,endPos') toks
toks'=replaceToks toks startPos endPos' (oldToks'++newToks)
-- error "blah 2"
(newFun',_) <- addLocInfo (newFun, newToks) -- This function calles problems because of the lexer.
put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))
return (replaceDecls parent (newFun' ++ hsDecls parent))
where
localDecls = hsDecls parent
newSource = if localDecls == []
then "where\n"++ concatMap (\l-> " "++l++"\n") (lines newFun')
else newFun'
where
newFun' = case newFunToks of
Just ts -> concatMap tokenCon ts
Nothing -> prettyprint newFun
addTypeDecl parent pn (decl, declToks) topLevel
= if isJust pn
then appendDecl parent (fromJust pn) (decl, declToks)
else if topLevel
then addTopLevelDecl (decl, declToks) parent
else addLocalDecl parent (decl,declToks)
where
{- Add a definition to the beginning of the definition declaration list, but after the data type declarations
if there is any. The definition will be pretty-printed if its token stream is not provided. -}
addTopLevelDecl (decl, declToks) parent
= do let decls = hsDecls parent
(decls1,decls2)=break (\x->isFunOrPatBind x || isTypeSig x) decls
((toks,_),(v1, v2))<-get
-- error "blah"
let loc1 = if decls2/=[] -- there are function/pattern binding decls.
then let ((startRow,_),_) = startEndLocIncComments toks (ghead "addTopLevelDecl" decls2)
in (startRow, 1)
else simpPos0 -- no function/pattern binding decls in the module.
(toks1, toks2) = if loc1==simpPos0 then (toks, [])
else break (\t->tokenPos t==loc1) toks
declStr = case declToks of
Just ts -> concatMap tokenCon ts
Nothing -> prettyprint decl++"\n\n"
colOffset = if decls ==[] then 1 else getOffset toks $ fst (getStartEndLoc toks (head decls))
newToks = tokenise (Pos 0 v1 1) colOffset True declStr
toks' = toks1 ++ newToks ++ toks2
put ((toks',modified),((tokenRow (glast "addTopLevelDecl" newToks) -10), v2))
return (replaceDecls parent (decls1++decl++decls2))
appendDecl parent pn (decl, declToks)
= do ((toks,_),(v1, v2))<-get
-- error (show parent ++ "----" ++ show pn ++ "-----" ++ show (decl, declToks))
let (startPos,endPos) = startEndLocIncFowComment toks (ghead "appendDecl1" after)
-- divide the toks into three parts.
(toks1, toks2, toks3) = splitToks' (startPos, endPos) toks
--get the toks defining pn
defToks = dropWhile (\t->tokenPos t /=startPos) toks2
offset = getOffset toks $ fst (getStartEndLoc toks (ghead "appendDecl2" decls))
declStr = case declToks of
Just ts -> concatMap tokenCon ts
Nothing -> prettyprint decl
newToks = tokenise (Pos 0 v1 1) offset True declStr
toks' = if endsWithNewLn (glast "appendDecl2" toks2)
then toks1++ toks2 ++ (newLnToken: newToks) ++ [newLnToken]++ compressPreNewLns toks3
else replaceToks toks startPos endPos (defToks++[newLnToken,newLnToken]++newToks)
-- (decl',_) <- addLocInfo (decl, newToks)
put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))
return (replaceDecls parent (before ++ [ghead "appendDecl14" after]++ decl++ tail after))
where
decls = hsDecls parent
(before,after) = break (defines pn) decls -- Need to handle the case that 'after' is empty?
splitToks' (startPos, endPos) toks
= let (ts1, ts2, ts3) = splitToks ( startPos, endPos) toks
(ts11, ts12) = break hasNewLn (reverse ts1)
in (reverse ts12, reverse ts11++ts2, ts3)
-- This function need to be tested.
addLocalDecl parent (newFun, newFunToks)
=do
((toks,_), (v1, v2))<-get
let (startPos@(_,startCol),endPos'@(endRow',_)) --endPos' does not include the following newline or comment.
=if localDecls==[] then startEndLocIncFowComment toks parent --The 'where' clause is empty
else startEndLocIncFowComment toks localDecls
toks1=gtail "addLocalDecl1" $ dropWhile (\t->tokenPos t/=endPos') toks
ts1=takeWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t) toks1
--nextTokPos is only used to test whether there is a 'In' or a nested comment.
nextTokPos= case (dropWhile (\t->isWhite t && ((not.isMultiLineComment) t) && (not.hasNewLn) t) toks1) of
[] -> simpPos0
l -> (tokenPos.ghead "addLocalFunInToks") l
needNewLn=if nextTokPos==simpPos0 --used to decide whether add a new line character before a introduced fun.
then if toks1==[] then True
else (not.endsWithNewLn) (last ts1)
else endRow'==fst nextTokPos
--endPos@(endRow,_)=if ts1==[] then endPos'
-- else tokenPos (last ts1)
offset1 = case newFunToks of
Just ts -> lengthOfToks (takeWhile isWhiteSpace ts)
Nothing -> 0
offset = if localDecls == [] then getOffset toks startPos + 2 -offset1 else getOffset toks startPos -offset1
newToks = tokenise (Pos 0 v1 1) offset True
$ if needNewLn then "\n"++newSource else newSource++"\n"
oldToks'=getToks (startPos,endPos') toks
toks'=replaceToks toks startPos endPos' (oldToks'++newToks)
-- error "blah 2"
(newFun',_) <- addLocInfo (newFun, newToks) -- This function calles problems because of the lexer.
put ((toks',modified),((tokenRow (glast "appendDecl2" newToks) -10), v2))
return (replaceDecls parent (hsDecls parent ++ newFun'))
where
localDecls = hsDecls parent
newSource = if localDecls == []
then "where\n"++ concatMap (\l-> " "++l++"\n") (lines newFun')
else newFun'
where
newFun' = case newFunToks of
Just ts -> concatMap tokenCon ts
Nothing -> prettyprint newFun
-- | Remove the type signature that defines the given identifier's type from the declaration list.
{-rmTypeSig::(MonadState (([PosToken],Bool),t1) m)
=> PName -- ^ The identifier whose type signature is to be removed.
->[HsDeclP] -- ^ The declaration list
->m [HsDeclP] -- ^ The result -}
rmTypeSig pn t = applyTP (full_tdTP (idTP `adhocTP` inDecls)) t
where
inDecls (decls::[HsDeclP])
| snd (break (definesTypeSig pn) decls) /=[]
= do ((toks,_), others) <- get
let (decls1,decls2)= break (definesTypeSig pn) decls
(toks',decls')=
let sig@(Dec (HsTypeSig loc is c tp))=ghead "rmTypeSig" decls2 -- as decls2/=[], no problem with head
(startPos,endPos)=getStartEndLoc toks sig
in if length is>1
then let newSig=(Dec (HsTypeSig loc (filter (\x-> (pNTtoPN x)/=pn) is) c tp))
pnt = ghead "rmTypeSig" (filter (\x-> pNTtoPN x == pn) is)
(startPos1, endPos1) = let (startPos1', endPos1') = getStartEndLoc toks pnt
in if fromJust (elemIndex pnt is) >0
then extendForwards toks startPos1' endPos1' isComma
else extendBackwards toks startPos1' endPos1' isComma
in (deleteToks toks startPos1 endPos1,(decls1++[newSig]++tail decls2))
else ((deleteToks toks startPos endPos),(decls1++tail decls2))
put ((toks',modified),others)
return decls'
inDecls x = return x
-- |Comment out the type signature that defines pn's type in the token stream and remove it from the AST.
commentOutTypeSig::(MonadState (([PosToken],Bool),t1) m)
=> PName -- ^ The identifier.
->[HsDeclP] -- ^ The deckaration list.
->m [HsDeclP] -- ^ The result.
commentOutTypeSig pn decls
=let (decls1,decls2)=break (definesTypeSig pn) decls
in if decls2/=[] then --There is a type signature for pn
do ((toks,_),others)<-get
let (toks',decls')=
let sig@(Dec (HsTypeSig loc is c tp))=ghead "rmTypeSig" decls2 -- as decls2/=[], no problem with head
in if length is>1 --This type signature also defines the type of variables other than pn
then let newSig=(Dec (HsTypeSig loc (filter (\x-> (pNTtoPN x)/=pn) is) c tp))
pnt = ghead "commentTypeSig" $ filter (\x->pNTtoPN x==pn) is
(startPos,(endPosR, endPosC)) = getStartEndLoc toks pnt
in ((commentToks (startPos, (endPosR, endPosC)) toks),(decls1++[newSig]++tail decls2))
else let (startPos,(endPosR, endPosC))=getStartEndLoc toks sig
in ((commentToks (startPos, (endPosR, endPosC)) toks),(decls1++tail decls2))
put ((toks',modified),others)
return decls'
else return decls
-- |Insert a term supplied as a string at the position supplied
insertTerm :: (HsDecls t, (MonadState (([PosToken], Bool), t1) m))
=> String -- ^ The comment.
-> PName -- ^ The definition to which we want to add the comment
-> t -- ^ The declaration list.
-> m t -- ^ The result.
insertTerm com pn t
= do
((toks,_),others)<-get
let (startPos,endPos) = startEndLocIncFowComment toks (ghead "insertComment" after)
let (toks', t') = ((insertTerms (startPos,endPos) toks com), t)
put ((toks', modified), others)
return t'
where
decls = hsDecls t
(before,after) = break (defines pn) decls
-- |Insert a comment supplied as a string at the position supplied
insertComment :: (HsDecls t, (MonadState (([PosToken], Bool), t1) m))
=> String -- ^ The comment.
-> PName -- ^ The definition to which we want to add the comment
-> t -- ^ The declaration list.
-> m t -- ^ The result.
insertComment com pn t
= do
((toks,_),others)<-get
let (startPos,endPos) = startEndLocIncFowComment toks (ghead "insertComment" after)
let (toks', t') = ((insertComments (startPos,endPos) toks com), t)
put ((toks', modified), others)
return t'
where
decls = hsDecls t
(before,after) = break (defines pn) decls
{- extractComment :: (HsDecls t, (MonadState (([PosToken], Bool), t1) m))
=> PName
-> t
-> m [PosToken] -}
extractComment pn t
= do
((toks, _), others) <- get
let (startPos, endPos) = startEndLocIncFowComment toks (ghead "extractComment" after)
let toks' = extractComments (startPos, endPos) toks
return toks'
where
decls = hsDecls t
(before, after) = break (defines pn) decls
-- | Remove the declaration (and the type signature is the second parameter is True) that defines the given identifier
-- from the declaration list.
{-
rmDecl::(MonadState (([PosToken],Bool),t1) m)
=>PName -- ^ The identifier whose definition is to be removed.
->Bool -- ^ True means including the type signature.
->[HsDeclP] -- ^ The declaration list.
-> m [HsDeclP]-- ^ The result.
-}
rmDecl pn incSig t = applyTP (once_tdTP (failTP `adhocTP` inDecls)) t
where
inDecls (decls::[HsDeclP])
| snd (break (defines pn) decls) /=[]
= do let (decls1, decls2) = break (defines pn) decls
decl = ghead "rmDecl" decls2
-- error $ (render.ppi) t -- ecl ++ (show decl)
case isTopLevelPN pn of
True -> if incSig then rmTopLevelDecl decl =<< rmTypeSig pn decls
else rmTopLevelDecl decl decls
False -> if incSig then rmLocalDecl decl =<< rmTypeSig pn decls
else rmLocalDecl decl decls
inDecls x = mzero
rmTopLevelDecl decl decls
=do ((toks,_),others)<-get
let (startLoc, endLoc)=startEndLocIncComments toks decl
toks'=deleteToks toks startLoc endLoc
put ((toks',modified),others)
return (decls \\ [decl])
{- The difference between removing a top level declaration and a local declaration is:
if the local declaration to be removed is the only declaration in current declaration list,
then the 'where'/ 'let'/'in' enclosing this declaration should also be removed.
Whereas, when a only top level decl is removed, the 'where' can not be removed.
-}
-- |Remove a location declaration that defines pn.
rmLocalDecl decl decls
=do ((toks,_),others)<-get
let (startPos,endPos)=getStartEndLoc toks decl --startEndLoc toks decl
(startPos',endPos')=startEndLocIncComments toks decl
--(startPos',endPos')=startEndLocIncFowComment toks decl
toks'=if length decls==1 --only one decl, which means the accompaning 'where',
--'let' or'in' should be removed too.
then let (toks1,toks2)=break (\t->tokenPos t==startPos) toks --devide the token stream.
--get the 'where' or 'let' token
rvToks1=dropWhile (not.isWhereOrLet) (reverse toks1)
--There must be a 'where' or 'let', so rvToks1 can not be empty.
whereOrLet=ghead "rmLocalFunPatBind:whereOrLet" rvToks1
--drop the 'where' 'or 'let' token
toks1'=takeWhile (\t->tokenPos t/=tokenPos whereOrLet) toks1
--remove the declaration from the token stream.
toks2'=gtail "rmLocalDecl" $ dropWhile (\t->tokenPos t/=endPos') toks2
--get the remained tokens after the removed declaration.
remainedToks=dropWhile isWhite toks2'
in if remainedToks==[]
then --the removed declaration is the last decl in the file.
(compressEndNewLns toks1'++ compressPreNewLns toks2')
else if --remainedToks/=[], so no problem with head.
isIn (ghead "rmLocalDecl:isIn" remainedToks)
|| isComma (ghead "rmLocalDecl:isComma" remainedToks)
--There is a 'In' after the removed declaration.
then if isWhere whereOrLet
then deleteToks toks (tokenPos whereOrLet) endPos'
else deleteToks toks (tokenPos whereOrLet)
$ tokenPos (ghead "rmLocalDecl:tokenPos" remainedToks)
--delete the decl and adjust the layout
else if isCloseSquareBracket (ghead "rmLocalDecl:isCloseSquareBracker" remainedToks) &&
(isBar.(ghead "rmLocalDecl:isBar")) (dropWhile isWhite (tail rvToks1))
then deleteToks toks (tokenPos((ghead "rmLocalDecl")
(dropWhile isWhite (tail rvToks1)))) endPos'
else deleteToks toks (tokenPos whereOrLet) endPos'
--there are more than one decls
else deleteToks toks startPos' endPos'
put ((toks',modified),others) --Change the above endPos' to endPos will not delete the following comments.
return $ (decls \\ [decl])
{- ********* IMPORTANT : THIS FUNCTION SHOULD BE UPDATED TO THE NEW TOKEN STREAM METHOD ****** -}
-- | Duplicate a functon\/pattern binding declaration under a new name right after the original one.
duplicateDecl::(MonadState (([PosToken],Bool),t1) m)
=>[HsDeclP] -- ^ The declaration list
->PName -- ^ The identifier whose definition is going to be duplicated
->String -- ^ The new name
->m [HsDeclP] -- ^ The result
{-there maybe fun/simple pattern binding and type signature in the duplicated decls
function binding, and type signature are handled differently here: the comment and layout
in function binding are preserved.The type signature is output ted by pretty printer, so
the comments and layout are NOT preserved.
-}
duplicateDecl decls pn newFunName
= do ((toks,_), others)<-get
let (startPos, endPos) =startEndLocIncComments toks funBinding
{-take those tokens before (and include) the function binding and its following
white tokens before the 'new line' token. (some times the function may be followed by
comments) -}
toks1 = let (ts1, ts2) =break (\t->tokenPos t==endPos) toks in ts1++[ghead "duplicateDecl" ts2]
--take those token after (and include) the function binding
toks2 = dropWhile (\t->tokenPos t/=startPos || isNewLn t) toks
put((toks2,modified), others)
--rename the function name to the new name, and update token stream as well
funBinding'<-renamePN pn Nothing newFunName True funBinding
--rename function name in type signature without adjusting the token stream
typeSig' <- renamePN pn Nothing newFunName False typeSig
((toks2,_), others)<-get
let offset = getOffset toks (fst (startEndLoc toks funBinding))
newLineTok = if toks1/=[] && endsWithNewLn (glast "doDuplicating" toks1)
then [newLnToken]
else [newLnToken,newLnToken]
toks'= if typeSig/=[]
then let offset = tokenCol ((ghead "doDuplicating") (dropWhile (\t->isWhite t) toks2))
sigSource = concatMap (\s->replicate (offset-1) ' '++s++"\n")((lines.render.ppi) typeSig')
t = mkToken Whitespace (0,0) sigSource
in (toks1++newLineTok++[t]++(whiteSpacesToken (0,0) (snd startPos-1))++toks2)
else (toks1++newLineTok++(whiteSpacesToken (0,0) (snd startPos-1))++toks2)
put ((toks',modified),others)
return (typeSig'++funBinding')
where
declsToDup = definingDecls [pn] decls True False
funBinding = filter isFunOrPatBind declsToDup --get the fun binding.
typeSig = filter isTypeSig declsToDup --get the type signature.
------------------------------------------------------------------------------
-- | Add identifiers to the export list of a module. If the second argument is like: Just p, then do the adding only if p occurs
-- in the export list, and the new identifiers are added right after p in the export list. Otherwise the new identifiers are add
-- to the beginning of the export list. In the case that the export list is emport, then if the third argument is True, then create
-- an explict export list to contain only the new identifiers, otherwise do nothing.
{-
addItemsToExport::( )
=> HsModuleP -- The module AST.
-> Maybe PName -- The condtion identifier.
-> Bool -- Create an explicit list or not
-> Either [String] [HsExportEntP] -- The identifiers to add in either String or HsExportEntP format.
-> m HsModuleP -- The result.
-}
addItemsToExport::(MonadState (([PosToken],Bool), t1) m)
=> HsModuleP -- The module AST.
-> Maybe PName -- The condtion identifier.
-> Bool -- Create an explicit list or not
-> Either [String] [HsExportEntP] -- The identifiers to add in either String or HsExportEntP format.
-> m HsModuleP -- The result.
addItemsToExport mod _ _ (Left []) = return mod
addItemsToExport mod _ _ (Right []) = return mod
addItemsToExport mod@(HsModule loc modName exps imps ds) (Just pn) _ ids
= case exps of
Just ents ->let (e1,e2) = break (findEntity pn) ents
in if e2 /=[]
then do ((toks,_),others)<-get
let e = (ghead "addVarItemInExport" e2)
es = case ids of
(Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'
(Right es') -> es'
let (_,endPos) = getStartEndLoc toks e
(t, (_,s)) = ghead "addVarItemInExport" $ getToks (endPos,endPos) toks
newToken = mkToken t endPos (s++","++ showEntities (render.ppi) es)
toks' = replaceToks toks endPos endPos [newToken]
put ((toks',modified),others)
return (HsModule loc modName (Just (e1++(e:es)++tail e2)) imps ds)
else return mod
Nothing -> return mod
addItemsToExport mod@(HsModule _ _ (Just ents) _ _) Nothing createExp ids
= do ((toks,_),others)<-get
let es = case ids of
(Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'
(Right es') -> es'
(t, (pos,s))=fromJust $ find isOpenBracket toks -- s is the '('
newToken = if ents /=[] then (t, (pos,(s++showEntities (render.ppi) es++",")))
else (t, (pos,(s++showEntities (render.ppi) es)))
pos'= simpPos pos
toks' = replaceToks toks pos' pos' [newToken]
put ((toks',modified),others)
return mod {hsModExports=Just (es++ ents)}
addItemsToExport mod@(HsModule _ (SN modName (SrcLoc _ c row col)) Nothing _ _) Nothing createExp ids
=case createExp of
True ->do ((toks,_),others)<-get
let es = case ids of
(Left is' ) ->map (\x-> (EntE (Var (nameToPNT x)))) is'
(Right es') -> es'
pos = (row,col)
newToken = mkToken Varid pos (modNameToStr modName++ "("
++ showEntities (render.ppi) es++")")
toks' = replaceToks toks pos pos [newToken]
put ((toks', modified), others)
return mod {hsModExports=Just es}
False ->return mod
-- | Add identifiers (given by the third argument) to the explicit entity list in the declaration importing the
-- specified module name. The second argument serves as a condition: if it is like : Just p, then do the adding
-- the if only 'p' occurs in the entity list; if it is Nothing, then do the adding as normal. This function
-- does nothing if the import declaration does not have an explicit entity list.
{-
addItemsToImport::( )
=>ModuleName -- ^ The imported module name.
->Maybe PName -- ^ The condition identifier.
->Either [String] [EntSpecP] -- ^ The identifiers to add in either String or EntSpecP format.
->t -- ^ The given syntax phrase.
->m t -- ^ The result.
-}
addItemsToImport::(Term t,MonadState (([PosToken],Bool),t1) m)
=>ModuleName -- ^ The imported module name.
->Maybe PName -- ^ The condition identifier.
->Either [String] [EntSpecP] -- ^ The identifiers to add in either String or EntSpecP format.
->t -- ^ The given syntax phrase.
->m t -- ^ The result.
addItemsToImport serverModName pn (Left []) t = return t
addItemsToImport serverModName pn (Right []) t = return t
addItemsToImport serverModName pn ids t
=applyTP (full_buTP (idTP `adhocTP` inImport)) t
where
inImport (imp@(HsImportDecl loc m@(SN modName _) qual as h):: HsImportDeclP)
| serverModName == modName && (if isJust pn then findPN (fromJust pn) h else True)
= case h of
Nothing -> return imp
Just (b, ents) -> do let ents'=case ids of
Left is' -> map (\x-> Var (nameToPNT x)) is'
Right es -> es
((toks,_),others)<-get
let (_,endPos)=getStartEndLoc toks (glast "addItemsToImport" ents)
(t,(_,s))=ghead "addItemsToImport" $ getToks (endPos,endPos) toks
newToken = mkToken t endPos (s++","++showEntities (render.ppi) ents')
toks'=replaceToks toks endPos endPos [newToken]
put ((toks',modified),others)
return (HsImportDecl loc m qual as (Just (b, ents++ents')))
inImport imp = return imp
-- | add items to the hiding list of an import declaration which imports the specified module.
addHiding::(MonadState (([PosToken],Bool),t1) m)
=>ModuleName -- ^ The imported module name
->HsModuleP -- ^ The current module
->[PName] -- ^ The items to be added
->m HsModuleP -- ^ The result
addHiding serverModName mod pns
= applyTP (full_tdTP (idTP `adhocTP` inImport)) mod
where
inImport (imp@(HsImportDecl loc (SN modName _) qual as h)::HsImportDeclP)
| serverModName == modName && not qual
= case h of
Nothing ->do ((toks,_),others)<-get
let (_,endPos)=getStartEndLoc toks imp
(t,(_,s)) = ghead "addHiding" $ getToks (endPos,endPos) toks
newToken=mkToken t endPos (s++" hiding ("++showEntities pNtoName pns++")")
toks'=replaceToks toks endPos endPos [newToken]
put ((toks',modified),others)
return (replaceHiding imp (Just (True, map mkNewEnt pns )))
Just (True, ents) ->do ((toks,_),others)<-get
let (_,endPos)=getStartEndLoc toks imp
(t, (_,s))=ghead "addHiding" $ getToks (endPos,endPos) toks
newToken=mkToken t endPos (","++showEntities pNtoName pns ++s)
toks'=replaceToks toks endPos endPos [newToken]
put ((toks',modified),others)
return (replaceHiding imp (Just (True, (map mkNewEnt pns)++ents)))
Just (False, ent) -> return imp
inImport x = return x
mkNewEnt pn = (Var (PNT pn Value (N (Just loc0))))
replaceHiding (HsImportDecl loc modName qual as h) h1 = HsImportDecl loc modName qual as h1
-- | Remove those specified items from the entity list in the import declaration.
{-
rmItemsFromImport::( )
=>HsModuleP -- ^ The module AST
->[PName] -- ^ The items to be removed
->m HsModuleP -- ^ The result
-}
rmItemsFromImport::(MonadState (([PosToken],Bool),t1) m)
=>HsModuleP -- ^ The module AST
->[PName] -- ^ The items to be removed
->m HsModuleP -- ^ The result
rmItemsFromImport mod pns
= applyTP (full_buTP (idTP `adhocTP` inImport)) mod
where
inImport (imp@(HsImportDecl loc modName qual as h)::HsImportDeclP)
| any (flip findEntity imp) pns
= case h of
Just (b, ents) ->
do let matchedEnts=findEnts pns ents
if matchedEnts==[]
then return imp
else if length matchedEnts == length ents
then do ((toks,_),others)<-get
let (startPos,endPos)=getStartEndLoc toks ents
toks'=deleteToks toks startPos endPos
put ((toks',modified),others)
return (HsImportDecl loc modName qual as (Just (b,[])))
else do ((toks,_),others)<-get
let remainedEnts=concatMap (\pn->filter (not.match pn) ents) pns
toks'=foldl deleteEnt toks $ map (getStartEndLoc toks) matchedEnts
put ((toks',modified),others)
return (HsImportDecl loc modName qual as (Just (b, remainedEnts)))
_ ->return imp
inImport x = return x
findEnts pns ents =nub $ concatMap (\pn->filter (match pn) ents) pns
-- this function does not check this sub entities of the ListSubs. any problems?
match::PName -> EntSpec PNT ->Bool
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
-- | Remove the sub entities of a type constructor or class from the export list.
rmSubEntsFromExport::(MonadState (([PosToken],Bool),(Int,Int)) m)
=>PName -- ^ The type constructor or class name
->HsModuleP -- ^ The module AST
->m HsModuleP -- ^ The result
rmSubEntsFromExport typeCon
= applyTP (full_buTP (idTP `adhocTP` inEntSpec))
where
inEntSpec (ent@(AllSubs pnt)::EntSpec PNT)
| pNTtoPN pnt == typeCon
=do (ent', _)<-updateToks ent (Abs pnt) prettyprint
return ent'
inEntSpec (ent@(ListSubs pnt _))
| pNTtoPN pnt == typeCon
= do (ent', _) <- updateToks ent (Abs pnt) prettyprint
return ent'
inEntSpec ent = return ent
---------------------------------------------------------------------------------------
-- | Remove the specified entities from the module's exports. The entities can be specified in either of two formats:
-- i.e. either specify the module names and identifier names to be removed, so just given the exact AST for these entities.
{-rmItemsFromExport::( )
=>HsModuleP -- ^ The module AST.
->Either ([ModuleName],[PName]) [HsExportEntP] -- ^ The entities to remove.
->m HsModuleP -- ^ The result.
-}
rmItemsFromExport::(MonadState (([PosToken],Bool),t1) m)
=>HsModuleP -- ^ The module AST.
->Either ([ModuleName],[PName]) [HsExportEntP] -- ^ The entities to remove.
->m HsModuleP -- ^ The result.
rmItemsFromExport mod@(HsModule loc modName exps imps ds) (Left (modNames, pns))
=if isNothing exps
then return mod
else do let ents =findEnts (modNames, pns) (fromJust exps)
rmItemsFromExport mod (Right ents)
where
findEnts (modNames, pns) ents
=let ms = concatMap (\m ->filter (\e -> case e of
ModuleE (SN m' _) -> m==m'
EntE e' -> False) ents) modNames
es =concatMap (\pn->filter (\e ->case e of
ModuleE _ -> False
EntE e' -> match pn e') ents) pns
in (ms++es)
match::PName -> EntSpec PNT ->Bool
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
rmItemsFromExport mod@(HsModule loc modName exps@(Just es) imps ds) (Right ents)
= do exps'<- if ents==[]
then return exps
else if length ents == length es
then do ((toks,_),others)<-get
let (startPos,endPos) = getStartEndLoc toks ents
toks'= deleteToks toks startPos endPos
put ((toks',modified),others)
return (Just [] ) -- should not remove the empty bracket!!!
else do ((toks,_),others)<-get
let toks' = foldl deleteEnt toks $ map (getStartEndLoc toks) ents
put ((toks',modified),others)
return (Just (es \\ ents))
return (HsModule loc modName exps' imps ds)
rmItemsFromExport mod _ = return mod
--This function is only used by this module, and should not be exported.
deleteEnt toks (startPos, endPos)
= let (toks1,toks2)=break (\t->tokenPos t==startPos) toks
previousTok=ghead "deleteEnt" $ dropWhile isWhiteSpace $ reverse toks1
toks' = dropWhile isWhiteSpace $ gtail "deleteEnts" $ dropWhile (\t->tokenPos t/=endPos) toks2
nextTok = ghead "deleteEnt" toks'
startPos'=if isComma previousTok && (not (isComma nextTok)) then tokenPos previousTok else startPos
in if isComma nextTok
then let remainedToks = tail toks'
in if remainedToks /= []
then let whites = takeWhile isWhiteSpace remainedToks
in if whites /= [] then deleteToks toks startPos' (tokenPos (last whites))
else deleteToks toks startPos' (tokenPos nextTok)
else deleteToks toks startPos' (tokenPos nextTok)
else deleteToks toks startPos' endPos
--------------------------------TRY TO REMOVE THIS FUNCTION------------------------------
{-
moveDecl::(CanHaveWhereClause t,DeclStartLoc t, Term t,Printable t,MonadPlus m,
MonadState (([PosToken],Bool),(Int, Int)) m)
=> [PName] -- ^ The identifier(s) whose defining declaration is to be moved. List is used to handle pattern bindings where multiple identifiers are defined.
-> t -- ^ The syntax phrase where the declaration is going to be moved to.
-> Bool -- ^ True mean the function\/pattern binding being moved is going to be at the same level with t. Otherwise it will be a local declaration of t.
-> [HsDeclP] -- ^ The declaration list where the definition\/pattern binding originally exists.
-> Bool -- ^ True means the type signature will not be discarded.
-> m t -- ^ The result.
-}
moveDecl pns dest sameLevel decls incSig
= do ((ts,_),_)<-get
let defToks' =(getDeclToks (ghead "moveDecl:0" pns) True decls ts)
defToks =whiteSpaceTokens (tokenRow (ghead "moveDecl" defToks'),0)
-- do not use tokenCol here. should count the whilte spaces.
(tokenCol (ghead "moveDecl2" defToks') -1) ++ defToks'
movedDecls = definingDecls pns decls True False
decls'<-rmDecl (ghead "moveDecl3" pns) False =<FilePath
->m (InScopes,Exports,HsModuleP,[PosToken])
-}
parseSourceFileOld filename
= (checkScope @@ parseSourceFile') filename
where
checkScope (ts,(((wm,_),mod),refs))
= check (checkRefs refs) >> return (inscpRel wm, exports wm, mod, expandNewLnTokens ts)
check [] = done
check errs = fail $ pp $ "Scoping errors" $$ vcat errs
parseSourceFile filename
= do
name <- fileNameToModName filename
res <- ((checkScope @@ parseModule') name)
return res
where
checkScope (ts,(((wm,_),mod),refs))
= check (checkRefs refs) >> return (inscpRel wm, exports wm, mod, expandNewLnTokens ts)
check [] = done
check errs = fail $ pp $ "Scoping errors" $$ vcat errs
parsePrelude
= do
name <- fileNameToModName (release_root ++ "/tools/base/tests/HaskellLibraries/Prelude.hs")
res <- ((checkScope @@ parseModule') name)
return res
where
checkScope (ts,(((wm,_),mod),refs))
= check (checkRefs refs) >> return (inscpRel wm, exports wm, mod, expandNewLnTokens ts)
check [] = done
check errs = fail $ pp $ "Scoping errors" $$ vcat errs
{- removed CMB MAY 2010, migrated to HINT library, sessions now redundant. -}
{- parseSourceFile2 filename modName
= (checkScope @@ parseSourceFile') filename
where
checkScope (ts,(((wm,_),mod),refs))
= check (checkRefs refs) >> return (inscpRel wm, exports wm, mod, expandNewLnTokens ts, ghcTypeCheck filename modName)
check [] = done
check errs = fail $ pp $ "Scoping errors" $$ vcat errs -}
--preprocssing the token stream to expand the white spaces to individual tokens.
expandNewLnTokens::[PosToken]->[PosToken]
expandNewLnTokens ts = concatMap expand ts
where
expand tok@(Whitespace,(pos,s)) = doExpanding pos s
expand x = [x]
doExpanding pos [] =[]
doExpanding pos@(Pos c row col) (t:ts)
= case t of
'\n' -> (Whitespace, (pos,[t])):(doExpanding (Pos c (row+1) 1) ts)
_ -> (Whitespace, (pos,[t])):(doExpanding (Pos c row (col+1)) ts)
------------------------------------------------------------------------------------------------
-- | Write refactored program source to files.
{-
writeRefactoredFiles::Bool -- ^ True means the current refactoring is a sub-refactoring
->[((String,Bool),([PosToken],HsModuleP))] -- ^ String: the file name; Bool: True means the file has been modified.[PosToken]: the token stream; HsModuleP: the module AST.
-> m ()
-}
writeRefactoredFiles (isSubRefactor::Bool) (files::[((String,Bool),([PosToken], HsModuleP))])
= do let modifiedFiles = filter (\((f,m),_)->m==modified) files
addToHistory isSubRefactor $ map (fst.fst) modifiedFiles
mapM_ modifyFile modifiedFiles
-- mapM_ writeTestDataForFile files -- This should be removed for the release version.
{- -- the 'writeTestDataForFile' causes a 'stack overflow' problem, when applying refactorings to
-- large-scale programs,and the possible reason might be lazy evaluation and the huge size of AST.
-}
where
modifyFile ((fileName,_),(ts,mod)) = do
--let source =(render.ppi) mod
let source = concatMap (snd.snd) ts
seq (length source) $ writeHaskellFile fileName source
editorCmds <-getEditorCmds
MT.lift $ sendEditorModified editorCmds fileName
writeTestDataForFile ((fileName,_),(ts,mod)) = do
let source=concatMap (snd.snd) ts
seq (length source) $ writeFile (createNewFileName "_TokOut" fileName) source
writeHaskellFile (createNewFileName "AST" fileName) ((render.ppi.rmPrelude) mod)
createNewFileName str fileName
=let (name, posfix)=span (/='.') fileName
in (name++str++posfix)
---------------------------------------------------------------------------------------
-----Remove the 'Prelude' imports added by Programatica------------------------------
rmPrelude::HsModuleP->HsModuleP
rmPrelude (HsModule s m e is ds) = HsModule s m e (is \\ prelimps) ds
prelimps = [HsImportDecl loc0 (SN (PlainModule "Prelude") loc0) True Nothing Nothing,
HsImportDecl loc0 (SN (PlainModule "Prelude") loc0) False Nothing Nothing]
-- | Return True if a string is a lexically valid variable name.
isVarId::String->Bool
isVarId id =isId id && isSmall (ghead "isVarId" id)
where isSmall c=isLower c || c=='_'
-- | Return True if a string is a lexically valid constructor name.
isConId::String->Bool
isConId id =isId id && isUpper (ghead "isConId" id)
-- | Return True if a string is a lexically valid operator name.
isOperator::String->Bool
isOperator id = id /= [] && isOpSym (ghead "isOperator" id) &&
isLegalOpTail (tail id) && not (isReservedOp id)
where
isOpSym id = elem id opSymbols
where opSymbols = ['!', '#', '$', '%', '&', '*', '+','.','/','<','=','>','?','@','\'','^','|','-','~']
isLegalOpTail tail = all isLegal tail
where isLegal c = isOpSym c || c==':'
isReservedOp id = elem id reservedOps
where reservedOps = ["..", ":","::","=","\"", "|","<-","@","~","=>"]
{-Returns True if a string lexically is an identifier. *This function should not be exported.*
-}
isId::String->Bool
isId id = id/=[] && isLegalIdTail (tail id) && not (isReservedId id)
where
isLegalIdTail tail=all isLegal tail
where isLegal c=isSmall c|| isUpper c || isDigit c || c=='\''
isReservedId id=elem id reservedIds
where reservedIds=["case", "class", "data", "default", "deriving","do","else" ,"if",
"import", "in", "infix","infixl","infixr","instance","let","module",
"newtype", "of","then","type","where","_"]
isSmall c=isLower c || c=='_'
-----------------------------------------------------------------------------
-- |Return True if a PName is a toplevel PName.
isTopLevelPN::PName->Bool
isTopLevelPN (PN i (G _ _ _))=True
isTopLevelPN _ =False
-- |Return True if a PName is a local PName.
isLocalPN::PName->Bool
isLocalPN (PN i (S _))=True
isLocalPN _ =False
-- |Return True if a PName is a qualified PName.
isQualifiedPN::PName->Bool
isQualifiedPN (PN (Qual mod id) _)=True
isQualifiedPN _ =False
-- |Return True if an PNT is a toplevel PNT.
isTopLevelPNT::PNT->Bool
isTopLevelPNT = isTopLevelPN.pNTtoPN
isLocalPNT :: PNT -> Bool
isLocalPNT = isLocalPN.pNTtoPN
-- |Return True if a PName is a function\/pattern name defined in t.
isFunOrPatName::(Term t)=>PName->t->Bool
isFunOrPatName pn
=isJust.(applyTU (once_tdTU (failTU `adhocTU` worker)))
where
worker (decl::HsDeclP)
| defines pn decl=Just True
worker _ =Nothing
-- |Return True if a PNT is a function name defined in t.
isFunPNT::(Term t)=>PNT -> t -> Bool
isFunPNT pnt t = isFunName (pNTtoPN pnt) t
isFunName::(Term t)=>PName->t->Bool
isFunName pn
=isJust.(applyTU (once_tdTU (failTU `adhocTU` worker)))
where
worker (decl::HsDeclP)
| isFunBind decl && defines pn decl =Just True
worker _ =Nothing
-- |Return True if a PName is a pattern name defined in t.
isPatName::(Term t)=>PName->t->Bool
isPatName pn
=isJust.(applyTU (once_tdTU (failTU `adhocTU` worker)))
where
worker (decl::HsDeclP)
| isPatBind decl && defines pn decl =Just True
worker _ =Nothing
-------------------------------------------------------------------------------
-- | Return True if a PNT is a type constructor.
isTypeCon :: PNT -> Bool
isTypeCon (PNT pn (Type typeInfo) _) = defType typeInfo == Just Data
isTypeCon _ = False
-- | Return True if PNT is a data type constructor.
isDataCon :: PNT -> Bool
isDataCon (PNT pn (ConstrOf _ typeInfo) _) = defType typeInfo == Just Data
isDataCon _ = False
-- | Return True if a declaration is a type signature declaration.
isTypeSig ::HsDeclP->Bool
isTypeSig (Dec (HsTypeSig loc is c tp))=True
isTypeSig _=False
-- | Return True if a declaration is a function definition.
isFunBind::HsDeclP->Bool
isFunBind (Dec (HsFunBind loc matches))=True
isFunBind _ =False
-- | Returns True if a declaration is a pattern binding.
isPatBind::HsDeclP->Bool
isPatBind (Dec (HsPatBind _ _ _ _))=True
isPatBind _=False
-- | Return True if a declaration is a pattern binding which only defines a variable value.
isSimplePatBind::HsDeclP->Bool
isSimplePatBind decl=case decl of
Dec (HsPatBind _ p _ _)->patToPN p /=defaultPN
_ ->False
-- | Return True if a declaration is a pattern binding but not a simple one.
isComplexPatBind::HsDeclP->Bool
isComplexPatBind decl=case decl of
Dec (HsPatBind _ p _ _)->patToPN p ==defaultPN
_ -> False
-- | Return True if a declaration is a function\/pattern definition.
isFunOrPatBind::HsDeclP->Bool
isFunOrPatBind decl=isFunBind decl || isPatBind decl
-- | Return True if a declaration is a Class declaration.
isClassDecl :: HsDeclP ->Bool
isClassDecl (Dec (HsClassDecl _ _ _ _ _)) = True
isClassDecl _ = False
-- | Return True if a declaration is a Class instance declaration.
isInstDecl :: HsDeclP -> Bool
isInstDecl (Dec (HsInstDecl _ _ _ _ _)) = True
isInstDecl _ = False
-- | Return True if a function is a directly recursive function.
isDirectRecursiveDef::HsDeclP->Bool
isDirectRecursiveDef (Dec (HsFunBind loc ms))
= any isUsedInDef ms
where
isUsedInDef (HsMatch loc1 fun pats rhs ds)
= findEntity (pNTtoPN fun) rhs
isDirectRecursiveDef _ = False
------------------------------------------------------------------------------------------------
-- | Add a qualifier to an identifier if it is not qualified.
qualifyPName::ModuleName -- ^ The qualifier.
->PName -- ^ The identifier.
->PName -- ^ The result.
qualifyPName qual pn
= case pn of
PN (UnQual n) ty -> PN (Qual qual n ) ty
_ -> pn
-- | Remove the qualifier from the given identifiers in the given syntax phrase.
rmQualifier::((MonadState (([PosToken], Bool), t1) m),Term t)
=>[PName] -- ^ The identifiers.
->t -- ^ The syntax phrase.
->m t -- ^ The result.
rmQualifier pns t
= applyTP (full_tdTP (adhocTP idTP rename )) t
where
rename pnt@(PNT pn@(PN (Qual modName s) l) ty loc@(N (Just (SrcLoc fileName _ row col))))
| elem pn pns
= do do ((toks,_), others)<-get
let toks' =replaceToks toks (row,col) (row,col) [mkToken Varid (row,col) s]
put ((toks', modified), others)
return (PNT (PN (UnQual s) l) ty loc)
rename x = return x
-- | Show a list of entities, the parameter f is a function that specifies how to format an entity.
showEntities::(Eq t, Term t)=>(t->String)->[t]->String
showEntities f [] = ""
showEntities f [pn] = f pn
showEntities f (pn:pns) =f pn ++ "," ++ showEntities f pns
-- | Show a PName in a format like: 'pn'(at row:r, col: c).
showPNwithLoc::PName->String
showPNwithLoc pn
= let (SrcLoc _ _ r c)=srcLoc pn
in " '"++pNtoName pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")"
----------------------------------------------------------------------------------
-- | Default identifier in the PName format.
defaultPN::PName
defaultPN=PN (UnQual "unknown") (G (PlainModule "unknown") "--" (N Nothing)) :: PName
-- | Default identifier in the PNT format.
defaultPNT::PNT
defaultPNT=PNT defaultPN Value (N Nothing) :: PNT
-- | Default module name.
defaultModName::ModuleName
defaultModName = PlainModule "unknown"
-- | Default expression.
defaultExp::HsExpP
defaultExp=Exp (HsId (HsVar defaultPNT))
-- | Default Type.
defaultTyp :: HsTypeP
defaultTyp = Typ (HsTyCon defaultPNT)
-- | Default pattern.
defaultPat::HsPatP
defaultPat=Pat (HsPId (HsVar defaultPNT))
------------------------------------------------------------------------------------
-- | From PNT to PName.
pNTtoPN :: PNT->PName
pNTtoPN (PNT pname _ _)=pname
-- | From PName to Name. This function ignores the qualifier.
pNtoName::PName->String
pNtoName (PN (UnQual i) orig)=i
pNtoName (PN (Qual modName i) orig)=i
-- | From PNT to Name. This function ingnores the qualifier.
pNTtoName::PNT->String
pNTtoName=pNtoName.pNTtoPN
-- | From HsDeclP to String.
declToName :: HsDeclP -> String
declToName (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))
= pNTtoName pnt
declToName (Dec (HsPatBind _ pnt _ _)) = pNTtoName (patToPNT pnt)
declToName (Dec (HsDataDecl _ _ t _ _)) = pNTtoName (extractPNT t)
declToName (Dec (HsTypeSig _ (i:is) _ _)) = pNTtoName (extractPNT i)
declToName _ = ""
declToName2 (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))
= pNTtoName pnt
declToName2 (Dec (HsPatBind _ pnt _ _)) = pNTtoName (patToPNT pnt)
declToName2 _ = ""
-- | From HsDeclP to PNT.
declToPNT' :: HsDeclP -> PNT
declToPNT' (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))
= pnt
declToPNT' (Dec (HsPatBind _ pnt _ _)) = patToPNT pnt
declToPNT' (Dec (HsDataDecl _ _ t _ _)) = extractPNT t
declToPNT' _ = defaultPNT
-- | From HsDeclP to PNT.
declToPNT :: HsDeclP -> PNT
declToPNT (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))
= pnt
declToPNT (Dec (HsPatBind _ pnt _ _)) = patToPNT pnt
declToPNT (Dec (HsDataDecl _ _ t _ _)) = extractPNT t
declToPNT (Dec (HsTypeSig _ (i:is) _ _)) = extractPNT i
declToPNT _ = defaultPNT
extractPNT::(Term t)=>t->PNT
extractPNT = (fromMaybe defaultPNT).(applyTU (once_tdTU (failTU `adhocTU` inPNT)))
where
inPNT (p@(PNT x y z)::PNT)
= Just p
inMatch _ =Nothing
declToPName2 :: HsDeclP -> PName
declToPName2 (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))
= pNTtoPN pnt
declToPName2 (Dec (HsPatBind _ pnt _ _)) = patToPN pnt
declToPName2 _ = defaultPN
-- | From HsDeclP to PName
declToPName :: [ String ] -> HsDeclP -> PName
declToPName [] _ = defaultPN
declToPName (name: names) d@(Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))
| name == pNTtoName pnt = pNTtoPN pnt
| otherwise = declToPName names d
declToPName (name:names) d@(Dec (HsPatBind _ pnt _ _)) -- = pNTtoPN (patToPNT pnt)
| name == pNTtoName (patToPNT pnt) = pNTtoPN (patToPNT pnt)
| otherwise = declToPName names d
declToPName _ _ = defaultPN
----------------------------------------------------------------------------------
class (Term t) => HasModName t where
-- | Fetch the module name from an identifier.
hasModName :: t->Maybe ModuleName
instance HasModName PNT where
hasModName (PNT (PN _ (G modName s1 loc)) _ _)=Just modName
hasModName _ =Nothing
instance HasModName PName where
hasModName (PN _ (G modName s1 loc))=Just modName
hasModName _ =Nothing
----------------------------------------------------------------------
-- | Compose a PNT form a String.
nameToPNT::String->PNT
nameToPNT id =(PNT (PN (UnQual id) (G (PlainModule "unknown") id
(N (Just loc0)))) Value (N (Just loc0)))
-- | Compose a PName from String.
nameToPN::String->PName
nameToPN id =(PN (UnQual id) (G (PlainModule "unknown") id (N (Just loc0))))
-- | Compose a PNT from a PName and the PName's name space Information
pNtoPNT::PName->IdTy PId->PNT
pNtoPNT pname ty = PNT pname ty (N (Just loc0))
-- | If an expression consists of only one identifier then return this identifier in the PNT format,
-- otherwise return the default PNT.
expToPNT::HsExpP->PNT
expToPNT (Exp (HsId (HsVar pnt)))=pnt
expToPNT (Exp (HsId (HsCon pnt)))=pnt
expToPNT (Exp (HsParen e))=expToPNT e
expToPNT _ =defaultPNT
typToPNT ::HsTypeP->PNT
typToPNT (Typ (HsTyCon pnt))=pnt
typToPNT (Typ (HsTyVar pnt))=pnt
typToPNT _ =defaultPNT
-- | If an expression consists of only one identifier then return this identifier in the PName format,
-- otherwise returns the default PName.
expToPN::HsExpP->PName
expToPN =pNTtoPN.expToPNT
-- | Compose an expression from a String.
nameToExp ::String ->HsExpP
nameToExp name
=Exp (HsId (HsVar (PNT (PN (UnQual name) (S loc0)) Value (N (Just loc0)))))
nameToTyp :: String -> HsTypeP
nameToTyp name
= Typ (HsTyVar (PNT (PN (UnQual name) (S loc0)) Value (N (Just loc0))))
-- nameToIdent :: String -> HsIdent i
-- | Compose an Identifier from a String
nameToIdent name
= (HsVar (PNT (PN (UnQual name) (S loc0)) Value (N (Just loc0))))
-- | Compose an expression from a pName.
pNtoExp::PName->HsExpP
pNtoExp pn =Exp (HsId (HsVar (PNT pn Value (N (Just loc0)))))
-- | If a pattern consists of only one identifier then return this identifier in the PNT format,
-- otherwise returns the default PNT.
patToPNT::HsPatP->PNT
patToPNT (Pat (HsPId (HsVar pnt)))= pnt
patToPNT (Pat (HsPLit l (HsInt v))) = patToPNT (Pat (HsPId (HsVar (PNT (PN (UnQual (show v)) (S l)) Value (N (Just l))))) )
patToPNT (Pat (HsPParen p))=patToPNT p
patToPNT (Pat (HsPAsPat pnt p)) = pnt
patToPNT _=defaultPNT
-- | If a pattern consists of only one identifier then returns this identifier in the PName format,
-- otherwise returns the default PName.
patToPN::HsPatP->PName
patToPN=pNTtoPN.patToPNT
-- | Compose a pattern from a String.
nameToPat::String->HsPatP
nameToPat name
=Pat (HsPId (HsVar (PNT (PN (UnQual name) (S loc0)) Value (N (Just loc0)))))
-- | Compose a pattern from a pName.
pNtoPat :: PName -> HsPatP
pNtoPat pname
=let loc=srcLoc pname
in (Pat (HsPId (HsVar (PNT pname Value (N (Just loc))))))
---------------------------------------------------------------------------
-- |Create a new name base on the old name. Suppose the old name is 'f', then
-- the new name would be like 'f_i' where 'i' is an integer.
mkNewName::String -- ^ The old name
->[String] -- ^ The set of names which the new name cannot take
->Int -- ^ The posfix value
->String -- ^ The result
mkNewName oldName fds init
=let newName=if init==0 then oldName
else oldName++"_"++ show init
in if elem newName fds
then mkNewName oldName fds (init+1)
else newName
-- | Return the identifier's defining location.
defineLoc::PNT->SrcLoc
defineLoc (PNT pname _ _) = srcLoc pname
-- | Return the identifier's source location.
useLoc::PNT->SrcLoc
useLoc (PNT pname _ (N (Just loc))) = loc
useLoc (PNT _ _ _ ) = loc0
-- | Return True if the identifier is used in the RHS if a function\/pattern binding.
isUsedInRhs::(Term t)=>PNT->t->Bool
isUsedInRhs pnt t= useLoc pnt /= defineLoc pnt && not (notInLhs pnt t)
where
notInLhs pnt
= (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inMatch
`adhocTU` inDecl)))
where
inMatch ((HsMatch loc1 name pats rhs ds)::HsMatchP)
| isJust (find (sameOccurrence pnt) [name]) = Just True
inMatch _ =Nothing
inDecl ((Dec (HsTypeSig loc is c tp))::HsDeclP)
|isJust (find (sameOccurrence pnt) is) = Just True
inDecl _ =Nothing
isUsedInRhsName :: (Term t) => PNT -> t -> Bool
isUsedInRhsName pnt t= notInLhs pnt t
where
notInLhs pntget
= (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inPNT)))
where
inPNT (p@(PNT (PN (UnQual x)_)_ _)::PNT)
| isJust (find (sameName pnt) [p]) = Just True
inPNT _ = Nothing
inMatch ((HsMatch loc1 name pats rhs ds)::HsMatchP)
| isJust (find (sameName pnt) [name]) = Just True
inMatch _ =Nothing
inDecl ((Dec (HsTypeSig loc is c tp))::HsDeclP)
|isJust (find (sameName pnt) is) = Just True
inDecl _ =Nothing
returnRHS :: PNT -> HsExpP -> Bool
returnRHS pnt e@(Exp (HsApp e1 e2)) = (returnRHS pnt e1) || (returnRHS pnt e2)
returnRHS pnt e@(Exp (HsId (HsVar x))) = sameName pnt x
returnRHS pnt e@(Exp (HsTuple (e1:es))) = or ( map (returnRHS pnt) (e1:es) )
returnRHS pnt e@(Exp (HsParen e1)) = returnRHS pnt e1
returnRHS pnt e@(Exp (HsCase e1 _)) = returnRHS pnt e1
returnRHS pnt e = False
returnRHS2 :: PNT -> HsExpP -> Bool
returnRHS2 pnt e@(Exp (HsApp e1 e2)) = (returnRHS2 pnt e1) || (returnRHS2 pnt e2)
returnRHS2 pnt e@(Exp (HsId (HsVar x))) = sameName x pnt
returnRHS2 pnt e@(Exp (HsTuple (e1:es))) = or ( map (returnRHS2 pnt) (e1:es) )
returnRHS2 pnt e@(Exp (HsParen e1)) = returnRHS2 pnt e1
returnRHS2 pnt e@(Exp (HsCase e1 _)) = returnRHS2 pnt e1
returnRHS2 pnt e = False
-- getParams pnt defaultExp = []
-- getParams _ e = error $ show e
getParams pnt (Exp (HsApp (Exp (HsId (HsVar (PNT (PN (UnQual "unknown") (G (PlainModule "unknown") "--" (N Nothing))) Value (N Nothing)) ))) e2)) = [e2]
getParams pnt e@(Exp (HsCase e1 _)) = getParams pnt e1
getParams pnt e@(Exp (HsApp e1 e2))
= (getParams pnt e1) ++ getParams2 e2
getParams pnt (Exp (HsTuple (e:es)))
| getParams pnt e /= [] = getParams pnt e
| otherwise = getParams pnt (Exp (HsTuple es))
getParams pnt e = []
getParams2 (Exp (HsId (HsVar (PNT (PN (UnQual "unknown") (G (PlainModule "unknown") "--" (N Nothing))) Value (N Nothing)) ))) = []
getParams2 (Exp (HsApp e1 e2)) = (getParams2 e1) ++ (getParams2 e2)
getParams2 e = [e]
-- | Return True is the identifier is unqualifiedly used in the given syntax phrase.
usedWithoutQual::(Term t)=>String->t->Bool
usedWithoutQual name t
=(fromMaybe False) (applyTU (once_tdTU (failTU `adhocTU` worker)) t)
where
worker (pnt::PNT)
|pNTtoName pnt ==name && isUsedInRhs pnt t && not (isQualifiedPN (pNTtoPN pnt))
= Just True
worker _ =Nothing
-- |Find the identifier(in PNT format) whose start position is (row,col) in the
-- file specified by the fileName, and returns defaultPNT is such an identifier does not exist.
locToPNT::(Term t)=>String -- ^ The file name
->(Int,Int) -- ^ The row and column number
->t -- ^ The syntax phrase
->PNT -- ^ The result
locToPNT fileName (row, col)
=(fromMaybe defaultPNT). applyTU (once_buTU (failTU `adhocTU` worker))
where
worker pnt@(PNT pname ty (N (Just (SrcLoc fileName1 _ row1 col1))))
|fileName1==fileName && (row1,col1) == (row,col) =Just pnt
worker _ =Nothing
-- | The same as locToPNT, except that it returns the identifier in the PName format.
locToPN::(Term t)=>String->(Int,Int)->t->PName
locToPN fileName pos = pNTtoPN.(locToPNT fileName pos)
-- | Given the syntax phrase (and the token stream), find the largest-leftmost expression contained in the
-- region specified by the start and end position. If no expression can be found, then return the defaultExp.
locToExp2::(Term t) => SimpPos -- ^ The start position.
-> SimpPos -- ^ The end position.
-> [PosToken] -- ^ The token stream which should at least contain the tokens for t.
-> t -- ^ The syntax phrase.
-> HsExpP -- ^ The result.
locToExp2 beginPos endPos toks t
= fromMaybe defaultExp $ applyTU (once_tdTU (failTU `adhocTU` exp)) t
where
{- exp (e@(Exp (HsDo stmts))::HsExpP)
| filter inScope (map (getStartEndLoc toks) (getStmtList stmts))/=[]
= do let atoms = filter (\atom->inScope (getStartEndLoc toks atom)) (getStmtList stmts)
atoms'= reverse (dropWhile (not.isQualifierOrLastAtom) (reverse atoms))
if atoms'==[]
then fail "Expession not selected"
else do stmts' <-atoms2Stmt atoms'
Just (Exp (HsDo stmts')) -}
exp (e::HsExpP)
|inScope e = Just e
exp _ =Nothing
inScope e
= let (startLoc, endLoc)
= if expToPNT e /= defaultPNT
then let (SrcLoc _ _ row col) = useLoc (expToPNT e)
in ((row,col), (row,col))
else getStartEndLoc toks e
in (startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && endLoc<=endPos
isQualifierOrLastAtom (HsQualifierAtom e) = True
isQualifierOrLastAtom (HsLastAtom e) = True
isQualifierOrLastAtom _ = False
atoms2Stmt [HsQualifierAtom e] = return (HsLast e)
atoms2Stmt [HsLastAtom e] = return (HsLast e)
atoms2Stmt (HsGeneratorAtom s p e : ss) = HsGenerator s p e # atoms2Stmt ss
atoms2Stmt (HsLetStmtAtom ds : ss) = HsLetStmt ds # atoms2Stmt ss
atoms2Stmt (HsQualifierAtom e : ss) = HsQualifier e # atoms2Stmt ss
atoms2Stmt _ = fail "last statement in a 'do' expression must be an expression"
-- | Given the syntax phrase (and the token stream), find the largest-leftmost expression contained in the
-- region specified by the start and end position. If no expression can be found, then return the defaultExp.
locToPat::(Term t) => SimpPos -- ^ The start position.
-> SimpPos -- ^ The end position.
-> [PosToken] -- ^ The token stream which should at least contain the tokens for t.
-> t -- ^ The syntax phrase.
-> HsPatP -- ^ The result.
locToPat beginPos endPos toks t
= fromMaybe defaultPat $ applyTU (once_tdTU (failTU `adhocTU` pat)) t
where
{- exp (e@(Exp (HsDo stmts))::HsExpP)
| filter inScope (map (getStartEndLoc toks) (getStmtList stmts))/=[]
= do let atoms = filter (\atom->inScope (getStartEndLoc toks atom)) (getStmtList stmts)
atoms'= reverse (dropWhile (not.isQualifierOrLastAtom) (reverse atoms))
if atoms'==[]
then fail "Expession not selected"
else do stmts' <-atoms2Stmt atoms'
Just (Exp (HsDo stmts')) -}
pat (p::HsPatP)
|inScope p = Just p
pat _ =Nothing
inScope p
= let (startLoc, endLoc)
= if patToPNT p /= defaultPNT
then let (SrcLoc _ _ row col) = useLoc (patToPNT p)
in ((row,col), (row,col))
else getStartEndLoc toks p
in (startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && endLoc<=endPos
-- | Given the syntax phrase (and the token stream), find the expression contained in the
-- region specified by the start and end position. If no expression can be found, then return the defaultExp.
locToLocalPat::(Term t) => SimpPos -- ^ The start position.
-> SimpPos -- ^ The end position.
-> [PosToken] -- ^ The token stream which should at least contain the tokens for t.
-> t -- ^ The syntax phrase.
-> HsPatP -- ^ The result.
locToLocalPat beginPos endPos toks t
= fromMaybe defaultPat $ applyTU (once_tdTU (failTU `adhocTU` pat)) t
where
{- exp (e@(Exp (HsDo stmts))::HsExpP)
| filter inScope (map (getStartEndLoc toks) (getStmtList stmts))/=[]
= do let atoms = filter (\atom->inScope (getStartEndLoc toks atom)) (getStmtList stmts)
atoms'= reverse (dropWhile (not.isQualifierOrLastAtom) (reverse atoms))
if atoms'==[]
then fail "Expession not selected"
else do stmts' <-atoms2Stmt atoms'
Just (Exp (HsDo stmts')) -}
pat (p::HsPatP)
|inScope p = Just p
pat _ =Nothing
inScope p
= let (startLoc, endLoc)
= if patToPNT p /= defaultPNT
then let (SrcLoc _ _ row col) = useLoc (patToPNT p)
in ((row,col), (row,col))
else getStartEndLoc toks p
in (startLoc==beginPos) && (startLoc<= endPos) && (endLoc >= beginPos) && endLoc<=endPos
{- isQualifierOrLastAtom (HsQualifierAtom p) = True
isQualifierOrLastAtom (HsLastAtom p) = True
isQualifierOrLastAtom _ = False
atoms2Stmt [HsQualifierAtom p] = return (HsLast e)
atoms2Stmt [HsLastAtom e] = return (HsLast e)
atoms2Stmt (HsGeneratorAtom s p e : ss) = HsGenerator s p e # atoms2Stmt ss
atoms2Stmt (HsLetStmtAtom ds : ss) = HsLetStmt ds # atoms2Stmt ss
atoms2Stmt (HsQualifierAtom e : ss) = HsQualifier e # atoms2Stmt ss
atoms2Stmt _ = fail "last statement in a 'do' expression must be an expression" -}
-- | Given the syntax phrase (and the token stream), find the largest-leftmost expression contained in the
-- region specified by the start and end position. If no expression can be found, then return the defaultExp.
locToExp::(Term t) => SimpPos -- ^ The start position.
-> SimpPos -- ^ The end position.
-> [PosToken] -- ^ The token stream which should at least contain the tokens for t.
-> t -- ^ The syntax phrase.
-> HsExpP -- ^ The result.
locToExp beginPos endPos toks t
= fromMaybe defaultExp $ applyTU (once_tdTU (failTU `adhocTU` exp)) t
where
{- exp (e@(Exp (HsDo stmts))::HsExpP)
| filter inScope2 (map (getStartEndLoc toks) (getStmtList stmts))/=[]
= do let atoms = filter (\atom->inScope (getStartEndLoc toks atom)) (getStmtList stmts)
atoms'= reverse (dropWhile (not.isQualifierOrLastAtom) (reverse atoms))
if atoms'==[]
then fail "Expession not selected"
else do stmts' <-atoms2Stmt atoms'
Just (Exp (HsDo stmts')) -}
exp (e::HsExpP)
|inScope e = Just e
exp _ =Nothing
inScope e
= let (startLoc, endLoc)
= if expToPNT e /= defaultPNT
then let (SrcLoc _ _ row col) = useLoc (expToPNT e)
in ((row,col), (row,col))
else getStartEndLoc toks e
in (startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && endLoc<=endPos
isQualifierOrLastAtom (HsQualifierAtom e) = True
isQualifierOrLastAtom (HsLastAtom e) = True
isQualifierOrLastAtom _ = False
atoms2Stmt [HsQualifierAtom e] = return (HsLast e)
atoms2Stmt [HsLastAtom e] = return (HsLast e)
atoms2Stmt (HsGeneratorAtom s p e : ss) = HsGenerator s p e # atoms2Stmt ss
atoms2Stmt (HsLetStmtAtom ds : ss) = HsLetStmt ds # atoms2Stmt ss
atoms2Stmt (HsQualifierAtom e : ss) = HsQualifier e # atoms2Stmt ss
atoms2Stmt _ = fail "last statement in a 'do' expression must be an expression"
---------------------------------------------------------------------------------------
-- | Collect the identifiers (in PName format) in a given syntax phrase.
hsPNs::(Term t)=> t->[PName]
hsPNs=(nub.ghead "hsPNs").applyTU (full_tdTU (constTU [] `adhocTU` inPnt))
where
inPnt (PNT pname ty loc) = return [pname]
hsPNs2::(Term t)=> t->[PName]
hsPNs2=(nub.ghead "hsPNs2").applyTU (full_tdTU (constTU [] `adhocTU` inPat))
where
-- inPat :: HsPatP -> [PName]
inPat (Pat (HsPWildCard)::HsPatP) = return [defaultPN]
inPat (_::HsPatP) = return []
-- | Collect the identifiers (in PNT format) in a given syntax phrase.
hsPNTs ::(Term t)=>t->[PNT]
hsPNTs =(nub.ghead "hsPNTs").applyTU (full_tdTU (constTU [] `adhocTU` inPnt))
where
inPnt pnt@(PNT _ _ _) = return [pnt]
-- |Find those declarations(function\/pattern binding and type signature) which define the specified PNames.
--incTypeSig indicates whether the corresponding type signature will be included.
definingDecls::[PName] -- ^ The specified identifiers.
->[HsDeclP] -- ^ A collection of declarations.
->Bool -- ^ True means to include the type signature.
->Bool -- ^ True means to look at the local declarations as well.
->[HsDeclP] -- ^ The result.
definingDecls pns ds incTypeSig recursive=concatMap defines ds
where
defines decl
=if recursive
then ghead "defines" $ applyTU (stop_tdTU (failTU `adhocTU` inDecl)) decl
else defines' decl
where
inDecl (d::HsDeclP)
|defines' d /=[] =return $ defines' d
inDecl _=mzero
defines' decl@(Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) (p:ps) _ _):ms)))
|isJust (find (==pname) pns) = [decl]
|otherwise = check (p:ps)
where
check [] = []
check (Pat (HsPId (HsVar (PNT pname _ _))):ps)
| isJust (find (==pname) pns) = [decl]
| otherwise = check ps
check (_:ps) = check ps
defines' decl@(Dec (HsPatBind loc p rhs ds)) ---CONSIDER AGAIN----
|(hsPNs p) `intersect` pns /=[] = [decl]
defines' decl@(Dec (HsTypeSig loc is c tp)) --handle cases like a,b::Int
|(map pNTtoPN is) `intersect` pns /=[]
=if incTypeSig
then [(Dec (HsTypeSig loc (filter (\x->isJust (find (==pNTtoPN x) pns)) is) c tp))]
else []
defines' decl@(Dec (HsDataDecl loc c tp cons i))
= if checkCons cons then [decl]
else []
where
checkCons [] = False
checkCons ((HsConDecl loc i c (PNT pname _ _) t):ms)
| isJust (find (==pname) pns) = True
| otherwise = checkCons ms
checkCons ((HsRecDecl s i c (PNT pname _ _) t):ms)
| isJust (find (==pname) pns) = True
| otherwise = checkCons ms
defines' _ =[]
-- | Return True if the function\/pattern binding defines the specified identifier.
defines::PName->HsDeclP->Bool
defines pn decl@(Dec (HsFunBind loc ((HsMatch loc1 (PNT pname ty loc2) pats rhs ds):ms)))
= pname == pn
defines pn decl@(Dec (HsPatBind loc p rhs ds)) = elem pn (hsPNs p)
defines _ _= False
-- | Return True if the second PNT defines the first.
definesPNT :: PNT -> PNT -> Bool
definesPNT p1 p2
= defineLoc p1 == defineLoc p2
defines'::PName->HsDeclP->Bool
defines' (PN (UnQual x) s) decl@(Dec (HsFunBind loc ((HsMatch loc1 (PNT (PN (UnQual x2) s2) ty loc2) pats rhs ds):ms)))
= x == x2
defines' (PN (UnQual x) s) decl@(Dec (HsPatBind loc p rhs ds)) = x == pNTtoName (patToPNT p)
defines' _ _= False
defines2 :: PName -> [HsPatP] -> HsDeclP -> Bool
-- defines2 a b c = error $ show (a,b,c)
defines2 pn@(PN (UnQual x) s) (p1:ps) decl@(Dec (HsFunBind loc ((HsMatch loc1 (PNT (PN (UnQual x2) s2) ty loc2) pats rhs ds):ms)))
= x == x2 || (or (map (defines2 pn (p1:ps)) ds))
defines2 pn@(PN (UnQual x1) s) (p1:ps) decl@(Dec (HsPatBind loc p rhs ds)) = (elem x1 (map pNtoName (hsPNs p)) || (or (map (defines2 pn (p1:ps)) ds))) && and (litsInPat (p1:ps) [p])
defines2 _ _ _= False
litsInPat [] _ = [True]
litsInPat _ [] = [True]
litsInPat (p:ps) [Pat (HsPTuple s (p2:ps2))]
| p == p2 = True : (litsInPat ps ps2)
| otherwise = [False]
litsInPat (a:as) (p@(Pat (HsPLit x y)):ps)
| a == p = True : (litsInPat as ps)
| otherwise = [False] -- error $ show (a, b) -- [True]
litsInPat (a:as) (b:bs) = litsInPat as bs
defines3 :: PName -> [HsPatP] -> HsDeclP -> [PName]
defines3 pn@(PN (UnQual x) s) (p:ps) decl@(Dec (HsFunBind loc ((HsMatch loc1 (PNT (PN (UnQual x2) s2) ty loc2) pats rhs ds):ms)))
| x == x2 = [(PN (UnQual x2) s2)]
| (or (map (defines2 pn (p:ps)) ds)) = concat (map (defines3 pn (p:ps)) ds)
| otherwise = []
defines3 pn@(PN (UnQual x1) s) (p1:ps1) decl@(Dec (HsPatBind loc p rhs ds))
| elem x1 (map pNtoName (hsPNs p)) = (hsPNs p) ++ (hsPNs2 p)
| (or (map (defines2 pn (p1:ps1)) ds)) = concat (map (defines3 pn (p1:ps1)) ds)
defines3 _ _ _ = []
-- | Return True if the declaration defines the type signature of the specified identifier.
definesTypeSig :: PName -> HsDeclP -> Bool
definesTypeSig pn (Dec (HsTypeSig loc is c tp))=elem pn (map pNTtoPN is)
definesTypeSig _ _ =False
-- | Return True if the declaration defines the type signature of the specified identifier.
isTypeSigOf :: PNT -> HsDeclP -> Bool
isTypeSigOf pnt (Dec (HsTypeSig loc is c tp))= elem pnt is
isTypeSigOf _ _ =False
-- | Return the list of identifiers (in PName format) defined by a function\/pattern binding.
definedPNs::HsDeclP->[PName]
definedPNs (Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) _ _ _):_))) =[pname]
definedPNs (Dec (HsPatBind _ p _ _)) =hsPNs p
definedPNs (Dec (HsDataDecl _ _ _ cons _) )
= getCons cons
where
getCons [] = []
getCons ((HsConDecl _ _ _ (PNT pname _ _) _):ms)
= pname : (getCons ms)
getCons ((HsRecDecl _ _ _ (PNT pname _ _) _):ms)
= pname : (getCons ms)
-- getCons _ = []
definedPNs _=[]
-- | Return the list of identifiers (in PName format) defined by a function\/pattern binding.
definedPNsForConstr :: HsDeclP -> [PName]
definedPNsForConstr (Dec (HsFunBind _ ((HsMatch _ (PNT pname _ _) _ _ _):_))) =[pname]
definedPNsForConstr (Dec (HsPatBind _ p _ _)) =hsPNs p
definedPNsForConstr (Dec (HsDataDecl _ _ t _ _) )
= [pNTtoPN (extractPNT t)]
definedPNsForConstr _=[]
-- |Return True if the given syntax phrase contains any free variables.
hasFreeVars::(Term t)=>t->Bool
hasFreeVars t = fromMaybe False (do (f,_)<-hsFreeAndDeclaredPNs t
if f/=[] then Just True
else Nothing)
{- Remove source location information in the syntax tree. that is to replace all
source locations by default location: loc0 -}
-- | Remove source location information in the syntax tree.
rmLocs :: (Term t)=> t->t
rmLocs t =runIdentity (applyTP (full_tdTP (idTP `adhocTP` exp
`adhocTP` pnt
`adhocTP` alt
`adhocTP` lit)) t)
where
exp ((Exp (HsNegApp loc e)) ::HsExpP)=return (Exp (HsNegApp loc0 e))
exp (Exp (HsExpTypeSig loc e c t))=return (Exp (HsExpTypeSig loc0 e c t))
exp x=return x
alt ((HsAlt loc p e ds)::HsAltP)=return (HsAlt loc0 p e ds)
lit (HsInt int) = return (HsInt int)
lit (HsFrac rat)= return (HsFrac rat)
lit (HsString s) = return (HsString s)
pnt (PNT pname ty _)= return (PNT pname ty (N (Just loc0)))
rmAllLocs :: (Term t)=> t->t
rmAllLocs t =runIdentity (applyTP (full_tdTP (idTP `adhocTP` l)) t)
where
l ((SrcLoc _ _ _ _)::SrcLoc) = return loc0
wildCardAllPNs :: (Term t)=> t -> t
wildCardAllPNs t = runIdentity (applyTP (full_tdTP (idTP `adhocTP` l `adhocTP` s)) t)
where
l ((PN (UnQual n) s)) = return (PN (UnQual "_") s)
s ((SrcLoc _ _ _ _)::SrcLoc) = return loc0
-- | Change the absolute define locations of local variables to relative ones,
-- so that equality between expressions can be compared via alpha-renaming.
toRelativeLocs::(Term t)=>t->t
toRelativeLocs e = runIdentity (applyTP (full_tdTP (idTP `adhocTP` inLoc)) e)
where
inLoc (SrcLoc f c row col)
| elem (row,col) defLocs
= let index=fromJust (elemIndex (row,col) defLocs) + 1
in return (SrcLoc f index index index)
inLoc loc = return loc
defLocs= ((nub.ghead "toRelativeLoc").applyTU (full_tdTU (constTU []
`adhocTU` inPnt ))) e
where
inPnt pnt@(PNT pn ty loc)
|defineLoc pnt == useLoc pnt= return [(\(SrcLoc _ _ r c)->(r,c)) (srcLoc pn)]
inPnt _ = return []
------------------------------------------------------------------------------------------
-- | Replace the name (and qualifier if specified) by a new name (and qualifier) in a PName.
-- The function does not modify the token stream.
replaceNameInPN::Maybe ModuleName -- ^ The new qualifier
->PName -- ^ The old PName
->String -- ^ The new name
->PName -- ^ The result
replaceNameInPN qualifier (PN (UnQual s)(S loc)) newName
= if isJust qualifier then (PN (Qual (fromJust qualifier) newName) (S loc))
else (PN (UnQual newName) (S loc))
replaceNameInPN qualifier (PN (Qual modName s)(S loc)) newName
= if isJust qualifier then (PN (Qual (fromJust qualifier) newName)(S loc))
else (PN (Qual modName newName) (S loc))
replaceNameInPN qualifier (PN (UnQual s) (G modName s1 loc)) newName
= if isJust qualifier then (PN (Qual (fromJust qualifier) newName) (G modName newName loc))
else (PN (UnQual newName) (G modName newName loc))
replaceNameInPN qualifier (PN (Qual modName s) (G modName1 s1 loc)) newName
=if isJust qualifier then (PN (Qual (fromJust qualifier) newName) (G modName1 newName loc))
else (PN (Qual modName newName) (G modName1 newName loc))
-- | Rename each occurrences of the identifier in the given syntax phrase with the new name.
-- If the Bool parameter is True, then modify both the AST and the token stream, otherwise only modify the AST.
{-
renamePN::(Term t)
=>PName -- ^ The identifier to be renamed.
->Maybe ModuleName -- ^ The qualifier
->String -- ^ The new name
->Bool -- ^ True means modifying the token stream as well.
->t -- ^ The syntax phrase
->m t
-}
renamePN::((MonadState (([PosToken], Bool), t1) m),Term t)
=>PName -- ^ The identifier to be renamed.
->Maybe ModuleName -- ^ The qualifier
->String -- ^ The new name
->Bool -- ^ True means modifying the token stream as well.
->t -- ^ The syntax phrase
->m t
renamePN oldPN qualifier newName updateToks t
= applyTP (full_tdTP (adhocTP idTP rename)) t
where
rename pnt@(PNT pn ty (N (Just (SrcLoc fileName c row col))))
| (pn ==oldPN) && (srcLoc oldPN == srcLoc pn)
= do if updateToks
then do ((toks,_),others)<-get
let toks'=replaceToks toks (row,col) (row,col)
[mkToken Varid (row,col) ((render.ppi) (replaceName pn newName))]
put ((toks', modified),others)
return (PNT (replaceName pn newName) ty (N (Just (SrcLoc fileName c row col))))
else return (PNT (replaceName pn newName) ty (N (Just (SrcLoc fileName c row col))))
where
replaceName = if isJust qualifier && canBeQualified pnt t
then replaceNameInPN qualifier
else replaceNameInPN Nothing
rename x = return x
-- | Return True if the identifier can become qualified.
canBeQualified::(Term t)=>PNT->t->Bool
canBeQualified pnt t
= isTopLevelPNT pnt && isUsedInRhs pnt t && not (findPntInImp pnt t)
where
findPntInImp pnt
= (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` inImp)))
where
inImp ((HsImportDecl loc modName qual as h)::HsImportDeclP)
|findEntity pnt h = Just True
inImp _ = Nothing
-- | Return True if the identifier(in PNT format) occurs in the given syntax phrase.
findPNT::(Term t)=>PNT->t->Bool
findPNT pnt
= (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))
where
worker (pnt1::PNT)
| sameOccurrence pnt pnt1 =Just True
worker _ =Nothing
-- | Return True if the identifier(in PNT format) occurs in the given syntax phrase.
findPN'::(Term t)=>PName->t->Bool
findPN' p1
= (fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))
where
worker (p2@(PN (UnQual x) s)::PName)
| rmLocs p1 == rmLocs p2 = Just True
worker _ =Nothing
-- | Return True if the identifier (in PName format) occurs in the given syntax phrase.
findPN::(Term t)=>PName->t->Bool
findPN pn
=(fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))
where
worker (pn1::PName)
|pn == pn1 && srcLoc pn == srcLoc pn1 = Just True
worker _ =Nothing
-- | Return True if the identifier (in PName format) occurs on the RHS of given syntax phrase.
findPNRHS::(Term t)=>PName->t->Bool
findPNRHS pn
=(fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))
where
worker (match@(HsMatch loc name pats rhs ds)::HsMatchP)
| findPN pn pats = Just True
worker _ =Nothing
-- | Return True if any of the specified PNames ocuur in the given syntax phrase.
findPNs::(Term t)=>[PName]->t->Bool
findPNs pns
=(fromMaybe False).(applyTU (once_tdTU (failTU `adhocTU` worker)))
where
worker (pn1::PName)
|elem pn1 pns = Just True
worker _ =Nothing
----------------------------------------------------------------------------------------
-- | Check whether the specified identifier is declared in the given syntax phrase t,
-- if so, rename the identifier by creating a new name automatically. If the Bool parameter
-- is True, the token stream will be modified, otherwise only the AST is modified.
{-
autoRenameLocalVar::(MonadPlus m, Term t)
=>Bool -- ^ True means modfiying the token stream as well.
->PName -- ^ The identifier.
->t -- ^ The syntax phrase.
-> m t -- ^ The result.
-}
autoRenameLocalVar::(MonadPlus m, (MonadState (([PosToken], Bool), (Int,Int)) m), Term t)
=>Bool -- ^ True means modfiying the token stream as well.
->PName -- ^ The identifier.
->t -- ^ The syntax phrase.
-> m t -- ^ The result.
autoRenameLocalVar updateToks pn
=applyTP (once_buTP (failTP `adhocTP` renameInMatch
`adhocTP` renameInPat
`adhocTP` renameInExp
`adhocTP` renameInAlt
`adhocTP` renameInStmts))
where
renameInMatch (match::HsMatchP)
|isDeclaredIn pn match=worker match
renameInMatch _ =mzero
renameInPat (pat::HsDeclP)
|isDeclaredIn pn pat=worker pat
renameInPat _ =mzero
renameInExp (exp::HsExpP)
|isDeclaredIn pn exp=worker exp
renameInExp _ =mzero
renameInAlt (alt::HsAltP)
|isDeclaredIn pn alt=worker alt
renameInAlt _ =mzero
renameInStmts (stmt::HsStmtP)
|isDeclaredIn pn stmt=worker stmt
renameInStmts _=mzero
worker t =do (f,d)<-hsFDNamesFromInside t
ds<-hsVisibleNames pn (hsDecls t)
let newName=mkNewName (pNtoName pn) (nub (f `union` d `union` ds)) 1
if updateToks
then renamePN pn Nothing newName True t
else renamePN pn Nothing newName False t
-------------------------------------------------------------------------------------
-- | Add a guard expression to the RHS of a function\/pattern definition. If a guard already
-- exists in the RHS, the new guard will be added to the beginning of the existing one.
addGuardsToRhs::(MonadState (([PosToken], Bool), (Int,Int)) m)
=> RhsP -- ^ The RHS of the declaration.
-> HsExpP -- ^ The guard expression to be added.
-> m RhsP -- ^ The result.
addGuardsToRhs (HsBody e) guardExp
= do ((toks,_), (v1,v2)) <-get
let (startPos', _) = startEndLoc toks e
(toks1,toks2) = break (\t->tokenPos t==startPos') toks
reversedToks1BeforeEqOrArrow = dropWhile (\t->not (isEqual t || isArrow t)) (reverse toks1)
eqOrArrowTok = ghead "addGuardsToRhs" reversedToks1BeforeEqOrArrow
startPos = tokenPos eqOrArrowTok
offset = lengthOfLastLine (reverse (gtail "addGuardsToRhs" reversedToks1BeforeEqOrArrow))
newCon = "|"++(render.ppi) guardExp ++ "\n" ++ replicate offset ' '++ tokenCon eqOrArrowTok
newToks = tokenise (Pos 0 v1 1) 0 False newCon
toks' = replaceToks toks startPos startPos newToks
put ((toks',modified), ((tokenRow (glast "addFormalParams" newToks) -10), v2))
(guardExp',_) <- addLocInfo (guardExp, newToks)
return $ HsGuard [(loc0, guardExp, e)]
addGuardsToRhs (HsGuard gs) guardExp
= do newGuards <- mapM (addGuard guardExp) gs
return (HsGuard newGuards)
where
addGuard guardExp (loc, e1, e2)
= do (e', _)<-updateToks e1 (Exp (HsInfixApp guardExp (HsVar (nameToPNT "&&")) e1)) prettyprint
return (loc, e', e2)
------------------------------------------------------------------------------------------------------
{-
addParamsToDecls::(MonadPlus m)
=> [HsDeclP] -- ^ A declaration list where the function is defined and\/or used.
->PName -- ^ The function name.
->[PName] -- ^ The parameters to be added.
->Bool -- ^ Modify the token stream or not.
->m [HsDeclP] -- ^ The result.
-}
addParamsToDecls::(MonadPlus m, (MonadState (([PosToken], Bool), (Int,Int)) m))
=> [HsDeclP] -- ^ A declaration list where the function is defined and\/or used.
->PName -- ^ The function name.
->[PName] -- ^ The parameters to be added.
->Bool -- ^ Modify the token stream or not.
->m [HsDeclP] -- ^ The result.
addParamsToDecls decls pn paramPNames modifyToks
= if (paramPNames/=[])
then mapM addParamToDecl decls
else return decls
where
addParamToDecl (Dec (HsFunBind loc matches@((HsMatch _ fun pats rhs ds):ms)))
| pNTtoPN fun == pn
= do matches'<-mapM addParamtoMatch matches
return (Dec (HsFunBind loc matches'))
where
addParamtoMatch (HsMatch loc fun pats rhs decls)
= do rhs'<-addActualParamsToRhs pn paramPNames rhs
let pats' = map pNtoPat paramPNames
pats'' <- if modifyToks then do (p, _)<-addFormalParams fun pats'
return p
else return pats'
return (HsMatch loc fun (pats'++pats) rhs' decls)
addParamToDecl (Dec (HsPatBind loc p rhs ds))
|patToPN p == pn
= do rhs'<-addActualParamsToRhs pn paramPNames rhs
let pats' = map pNtoPat paramPNames
pats'' <- if modifyToks then do (p, _) <-addFormalParams p pats'
return p
else return pats'
return (Dec (HsFunBind loc [HsMatch loc (patToPNT p) pats' rhs ds]))
addParamToDecl x=return x
addActualParamsToRhs pn paramPNames
= applyTP (stop_tdTP (failTP `adhocTP` worker))
where
worker exp@(Exp (HsId (HsVar (PNT pname ty loc))))
| pname==pn
= do let newExp=Exp (HsParen (foldl addParamToExp exp (map pNtoExp paramPNames)))
if modifyToks then do (newExp', _) <- updateToks exp newExp prettyprint
return newExp'
else return newExp
worker x =mzero
addParamToExp exp param=(Exp (HsApp exp param))
-------------------------------------------------------------------
-- | Remove the first n parameters of a given identifier in an expression.
rmParams:: (MonadPlus m,MonadState (([PosToken], Bool), (Int,Int)) m)=>
PNT -- ^ The identifier whose parameters are to be removed.
->Int -- ^ Number of parameters to be removed.
->HsExpP -- ^ The original expression.
->m HsExpP -- ^ The result expression.
rmParams pnt n exp
= if n==0 then return exp
else do exp'<-rmOneParam pnt exp
rmParams pnt (n-1) exp'
where
rmOneParam pnt= applyTP (stop_tdTP (failTP `adhocTP` inExp))
inExp (exp@(Exp (HsParen (Exp (HsApp e1 e2))))::HsExpP)
---dfd
|sameOccurrence (expToPNT e1) pnt
=do updateExp exp e1
inExp exp@(Exp (HsApp e1 e2))
| sameOccurrence (expToPNT e1) pnt
=do updateExp exp e1
inExp _=mzero
updateExp exp e1
= do ((toks,_),others)<-get --handle the case like '(fun x) => fun "
let (startPos,endPos)=getStartEndLoc toks exp
toks'=replaceToks toks startPos endPos $ getToks (getStartEndLoc toks e1) toks
put ((toks',modified),others)
return e1
-------------------------------------------------------------------------------------------------------
{-A simple function binding satisfies : 1. all parameters are variables
2. only one match(equation)
3. The rhs of the match is not in guard style.
that is:
HsFunBind SrcLoc ((HsMatch SrcLoc i [var] (HsBody e) ds):[]) ds
If a function binding is not a simple function binding, then convert it into a simple binding
using Case or IfThenElse expressions like this:
case1: there are multi matches => case expression
case2: there is only one match, however the parameters are not simple variables =>case expression.
case3: there is only one match and the parameters are all simple variables, however there is a guard
in Rhs => If then else
In case of pattern binding: if there is guard in its Rhs, then convert it into IfThenElse style. -}
-- | If a function\/pattern binding then convert it into a simple binding using case and\/or if-then-else expressions.
-- A simple function\/pattern binding should satisfy: a) all the paraneters are simple variables; b). only has one equation;
-- c). the RHS does not have guards. This function DOES NOT modify the token stream not AST.
simplifyDecl::(Monad m)=>HsDeclP->m HsDeclP
simplifyDecl decl
|isFunBind decl =if (multiMatches decl) || (singleMatchWithComplexParams decl)
then matchesToCase decl
else return (guardToIfThenElse decl)
|isPatBind decl=return (guardToIfThenElse decl)
|otherwise = return decl
where
multiMatches (Dec (HsFunBind loc matches))=length matches>1
multiMatches _ = False
singleMatchWithComplexParams (Dec (HsFunBind loc matches@((HsMatch loc1 pnt pats rhs ds):ms)))
=length matches==1 && any (==defaultPN) (map patToPN pats)
singleMatchWithComplexParams _ =False
--convert a multi-match function declaration into a single-match declration using case expression.
matchesToCase decl@(Dec (HsFunBind loc matches@((HsMatch loc1 pnt pats rhs ds):ms)))
=do params<-mkNewParamPNames (length pats)
exp<-pNamesToExp params
return (Dec (HsFunBind loc [(HsMatch loc1 pnt (map pNtoPat params)
(HsBody (Exp (HsCase exp (map matchToAlt matches)))) [])]))
--make n new parameters like [x_0,x_1, ...,x_n]
mkNewParamPNames n=mkNewParamPNames' n []
where mkNewParamPNames' n pNames
=if n==0 then return pNames
else do let pn'= PN (UnQual ("x_"++show (n-1))) (S loc0)
mkNewParamPNames' (n-1) (pn':pNames)
matchToAlt ((HsMatch loc1 pnt pats rhs ds)::HsMatchP)=HsAlt loc0 (listToTuple pats) rhs ds
where
listToTuple pats=if (length pats)==1 then ghead "listToTuple" pats --no problem with head
else (Pat (HsPTuple loc0 pats))
pNamesToExp pns@(p:ps)=if ps==[] then return $ pNtoExp p
else do let exp'=map pNtoExp pns
return (Exp (HsTuple exp'))
guardToIfThenElse :: HsDeclP -> HsDeclP
guardToIfThenElse decl= case decl of
(Dec (HsPatBind loc p g@(HsGuard gs) ds))->(Dec (HsPatBind loc p (rmGuard g) ds))
(Dec (HsFunBind loc ((HsMatch loc1 pnt pats g@(HsGuard gs) ds):[]))) ->
(Dec (HsFunBind loc ((HsMatch loc1 pnt pats (rmGuard g) ds):[])))
_ ->decl
where
rmGuard ((HsGuard gs)::RhsP)
= let (_,e1,e2)=glast "guardToIfThenElse" gs
in if ((pNtoName.expToPN) e1)=="otherwise"
then HsBody (foldl mkIfThenElse e2 (tail(reverse gs)))
else HsBody (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")))))
-----------------------------------------------------------------------------------------
-- | Collect those data constructors that occur in the given syntax phrase, say t. In the result,
-- the first list contains the data constructors that are declared in other modules, and the second
-- list contains the data constructors that are declared in the current module.
hsDataConstrs::Term t=>ModuleName -- ^ The name of the module which 't' belongs to.
-> t -- ^ The given syntax phrase.
->([PName],[PName]) -- ^ The result.
hsDataConstrs modName
= ghead "hsDataConstrs". (applyTU (stop_tdTU (failTU `adhocTU` pnt)))
where
pnt (PNT pname (ConstrOf _ _) _)
= if hasModName pname==Just modName
then return ([],[pname])
else return ([pname],[])
pnt _ = mzero
-- | Collect those type constructors and class names that occur in the given syntax phrase, say t.
-- In the result, the first list contains the type constructor\/classes which are
-- declared in other modules, and the second list contains those type constructor\/classes
-- that are declared in the current module.
hsTypeConstrsAndClasses::Term t=>ModuleName -- ^ The name of the module which 't' belongs to.
-> t -- ^ The given syntax phrase.
-> ([PName],[PName]) -- ^ The result.
hsTypeConstrsAndClasses modName
= ghead "hsTypeConstrAndClasses".(applyTU (stop_tdTU (failTU `adhocTU` pnt)))
where
pnt (PNT (PN i (G modName1 id loc)) (Type _) _)
= if modName == modName1
then return ([],[(PN i (G modName id loc))])
else return ([(PN i (G modName id loc))], [])
pnt (PNT pname (Class _ _) _)=if hasModName pname==Just modName
then return ([],[pname])
else return ([pname],[])
pnt _ =mzero
-- |Collect those type variables that are declared in a given syntax phrase t.
-- In the returned result, the first list is always be empty.
hsTypeVbls::(Term t) => t -> ([PName],[PName])
hsTypeVbls =ghead "hsTypeVbls".(applyTU (stop_tdTU (failTU `adhocTU` pnt)))
where
pnt (PNT (PN i (S loc)) (Type _) _) = return ([], [(PN i (S loc))])
pnt _ =mzero
-- |Collect the class instances of the spcified class from the given syntax phrase. In the result,
-- the first list contains those class instances which are declared in other modules,
-- and the second list contains those class instances that are declared in the current module.
hsClassMembers::Term t => String -- ^ The class name.
->ModuleName -- ^ The module name.
->t -- ^ The syntax phrase.
->([PName],[PName]) -- ^ The result.
hsClassMembers className modName
= ghead "hsClassMembers". (applyTU (stop_tdTU (failTU `adhocTU` pnt)))
where
pnt(PNT pname (MethodOf i _ _) _) -- Claus
| pNtoId i==className
= if hasModName pname == Just modName
then return ([],[pname])
else return ([pname],[])
pnt _ = mzero
pNtoId :: PN (HsName.Id) ->String
pNtoId (PN i orig)=i
------------------------------------------------------------------------------------------
-- | Collect the free and declared variables (in the PName format) in a given syntax phrase t.
-- In the result, the first list contains the free variables, and the second list contains the declared variables.
hsFreeAndDeclaredPNs:: (Term t, MonadPlus m)=> t-> m ([PName],[PName])
hsFreeAndDeclaredPNs t=do (f,d)<-hsFreeAndDeclared' t
return (nub f, nub d)
where
hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp
`adhocTU` pat
`adhocTU` match
`adhocTU` patBind
`adhocTU` alt
`adhocTU` decls
`adhocTU` stmts
`adhocTU` recDecl))
exp (Exp (HsId (HsVar (PNT pn _ _))))=return ([pn],[])
exp (Exp (HsId (HsCon (PNT pn _ _))))=return ([pn],[])
exp (Exp (HsInfixApp e1 (HsVar (PNT pn _ _)) e2))
=addFree pn (hsFreeAndDeclaredPNs [e1,e2])
exp (Exp (HsLambda pats body))
= do (pf,pd) <-hsFreeAndDeclaredPNs pats
(bf,_) <-hsFreeAndDeclaredPNs body
return ((bf `union` pf) \\ pd, [])
exp (Exp (HsLet decls exp))
= do (df,dd)<- hsFreeAndDeclaredPNs decls
(ef,df)<- hsFreeAndDeclaredPNs exp
return ((df `union` (ef \\ dd)), dd ++ df) -- [])
exp (Exp (HsRecConstr _ (PNT pn _ _) e))
=addFree pn (hsFreeAndDeclaredPNs e) --Need Testing
exp (Exp (HsAsPat (PNT pn _ _) e))
=addFree pn (hsFreeAndDeclaredPNs e)
exp _ = mzero
pat (Pat (HsPId (HsVar (PNT pn _ _))))=return ([],[pn])
pat (Pat (HsPInfixApp p1 (PNT pn _ _) p2))=addFree pn (hsFreeAndDeclaredPNs [p1,p2])
pat (Pat (HsPApp (PNT pn _ _) pats))=addFree pn (hsFreeAndDeclaredPNs pats)
pat (Pat (HsPRec (PNT pn _ _) fields))=addFree pn (hsFreeAndDeclaredPNs fields)
pat _ =mzero
match ((HsMatch _ (PNT fun _ _) pats rhs decls)::HsMatchP)
= do (pf,pd) <- hsFreeAndDeclaredPNs pats
(rf,rd) <- hsFreeAndDeclaredPNs rhs
(df,dd) <- hsFreeAndDeclaredPNs decls
return ((pf `union` ((rf `union` df) \\ (dd `union` pd `union` [fun]))),[fun])
-------Added by Huiqing Li-------------------------------------------------------------------
patBind ((Dec (HsPatBind _ pat (HsBody rhs) decls))::HsDeclP)
=do (pf,pd) <- hsFreeAndDeclaredPNs pat
(rf,rd) <- hsFreeAndDeclaredPNs rhs
(df,dd) <- hsFreeAndDeclaredPNs decls
return (pf `union` ((rf `union` df) \\(dd `union` pd)),pd)
patBind _=mzero
-------------------------------------------------------------------------------------------
alt ((HsAlt _ pat exp decls)::(HsAlt (HsExpP) (HsPatP) [HsDeclP]))
= do (pf,pd) <- hsFreeAndDeclaredPNs pat
(ef,ed) <- hsFreeAndDeclaredPNs exp
(df,dd) <- hsFreeAndDeclaredPNs decls
return (pf `union` (((ef \\ dd) `union` df) \\ pd),[])
decls (ds :: [HsDeclP])
=do (f,d) <-hsFreeAndDeclaredList ds
return (f\\d,d)
stmts ((HsGenerator _ pat exp stmts) :: HsStmt (HsExpP) (HsPatP) [HsDeclP]) -- Claus
=do (pf,pd) <-hsFreeAndDeclaredPNs pat
(ef,ed) <-hsFreeAndDeclaredPNs exp
(sf,sd) <-hsFreeAndDeclaredPNs stmts
return (pf `union` ef `union` (sf\\pd),[]) -- pd) -- Check this
stmts ((HsLetStmt decls stmts) :: HsStmt (HsExpP) (HsPatP) [HsDeclP])
=do (df,dd) <-hsFreeAndDeclaredPNs decls
(sf,sd) <-hsFreeAndDeclaredPNs stmts
return (df `union` (sf \\dd),[])
stmts _ =mzero
recDecl ((HsRecDecl _ _ _ _ is) :: HsConDeclI PNT (HsTypeI PNT) [HsTypeI PNT])
=do let d=map pNTtoPN $ concatMap fst is
return ([],d)
recDecl _ =mzero
addFree free mfd=do (f,d)<-mfd
return ([free] `union` f, d)
hsFreeAndDeclaredList l=do fds<-mapM hsFreeAndDeclaredPNs l
return (foldr union [] (map fst fds),
foldr union [] (map snd fds))
-- |The same as `hsFreeAndDeclaredPNs` except that the returned variables are in the String format.
hsFreeAndDeclaredNames::(Term t, MonadPlus m)=> t->m([String],[String])
hsFreeAndDeclaredNames t =do (f1,d1)<-hsFreeAndDeclaredPNs t
return ((nub.map pNtoName) f1, (nub.map pNtoName) d1)
-----------------------------------------------------------------------------------------
{- |`hsFDsFromInside` is different from `hsFreeAndDeclaredPNs` in that: given an syntax phrase t,
`hsFDsFromInside` returns not only the declared variables that are visible from outside of t,
but also those declared variables that are visible to the main expression inside t.
-}
hsFDsFromInside:: (Term t, MonadPlus m)=> t-> m ([PName],[PName])
hsFDsFromInside t = do (f,d)<-hsFDsFromInside' t
return (nub f, nub d)
where
hsFDsFromInside' = applyTU (once_tdTU (failTU `adhocTU` mod
-- `adhocTU` decls
`adhocTU` decl
`adhocTU` match
`adhocTU` exp
`adhocTU` alt
`adhocTU` stmts ))
mod ((HsModule loc modName exps imps ds)::HsModuleP)
= hsFreeAndDeclaredPNs ds
{- decls (ds::[HsDeclP]) --CHECK THIS.
= hsFreeAndDeclaredPNs decls
-}
match ((HsMatch loc1 (PNT fun _ _) pats rhs ds) ::HsMatchP)
= do (pf, pd) <-hsFreeAndDeclaredPNs pats
(rf, rd) <-hsFreeAndDeclaredPNs rhs
(df, dd) <-hsFreeAndDeclaredPNs ds
return (nub (pf `union` ((rf `union` df) \\ (dd `union` pd `union` [fun]))),
nub (pd `union` rd `union` dd `union` [fun]))
decl ((Dec (HsPatBind loc p rhs ds))::HsDeclP)
= do (pf, pd)<-hsFreeAndDeclaredPNs p
(rf, rd)<-hsFreeAndDeclaredPNs rhs
(df, dd)<-hsFreeAndDeclaredPNs ds
return (nub (pf `union` ((rf `union` df) \\ (dd `union` pd))),
nub ((pd `union` rd `union` dd)))
decl (Dec (HsFunBind loc matches))
=do fds <-mapM hsFDsFromInside matches
return (nub (concatMap fst fds), nub(concatMap snd fds))
decl _ = mzero
exp ((Exp (HsLet decls exp))::HsExpP)
= do (df,dd)<- hsFreeAndDeclaredPNs decls
(ef,_)<- hsFreeAndDeclaredPNs exp
return (nub (df `union` (ef \\ dd)), nub dd)
exp (Exp (HsLambda pats body))
= do (pf,pd) <-hsFreeAndDeclaredPNs pats
(bf,_) <-hsFreeAndDeclaredPNs body
return (nub ((bf `union` pf) \\ pd), nub pd)
exp _ = mzero
alt ((HsAlt _ pat exp decls)::HsAltP)
= do (pf,pd) <- hsFreeAndDeclaredPNs pat
(ef,ed) <- hsFreeAndDeclaredPNs exp
(df,dd) <- hsFreeAndDeclaredPNs decls
return (nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), nub (pd `union` dd))
stmts ((HsLetStmt decls stmts)::HsStmtP)
= do (df,dd) <-hsFreeAndDeclaredPNs decls
(sf,sd) <-hsFreeAndDeclaredPNs stmts
return (nub (df `union` (sf \\dd)),[]) -- dd)
stmts (HsGenerator _ pat exp stmts)
= do (pf,pd) <-hsFreeAndDeclaredPNs pat
(ef,ed) <-hsFreeAndDeclaredPNs exp
(sf,sd) <-hsFreeAndDeclaredPNs stmts
return (nub (pf `union` ef `union` (sf\\pd)),[]) -- pd)
stmts _ = mzero
-- | The same as `hsFDsFromInside` except that the returned variables are in the String format
hsFDNamesFromInside::(Term t, MonadPlus m)=>t->m ([String],[String])
hsFDNamesFromInside t =do (f,d)<-hsFDsFromInside t
return ((nub.map pNtoName) f, (nub.map pNtoName) d)
------------------------------------------------------------------------------------------
-- | Same as `hsVisiblePNs' except that the returned identifiers are in String format.
hsVisibleNames:: (Term t1, Term t2, FindEntity t1, MonadPlus m) => t1 -> t2 -> m [String]
hsVisibleNames e t =do d<-hsVisiblePNs e t
return ((nub.map pNtoName) d)
-- | Given syntax phrases e and t, if e occurs in t, then return those vairables
-- which are declared in t and accessible to e, otherwise return [].
hsVisiblePNs :: (Term t1, Term t2, FindEntity t1, MonadPlus m) => t1 -> t2 -> m [PName]
hsVisiblePNs e t =applyTU (full_tdTU (constTU [] `adhocTU` mod
`adhocTU` exp
`adhocTU` match
`adhocTU` patBind
`adhocTU` alt
`adhocTU` stmts)) t
where
mod ((HsModule loc modName exps imps decls)::HsModuleP)
|findEntity e decls
=do (df,dd)<-hsFreeAndDeclaredPNs decls
return dd
mod _=return []
exp ((Exp (HsLambda pats body))::HsExpP)
|findEntity e body
= do (pf,pd) <-hsFreeAndDeclaredPNs pats
return pd
exp (Exp (HsLet decls e1))
|findEntity e e1 || findEntity e decls
= do (df,dd)<- hsFreeAndDeclaredPNs decls
return dd
exp _ =return []
match (m@(HsMatch _ (PNT fun _ _) pats rhs decls)::HsMatchP)
|findEntity e rhs || findEntity e decls
= do (pf,pd) <- hsFreeAndDeclaredPNs pats
(df,dd) <- hsFreeAndDeclaredPNs decls
return (pd `union` dd `union` [fun])
match _=return []
patBind (p@(Dec (HsPatBind _ pat rhs decls))::HsDeclP)
|findEntity e rhs || findEntity e decls
=do (pf,pd) <- hsFreeAndDeclaredPNs pat
(df,dd) <- hsFreeAndDeclaredPNs decls
return (pd `union` dd)
patBind _=return []
alt ((HsAlt _ pat exp decls)::HsAltP)
|findEntity e exp || findEntity e decls
= do (pf,pd) <- hsFreeAndDeclaredPNs pat
(df,dd) <- hsFreeAndDeclaredPNs decls
return (pd `union` dd)
alt _=return []
stmts ((HsGenerator _ pat exp stmts) :: HsStmtP)
|findEntity e stmts
=do (pf,pd) <-hsFreeAndDeclaredPNs pat
return pd
stmts (HsLetStmt decls stmts)
|findEntity e decls || findEntity e stmts
=do (df,dd) <-hsFreeAndDeclaredPNs decls
return dd
stmts _ =return []
-------------------------------------------------------------------------------
{- | The HsDecls class -}
class (Term t) => HsDecls t where
-- | Return the declarations that are directly enclosed in the given syntax phrase.
hsDecls :: t->[HsDeclI PNT]
-- | Replace the directly enclosed declaration list by the given declaration list.
-- Note: This function does not modify the token stream.
replaceDecls :: t->[HsDeclI PNT]->t
-- | Return True if the specified identifier is declared in the given syntax phrase.
isDeclaredIn :: PName -> t->Bool
instance HsDecls HsMatchP where
hsDecls (HsMatch loc1 fun pats rhs ds)=ds
replaceDecls (HsMatch loc1 fun pats rhs ds) ds'
=(HsMatch loc1 fun pats rhs ds')
isDeclaredIn pn match@(HsMatch loc1 (PNT fun _ _) pats rhs ds)
=fromMaybe False ( do (_,d)<-hsFDsFromInside match
Just (elem pn (d \\ [fun])))
instance HsDecls HsDeclP where
hsDecls (Dec (HsPatBind loc p rhs ds))=ds
hsDecls (Dec (HsFunBind loc matches))=concatMap hsDecls matches
hsDecls _ =[]
replaceDecls (Dec (HsPatBind loc p rhs ds)) ds'
=Dec (HsPatBind loc p rhs ds')
replaceDecls x ds' =x
isDeclaredIn pn (Dec (HsPatBind loc p rhs ds))
= fromMaybe False (do (_, rd)<-hsFreeAndDeclaredPNs rhs
(_, dd)<-hsFreeAndDeclaredPNs ds
Just (elem pn (rd `union` dd)))
isDeclaredIn pn _ =False
instance HsDecls [HsDeclP] where
hsDecls ds=concatMap hsDecls ds
replaceDecls ds _ = ds -- This should not happen.
isDeclaredIn _ ds = False -- This should not happen.
instance HsDecls HsModuleP where
hsDecls (HsModule loc modName exps imps ds)=ds
replaceDecls (HsModule loc modName exps imps ds) ds'
= HsModule loc modName exps imps ds'
isDeclaredIn pn (HsModule loc modName exps imps ds)
=fromMaybe False (do (rf,rd)<-hsFreeAndDeclaredPNs ds
Just (elem pn rd))
instance HsDecls RhsP where
hsDecls rhs=fromMaybe [] (applyTU (stop_tdTU (failTU `adhocTU` inLet
`adhocTU` inAlt
`adhocTU` inStmt)) rhs)
where inLet ((Exp (HsLet ds e)) ::HsExpP)=Just ds
inLet _ =mzero
inAlt ((HsAlt _ p rhs ds)::HsAlt HsExpP HsPatP [HsDeclP])=Just ds
inStmt ((HsLetStmt ds _)::HsStmt HsExpP HsPatP [HsDeclP])=Just ds
inStmt _=mzero
replaceDecls rhs _ = rhs -- This should not happen.
isDeclaredIn _ _ = False -- This should not happen.
instance HsDecls HsExpP where
hsDecls rhs=fromMaybe [] (applyTU (stop_tdTU (failTU `adhocTU` inLet
`adhocTU` inAlt
`adhocTU` inStmt)) rhs)
where inLet ((Exp (HsLet ds e)) ::HsExpP)=Just ds
inLet (Exp (HsListComp (HsLetStmt ds stmts)))=Just ds
inLet (Exp (HsDo (HsLetStmt ds stmts)))=Just ds
inLet _ =Nothing
inAlt ((HsAlt _ p rhs ds)::HsAlt HsExpP HsPatP [HsDeclP])=Just ds
inStmt ((HsLetStmt ds _)::HsStmt HsExpP HsPatP [HsDeclP])=Just ds
inStmt _=Nothing
replaceDecls (Exp (HsLet ds e)) ds'
=if ds'==[]
then e
else (Exp (HsLet ds' e))
replaceDecls (Exp (HsListComp (HsLetStmt ds stmts))) ds'
=if ds'==[] && isLast stmts
then (Exp (HsList [fromJust (expInLast stmts)]))
else (Exp (HsListComp (HsLetStmt ds' stmts)))
where
isLast (HsLast e)=True
isLast _=False
expInLast (HsLast e)=Just e
expInLast _=Nothing
replaceDecls (Exp (HsDo (HsLetStmt ds stmts))) ds'
=if ds'==[]
then (Exp (HsDo stmts))
else (Exp (HsDo (HsLetStmt ds' stmts)))
replaceDecls x ds'=x
isDeclaredIn pn (Exp (HsLambda pats body))
= fromMaybe False (do (pf,pd) <-hsFreeAndDeclaredPNs pats
Just (elem pn pd))
isDeclaredIn pn (Exp (HsLet decls e))
=fromMaybe False (do (df,dd)<- hsFreeAndDeclaredPNs decls
Just (elem pn dd))
isDeclaredIn pn _=False
instance HsDecls HsStmtP where
hsDecls (HsLetStmt ds stmts)=ds
hsDecls _ = []
replaceDecls (HsLetStmt ds stmts) ds'
= if ds'/=[] then HsLetStmt ds' stmts
else stmts
isDeclaredIn pn (HsGenerator _ pat exp stmts) -- Claus
=fromMaybe False (do (pf,pd) <-hsFreeAndDeclaredPNs pat
Just (elem pn pd))
isDeclaredIn pn (HsLetStmt decls stmts)
=fromMaybe False (do (df,dd) <-hsFreeAndDeclaredPNs decls
Just (elem pn dd))
isDeclaredIn pn _=False
instance HsDecls HsAltP where
hsDecls (HsAlt _ p rhs ds)=ds
replaceDecls (HsAlt loc p rhs ds) ds'=HsAlt loc p rhs ds'
isDeclaredIn pn (HsAlt _ pat exp decls)
=fromMaybe False ( do (pf,pd) <- hsFreeAndDeclaredPNs pat
(df,dd) <- hsFreeAndDeclaredPNs decls
Just (elem pn (pd `union` dd)))
-------------------------------------------------------------------------------------------
class (Term a)=>FindEntity a where
-- | Returns True is a syntax phrase, say a, is part of another syntax phrase, say b.
findEntity:: (Term b)=> a->b->Bool
instance FindEntity HsDeclP where
findEntity d b
= (fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` inDec)) b)
where
inDec (d1::HsDeclP)
| d == d1 = Just True
inDec _ = Nothing
instance FindEntity HsExpP where
findEntity e b
=(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` inExp)) b)
where
inExp (e1::HsExpP)
| e==e1 =Just True
inExp _ =Nothing
instance FindEntity HsStmtP where
findEntity s b
=(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` inStmt)) b)
where
inStmt (s1::HsStmtP)
| s==s1 =Just True
inStmt _ =Nothing
instance FindEntity PName where
findEntity pn b
=(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` worker)) b)
where
worker (PNT pname _ _ )
|pname==pn= Just True
worker _ =Nothing
instance FindEntity PNT where
findEntity pnt b
=(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` worker)) b)
where
worker (pnt1::PNT)
|sameOccurrence pnt pnt1 = Just True
worker _ =Nothing
-------------------------------------------------------------------------------------------
class (Term a)=>FindEntityWithLocation a where
-- | Returns True is a syntax phrase, say a, is part of another syntax phrase, say b.
findEntityWithLocation:: (Term b)=> a->b->Bool
instance FindEntityWithLocation HsExpP where
findEntityWithLocation e b
=(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` inExp)) b)
where
inExp (e1::HsExpP)
| e==e1 && srcLocs e == srcLocs e1 =Just True
inExp _ =Nothing
instance FindEntityWithLocation HsStmtP where
findEntityWithLocation e b
= (fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` inStmt)) b)
where
inStmt (s1::HsStmtP)
| e == s1 && srcLocs e == srcLocs s1 = Just True
inStmt _ = Nothing
instance FindEntityWithLocation PName where
findEntityWithLocation pn b
=(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` worker)) b)
where
worker (PNT pname _ _ )
|pname==pn= Just True
worker _ =Nothing
instance FindEntityWithLocation PNT where
findEntityWithLocation pnt b
=(fromMaybe False)(applyTU (once_tdTU (failTU `adhocTU` worker)) b)
where
worker (pnt1::PNT)
|sameOccurrence pnt pnt1 = Just True
worker _ =Nothing
-----------------------------------------------------------------------------------------
-- Get the toks for a declaration, and adjust its offset to 0.
getDeclAndToks pn incSig toks t
= ghead "getDeclAndToks" $ applyTU (stop_tdTU (failTU `adhocTU` inDecls)) t
where
inDecls decls
|snd (break (defines pn) decls) /=[]
= return $ getDeclAndToks' pn incSig decls toks
inDecls x = mzero
getDeclAndToks' pn incSig decls toks
= let typeSig = if (not incSig)
then Nothing
else let (decls1,decls2) =break (definesTypeSig pn) decls
in if decls2==[] then Nothing else Just (ghead "getDeclAndToks" decls2)
(decls1', decls2') = break (defines pn) decls
decl = if decls2' == [] then error "getDeclAndToks:: declaration does not exisit"
else ghead "getDeclAndToks2" decls2'
offset = getOffset toks (fst (startEndLoc toks decl))
declToks =removeOffset offset $ getToks' decl toks
sigToks = case typeSig of
Nothing -> []
Just (sig@(Dec (HsTypeSig _ [i] _ _)))-> removeOffset offset $ getToks' sig toks
Just (Dec (HsTypeSig loc is c ty))-> let sig' =(Dec (HsTypeSig loc0 [nameToPNT (pNtoName pn)] c ty))
in tokenise (Pos 0 (-1111) 1) 0 True $ prettyprint sig'++"\n"
in (if isJust typeSig then [fromJust typeSig, decl] else [decl], (sigToks ++ declToks))
getToks' decl toks
= let (startPos, endPos) = startEndLocIncComments toks decl
(toks1, _) =let(ts1, (t:ts2'))= break (\t -> tokenPos t == endPos) toks
in (ts1++[t], ts2')
in dropWhile (\t -> tokenPos t /= startPos || isNewLn t) toks1
removeOffset offset toks
= let groupedToks = groupTokensByLine toks
in concatMap (doRmWhites offset) groupedToks
{-
-- THIS FUNCTION SHOULD NOT BE IN THE API.
-- | Get the list of tokens which represent the declaration that defines pn.
getDeclToks :: PName -- ^ The identifier.
-> Bool -- ^ True means type signature should be included.
-> [HsDeclP] -- ^ The declaration list in which the identifier is defined.
-> [PosToken] -- ^ The input token stream.
-> [PosToken] -- ^ The result.
-}
--- IMPORTANT: GET RID OF THE -1111*****************
getDeclToks pn incSig decls toks
= let (decls1,decls2) =break (definesTypeSig pn) decls
typeSig = if decls2==[] then Nothing else Just (ghead "getDeclToks1" decls2) --There may or may not type signature.
(decls1', decls2') = break (defines pn) decls
decl = if decls2' == [] then error "getDeclToks:: declaration does not exisit"
else ghead "getDeclToks2" decls2'
declToks = getToks' decl toks
sigToks
= case typeSig of
Nothing -> []
Just (sig@(Dec (HsTypeSig _ [i] _ _)))-> getToks' sig toks
Just (Dec (HsTypeSig loc is c ty))-> let sig' =(Dec (HsTypeSig loc0 [nameToPNT (pNtoName pn)] c ty))
in tokenise (Pos 0 (-1111) 1) 0 True $ prettyprint sig'++"\n"
in if incSig then sigToks ++ declToks else declToks
where
getToks' decl toks
= let (startPos, endPos) = startEndLocIncComments toks decl
(toks1, _) =let(ts1, (t:ts2'))= break (\t -> tokenPos t == endPos) toks
in (ts1++[t], ts2')
in dropWhile (\t -> tokenPos t /= startPos || isNewLn t) toks1
inRegion t toks beginPos endPos
=let (sLoc', eLoc')={-getStartEndLoc-} startEndLoc toks t
(sLoc,eLoc)=extendBothSides toks sLoc' eLoc' isWhite isWhite
in beginPos>=sLoc && beginPos<=eLoc
applyRefac refac Nothing fileName
= do (inscps, exps, mod, toks)<-parseSourceFile fileName
(mod',((toks',m),_))<-runStateT (refac (inscps, exps, mod)) ((toks,False), (-1000,0))
return ((fileName,m),(toks',mod'))
applyRefac refac (Just (inscps, exps, mod, toks)) fileName
= do (mod',((toks',m),_))<-runStateT (refac (inscps, exps, mod)) ((toks,False), (-1000,0))
return ((fileName,m),(toks', mod'))
applyRefacToClientMods refac fileName
= do clients <- clientModsAndFiles =<< fileNameToModName fileName
mapM (applyRefac refac Nothing) (map snd clients)
{-
--this function try to find an identifier through a textual interface. More details will be added.
findPNByPath::String->HsModuleP->Either String PName
findPNByPath path mod
= case findDeclByPath path mod of
Left errMsg -> Left errMsg
Right decl -> Right $ head $ definedPNs decl
where
findDeclByPath path mod
= let names = extractPath path
in findPNByPath' names (hsModDecls mod)
extractPath path = extractPath' [] path
extractPath' r path =
case span (/='.') path of
(name, "") -> r++[name]
(name, subPath) -> extractPath' (r++[name]) (tail subPath)
findPNByPath' (name:names) [] = Left "Can not find the declaration"
findPNByPath' (name:names) decls
= let decl = findDeclByName name decls
in if decl==[] then Left "Can not find the declaration"
else if names==[] then Right (head decl)
else findPNByPath' names (hsDecls (head decl))
findDeclByName name decls = filter definesName decls
where
definesName (Dec (HsFunBind _ ((HsMatch _ (PNT pn _ _) _ _ _):_)))
= pNtoName pn == name
definesName (Dec (HsPatBind _ p _ _)) = name == (pNtoName.head.hsPNs) p
definesName _ = False
-}
-- checkTypes takes a string representation of a type, and the name of a pattern match or function
-- checkTypes calls the ghc typechecker, and returns True if the data type appears within the
-- type of the function.
-- checkTypes also removes the return type of the fuction/pattern as we are only interested in
-- the type of the arguments.
-- checkTypes :: String -> String -> Bool
checkTypes dat name modName fileName = or (map (ordSubset dat) (tails (ghcTypeCheck1 name modName fileName)))
getTypes expr modName fileName = lines2 (ghcTypeCheck1 expr modName fileName)
cleanTypes types = map (reverse. removeGHCBracket . removeGHC . reverse) types
getContext x = (res1, res2)
where
res1 = reverse $ {-removeBracket $ removeContextGHC $-} reverse con
res2 = head $ cleanTypes [last (createContext x)]
con
| length (createContext x) == 1 = []
| otherwise = head (createContext x)
removeGHC [] = []
-- removeGHC (']':xs) = ']' : ((removeGHC xs) ++ "[" )
removeGHC (x:xs)
| x == '.' = removeGHC xs2
| otherwise = x : (removeGHC xs)
where
(_, xs2) = break (\x -> x==' ' || x == '[' || x == '(') xs
removeContextGHC [] = []
removeContextGHC (']':xs) = ']' : ((removeContextGHC xs) ++ "[" )
removeContextGHC (x:xs)
| x == '.' = []
| otherwise = x : (removeContextGHC xs)
removeBracket [] = []
removeBracket (')':'(':xs) = ")(" ++ (removeBracket xs)
removeBracket (x:xs)
| x == '(' = xs
| otherwise = x : (removeBracket xs)
removeGHCBracket [] = []
removeGHCBracket (')':'(':xs) = ")(" ++ (removeBracket xs)
removeGHCBracket (x:xs)
| x == ')' = (x : xs)
| otherwise = x : (removeBracket xs)
-- checkTypes2 is the same as checkTypes, the only difference is that it returns
-- which argument (the arity) is of the type in question.
-- currently it returns the number of the first argument of the type in question.
checkTypes2 dat name modName fileName
| res /= [] = (True, res2)
| otherwise = (False, [])
where
res = findArity (lines2 (ghcTypeCheck1 name modName fileName)) dat
(res2, _) = splitAt (length res -1) res
checkTypesInPat dat pats modName fileName
= (False, (res (convertPats pats)))
where
res [] = [([],"")]
res (x:xs)
| x == "NULL" = ([0],"") : (res xs)
| otherwise = ((init (findArity (lines2 (ghcTypeCheck1 x modName fileName)) dat) ), x) : (res xs)
convertPats [] = []
convertPats ((Pat (HsPParen (Pat (HsPApp i _)))):xs) = (pNtoName (pNTtoPN i)) : convertPats xs
-- convertPats ((HsPApp (HsCon i) [p]):xs) = (pNtoName (pNTtoPN i)) : convertPats xs
convertPats (x:xs) = "NULL" : convertPats xs
findArity :: Eq a => [[a]] -> [a] -> [Int]
findArity [] _ = []
findArity (x:xs) p
| or (map (ordSubset p) (tails x)) = 1 : (findArity xs p)
| otherwise = 0 : (findArity xs p)
--lines2 :: Eq a => [a] -> [[a]]
createContext [] = []
createContext (x:xs)
= l : ls
where
(l, xs') = break (== '=') (x:xs)
(l2, xs'') = break (== '>') xs'
ls
| xs'' == [] = []
| otherwise = createContext (tail xs'')
lines2 [] = []
lines2 (x:xs)
= l : ls
where
(l, xs') = break (== '-') (x:xs)
(l2,xs'') = break (=='>') xs'
ls
| xs'' == [] = []
| otherwise = lines2 (tail xs'')
getDataName :: Term t => t -> String
getDataName t
= fromMaybe ""
(applyTU (once_tdTU (failTU `adhocTU` inData)) t)
where
inData ((HsTyCon (PNT (PN (UnQual x)_) _ _)) :: TI PNT HsTypeP)
= Just x
inData _ = mzero
ordSubset :: Eq a => [a] -> [a] -> Bool
ordSubset [] _ = True
ordSubset _ [] = False
ordSubset (x:xs) (y:ys)
| x == y = True && (ordSubset xs ys)
| x /= y = False && (ordSubset (x:xs) ys)
| otherwise = False
{-|
createFuncFromPat takes the function name and a list of expressions to be
used in the call. createFunc then creates a function application
based on the expressions in the second argument.
-}
createFuncFromPat :: PNT -> [HsExpP] -> HsExpP
createFuncFromPat _ [] = defaultExp
createFuncFromPat pat [exp]
= (Exp (HsApp (Exp (HsId (HsCon pat))) exp))
createFuncFromPat pat (exp:exps)
= createFunc' (Exp (HsId (HsCon (pat)))) (exp:exps)
createDataFunc :: PNT -> [HsTypeP] -> HsTypeP
createDataFunc pat [] = (Typ (HsTyCon pat))
createDataFunc pat [typ]
= (Typ (HsTyApp (Typ (HsTyCon pat)) typ))
createDataFunc pat (typ:typs)
= createTypFunc' (Typ (HsTyCon pat)) (typ:typs)
{-|
createTypFun takes the data type name and a list of types to be
used in the declaration. createTypFunc then creates a data type application
based on the types in the second argument.
-}
createTypFunc :: PNT -> [HsTypeP] -> HsTypeP
createTypFunc _ [] = defaultTyp
createTypFunc pat [typ]
= (Typ (HsTyApp (Typ (HsTyCon pat)) typ))
createTypFunc pat (typ:typs)
= createTypFunc' (Typ (HsTyCon pat)) (typ:typs)
-- | createFunc' is used by createFunc to build up a function application
createTypFunc' :: HsTypeP -> [HsTypeP] -> HsTypeP
createTypFunc' typ [x]
= (Typ (HsTyApp typ x))
createTypFunc' typ (x:xs)
= (createTypFunc' (Typ (HsTyApp (typ) x)) xs)
{-|
createFunc takes the function name and a list of expressions to be
used in the call. createFunc then creates a function application
based on the expressions in the second argument.
-}
createFunc :: PNT -> [HsExpP] -> HsExpP
createFunc n [] = (Exp (HsId (HsVar n)))
createFunc pat [exp]
= (Exp (HsApp (Exp (HsId (HsVar pat))) exp))
createFunc pat (exp:exps)
= createFunc' (Exp (HsId (HsVar (pat)))) (exp:exps)
-- | createFunc' is used by createFunc to build up a function application
createFunc' :: HsExpP -> [HsExpP] -> HsExpP
createFunc' exp [x]
= (Exp (HsApp exp x))
createFunc' exp (x:xs)
= (createFunc' (Exp (HsApp (exp) x)) xs)
-- | call the GHC typechecker to return a typed String
getSig fileName modName name
= do
let types = getTypes name modName fileName
-- error $ show types
let types1 = cleanTypes (tail types)
-- error $ show types1
let (context, l) = getContext (head types)
let types2 = l : types1
-- let context2 = init context
let types3 = map (filter (/= '\n')) types2
let newSig = createTypeSig name context types3
-- error $ show newSig
return newSig
getSigAsString fileName modName name
= do
let types = getTypes name modName fileName
-- error $ show types
let types1 = cleanTypes (tail types)
-- error $ show types1
let (context, l) = getContext (head types)
let types2 = l : types1
-- let context2 = init context
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)
getSigOmitLast modName name fileName
= do
let types = getTypes name modName fileName
-- error $ show types
let types1 = cleanTypes (tail types)
-- error $ show types1
let (context, l) = getContext (head types)
let types2 = l : types1
-- let context2 = init context
let types3 = map (filter (/= '\n')) types2
let newSig = createTypeSig name context (init types3)
-- error $ show newSig
return newSig
-- | createTypeSig :: String -> [String] -> [String] -> HsDeclP
createTypeSig name [] types
= Dec (HsTypeSig loc0 [nameToPNT name] [] (createApplication types))
createTypeSig name context types
= Dec (HsTypeSig loc0 [nameToPNT name] [(Typ (HsTyVar (nameToPNT context)))] (createApplication types))
createApplication [var]
= (Typ (HsTyVar (nameToTypePNT var)))
createApplication (v:vars)
= Typ (HsTyVar (nameToTypePNT (v ++ (concatMap (" -> "++) vars))))
where
myConcat :: [ String ] -> String
myConcat [] = []
myConcat (x:xs) = (x ++ " -> ") ++ (myConcat xs)
createApplication' x [y]
= (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y)))))
createApplication' x (y:ys)
= (createApplication' (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y))))) ys)
findType pnt t
= applyTU (stop_tdTU (failTU `adhocTU` inSig)) t
where
inSig (dec@(Dec (HsTypeSig _ _ _ _))::HsDeclP)
= do
let res = definesTypeSig (pNTtoPN pnt) dec
if res == True
then return [True]
else fail ""
inSig _ = fail ""
nameToTypePNT :: String -> PNT
nameToTypePNT id = (PNT (PN (UnQual id) (S loc0)) (Type (TypeInfo {defType = Nothing, constructors = [], fields = []})) (N (Just loc0)))