diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2015-10-04 v0.8.0.0 + * Major rework, replacing haskell-token-utils with ghc-exactprint + * Now supports GHC 7.10.2 and up. ONLY. + * Functionally equivalent to v0.7.2.8 2014-10-13 v0.7.2.8 lower bounds on parsec and haskell-token-utils 2014-08-20 v0.7.2.7 @@ -87,18 +91,18 @@ * Now able to get tokens for a file pre-processed with CPP. But it is the pre-processed output, so the CPP directives are stripped out when writing out the refactored source. - + 2013-09-11 v0.7.0.4 * Correct Haddock compile error. Close #4 * hsWithBndrs only exists for GHC > 7.4.x 2013-09-10 v0.7.0.3 - + * Fix elisp, would not commit refactoring due to missing methods - + 2013-09-08 v0.7.0.2 * Fix issue #3: ifToCase formatting - + 2013-09-05 v0.7.0.1 * Fix issue #2: elisp diff --git a/HaRe.cabal b/HaRe.cabal --- a/HaRe.cabal +++ b/HaRe.cabal @@ -1,5 +1,5 @@ Name: HaRe -Version: 0.7.2.8 +Version: 0.8.0.0 Author: Chris Brown, Huiqing Li, Simon Thompson, Alan Zimmerman Maintainer: Alan Zimmerman Stability: Alpha @@ -11,50 +11,118 @@ A Haskell 2010 refactoring tool. HaRe supports the full Haskell 2010 standard, through making use of the GHC API. . - It is tested against GHC 7.4.x and 7.6.x (via travis-ci.org) + Version 0.7.2.8 supports up to GHC 7.6.3. . + There is no support for GHC 7.8.x. There will never be support for GHC 7.8.x + . + From version 0.8.0.0, GHC 7.10.2 is supported. + . + It is tested against GHC 7.10.2 (via travis-ci.org) + . It currently only has emacs integration built in, community input welcome for others. . - Warning: This is alpha code. Always commit code to your version - control system before refactoring. The developers make no - warranties, use at your own risk. - . - Despite the disclaimer, HaRe attempts to operate in a safe way, by - first writing new files with proposed changes, and only swapping - these with the originals when the change is accepted. In the - process the original file is renamed to have the current date/time - as a suffix. Thus it should be possible to (manually) undo changes. + HaRe attempts to operate in a safe way, by first writing new files with + proposed changes, and only swapping these with the originals when the change + is accepted. In the process the original file is renamed to have the current + date/time as a suffix. Thus it should be possible to (manually) undo changes. . - The renaming refactoring seems reasonably reliable, as does lifting - and demoting + Even so, it is strongly advised to back up any source files before + refactoring, as we can make no promises as to the reliability of this tool. + Use at your own risk. . At the moment parsing of any file with FFI exports will fail. . - + See Language.Haskell.Refact.HaRe for the current list of refactorings supported + . Synopsis: the Haskell Refactorer. Category: Development, Refactoring Cabal-Version: >= 1.8 Build-Type: Simple + +tested-with: GHC == 7.10.2 + data-files: elisp/*.el + configure.sh + test/testdata/*.cabal + test/testdata/*.hs + test/testdata/Case/*.hs + test/testdata/Case/*.hs.expected + test/testdata/Case/*.hs.expected.dd + test/testdata/Demote/*.expected.hs + test/testdata/Demote/*.hs + test/testdata/Demote/*.hs.expected + test/testdata/DupDef/*.hs + test/testdata/DupDef/*.hs.expected + test/testdata/DupDef/*.hs.expected.dd + test/testdata/DupDef/*.hs.expected.gg + test/testdata/DupDef/*.hs.expected.ll + test/testdata/DupDef/*.hs.expected.mm + test/testdata/DupDef/*.hs.expected.nn + test/testdata/FreeAndDeclared/*.hs + test/testdata/Layout/*.hs + test/testdata/Layout/*.hs.expected + test/testdata/LiftOneLevel/*.hs + test/testdata/LiftOneLevel/*.hs.expected + test/testdata/LiftToToplevel/*.expected.hs + test/testdata/LiftToToplevel/*.hs + test/testdata/LiftToToplevel/*.hs.expected + test/testdata/MoveDef/*.hs + test/testdata/MoveDef/*.hs.expected + test/testdata/Renaming/*.expected.hs + test/testdata/Renaming/*.hs + test/testdata/Renaming/*.hs.expected + test/testdata/Simple/*.hs + test/testdata/Simple/*.hs.expected + test/testdata/SwapArgs/*.hs + test/testdata/TH/*.hs + test/testdata/TypeUtils/*.hs + test/testdata/Visible/*.hs + test/testdata/cabal/cabal1/*.cabal + test/testdata/cabal/cabal1/*.hs + test/testdata/cabal/cabal1/src/*.hs + test/testdata/cabal/cabal1/src/Foo/*.hs + test/testdata/cabal/cabal2/*.cabal + test/testdata/cabal/cabal2/*.hs + test/testdata/cabal/cabal2/src/*.hs + test/testdata/cabal/cabal2/src/Foo/*.hs + test/testdata/cabal/cabal3/*.cabal + test/testdata/cabal/cabal3/*.hs + test/testdata/cabal/cabal3/src/*.hs + test/testdata/cabal/cabal3/src/Foo/*.hs + test/testdata/cabal/cabal4/*.cabal + test/testdata/cabal/cabal4/*.hs + test/testdata/cabal/cabal4/src/*.expected.hs + test/testdata/cabal/cabal4/src/*.hs + test/testdata/cabal/cabal4/src/Foo/*.expected.hs + test/testdata/cabal/cabal4/src/Foo/*.hs + test/testdata/cabal/foo/*.cabal + test/testdata/cabal/foo/*.hs + test/testdata/cabal/foo/src/*.expected.hs + test/testdata/cabal/foo/src/*.hs + test/testdata/cabal/foo/src/Foo/*.expected.hs + test/testdata/cabal/foo/src/Foo/*.hs + data-Dir: . extra-source-files: ChangeLog Library - Build-Depends: base >= 4.0 && < 4.8 + -- GHC 7.10.2 ships with base 4.8.1.0 + Build-Depends: base >= 4.8.1.0 && < 4.9 , containers , directory - , dual-tree + -- , dual-tree , semigroups , monoid-extras + , cabal-helper , filepath , ghc , ghc-paths , ghc-prim , ghc-syb-utils - , ghc-mod >= 4.1.0 && < 5 + , ghc-mod >= 5.4 , mtl , old-time , pretty @@ -62,13 +130,16 @@ , syb , hslogger , transformers + , transformers-base , time , Strafunski-StrategyLib , syz - - , haskell-token-utils >= 0.0.0.6 + , ghc-exactprint >= 0.4.1 + , monad-control + , Cabal >= 1.22 + -- , uniplate - GHC-Options: -Wall + -- GHC-Options: -Wall -O0 Hs-Source-Dirs: src -- Other-Modules: Paths_HaRe @@ -79,8 +150,11 @@ , Language.Haskell.Refact.Refactoring.DupDef , Language.Haskell.Refact.Refactoring.MoveDef , Language.Haskell.Refact.Refactoring.Renaming + , Language.Haskell.Refact.Refactoring.RoundTrip , Language.Haskell.Refact.Refactoring.SwapArgs + , Language.Haskell.Refact.Refactoring.Simple , Language.Haskell.Refact.Utils.Binds + , Language.Haskell.Refact.Utils.ExactPrint , Language.Haskell.Refact.Utils.GhcBugWorkArounds , Language.Haskell.Refact.Utils.GhcModuleGraph , Language.Haskell.Refact.Utils.GhcUtils @@ -88,37 +162,60 @@ , Language.Haskell.Refact.Utils.LocUtils , Language.Haskell.Refact.Utils.Monad , Language.Haskell.Refact.Utils.MonadFunctions - , Language.Haskell.Refact.Utils.TokenUtils , Language.Haskell.Refact.Utils.TypeSyn , Language.Haskell.Refact.Utils.TypeUtils + , Language.Haskell.Refact.Utils.Types , Language.Haskell.Refact.Utils.Utils + , Language.Haskell.Refact.Utils.Variables , Paths_HaRe - Extensions: CPP - + if impl (ghc < 7.10.2) + buildable: False Executable ghc-hare Main-Is: MainHaRe.hs -- Other-Modules: Paths_HaRe - GHC-Options: -Wall + -- GHC-Options: -Wall -O0 -- GHC-Options: -prof -fprof-auto -rtsopts -caf-all Hs-Source-Dirs: ./src - Build-Depends: base >= 4.0 && < 4.8 + other-modules: + Language.Haskell.Refact.API + , Language.Haskell.Refact.HaRe + , Language.Haskell.Refact.Refactoring.Case + , Language.Haskell.Refact.Refactoring.RoundTrip + , Language.Haskell.Refact.Utils.Binds + , Language.Haskell.Refact.Utils.ExactPrint + , Language.Haskell.Refact.Utils.GhcModuleGraph + , Language.Haskell.Refact.Utils.GhcUtils + , Language.Haskell.Refact.Utils.GhcVersionSpecific + , Language.Haskell.Refact.Utils.LocUtils + , Language.Haskell.Refact.Utils.Monad + , Language.Haskell.Refact.Utils.MonadFunctions + , Language.Haskell.Refact.Utils.TypeSyn + , Language.Haskell.Refact.Utils.TypeUtils + , Language.Haskell.Refact.Utils.Types + , Language.Haskell.Refact.Utils.Utils + , Language.Haskell.Refact.Utils.Variables + , Paths_HaRe + + -- GHC 7.10.2 ships with base 4.8.1.0 + Build-Depends: base >= 4.8.1.0 && < 4.9 , array , containers , directory - , dual-tree + -- , dual-tree , semigroups , monoid-extras + , cabal-helper , filepath , ghc , ghc-paths , ghc-prim , ghc-syb-utils - , ghc-mod >= 4.1.0 && < 5 + , ghc-mod >= 5.4 , mtl , old-time , parsec >= 3.1.6 @@ -127,18 +224,24 @@ , syb , time , transformers + , transformers-base , hslogger , Strafunski-StrategyLib , syz - , haskell-token-utils >= 0.0.0.6 - , HaRe >= 0.7.2.3 + , ghc-exactprint >= 0.4.1 + , monad-control + , Cabal >= 1.22 + -- , Paths_HaRe + , HaRe >= 0.8 Extensions: CPP - + if impl (ghc < 7.10.2) + buildable: False test-suite spec type: exitcode-stdio-1.0 ghc-options: + -- -O0 -- reinstate these later -Wall -- -Wall -- reinstate these later -Werror @@ -151,27 +254,41 @@ Hs-Source-Dirs: -- src test + other-modules: + CaseSpec + , DupDefSpec + , GhcUtilsSpec + , LocUtilsSpec + , MonadFunctionsSpec + , MoveDefSpec + , RenamingSpec + , RoundTripSpec + , SimpleSpec + , SwapArgsSpec + , TestUtils + , TypeUtilsSpec + , UtilsSpec build-depends: - base >= 4.0 && < 4.8 + -- GHC 7.10.2 ships with base 4.8.1.0 + base >= 4.8.1.0 && < 4.9 , Diff >= 0.3.0 - -- , HUnit == 1.2.* , HUnit , QuickCheck >= 2.5 , containers - , dual-tree + -- , dual-tree , semigroups , monoid-extras , deepseq , directory , filepath - , ghc >= 7.0.1 && < 7.8 + , ghc -- , ghc-paths == 0.1.* , ghc-paths , ghc-prim , ghc-syb-utils - , ghc-mod >= 4.1.0 && < 5 + , ghc-mod >= 5.4 , hspec , mtl , old-time @@ -181,20 +298,27 @@ , rosezipper , syb , transformers + , transformers-base , time , hslogger , Strafunski-StrategyLib , syz - , haskell-token-utils >= 0.0.0.6 - , HaRe >= 0.7.2.3 + , ghc-exactprint >= 0.4.1 + , monad-control + , Cabal >= 1.22 + -- , uniplate + -- , Paths_HaRe + -- , haskell-token-utils >= 0.0.0.6 + , HaRe >= 0.8 Extensions: CPP - + if impl (ghc < 7.10.2) + buildable: False -- test-suite doctests -- type: exitcode-stdio-1.0 -- ghc-options: -threaded -- main-is: doctests.hs --- build-depends: base >= 4.0 && < 4.8 +-- build-depends: base >= 4.0 && < 4.9 -- , doctest >= 0.8 -- , ghc-mod -- Hs-Source-Dirs: diff --git a/configure.sh b/configure.sh new file mode 100644 --- /dev/null +++ b/configure.sh @@ -0,0 +1,14 @@ +#!/bin/sh + +# This script is temporary until ghc-mod is fixed to reconfigure on change + +cabal clean && cabal configure --enable-tests --disable-optimization + +# Make sure the tests run against the newly installed environment +(cd test/testdata && cabal clean && cabal configure) + +(cd test/testdata/cabal/cabal1 && cabal clean && cabal configure) +(cd test/testdata/cabal/cabal2 && cabal clean && cabal configure) +(cd test/testdata/cabal/cabal3 && cabal clean && cabal configure) +(cd test/testdata/cabal/cabal4 && cabal clean && cabal configure) +(cd test/testdata/cabal/foo && cabal clean && cabal configure) diff --git a/elisp/hare.el b/elisp/hare.el --- a/elisp/hare.el +++ b/elisp/hare.el @@ -91,6 +91,7 @@ (define-key haskell-mode-map "\C-c\C-rlo" 'hare-refactor-lift-one) (define-key haskell-mode-map "\C-c\C-rlt" 'hare-refactor-lifttotop) (define-key haskell-mode-map "\C-c\C-rr" 'hare-refactor-rename) + (define-key haskell-mode-map "\C-c\C-rt" 'hare-refactor-roundtrip) (define-key haskell-mode-map "\C-c\C-rsh" 'hare-refactor-show) (hare-init-menu) (setq hare-initialized t))) @@ -112,7 +113,8 @@ (define-key haskell-mode-map [menu-bar mymenu lo] '("Lift one level" . hare-refactor-lift-one)) (define-key haskell-mode-map [menu-bar mymenu lt] '("Lift to top level" . hare-refactor-lifttotop)) (define-key haskell-mode-map [menu-bar mymenu r ] '("Rename" . hare-refactor-rename)) - (define-key haskell-mode-map [menu-bar mymenu sh ] '("Show" . hare-refactor-show)) + (define-key haskell-mode-map [menu-bar mymenu r ] '("Round trip" . hare-refactor-roundtrip)) + (define-key haskell-mode-map [menu-bar mymenu sh ] '("Show" . hare-refactor-show)) ) (defun hare-init-interactive () @@ -1048,6 +1050,23 @@ (if (buffers-saved) (hare-refactor-command current-file-name line-no column-no `("rename" ,current-file-name ,name + ,(number-to-string line-no) ,(number-to-string column-no) + ) + hare-search-paths 'emacs tab-width) + (message "Refactoring aborted.")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hare-refactor-roundtrip () + "Round trip a source file, to check HaRe plumbing." + (interactive) + (let ((current-file-name (buffer-file-name)) + (line-no (current-line-no)) + (column-no (current-column-no)) + (buffer (current-buffer))) + (if (buffers-saved) + (hare-refactor-command current-file-name line-no column-no + `("roundtrip" ,current-file-name ,(number-to-string line-no) ,(number-to-string column-no) ) hare-search-paths 'emacs tab-width) diff --git a/src/Language/Haskell/Refact/API.hs b/src/Language/Haskell/Refact/API.hs --- a/src/Language/Haskell/Refact/API.hs +++ b/src/Language/Haskell/Refact/API.hs @@ -17,22 +17,15 @@ , getRefacSettings , defaultSettings , logSettings - , initGhcSession - , loadModuleGraphGhc - , ensureTargetLoaded - , canonicalizeGraph - , logm + , logDataWithAnns -- * from `Language.Haskell.Refact.Utils.Utils` -- ** Managing the GHC / project environment - -- , loadModuleGraphGhc - , getModuleGhc , parseSourceFileGhc - , activateModule - , getModuleDetails + , getTargetGhc -- ** The bits that do the work , runRefacSession @@ -41,8 +34,7 @@ , ApplyRefacResult , RefacSource(..) - , update - , fileNameToModName + , nameSybQuery , fileNameFromModSummary , getModuleName , clientModsAndFiles @@ -53,44 +45,27 @@ -- ** Conveniences for state access - -- , fetchToksFinal - , fetchLinesFinal - , fetchOrigToks - , fetchToks -- Deprecated , getTypecheckedModule + , RefacResult(..) , getRefactStreamModified + , setRefactStreamModified , getRefactInscopes , getRefactRenamed , putRefactRenamed , getRefactParsed + , putRefactParsed , putParsedModule , clearParsedModule , getRefactFileName - - -- ** TokenUtils API - , replaceToken - , putToksForSpan - , putDeclToksForSpan - , getToksForSpan - -- , getToksForSpanNoInv - -- , getToksForSpanWithIntros - , getToksBeforeSpan - , putToksForPos - , addToksAfterSpan - , addToksAfterPos - , putDeclToksAfterSpan - , removeToksForSpan - , removeToksForPos - , syncDeclToLatestStash - , indentDeclAndToks + , getRefactTargetModule + , getRefactNameMap - -- ** LayoutUtils API + , getRefactModule + , getRefactModuleName - -- ** For debugging - , drawTokenTree - , drawTokenTreeDetailed - , getTokenTree - , showLinesDebug + -- * New ghc-exactprint interfacing + -- , refactRunTransform + , liftT -- ** State flags for managing generic traversals , getRefactDone @@ -102,108 +77,21 @@ -- , logm - , updateToks - , updateToksWithPos -- * from `Language.Haskell.Refact.Utils.LocUtils` - , SimpPos,unmodified,modified - , simpPos0 - , nullSrcSpan - -- , showToks - , whiteSpaceTokens - , realSrcLocFromTok - , isWhite - , notWhite - , isWhiteSpace - , isWhiteSpaceOrIgnored - , isIgnored - , isIgnoredNonComment - {- - ,isNewLn,isCommentStart -},isComment {-, - isNestedComment-},isMultiLineComment {-,isOpenBracket,isCloseBracket, -} - ,isOpenSquareBracket,isCloseSquareBracket {- ,isOpenBrace,isConid, - isLit,isWhereOrLet,isWhere,isLet-},isIn {- ,isCase,isDo,isIf,isForall, - isHiding,isModule-} ,isComma {-,isEqual,isLambda,isIrrefute -},isBar --,isMinus, - ,endsWithNewLn,startsWithNewLn,hasNewLn {- ,startsWithEmptyLn, - lastNonSpaceToken,firstNonSpaceToken -} ,compressPreNewLns,compressEndNewLns + , SimpPos - , lengthOfLastLine - , getToks - -- , replaceToks,replaceTok - ,replaceTokNoReAlign,deleteToks,doRmWhites -- ,doAddWhites - , srcLocs - , getSrcSpan, getAllSrcLocs - -- , ghcSrcLocs -- Test version - -- , getLocatedStart - -- , getLocatedEnd - , getBiggestStartEndLoc - {- - , getStartEndLoc2, - startEndLoc,extendBothSides -},extendForwards,extendBackwards - , startEndLocIncFowComment{- ,startEndLocIncFowNewLn -} - , startEndLocIncComments, startEndLocIncComments' - , tokenise - , basicTokenise - , prettyprintPatList - , groupTokensByLine - , toksOnSameLine - , addLocInfo - -- , getIndentOffset - , getLineOffset - -- , splitToks - -- , splitOnNewLn - {- - , insertComments, - extractComments, insertTerms - -} - , tokenCol - , tokenColEnd - , tokenRow - , tokenPos - , tokenPosEnd - , tokenSrcSpan - , tokenCon - , increaseSrcSpan , getGhcLoc , getGhcLocEnd , getLocatedStart , getLocatedEnd , getStartEndLoc , startEndLocGhc - , realSrcLocEndTok - , fileNameFromTok - , splitToks , emptyList, nonEmptyList - -- , divideComments - , notWhiteSpace - , isDoubleColon - , isEmpty - , isWhereOrLet - , isWhere - , isLet - , isElse - , isThen - , isOf - , isDo - , getIndentOffset - , splitOnNewLn - , tokenLen - , newLnToken - -- , newLinesToken - -- , monotonicLineToks - , reSequenceToks - , mkToken - , mkZeroToken - , markToken - , isMarked - , addOffsetToToks - , matchTokenPos - , rmOffsetFromToks -- * from `Language.Haskell.Refact.Utils.TypeSyn` , InScopes - , PosToken , ghead , glast , gtail @@ -214,139 +102,116 @@ -- ** Program Analysis -- ** Imports and exports , inScopeInfo, isInScopeAndUnqualified, isInScopeAndUnqualifiedGhc, inScopeNames - -- , hsQualifier, {-This function should be removed-} rmPrelude - {-,exportInfo -}, isExported, isExplicitlyExported, modIsExported + , isExported, isExplicitlyExported, modIsExported + , equivalentNameInNewMod -- *** Variable analysis , isFieldName , isClassName , isInstanceName - ,hsPNs -- ,hsDataConstrs,hsTypeConstrsAndClasses, hsTypeVbls - {- ,hsClassMembers -} , hsBinds, replaceBinds, HsValBinds(..) - ,isDeclaredIn + , hsPNs + , hsBinds + , HsValBinds(..) + ,isDeclaredIn,isDeclaredInRdr + ,FreeNames(..),DeclaredNames(..) ,hsFreeAndDeclaredPNsOld, hsFreeAndDeclaredNameStrings + ,hsFreeAndDeclaredRdr ,hsFreeAndDeclaredPNs ,hsFreeAndDeclaredGhc ,getDeclaredTypes ,getFvs, getFreeVars, getDeclaredVars -- These two should replace hsFreeAndDeclaredPNs - ,hsVisiblePNs {- , hsVisiblePNsOld -}, hsVisibleNames + ,hsVisiblePNs, hsVisiblePNsRdr, hsVisibleNames + ,hsVisibleNamesRdr + ,hsFDsFromInsideRdr, hsFDNamesFromInsideRdr ,hsFDsFromInside, hsFDNamesFromInside ,hsVisibleDs + ,rdrName2Name, rdrName2NamePure -- *** Property checking ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName -- ,isTopLevelPNT - ,isQualifiedPN {- , isFunName, isPatName-}, isFunOrPatName {-,isTypeCon-} ,isTypeSig - ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind - ,isComplexPatBind,isFunOrPatBindP,isFunOrPatBindR -- ,isClassDecl,isInstDecl -- ,isDirectRecursiveDef - ,usedWithoutQualR {- ,canBeQualified, hasFreeVars -},isUsedInRhs + ,isQualifiedPN, isFunOrPatName,isTypeSig + ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind,isSimplePatDecl + ,isComplexPatBind,isComplexPatDecl,isFunOrPatBindP,isFunOrPatBindR + ,usedWithoutQualR,isUsedInRhs + ,findNameInRdr ,findPNT,findPN,findAllNameOccurences - ,findPNs, findEntity, findEntity' + ,findPNs, findNamesRdr, findEntity, findEntity' ,sameOccurrence , findIdForName , getTypeForName - ,defines, definesP,definesTypeSig -- , isTypeSigOf - -- ,HasModName(hasModName), HasNameSpace(hasNameSpace) - ,sameBind - {- ,usedByRhs -},UsedByRhs(..) + ,defines, definesP,definesTypeSig + ,sameBind,sameBindRdr + ,UsedByRhs(..) -- *** Modules and files - -- ,clientModsAndFiles,serverModsAndFiles,isAnExistingMod - -- ,fileNameToModName, strToModName, modNameToStr , isMainModule , getModule -- *** Locations - ,defineLoc, useLoc, locToExp -- , getStartEndLoc + ,defineLoc, useLoc, locToExp ,locToName, locToRdrName ,getName -- * Program transformation -- *** Adding - ,addDecl, addItemsToImport, addHiding --, rmItemsFromImport, addItemsToExport - ,addParamsToDecls, addActualParamsToRhs {- , addGuardsToRhs-}, addImportDecl, duplicateDecl -- , moveDecl + ,addDecl, addItemsToImport, addHiding + ,addParamsToDecls, addActualParamsToRhs, addImportDecl, duplicateDecl -- , moveDecl -- *** Removing - ,rmDecl, rmTypeSig, rmTypeSigs -- , commentOutTypeSig, rmParams - -- ,rmItemsFromExport, rmSubEntsFromExport, Delete(delete) + ,rmDecl, rmTypeSig, rmTypeSigs -- *** Updating - -- ,Update(update) - {- ,qualifyPName-},rmQualifier,qualifyToplevelName,renamePN {- ,replaceNameInPN -},autoRenameLocalVar + ,Update(update) + ,rmQualifier,qualifyToplevelName,renamePN',autoRenameLocalVar -- ** Miscellous -- *** Parsing, writing and showing - {- ,parseSourceFile,writeRefactoredFiles-}, showEntities,showPNwithLoc -- , newProj, addFile, chase + , showEntities,showPNwithLoc -- *** Locations -- ,toRelativeLocs, rmLocs -- *** Default values - ,defaultPN {- ,defaultPNT -},defaultName {-,defaultModName-},defaultExp -- ,defaultPat, defaultExpUnTyped + ,defaultPN,defaultName,defaultExp -- *** Identifiers, expressions, patterns and declarations - ,ghcToPN,lghcToPN, expToName + ,ghcToPN,lghcToPN, expToName, expToNameRdr + ,patToNameRdr ,nameToString - {- ,expToPNT, expToPN, nameToExp,pNtoExp -},patToPNT {- , patToPN --, nameToPat -},pNtoPat - {- ,definingDecls -}, definedPNs + ,patToPNT ,pNtoPat + , definedPNs, definedPNsRdr,definedNamesRdr + , definingDeclsRdrNames, definingDeclsRdrNames', definingSigsRdrNames , definingDeclsNames, definingDeclsNames', definingSigsNames , definingTyClDeclsNames , allNames - -- ,simplifyDecl -- *** Others + , divideDecls , mkRdrName,mkNewGhcName,mkNewName,mkNewToplevelName -- The following functions are not in the the API yet. - , causeNameClashInExports {- , inRegion , unmodified -} + , causeNameClashInExports - , removeOffset + -- , removeOffset + , declsSybTransform + -- ** Typed AST traversals (added by CMB) -- ** Miscellous - -- ,removeFromInts, getDataName, checkTypes, getPNs, getPN, getPNPats, mapASTOverTAST -- ** Debug stuff - , getDeclAndToks, getSigAndToks - , getToksForDecl, removeToksOffset -- ++AZ++ remove this after debuggging , getParsedForRenamedLPat , getParsedForRenamedName , getParsedForRenamedLocated - -- , allPNT - -- , allPNTLens - -- , newNameTok , stripLeadingSpaces - -- , lookupNameGhc -- ** from `Language.Haskell.Refact.Utils.GhcUtils` -- ** SYB versions - , everythingButStaged - , somethingStaged - , everythingStaged - , somewhereMStaged - , somewhereMStagedBu - , everywhereMStaged , everywhereMStaged' , everywhereStaged , everywhereStaged' , onelayerStaged , listifyStaged - -- *** SYB Utility - , checkItemRenamer - - -- ** Strafunski StrategyLib versions - , full_tdTUGhc - , stop_tdTUGhc - , stop_tdTPGhc - , allTUGhc' - , once_tdTPGhc - , once_buTPGhc - , oneTPGhc - , allTUGhc - - -- *** Strafunski utility - , checkItemStage' - , checkItemRenamer' - -- ** Scrap Your Zipper versions , zeverywhereStaged , zopenStaged @@ -356,41 +221,38 @@ , zopenStaged' , ztransformStagedM -- *** SYZ utilities - , checkZipperStaged , upUntil , findAbove -- * from `Language.Haskell.Refact.Utils.GhcVersionSpecific` , showGhc + , showGhcQual , prettyprint , prettyprint2 , ppType - , lexStringToTokens - , getDataConstructors , setGhcContext -- * from `Language.Haskell.Refact.Utils.TokenUtils` - , Positioning(..) - , reIndentToks - , ghcSrcSpanToForestSpan + , NameMap - -- * Span conversion functions - , gs2f,f2gs - , gs2ss,ss2gs + -- * from `Language.Haskell.Refact.Utils.ExactPrint'` + , replace + , setRefactAnns + ) where import Language.Haskell.Refact.Utils.Binds +import Language.Haskell.Refact.Utils.ExactPrint import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.GhcVersionSpecific import Language.Haskell.Refact.Utils.LocUtils import Language.Haskell.Refact.Utils.Monad import Language.Haskell.Refact.Utils.MonadFunctions -import Language.Haskell.Refact.Utils.TokenUtils import Language.Haskell.Refact.Utils.TypeSyn import Language.Haskell.Refact.Utils.TypeUtils +import Language.Haskell.Refact.Utils.Types import Language.Haskell.Refact.Utils.Utils +import Language.Haskell.Refact.Utils.Variables -import Language.Haskell.TokenUtils.Types -import Language.Haskell.TokenUtils.TokenUtils -import Language.Haskell.TokenUtils.Utils -import Language.Haskell.TokenUtils.GHC.Layout +import Language.Haskell.GHC.ExactPrint.Utils + diff --git a/src/Language/Haskell/Refact/HaRe.hs b/src/Language/Haskell/Refact/HaRe.hs --- a/src/Language/Haskell/Refact/HaRe.hs +++ b/src/Language/Haskell/Refact/HaRe.hs @@ -8,14 +8,14 @@ , SimpPos -- * Refactorings - -- |Note: the 'Cradle' in the type signatures is the one from ghc-mod , ifToCase , duplicateDef , liftToTopLevel , liftOneLevel , demote , rename - , swapArgs + -- , swapArgs + , roundTrip ) where @@ -23,7 +23,9 @@ import Language.Haskell.Refact.Refactoring.DupDef import Language.Haskell.Refact.Refactoring.MoveDef import Language.Haskell.Refact.Refactoring.Renaming -import Language.Haskell.Refact.Refactoring.SwapArgs +-- import Language.Haskell.Refact.Refactoring.SwapArgs +import Language.Haskell.Refact.Refactoring.RoundTrip import Language.Haskell.Refact.Utils.Monad -import Language.Haskell.TokenUtils.Types +import Language.Haskell.Refact.Utils.Types + diff --git a/src/Language/Haskell/Refact/Refactoring/Case.hs b/src/Language/Haskell/Refact/Refactoring/Case.hs --- a/src/Language/Haskell/Refact/Refactoring/Case.hs +++ b/src/Language/Haskell/Refact/Refactoring/Case.hs @@ -1,231 +1,147 @@ +{-# LANGUAGE StandaloneDeriving #-} module Language.Haskell.Refact.Refactoring.Case(ifToCase) where import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB +import qualified BasicTypes as GHC import qualified GHC as GHC -import Control.Monad -import Control.Monad.IO.Class -import Language.Haskell.GhcMod +import qualified Language.Haskell.GhcMod as GM (Options(..)) import Language.Haskell.Refact.API +-- To be moved into HaRe API +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils + +import System.Directory +import qualified Data.Map as Map +-- import Debug.Trace + -- --------------------------------------------------------------------- -- | Convert an if expression to a case expression -ifToCase :: RefactSettings -> Cradle -> FilePath -> SimpPos -> SimpPos -> IO [FilePath] -ifToCase settings cradle fileName beginPos endPos = - runRefacSession settings cradle (comp fileName beginPos endPos) +ifToCase :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> SimpPos -> IO [FilePath] +ifToCase settings opts fileName beginPos endPos = do + absFileName <- canonicalizePath fileName + runRefacSession settings opts (comp absFileName beginPos endPos) comp :: FilePath -> SimpPos -> SimpPos -> RefactGhc [ApplyRefacResult] comp fileName beginPos endPos = do - getModuleGhc fileName - renamed <- getRefactRenamed - logm $ "Case.comp:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ - let expr = locToExp beginPos endPos renamed - -- logm $ "Case.comp:expr=" ++ (SYB.showData SYB.Renamer 0 expr) -- ++AZ++ + parseSourceFileGhc fileName + parsed <- getRefactParsed + oldAnns <- liftT getAnnsT + logm $ "Case.comp:parsed=" ++ (showAnnData oldAnns 0 parsed) -- ++AZ++ + let expr = locToExp beginPos endPos parsed case expr of Just exp1@(GHC.L _ (GHC.HsIf _ _ _ _)) -> do (refactoredMod,_) <- applyRefac (doIfToCaseInternal exp1) RSAlreadyLoaded return [refactoredMod] - _ -> error $ "You haven't selected an if-then-else expression!" -- ++ (show (beginPos,endPos,fileName)) ++ "]:" ++ (SYB.showData SYB.Parser 0 $ ast) + _ -> error $ "You haven't selected an if-then-else expression!" -- (show (beginPos,endPos,fileName)) ++ "]:" ++ (SYB.showData SYB.Parser 0 $ ast) doIfToCaseInternal :: - GHC.Located (GHC.HsExpr GHC.Name) + GHC.Located (GHC.HsExpr GHC.RdrName) -> RefactGhc () doIfToCaseInternal expr = do - rs <- getRefactRenamed + rs <- getRefactParsed reallyDoIfToCase expr rs reallyDoIfToCase :: - GHC.Located (GHC.HsExpr GHC.Name) - -> GHC.RenamedSource + GHC.Located (GHC.HsExpr GHC.RdrName) + -> GHC.ParsedSource -> RefactGhc () -reallyDoIfToCase expr rs = do +reallyDoIfToCase expr p = do - void $ everywhereMStaged SYB.Renamer (SYB.mkM inExp) rs - showLinesDebug "after refactoring" + p2 <- SYB.everywhereMStaged SYB.Parser (SYB.mkM inExp) p + putRefactParsed p2 mempty return () where - inExp :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name)) - inExp exp1@(GHC.L l (GHC.HsIf _se (GHC.L l1 _) (GHC.L l2 _) (GHC.L l3 _))) + inExp :: (GHC.Located (GHC.HsExpr GHC.RdrName)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.RdrName)) + inExp exp1@(GHC.L _ (GHC.HsIf _se (GHC.L _ _) (GHC.L _ _) (GHC.L _ _))) | sameOccurrence expr exp1 = do - -- drawTokenTreeDetailed "reallyDoIfToCase" -- ++AZ++ debug newExp <- ifToCaseTransform exp1 - - -- let (GHC.RealSrcLoc rl) = GHC.srcSpanStart l - let caseTok = tokenise (gs2ss l) 0 False "case" - condToks <- getToksForSpan l1 - let ofTok = tokenise - (gs2ss $ tokenSrcSpan (glast "reallyDoIfToCase" condToks)) - -- (realSrcLocFromTok (glast "reallyDoIfToCase" condToks)) - 1 True "of" - let trueToks = basicTokenise "True ->" - let falseToks = basicTokenise "False ->" - thenToksRaw <- getToksForSpan l2 - elseToksRaw <- getToksForSpan l3 - - let thenToks = dropWhile isEmpty thenToksRaw - let elseToks = dropWhile isEmpty elseToksRaw - - logm $ "reallyDoIfToCase:elseToks=" ++ (show elseToks) - - let t0 = reIndentToks PlaceAdjacent caseTok condToks - let t1' = reIndentToks PlaceAdjacent (caseTok ++ t0) ofTok - let t1 = caseTok ++ t0 ++ t1' - - let t2 = reIndentToks (PlaceIndent 1 4 0) t1 trueToks - let t3 = reIndentToks PlaceAdjacent (t1++t2) thenToks - - let (_,col) = tokenPos $ ghead "reallyDoIfToCase" t2 - - let t4 = reIndentToks (PlaceAbsCol 1 col 0) (t1++t2++t3) falseToks - -- logm $ "reallyDoIfToCase:(t1++t2++t3++t4)=" ++ (show (t1++t2++t3++t4)) - let t5 = reIndentToks PlaceAdjacent (t1++t2++t3++t4) elseToks - - let caseToks = t1++t2++t3++t4++t5 ++ [newLnToken (last t5)] - - logm $ "reallyDoIfToCase:t1=[" ++ (GHC.showRichTokenStream t1) ++ "]" - logm $ "reallyDoIfToCase:t2=[" ++ (GHC.showRichTokenStream t2) ++ "]" - logm $ "reallyDoIfToCase:t3=[" ++ (GHC.showRichTokenStream t3) ++ "]" - - -- logm $ "reallyDoIfToCase:t1++t2++t3=" ++ (show (t1++t2++t3)) - - logm $ "reallyDoIfToCase:t4=[" ++ (GHC.showRichTokenStream t4) ++ "]" - logm $ "reallyDoIfToCase:t5=[" ++ (GHC.showRichTokenStream t5) ++ "]" - - logm $ "reallyDoIfToCase:caseToks=" ++ (show caseToks) - - -- drawTokenTreeDetailed "reallyDoIfToCase" - - void $ putToksForSpan l caseToks - - -- drawTokenTree "reallyDoIfToCase after putToks" - -- drawTokenTreeDetailed "reallyDoIfToCase after putToks" - return newExp inExp e = return e --- TODO: rearrange the structure and preserve the comments in the original, e.g. in e1,e2,e3 -ifToCaseTransform :: GHC.Located (GHC.HsExpr GHC.Name) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name)) -ifToCaseTransform (GHC.L l (GHC.HsIf _se e1 e2 e3)) = do - trueName <- mkNewGhcName Nothing "True" - falseName <- mkNewGhcName Nothing "False" - let ret = GHC.L l (GHC.HsCase e1 - (GHC.MatchGroup +-- |Actually do the transformation +ifToCaseTransform :: GHC.Located (GHC.HsExpr GHC.RdrName) + -> RefactGhc (GHC.Located (GHC.HsExpr GHC.RdrName)) +ifToCaseTransform li@(GHC.L _ (GHC.HsIf _se e1 e2 e3)) = do + caseLoc <- liftT uniqueSrcSpanT -- HaRe:-1:1 + trueMatchLoc <- liftT uniqueSrcSpanT -- HaRe:-1:2 + trueLoc1 <- liftT uniqueSrcSpanT -- HaRe:-1:3 + trueLoc <- liftT uniqueSrcSpanT -- HaRe:-1:4 + trueRhsLoc <- liftT uniqueSrcSpanT -- HaRe:-1:5 + falseLoc1 <- liftT uniqueSrcSpanT -- HaRe:-1:6 + falseLoc <- liftT uniqueSrcSpanT -- HaRe:-1:7 + falseMatchLoc <- liftT uniqueSrcSpanT -- HaRe:-1:8 + falseRhsLoc <- liftT uniqueSrcSpanT -- HaRe:-1:9 + let trueName = mkRdrName "True" + let falseName = mkRdrName "False" + let ret = GHC.L caseLoc (GHC.HsCase e1 + (GHC.MG [ - (GHC.noLoc $ GHC.Match + (GHC.L trueMatchLoc $ GHC.Match + Nothing [ - GHC.noLoc $ GHC.ConPatIn (GHC.noLoc trueName) (GHC.PrefixCon []) + GHC.L trueLoc1 $ GHC.ConPatIn (GHC.L trueLoc trueName) (GHC.PrefixCon []) ] Nothing - ((GHC.GRHSs + (GHC.GRHSs [ - GHC.noLoc $ GHC.GRHS [] e2 - ] GHC.EmptyLocalBinds)) + GHC.L trueRhsLoc $ GHC.GRHS [] e2 + ] GHC.EmptyLocalBinds) ) - , (GHC.noLoc $ GHC.Match + , (GHC.L falseMatchLoc $ GHC.Match + Nothing [ - GHC.noLoc $ GHC.ConPatIn (GHC.noLoc falseName) (GHC.PrefixCon []) + GHC.L falseLoc1 $ GHC.ConPatIn (GHC.L falseLoc falseName) (GHC.PrefixCon []) ] Nothing - ((GHC.GRHSs + (GHC.GRHSs [ - GHC.noLoc $ GHC.GRHS [] e3 - ] GHC.EmptyLocalBinds)) + GHC.L falseRhsLoc $ GHC.GRHS [] e3 + ] GHC.EmptyLocalBinds) ) - ] undefined)) - return ret -ifToCaseTransform x = return x + ] [] GHC.placeHolderType GHC.FromSource)) --- --------------------------------------------------------------------- -{- -HsIf (Maybe (SyntaxExpr id)) (LHsExpr id) (LHsExpr id) (LHsExpr id) + oldAnns <- liftT $ getAnnsT + let annIf = gfromJust "Case.annIf" $ getAnnotationEP li oldAnns + let annThen = gfromJust "Case.annThen" $ getAnnotationEP e2 oldAnns + let annElse = gfromJust "Case.annElse" $ getAnnotationEP e3 oldAnns + logm $ "Case:annIf=" ++ show annIf + logm $ "Case:annThen=" ++ show annThen + logm $ "Case:annElse=" ++ show annElse -[Can ignore The SyntaxExpr] + -- AZ:TODO: under some circumstances the GRHS annotations need LineSame, in others LineChanged. + let ifDelta = gfromJust "Case.ifDelta" $ lookup (G GHC.AnnIf) (annsDP annIf) + -- let ifSpanEntry = gfromJust "Case.ifSpanEntry" $ lookup (AnnSpanEntry) (annsDP annIf) + let anne2' = + [ + ( AnnKey caseLoc (CN "HsCase"), annIf { annsDP = [ (G GHC.AnnCase, ifDelta) + , (G GHC.AnnOf, DP (0,1))] + } ) + -- , ( AnnKey caseVirtualLoc (CN "(:)"), Ann (DP (1,newCol)) (ColDelta newCol) (DP (1,newCol)) [] [(DP (1,0))]) + , ( AnnKey trueMatchLoc (CN "Match"), Ann (DP (1,2)) [] [] [] Nothing Nothing ) + , ( AnnKey trueLoc1 (CN "ConPatIn"), Ann (DP (0,0)) [] [] [] Nothing Nothing ) + , ( AnnKey trueLoc (CN "Unqual"), Ann (DP (0,0)) [] [] [(G GHC.AnnVal, DP (0,0))] Nothing Nothing) + , ( AnnKey trueRhsLoc (CN "GRHS"), Ann (DP (0,2)) [] [] [(G GHC.AnnRarrow, DP (0,0))] Nothing Nothing) + , ( AnnKey falseMatchLoc (CN "Match"), Ann (DP (1,0)) [] [] [] Nothing Nothing) + , ( AnnKey falseLoc1 (CN "ConPatIn"), Ann (DP (0,0)) [] [] [] Nothing Nothing) + , ( AnnKey falseLoc (CN "Unqual"), Ann (DP (0,0)) [] [] [(G GHC.AnnVal, DP (0,0))] Nothing Nothing) + , ( AnnKey falseRhsLoc (CN "GRHS"), Ann (DP (0,1)) [] [] [(G GHC.AnnRarrow, DP (0,0))] Nothing Nothing) + ] -HsCase (LHsExpr id) (MatchGroup id) + liftT $ putAnnsT (oldAnns `Map.union` (Map.fromList anne2')) + return ret +ifToCaseTransform x = return x --} +-- --------------------------------------------------------------------- -{- -Need to move to -(L {test/testdata/Case/B.hs:(9,10)-(11,17)} - (HsCase - (L {test/testdata/Case/B.hs:9:15-21} - (HsPar - (L {test/testdata/Case/B.hs:9:16-20} - (HsApp - (L {test/testdata/Case/B.hs:9:16-18} - (HsVar {Name: GHC.Real.odd})) - (L {test/testdata/Case/B.hs:9:20} - (HsVar {Name: x})))))) - (MatchGroup - [ - (L {test/testdata/Case/B.hs:10:3-15} - (Match - [ - (L {test/testdata/Case/B.hs:10:3-6} - (ConPatIn - (L {test/testdata/Case/B.hs:10:3-6} {Name: GHC.Types.True}) - (PrefixCon - [])))] - (Nothing) - (GRHSs - [ - (L {test/testdata/Case/B.hs:10:11-15} - (GRHS - [] - (L {test/testdata/Case/B.hs:10:11-15} - (HsLit - (HsString {FastString: "Odd"})))))] - (EmptyLocalBinds)))), - (L {test/testdata/Case/B.hs:11:3-17} - (Match - [ - (L {test/testdata/Case/B.hs:11:3-7} - (ConPatIn - (L {test/testdata/Case/B.hs:11:3-7} {Name: GHC.Types.False}) - (PrefixCon - [])))] - (Nothing) - (GRHSs - [ - (L {test/testdata/Case/B.hs:11:12-17} - (GRHS - [] - (L {test/testdata/Case/B.hs:11:12-17} - (HsLit - (HsString {FastString: "Even"})))))] - (EmptyLocalBinds))))] {!type placeholder here?!}))) - -from --- - -(L {test/testdata/Case/B.hs:4:9-41} - (HsIf - (Nothing) - (L {test/testdata/Case/B.hs:4:12-18} - (HsPar - (L {test/testdata/Case/B.hs:4:13-17} - (HsApp - (L {test/testdata/Case/B.hs:4:13-15} - (HsVar {Name: GHC.Real.odd})) - (L {test/testdata/Case/B.hs:4:17} - (HsVar {Name: x})))))) - (L {test/testdata/Case/B.hs:4:25-29} - (HsLit - (HsString {FastString: "Odd"}))) - (L {test/testdata/Case/B.hs:4:36-41} - (HsLit - (HsString {FastString: "Even"}))))) - --} - -- EOF - - diff --git a/src/Language/Haskell/Refact/Refactoring/DupDef.hs b/src/Language/Haskell/Refact/Refactoring/DupDef.hs --- a/src/Language/Haskell/Refact/Refactoring/DupDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/DupDef.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} module Language.Haskell.Refact.Refactoring.DupDef(duplicateDef) where @@ -8,157 +9,219 @@ import qualified GHC.SYB.Utils as SYB import qualified GHC -import qualified OccName as GHC +import qualified RdrName as GHC -import Control.Monad import Data.List import Data.Maybe -import Language.Haskell.GhcMod +import qualified Language.Haskell.GhcMod as GM +import Language.Haskell.GhcMod.Internal as GM import Language.Haskell.Refact.API +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Transform +import System.Directory + -- --------------------------------------------------------------------- -- | This refactoring duplicates a definition (function binding or -- simple pattern binding) at the same level with a new name provided by -- the user. The new name should not cause name clash/capture. -duplicateDef :: RefactSettings -> Cradle -> FilePath -> String -> SimpPos -> IO [FilePath] -duplicateDef settings cradle fileName newName (row,col) = - runRefacSession settings cradle (comp fileName newName (row,col)) +duplicateDef :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath] +duplicateDef settings opts fileName newName (row,col) = do + absFileName <- canonicalizePath fileName + runRefacSession settings opts (comp absFileName newName (row,col)) comp :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult] comp fileName newName (row, col) = do - if isVarId newName - then do - getModuleGhc fileName - renamed <- getRefactRenamed - parsed <- getRefactParsed - - let (Just (modName,_)) = getModuleName parsed - let maybePn = locToName (row, col) renamed - case maybePn of - Just pn -> - do - -- refactoredMod@((_fp,ismod),(_toks',renamed')) <- applyRefac (doDuplicating pn newName) (Just modInfo) fileName - (refactoredMod@((_fp,ismod),(_,_toks',renamed')),_) <- applyRefac (doDuplicating pn newName) (RSFile fileName) - case (ismod) of - False -> error "The selected identifier is not a function/simple pattern name, or is not defined in this module " - True -> return () + if isVarId newName + then + do + parseSourceFileGhc fileName + renamed <- getRefactRenamed + parsed <- getRefactParsed + targetModule <- getRefactTargetModule + logm $ "DupDef.comp:got targetModule" - if modIsExported modName renamed - then do clients <- clientModsAndFiles modName - logm ("DupDef: clients=" ++ (showGhc clients)) -- ++AZ++ debug - refactoredClients <- mapM (refactorInClientMod (GHC.unLoc pn) modName - (findNewPName newName renamed')) clients - return $ refactoredMod:refactoredClients - else return [refactoredMod] - Nothing -> error "Invalid cursor position!" - else error $ "Invalid new function name:" ++ newName ++ "!" + let (Just (modName,_)) = getModuleName parsed + let maybePn = locToName (row, col) renamed + case maybePn of + Just pn -> + do + logm $ "DupDef.comp:about to applyRefac for:pn=" ++ SYB.showData SYB.Parser 0 pn + (refactoredMod@((_fp,_ismod),(_anns',_parsed')),(isDone,nn)) <- applyRefac (doDuplicating pn newName) (RSFile fileName) + logm $ "DupDef.com:isDone=" ++ show isDone + case isDone of + DupDefFailed -> error "The selected identifier is not a function/simple pattern name, or is not defined in this module " + DupDefLowerLevel -> return [refactoredMod] + DupDefTopLevel -> do + if modIsExported modName renamed + then + do + logm $ "DupDef.comp:about to clientMods" + clients <- clientModsAndFiles targetModule + logm ("DupDef: clients=" ++ (showGhc clients)) -- ++AZ++ debug + refactoredClients <- mapM (refactorInClientMod (GHC.unLoc pn) modName nn) + clients + return $ refactoredMod:refactoredClients + else return [refactoredMod] + Nothing -> error "Invalid cursor position!" + else error $ "Invalid new function name:" ++ newName ++ "!" +data DupDefResult = DupDefFailed | DupDefTopLevel | DupDefLowerLevel + deriving (Eq,Show) doDuplicating :: GHC.Located GHC.Name -> String - -> RefactGhc () + -> RefactGhc (DupDefResult,GHC.Name) doDuplicating pn newName = do + logm $ "DupDef.comp:doDuplicating entered" inscopes <- getRefactInscopes - renamed <- getRefactRenamed - reallyDoDuplicating pn newName inscopes renamed + logm $ "DupDef.comp:doDuplicating got inscopes" + reallyDoDuplicating pn newName inscopes reallyDoDuplicating :: GHC.Located GHC.Name -> String - -> InScopes -> GHC.RenamedSource - -> RefactGhc () -reallyDoDuplicating pn newName inscopes renamed = do + -> InScopes + -> RefactGhc (DupDefResult,GHC.Name) +reallyDoDuplicating pn newName _inscopes = do + clearRefactDone + parsed <- getRefactParsed + newNameGhc <- mkNewGhcName Nothing newName - renamed' <- everywhereMStaged SYB.Renamer (SYB.mkM dupInMod - `SYB.extM` dupInMatch - `SYB.extM` dupInPat - `SYB.extM` dupInLet - `SYB.extM` dupInLetStmt - ) renamed - putRefactRenamed renamed' - return () + -- Check if it is a top level dup + parsed2 <- dupInModule newNameGhc parsed + d <- getRefactDone + if d + then do + putRefactParsed parsed2 emptyAnns + return (DupDefTopLevel,newNameGhc) + else do + parsed' <- SYB.everywhereMStaged SYB.Parser ( + SYB.mkM (dupInMatch newNameGhc) + `SYB.extM` (dupInPat newNameGhc) + `SYB.extM` (dupInLet newNameGhc) + `SYB.extM` (dupInLetStmt newNameGhc) + ) parsed2 + putRefactParsed parsed' emptyAnns + done <- getRefactDone + if done then return (DupDefLowerLevel,newNameGhc) + else return (DupDefFailed,newNameGhc) where --1. The definition to be duplicated is at top level. - -- dupInMod :: (GHC.HsGroup GHC.Name)-> RefactGhc (GHC.HsGroup GHC.Name) - dupInMod (grp :: (GHC.HsGroup GHC.Name)) - | not $ emptyList (findFunOrPatBind pn (hsBinds grp)) = doDuplicating' inscopes grp pn - dupInMod grp = return grp + dupInModule :: GHC.Name -> GHC.ParsedSource -> RefactGhc GHC.ParsedSource + dupInModule newNameGhc p + = do + declsp <- liftT $ hsDecls p + nm <- getRefactNameMap + if not $ emptyList (findFunOrPatBind nm pn declsp) + then doDuplicating' newNameGhc p pn + else return p --2. The definition to be duplicated is a local declaration in a match - dupInMatch (match@(GHC.Match _pats _typ rhs)::GHC.Match GHC.Name) - | not $ emptyList (findFunOrPatBind pn (hsBinds rhs)) = doDuplicating' inscopes match pn - dupInMatch match = return match + dupInMatch newNameGhc (match::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + = do + nm <- getRefactNameMap + declsp <- liftT $ hsDecls match + logm $ "dupInMatch:declsp=" ++ showGhc declsp + if not $ emptyList (findFunOrPatBind nm pn declsp) + then doDuplicating' newNameGhc match pn + else return match --3. The definition to be duplicated is a local declaration in a pattern binding - dupInPat (pat@(GHC.PatBind _p rhs _typ _fvs _) :: GHC.HsBind GHC.Name) - | not $ emptyList (findFunOrPatBind pn (hsBinds rhs)) = doDuplicating' inscopes pat pn - dupInPat pat = return pat + dupInPat newNameGhc (pat@(GHC.L _ (GHC.ValD (GHC.PatBind _p _rhs _typ _fvs _))) :: GHC.LHsDecl GHC.RdrName) + = do + logm $ "dupInPat hit" + doDuplicating' newNameGhc pat pn + dupInPat _ pat = return pat --4: The defintion to be duplicated is a local decl in a Let expression - dupInLet (letExp@(GHC.HsLet ds _e):: GHC.HsExpr GHC.Name) - | not $ emptyList (findFunOrPatBind pn (hsBinds ds)) = doDuplicating' inscopes letExp pn - dupInLet letExp = return letExp + dupInLet newNameGhc (letExp@(GHC.L _ (GHC.HsLet _ds _e)):: GHC.LHsExpr GHC.RdrName) + = doDuplicating' newNameGhc letExp pn + dupInLet _ letExp = return letExp --5. The definition to be duplicated is a local decl in a case alternative. -- Note: The local declarations in a case alternative are covered in #2 above. --6.The definition to be duplicated is a local decl in a Let statement. - dupInLetStmt (letStmt@(GHC.LetStmt ds):: GHC.Stmt GHC.Name) - -- was |findFunOrPatBind pn ds /=[]=doDuplicating' inscps letStmt pn - |not $ emptyList (findFunOrPatBind pn (hsBinds ds)) = doDuplicating' inscopes letStmt pn - dupInLetStmt letStmt = return letStmt + dupInLetStmt newNameGhc (letStmt@(GHC.L _ (GHC.LetStmt _ds)):: GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + = doDuplicating' newNameGhc letStmt pn + dupInLetStmt _ letStmt = return letStmt - -- findFunOrPatBind :: (SYB.Data t) => GHC.Located GHC.Name -> t -> [GHC.LHsBind GHC.Name] - findFunOrPatBind (GHC.L _ n) ds = filter (\d->isFunBindR d || isSimplePatBind d) $ definingDeclsNames [n] ds True False + findFunOrPatBind nm (GHC.L _ n) ds + = filter (\d->isFunBindP d || isSimplePatDecl d) $ definingDeclsRdrNames nm [n] ds True False - doDuplicating' :: (HsValBinds t) => InScopes -> t -> GHC.Located GHC.Name - -> RefactGhc (t) - doDuplicating' _inscps parentr ln@(GHC.L _ n) - = do let - declsr = hsBinds parentr + doDuplicating' :: (SYB.Typeable t,SYB.Data t) => GHC.Name -> t -> GHC.Located GHC.Name -> RefactGhc t + doDuplicating' newNameGhc t _ln = do + logm $ "doDuplicating' entered" + -- logm $ "doDuplicating' entered:t=" ++ SYB.showData SYB.Parser 0 t + -- declsp <- liftT $ hsDecls t + declsp <- liftT $ hsDeclsGeneric t + nm <- getRefactNameMap + if not $ emptyList (findFunOrPatBind nm pn declsp) + then doDuplicating'' newNameGhc t pn + else return t - duplicatedDecls = definingDeclsNames [n] declsr True False - -- (after,before) = break (definesP pn) (reverse declsp) - (f,d) <- hsFDNamesFromInside parentr + doDuplicating'' :: (SYB.Data t) => GHC.Name -> t -> GHC.Located GHC.Name + -> RefactGhc t + doDuplicating'' newNameGhc parentr ln = do + logm $ "doDuplicating'':parentr=" ++ SYB.showData SYB.Parser 0 parentr + r <- hasDeclsSybTransform workerHsDecls workerBind parentr + logm $ "doDuplicating'':done" + return r + where + workerHsDecls :: forall t. HasDecls t => t -> RefactGhc t + workerHsDecls t = do + logm $ "workerHsDecls hit" + ds <- liftT $ hsDecls t + ds' <- doDuplicating3 newNameGhc parentr ln ds + liftT $ replaceDecls t ds' + + workerBind :: (GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName)) + workerBind t@(GHC.L _ (GHC.PatBind{})) = do + logm $ "workerBind hit" + ds <- liftT $ hsDeclsPatBind t + ds' <- doDuplicating3 newNameGhc t ln ds + liftT $ replaceDeclsPatBind t ds' + workerBind x = error $ "DupDef.doDuplicating'':workerBind got:" ++ showGhc x + + doDuplicating3 :: (SYB.Data t) => GHC.Name -> t -> GHC.Located GHC.Name + -> [GHC.LHsDecl GHC.RdrName] + -> RefactGhc [GHC.LHsDecl GHC.RdrName] + doDuplicating3 newNameGhc parentr ln@(GHC.L _ n) declsp + = do + logm $ "doDuplicating'' entered:ln" ++ showGhc ln + -- declsp <- liftT $ hsDecls parentr + nm <- getRefactNameMap + let + duplicatedDecls = definingDeclsRdrNames nm [n] declsp True False + + logm $ "doDuplicating'':duplicatedDecls=" ++ showGhc duplicatedDecls + (f,d) <- hsFDNamesFromInsideRdr parentr --f: names that might be shadowd by the new name, --d: names that might clash with the new name - dv <- hsVisibleNames ln declsr --dv: names may shadow new name - let vars = nub (f `union` d `union` dv) + logm $ "doDuplicating'':(f,d)=" ++ show (f,d) + dv <- hsVisiblePNsRdr nm ln declsp --dv: names may shadow new name + let vars = nub (f `union` d `union` map showGhc dv) - newNameGhc <- mkNewGhcName Nothing newName -- TODO: Where definition is of form tup@(h,t), test each element of it for clashes, or disallow nameAlreadyInScope <- isInScopeAndUnqualifiedGhc newName Nothing - -- logm ("DupDef: nameAlreadyInScope =" ++ (show nameAlreadyInScope)) -- ++AZ++ debug - -- logm ("DupDef: ln =" ++ (show ln)) -- ++AZ++ debug - - if elem newName vars || (nameAlreadyInScope && findEntity ln duplicatedDecls) + if elem newName vars || (nameAlreadyInScope && findEntity ln duplicatedDecls) then error ("The new name'"++newName++"' will cause name clash/capture or ambiguity problem after " ++ "duplicating, please select another name!") - else do newBinding <- duplicateDecl declsr parentr n newNameGhc - -- let newDecls = replaceDecls declsr (declsr ++ newBinding) - let newDecls = replaceBinds declsr (declsr ++ newBinding) - return $ replaceBinds parentr newDecls - - - --- | Find the the new definition name in GHC.Name format. -findNewPName :: String -> GHC.RenamedSource -> GHC.Name -findNewPName name renamed = gfromJust "findNewPName" res - where - res = somethingStaged SYB.Renamer Nothing - (Nothing `SYB.mkQ` worker) renamed - - worker (pname::GHC.Name) - | (GHC.occNameString $ GHC.getOccName pname) == name = Just pname - worker _ = Nothing + else do + setRefactDone + newdecls <- duplicateDecl declsp n newNameGhc + -- parentr' <- liftT $ replaceDecls parentr newdecls + -- return parentr' + return newdecls -- | Do refactoring in the client module. That is to hide the @@ -166,31 +229,26 @@ -- the client module. refactorInClientMod :: GHC.Name -> GHC.ModuleName -> GHC.Name -> TargetModule -> RefactGhc ApplyRefacResult -refactorInClientMod oldPN serverModName newPName targetModule@(_,modSummary) +refactorInClientMod oldPN serverModName newPName targetModule = do - logm ("refactorInClientMod: (serverModName,newPName)=" ++ (showGhc (serverModName,newPName))) -- ++AZ++ debug - void $ activateModule targetModule + logm ("refactorInClientMod: (oldPN,serverModName,newPName)=" ++ (showGhc (oldPN,serverModName,newPName))) + -- void $ activateModule targetModule + getTargetGhc targetModule - let fileName = gfromJust "refactorInClientMod" $ GHC.ml_hs_file $ GHC.ms_location modSummary -{- - -- modInfo@(t,ts) <- getModuleGhc fileName - getModuleGhc fileName --} + let fileName = GM.mpPath targetModule renamed <- getRefactRenamed parsed <- getRefactParsed let modNames = willBeUnQualImportedBy serverModName renamed logm ("refactorInClientMod: (modNames)=" ++ (showGhc (modNames))) -- ++AZ++ debug - -- if isJust modNames && needToBeHided (pNtoName newPName) exps parsed mustHide <- needToBeHided newPName renamed parsed logm ("refactorInClientMod: (mustHide)=" ++ (showGhc (mustHide))) -- ++AZ++ debug if isJust modNames && mustHide then do - -- refactoredMod <- applyRefac (doDuplicatingClient serverModName [newPName]) (Just modInfo) fileName (refactoredMod,_) <- applyRefac (doDuplicatingClient serverModName [newPName]) (RSFile fileName) return refactoredMod - else return ((fileName,unmodified),([],[],renamed)) + else return ((fileName,RefacUnmodifed),(emptyAnns,parsed)) where needToBeHided :: GHC.Name -> GHC.RenamedSource -> GHC.ParsedSource -> RefactGhc Bool needToBeHided name exps parsed = do @@ -201,9 +259,10 @@ doDuplicatingClient :: GHC.ModuleName -> [GHC.Name] -> RefactGhc () doDuplicatingClient serverModName newPNames = do - renamed <- getRefactRenamed - renamed' <- addHiding serverModName renamed newPNames - putRefactRenamed renamed' + logm $ "doDuplicatingClient:newPNames=" ++ showGhc newPNames + parsed <- getRefactParsed + parsed' <- addHiding serverModName parsed (map GHC.nameRdrName newPNames) + putRefactParsed parsed' emptyAnns return () @@ -214,7 +273,7 @@ willBeUnQualImportedBy :: GHC.ModuleName -> GHC.RenamedSource -> Maybe [GHC.ModuleName] willBeUnQualImportedBy modName (_,imps,_,_) = let - ms = filter (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h)) + ms = filter (\(GHC.L _ (GHC.ImportDecl _ (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h)) -> modName == modName1 && not isQualified && (isNothing h -- not hiding @@ -225,8 +284,7 @@ in if (emptyList ms) then Nothing else Just $ nub $ map getModName ms - where getModName (GHC.L _ (GHC.ImportDecl _modName1 _qualify _source _safe _isQualified _isImplicit as _h)) + where getModName (GHC.L _ (GHC.ImportDecl _ _modName1 _qualify _source _safe _isQualified _isImplicit as _h)) = if isJust as then (fromJust as) else modName - -- simpModName (SN m loc) = m diff --git a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs --- a/src/Language/Haskell/Refact/Refactoring/MoveDef.hs +++ b/src/Language/Haskell/Refact/Refactoring/MoveDef.hs @@ -1,1800 +1,1655 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - -module Language.Haskell.Refact.Refactoring.MoveDef - ( liftToTopLevel - , liftOneLevel - , demote - -- ,liftingInClientMod - ) where - -import qualified Data.Generics as SYB -import qualified GHC.SYB.Utils as SYB - --- import qualified DynFlags as GHC -import qualified Exception as GHC -import qualified FastString as GHC -import qualified GHC as GHC -import qualified Name as GHC -import qualified Outputable as GHC -import qualified TyCon as GHC -import qualified TypeRep as GHC -import qualified Var as Var - -import Control.Exception -import Control.Monad.State -import qualified Data.Generics.Zipper as Z -import Data.List -import Data.Maybe - -import Language.Haskell.GhcMod -import Language.Haskell.Refact.API - -import Data.Generics.Strafunski.StrategyLib.StrategyLib - --- import Debug.Trace - --- --------------------------------------------------------------------- - --- data Direction = UptoTopLevel | UpOneLevel | Down - -{--------This function handles refactorings involving moving a definition-------- - - According to the Haskell's syntax, a declaration may occur in one of -the following six contexts: - - 1. A top level declaration in the module: - old: HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds - new: (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString) - HsGroup hs_valds :: HsValBinds id ... - - 2. A local declaration in a Match: (of a FunBind) - old: HsMatch SrcLoc i [p] (HsRhs e) ds - new: Match [LPat id] (Maybe (LHsType id)) (GRHSs id) - - 3. A local declaration in a pattern binding: - old: HsPatBind SrcLoc p (HsRhs e) ds - new: PatBind (LPat idL) (GRHSs idR) PostTcType NameSet (Maybe tickish) - - 4. A local declaration in a Let expression: - old: HsLet ds e - new: HsLet (HsLocalBinds id) (LHsExpr id) - - 5. A local declaration in a Case alternative: - old: HsAlt SrcLoc p (HsRhs e) ds - new: HsCase (LHsExpr id) (MatchGroup id) - new is same as in a FunBind. - - 6. A local declaration in a Do statement: - old: HsLetStmt ds (HsStmt e p ds) - new: LetStmt (HsLocalBindsLR idL idR) - in context GRHS [LStmt id] (LHsExpr id) --} - --- | Lift a definition to the top level -liftToTopLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath] -liftToTopLevel settings cradle fileName (row,col) = - runRefacSession settings cradle (compLiftToTopLevel fileName (row,col)) - - -compLiftToTopLevel :: FilePath -> SimpPos - -> RefactGhc [ApplyRefacResult] -compLiftToTopLevel fileName (row,col) = do - getModuleGhc fileName - renamed <- getRefactRenamed - parsed <- getRefactParsed - - let (Just (modName,_)) = getModuleName parsed - let maybePn = locToName (row, col) renamed - case maybePn of - Just pn -> do - liftToTopLevel' modName pn - _ -> error "\nInvalid cursor position!\n" - - --- --------------------------------------------------------------------- - --- | Move a definition one level up from where it is now -liftOneLevel :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath] -liftOneLevel settings cradle fileName (row,col) = - runRefacSession settings cradle (compLiftOneLevel fileName (row,col)) - - -compLiftOneLevel :: FilePath -> SimpPos - -> RefactGhc [ApplyRefacResult] -compLiftOneLevel fileName (row,col) = do - getModuleGhc fileName - renamed <- getRefactRenamed - parsed <- getRefactParsed - - -- logm $ "compLiftOneLevel:(fileName,row,col)="++(show (fileName,row,col)) - -- logm $ "compLiftOneLevel:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ - - let (Just (modName,_)) = getModuleName parsed - let maybePn = locToName (row, col) renamed - case maybePn of - Just pn -> do - rs <- liftOneLevel' modName pn - logm $ "compLiftOneLevel:rs=" ++ (show $ (refactDone rs,map (\((_,d),_) -> d) rs)) - if (refactDone rs) - then return rs - else error ( "Lifting this definition failed. "++ - " This might be because that the definition to be "++ - "lifted is defined in a class/instance declaration.") - _ -> error "\nInvalid cursor position!\n" - - - --- --------------------------------------------------------------------- - --- | Move a definition one level down -demote :: RefactSettings -> Cradle -> FilePath -> SimpPos -> IO [FilePath] -demote settings cradle fileName (row,col) = - runRefacSession settings cradle (compDemote fileName (row,col)) - -compDemote ::FilePath -> SimpPos - -> RefactGhc [ApplyRefacResult] -compDemote fileName (row,col) = do - getModuleGhc fileName - renamed <- getRefactRenamed - parsed <- getRefactParsed - - -- TODO: make the next one an API call, that also gets the - -- parsed source - let (Just (modName,_)) = getModuleName parsed - let maybePn = locToName (row, col) renamed - case maybePn of - Just pn -> do - demote' modName pn - _ -> error "\nInvalid cursor position!\n" - - -{- -demote args - = do let fileName = ghead "filename" args - row = read (args!!1)::Int - col = read (args!!2)::Int - modName <- fileNameToModName fileName - (inscps, _, mod, toks) <- parseSourceFile fileName - let pnt = locToPNT fileName (row, col) mod - pn = pNTtoPN pnt - if pn /= defaultPN - then demote' modName fileName (mod, toks) pn - else error "\nInvalid cursor position!\n" - -move direction args - = do let fileName = ghead "filename" args - row = read (args!!1)::Int - col = read (args!!2)::Int - modName <- fileNameToModName fileName - (inscps, _, mod, toks) <- parseSourceFile fileName - let pnt = locToPNT fileName (row, col) mod - pn = pNTtoPN pnt - if pn /= defaultPN - then - case direction of - UptoTopLevel ->liftToTopLevel' modName fileName (inscps, mod, toks) pnt - UpOneLevel ->liftOneLevel' modName fileName (inscps, mod, toks) pnt - Down ->demote' modName fileName (mod, toks) pn - else error "\nInvalid cursor position!\n" - - -{- Refactoring Names: 'liftToTopLevel' - - This refactoring lifts a local function/pattern binding to the top - level of the module, so as to make it accessible to other functions in - the current module, and those modules that import current module. - - In the current implementation, a definition will be lifted only if - none of the identifiers defined in this definition will cause name - clash/capture problems in the current module after lifting. - - In the case that the whole current module is exported implicitly, - the lifted identifier will be exported automatically after lifting. If - the identifier will cause name clash/ambiguous occurrence problem in a - client module, it will be hided in the import declaration of the - client module (Note: this might not be the best solution, we prefer - hiding it in the server module instead of in the client module in the - final version). - - In the case of indirect importing, it might be time-consuming to - trace whether the lifted identifier will cause any problem in a client - module that indirectly imports the current module. The current - solution is: suppose a defintion is lifted to top level in module A, - and module A is imported and exported by module B, then the lifted - identifier will be hided in the import declaration of B no matter - whether it causes problems in module B or not. - - Function name: liftToTopLevel - parameters: fileName--current file name. - mod -- the scoped abstract syntax tree of the module. - pn -- the function/pattern name to be lifted. --} - --} - -liftToTopLevel' :: GHC.ModuleName -- -> (ParseResult,[PosToken]) -> FilePath - -> GHC.Located GHC.Name - -> RefactGhc [ApplyRefacResult] -liftToTopLevel' modName pn@(GHC.L _ n) = do - renamed <- getRefactRenamed - -- logm $ "liftToTopLevel':renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ - logm $ "liftToTopLevel':pn=" ++ (showGhc pn) - if isLocalFunOrPatName n renamed - then do - (refactoredMod,declPns) <- applyRefac (liftToMod) RSAlreadyLoaded - - logm $ "liftToTopLevel' applyRefac done " - -- logm $ "liftToTopLevel' applyRefac done:toks= " ++ (show (fst $ snd refactoredMod)) - - if modIsExported modName renamed - then do clients <- clientModsAndFiles modName - logm $ "liftToTopLevel':(clients,declPns)=" ++ (showGhc (clients,declPns)) - refactoredClients <- mapM (liftingInClientMod modName declPns) clients - return (refactoredMod:(concat refactoredClients)) - else do return [refactoredMod] - else error "\nThe identifier is not a local function/pattern name!" - - where - {-step1: divide the module's top level declaration list into three parts: - 'parent' is the top level declaration containing the lifted declaration, - 'before' and `after` are those declarations before and after 'parent'. - step2: get the declarations to be lifted from parent, bind it to liftedDecls - step3: remove the lifted declarations from parent and extra arguments may be introduce. - step4. test whether there are any names need to be renamed. - -} - liftToMod = do - renamed <- getRefactRenamed - let declsr = hsBinds renamed - let (before,parent,after) = divideDecls declsr pn - -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ++ - {- ++AZ++ : hsBinds does not return class or instance definitions - when (isClassDecl $ ghead "liftToMod" parent) - $ error "Sorry, the refactorer cannot lift a definition from a class declaration!" - when (isInstDecl $ ghead "liftToMod" parent) - $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!" - -} - let liftedDecls = definingDeclsNames [n] parent True True - declaredPns = nub $ concatMap definedPNs liftedDecls - liftedSigs = definingSigsNames [n] parent - mLiftedSigs = listToMaybe liftedSigs - - -- TODO: what about declarations between this - -- one and the top level that are used in this one? - - -- logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns)) - -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns - pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns - - -- (_,dd) <- hsFreeAndDeclaredPNs renamed - let dd = getDeclaredVars $ hsBinds renamed - logm $ "liftToMod:(ddd)=" ++ (showGhc dd) - - -- drawTokenTree "liftToMod.a" - drawTokenTreeDetailed "liftToMod.a" - - if pns==[] - then do - -- TODO: change the order, first move the decls then add params, - -- else the liftedDecls get mangled while still in the parent - (parent',liftedDecls',_mLiftedSigs') <- addParamsToParentAndLiftedDecl n dd parent liftedDecls mLiftedSigs - -- let liftedDecls''=if paramAdded then filter isFunOrPatBindR liftedDecls' - -- else liftedDecls' - - -- drawTokenTree "liftToMod.c" - -- logm $ "liftToMod:(declaredPns)=" ++ (showGhc declaredPns) - -- logm $ "liftToMod:(liftedDecls')=" ++ (showGhc liftedDecls') - - let renamed' = replaceBinds renamed (before++parent'++after) - defName = (ghead "liftToMod" (definedPNs (ghead "liftToMod2" parent'))) - void $ moveDecl1 renamed' - (Just defName) - [GHC.unLoc pn] (Just liftedDecls') declaredPns True - - -- drawTokenTree "liftToMod.b" - - return declaredPns - - else askRenamingMsg pns "lifting" - - - --- --------------------------------------------------------------------- - -moveDecl1 :: (HsValBinds t) - => t -- ^ The syntax element to update - -> Maybe GHC.Name -- ^ If specified, add defn after this one - - -- TODO: make this next parameter a single value, not a list, - -- after module complete - -> [GHC.Name] -- ^ The first one is the decl to move - -> Maybe [GHC.LHsBind GHC.Name] - -> [GHC.Name] -- ^ The signatures to remove. May be multiple if - -- decl being moved has a patbind. - -> Bool -- ^ True if moving to the top level - -> RefactGhc t -- ^ The updated syntax element (and tokens in monad) -moveDecl1 t defName ns mliftedDecls sigNames topLevel = do - - -- TODO: work with all of ns, not just the first - let n = ghead "moveDecl1" ns - let funBinding = case mliftedDecls of - Nothing -> definingDeclsNames' [n] t - Just liftedDecls -> liftedDecls - - let Just sspan = getSrcSpan funBinding - funToks <- getToksForSpan sspan - - (t'',sigsRemoved) <- rmTypeSigs sigNames t - (t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1" ns) False t'' - - let getToksForMaybeSig (GHC.L ss _) = - do - sigToks <- getToksForSpan ss - return sigToks - - maybeToksSigMulti <- mapM getToksForMaybeSig - $ sortBy (\(GHC.L s1 _) (GHC.L s2 _) -> compare (ghcSrcSpanToForestSpan s1) (ghcSrcSpanToForestSpan s2)) - sigsRemoved - let maybeToksSig = concat maybeToksSigMulti - - r <- addDecl t' defName (ghead "moveDecl1 2" funBinding,sigsRemoved,Just (maybeToksSig ++ funToks)) topLevel - - return r - - -askRenamingMsg :: [GHC.Name] -> String -> t -askRenamingMsg pns str - = error ("The identifier(s): " ++ (intercalate "," $ map showPN pns) ++ - " will cause name clash/capture or ambiguity occurrence problem after " - ++ str ++", please do renaming first!") - - where - showPN pn = showGhc (pn,GHC.nameSrcLoc pn) - --- |Get the subset of 'pns' that need to be renamed before lifting. -pnsNeedRenaming :: (SYB.Data t1) => - t1 -> [GHC.LHsBind GHC.Name] -> t2 -> [GHC.Name] - -> RefactGhc [GHC.Name] -pnsNeedRenaming dest parent _liftedDecls pns - =do - r <- mapM pnsNeedRenaming' pns - return (concat r) - where - pnsNeedRenaming' pn - = do - (f,d) <- hsFDsFromInside dest --f: free variable names that may be shadowed by pn - --d: declaread variables names that may clash with pn - vs <- hsVisiblePNs pn parent --vs: declarad variables that may shadow pn - let -- inscpNames = map (\(x,_,_,_)->x) $ inScopeInfo inscps - vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames - -- if elem (pNtoName pn) vars || isInScopeAndUnqualified (pNtoName pn) inscps && findEntity pn dest - isInScope <- isInScopeAndUnqualifiedGhc (pNtoName pn) Nothing - logm $ "MoveDef.pnsNeedRenaming:(f,d,vs,vars,isInScope)=" ++ (showGhc (f,d,vs,vars,isInScope)) - if elem (pNtoName pn) vars || isInScope && findEntity pn dest - then return [pn] - else return [] - --This pNtoName takes into account the qualifier. - pNtoName = showGhc - - -addParamsToParent :: (HsValBinds t) => GHC.Name -> [GHC.Name] -> t -> RefactGhc t -addParamsToParent _pn [] t = return t -addParamsToParent pn params t = do - logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params)) - addActualParamsToRhs True pn params t - - --- |Do refactoring in the client module. that is to hide the identifer --- in the import declaration if it will cause any problem in the --- client module. -liftingInClientMod :: GHC.ModuleName -> [GHC.Name] -> TargetModule - -> RefactGhc [ApplyRefacResult] -liftingInClientMod serverModName pns targetModule@(_,modSummary) = do - void $ activateModule targetModule - renamed <- getRefactRenamed - -- logm $ "liftingInClientMod:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ - let clientModule = GHC.ms_mod modSummary - logm $ "liftingInClientMod:clientModule=" ++ (showGhc clientModule) - -- = do (inscps, exps ,mod ,ts) <- parseSourceFile fileName - -- let modNames = willBeUnQualImportedBy serverModName mod - modNames <- willBeUnQualImportedBy serverModName - logm $ "liftingInClientMod:modNames=" ++ (showGhc modNames) - if isJust modNames - then do - pns' <- namesNeedToBeHided clientModule (gfromJust "liftingInClientMod" modNames) pns - logm $ "liftingInClientMod:pns'=" ++ (showGhc pns') - -- in if pns' /= [] - if (nonEmptyList pns') - -- then do <-runStateT (addHiding serverModName mod pns') ((ts,unmodified),(-1000,0)) - then do (refactoredMod,_) <- applyRefac (addHiding serverModName renamed pns') RSAlreadyLoaded - return [refactoredMod] - else return [] - else return [] - --- |Test whether an identifier defined in the modules specified by --- 'names' will be exported by current module. -willBeExportedByClientMod :: [GHC.ModuleName] -> GHC.RenamedSource -> Bool -willBeExportedByClientMod names renamed = - let (_,_,exps,_) = renamed - in if isNothing exps - then False - else any isJust $ map (\y-> (find (\x-> (simpModule x==Just y)) (gfromJust "willBeExportedByClientMod" exps))) names - where simpModule (GHC.L _ (GHC.IEModuleContents m)) = Just m - simpModule _ = Nothing - --- |get the module name or alias name by which the lifted identifier --- will be imported automatically. --- TODO: maybe move this into TypeUtils --- willBeUnQualImportedBy::HsName.ModuleName->HsModuleP->Maybe [HsName.ModuleName] -willBeUnQualImportedBy :: GHC.ModuleName -> RefactGhc (Maybe [GHC.ModuleName]) -willBeUnQualImportedBy modName = do - (_,imps,_,_) <- getRefactRenamed - let ms = filter (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h)) - -> modName == modName1 && (not isQualified) && (isNothing h || (isJust h && ((fst (fromJust h)) == True)))) - imps - - res = if (emptyList ms) then Nothing - else Just $ nub $ map getModName ms - - getModName (GHC.L _ (GHC.ImportDecl (GHC.L _ modName2) _qualify _source _safe _isQualified _isImplicit as _h)) - = if isJust as then simpModName (fromJust as) - else modName2 - - simpModName m = m - - logm $ "willBeUnQualImportedBy:(ms,res)=" ++ (showGhc (ms,res)) - - return res - - --- |get the subset of 'pns', which need to be hided in the import --- declaration in module 'mod' --- Note: these are newly exported from the module, so we cannot use --- the GHC name resolution i nthis case. -namesNeedToBeHided :: GHC.Module -> [GHC.ModuleName] -> [GHC.Name] - -> RefactGhc [GHC.Name] -namesNeedToBeHided clientModule modNames pns = do - renamed <- getRefactRenamed - parsed <- getRefactParsed - logm $ "namesNeedToBeHided:willBeExportedByClientMod=" ++ (show $ willBeExportedByClientMod modNames renamed) - gnames <- GHC.getNamesInScope - let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames - logm $ "namesNeedToBeHided:(clientInscopes)=" ++ (showGhc (clientInscopes)) - - pnsMapped <- mapM getLocalEquiv pns - logm $ "namesNeedToBeHided:pnsMapped=" ++ (showGhc pnsMapped) - - let pnsMapped' = filter (\(_,_,ns) -> not $ emptyList ns) pnsMapped - - if willBeExportedByClientMod modNames renamed - then return pns - else do - ff <- mapM (needToBeHided parsed) pnsMapped' - return $ concat ff - where - -- | Strip the package prefix from the name and return the - -- stripped name together with any names in the local module that - -- may match the stripped one - getLocalEquiv :: GHC.Name -> RefactGhc (GHC.Name,String,[GHC.Name]) - getLocalEquiv pn = do - let pnStr = stripPackage $ showGhc pn - logm $ "MoveDef getLocalEquiv: about to parseName:" ++ (show pnStr) - ecns <- GHC.gtry $ GHC.parseName pnStr - let cns = case ecns of - Left (_e::SomeException) -> [] - Right v -> v - logm $ "MoveDef getLocalEquiv: cns:" ++ (showGhc cns) - return (pn,pnStr,cns) - - stripPackage :: String -> String - stripPackage str = reverse s - where - (s,_) = break (== '.') $ reverse str - - needToBeHided :: GHC.ParsedSource -> (GHC.Name,String,[GHC.Name]) -> RefactGhc [GHC.Name] - needToBeHided parsed (pn,_pnStr,pnsLocal) = do - let uwoq = map (\n -> usedWithoutQualR n parsed) pnsLocal - - -- logm $ "needToBeHided:(hsBinds renamed)=" ++ (showGhc (hsBinds renamed)) - logm $ "needToBeHided:(pn,uwoq)=" ++ (showGhc (pn,uwoq)) - - if (any (== True) uwoq --the same name is used in the module unqualifiedly or - --is exported unqualifiedly by an Ent decl - - -- was || causeNameClashInExports pn modNames renamed) - -- TODO: ++AZ++ check if next line needs to be reinstated - -- was || any (\m -> causeNameClashInExports oldPN pn m renamed) modNames) - || False) - then return [pn] - else return [] - - --- **************************************************************************************************************-- - -{- Refactoring Names: 'liftOneLevel' - Descritption: - this refactoring lifts a local function/pattern binding only one level up. - By 'lifting one-level up' ,I mean: - - case1: In a module (HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds): - A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration. - - new: (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString) - HsGroup hs_valds :: HsValBinds id ... - - - - case2: In a match ( HsMatch SrcLoc i [p] (HsRhs e) ds) : - A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration. - A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to - other declaration list in 'e' - - (in a FunBind) - new: Match [LPat id] (Maybe (LHsType id)) (GRHSs id) - - - case3: In a pattern binding (HsPatBind SrcLoc p (HsRhs e) ds): - A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration. - A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to - other declaration list in 'e' - - new: PatBind (LPat idL) (GRHSs idR) PostTcType NameSet (Maybe tickish) - - - - case4: In the Let expression (Exp (HsLet ds e): - A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration. - A declaration D, say, in the expression 'e' will be lifted to 'ds' if D is not local to - other declaration list in 'e' - - new: HsLet (HsLocalBinds id) (LHsExpr id) - - - case5: In the case Alternative expression:(HsAlt loc p rhs ds) - A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration. - A declaration D in 'rhs' will be lifted to 'ds' if D is not local to other declaration - list in 'rhs'. - - new: HsCase (LHsExpr id) (MatchGroup id) - new is same as in a FunBind. - - - case6: In the do statement expression:(HsLetStmt ds stmts) - A local declaration D will be lifted to the same level as the 'ds', if D is in the - where clause of one of ds's element declaration. - A declaration D in 'stmts' will be lifted to 'ds' if D is not local to other declaration - list in 'stmts'. - - new: LetStmt (HsLocalBindsLR idL idR) - in context GRHS [LStmt id] (LHsExpr id) - - -Function name: liftOneLevel -parameters: fileName--current file name. - mod -- the scoped abstract syntax tree of the module. - pn -- the function/pattern name to be lifted. - --} - -liftOneLevel' :: GHC.ModuleName - -> GHC.Located GHC.Name - -> RefactGhc [ApplyRefacResult] - -liftOneLevel' modName pn@(GHC.L _ n) = do - renamed <- getRefactRenamed - if isLocalFunOrPatName n renamed - then do -- (mod', ((toks',m),_))<-liftOneLevel'' - (refactoredMod,_) <- applyRefac (liftOneLevel'') RSAlreadyLoaded - let (b, pns) = liftedToTopLevel pn renamed - if b && modIsExported modName renamed - then do clients<-clientModsAndFiles modName - -- logm $ "liftOneLevel':(clients,declPns)=" ++ (showGhc (clients,declPns)) - refactoredClients <- mapM (liftingInClientMod modName pns) clients - return (refactoredMod:(concat refactoredClients)) - else do return [refactoredMod] - else error "\nThe identifer is not a function/pattern name!" - - where - liftOneLevel''= do - logm $ "in liftOneLevel''" - renamed <- getRefactRenamed - ztransformStagedM SYB.Renamer (Nothing - `SYB.mkQ` liftToModQ - `SYB.extQ` liftToMatchQ' - `SYB.extQ` liftToLet' - -- `SYB.mkQ` liftToMatchQ - -- `SYB.extQ` liftToLet - ) (Z.toZipper renamed) - - where - isValBinds :: GHC.HsValBinds GHC.Name -> Bool - isValBinds _ = True - - isGRHSs :: GHC.GRHSs GHC.Name -> Bool - isGRHSs _ = True - - isHsLet :: GHC.HsExpr GHC.Name -> Bool - isHsLet (GHC.HsLet _ _) = True - isHsLet _ = False - - liftToModQ ((g,_imps,_exps,_docs):: GHC.RenamedSource) - | nonEmptyList candidateBinds - = Just (doLiftZ candidateBinds) - | otherwise = Nothing - where - candidateBinds = map snd - $ filter (\(l,_bs) -> nonEmptyList l) - $ map (\bs -> (definingDeclsNames [n] (hsBinds bs) False False,bs)) - $ (hsBinds g) - - liftToMatchQ' :: (SYB.Data a) => GHC.Match GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a)) - liftToMatchQ' ((GHC.Match _pats _mtyp (GHC.GRHSs rhs ds))::GHC.Match GHC.Name) - | (nonEmptyList (definingDeclsNames [n] (hsBinds ds) False False)) - = Just (doLiftZ ds) - | (nonEmptyList (definingDeclsNames [n] (hsBinds rhs) False False)) - = Just (doLiftZ rhs) - | otherwise = Nothing - - liftToLet' :: GHC.HsExpr GHC.Name -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a)) - liftToLet' ((GHC.HsLet ds _e)::GHC.HsExpr GHC.Name) - | nonEmptyList (definingDeclsNames [n] (hsBinds ds) False False) - = Just (doLiftZ ds) - | otherwise = Nothing - liftToLet' _ = Nothing - - doLiftZ :: (HsValBinds t) - => t -> SYB.Stage -> Z.Zipper a - -> RefactGhc (Z.Zipper a) - doLiftZ ds _stage z = - do - logm $ "in liftOneLevel''.liftToLet in ds" - - let zu = case (Z.up z) of - Just zz -> fromMaybe (error "MoveDef.liftToLet.1") - $ upUntil (False `SYB.mkQ` isGRHSs - `SYB.extQ` isHsLet - `SYB.extQ` isValBinds) - zz - Nothing -> z - - let - wtop (ren::GHC.RenamedSource) = do - worker ren (hsBinds ds) pn True - - wgrhs (grhss::GHC.GRHSs GHC.Name) = do - (_,dd) <- (hsFreeAndDeclaredPNs grhss) - worker1 grhss (hsBinds ds) pn dd False - - wlet :: GHC.HsExpr GHC.Name -> RefactGhc (GHC.HsExpr GHC.Name) - wlet l@(GHC.HsLet dsl _e) = do - (_,dd) <- hsFreeAndDeclaredPNs dsl - dsl' <- worker1 l (hsBinds ds) pn dd False - return dsl' - wlet x = return x - - wvalbinds (vb::GHC.HsValBinds GHC.Name) = do - (_,dd) <- (hsFreeAndDeclaredPNs vb) - worker1 vb (hsBinds ds) pn dd False - - ds' <- Z.transM (SYB.mkM wtop `SYB.extM` wgrhs - `SYB.extM` wlet `SYB.extM` wvalbinds) zu - - return ds' - - -- TODO: merge worker and worker1 - worker :: (HsValBinds t,GHC.Outputable t) - => t -- ^The destination of the lift operation - -> [GHC.LHsBind GHC.Name] -- ^ list containing the - -- decl to be lifted - -> GHC.Located GHC.Name -- ^ The name of the decl to - -- be lifted - -> Bool -- ^True if lifting to the top level - -> RefactGhc t - worker dest ds pnn toToplevel - =do let (before,parent,after)=divideDecls ds pnn -- parent is misnomer, it is the decl to be moved - liftedDecls=definingDeclsNames [n] parent True True - declaredPns=nub $ concatMap definedPNs liftedDecls - (_, dd) <- hsFreeAndDeclaredPNs dest - pns<-pnsNeedRenaming dest parent liftedDecls declaredPns - logm $ "MoveDef.worker: pns=" ++ (showGhc pns) - if pns==[] - then do - (parent',liftedDecls',_mLiftedSigs')<-addParamsToParentAndLiftedDecl n dd - parent liftedDecls Nothing - --True means the new decl will be at the same level with its parant. - dest' <- moveDecl1 (replaceBinds dest (before++parent'++after)) - (Just (ghead "worker" (definedPNs (ghead "worker" parent')))) - [n] (Just liftedDecls') declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move - return dest' - --parent'<-doMoving declaredPns (ghead "worker" parent) True paramAdded parent' - --return (before++parent'++liftedDecls''++after) - else askRenamingMsg pns "lifting" - - worker1 :: (HsValBinds t,GHC.Outputable t) - => t -- ^The destination of the lift operation - -> [GHC.LHsBind GHC.Name] -- ^ list containing the - -- decl to be lifted - -> GHC.Located GHC.Name -- ^ The name of the decl to - -- be lifted - -> [GHC.Name] -- ^Declared variables in the destination - -> Bool -- ^True if lifting to the top level - -> RefactGhc t - worker1 dest ds pnn dd toToplevel - {- - Actions required - 1. add parameters to original decls if required - 2. add parameters to any points that call the lifted decl - once it is lifted - 3. Replace the above in the AST - 4. Do the move - -} - - =do let (_before,decl,_after)=divideDecls ds pnn - liftedDecls=definingDeclsNames [n] decl True True - declaredPns=nub $ concatMap definedPNs liftedDecls - - pns <- pnsNeedRenaming dest decl liftedDecls declaredPns - logm $ "MoveDef.worker1: pns=" ++ (showGhc pns) - if pns==[] - then do - (parent',liftedDecls',_mLiftedSigs') - <- addParamsToParentAndLiftedDecl n dd dest liftedDecls Nothing - --True means the new decl will be at the same level with its parant. - parent'' <- moveDecl1 parent' Nothing - [n] (Just liftedDecls') declaredPns toToplevel -- False -- ++AZ++ TODO: should be True for toplevel move - return parent'' - --decl'<-doMoving declaredPns (ghead "worker" decl) True paramAdded decl' - --return (before++decl'++liftedDecls''++after) - else askRenamingMsg pns "lifting" - - -liftedToTopLevel :: GHC.Located GHC.Name -> GHC.RenamedSource -> (Bool,[GHC.Name]) -liftedToTopLevel pnt@(GHC.L _ pn) renamed - = if nonEmptyList (definingDeclsNames [pn] (hsBinds renamed) False True) - then let (_, parent,_) = divideDecls (hsBinds renamed) pnt - liftedDecls=definingDeclsNames [pn] (hsBinds parent) True True - declaredPns = nub $ concatMap definedPNs liftedDecls - in (True, declaredPns) - else (False, []) - - -addParamsToParentAndLiftedDecl :: (HsValBinds t,GHC.Outputable t) => - GHC.Name -- ^name of decl being lifted - -> [GHC.Name] -- ^Declared names in parent - -> t -- ^parent - -> [GHC.LHsBind GHC.Name] -- ^decls being lifted - -> Maybe (GHC.LSig GHC.Name) -- ^ lifted decls signature if present - -> RefactGhc (t, [GHC.LHsBind GHC.Name], Maybe (GHC.LSig GHC.Name)) -addParamsToParentAndLiftedDecl pn dd parent liftedDecls mLiftedSigs - =do (ef,_) <- hsFreeAndDeclaredPNs parent - (lf,_) <- hsFreeAndDeclaredPNs liftedDecls - - -- logm $ "addParamsToParentAndLiftedDecl:parent=" ++ (showGhc parent) - - -- parameters to be added to pn because of lifting - let newParams= ((nub lf) \\ (nub ef)) \\ dd - - logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd)) - - if newParams /= [] - then if (any isComplexPatBind liftedDecls) - then error "This pattern binding cannot be lifted, as it uses some other local bindings!" - else do -- first remove the decls to be lifted, so they are not disturbed - (parent'',liftedDecls'',_msig) <- rmDecl pn False parent - - parent' <- addParamsToParent pn newParams parent'' - - liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams True - - mLiftedSigs' <- addParamsToSigs newParams mLiftedSigs - - logm $ "addParamsToParentAndLiftedDecl:mLiftedSigs'=" ++ showGhc mLiftedSigs' - - return (parent',liftedDecls', mLiftedSigs') - else return (parent,liftedDecls,mLiftedSigs) - --- --------------------------------------------------------------------- - --- TODO: perhaps move this to TypeUtils -addParamsToSigs :: [GHC.Name] -> Maybe (GHC.LSig GHC.Name) -> RefactGhc (Maybe (GHC.LSig GHC.Name)) -addParamsToSigs _ Nothing = return Nothing -addParamsToSigs [] ms = return ms -addParamsToSigs newParams (Just (GHC.L l (GHC.TypeSig lns ltyp@(GHC.L lt _)))) = do - mts <- mapM getTypeForName newParams - let ts = catMaybes mts - -- Note : the '::' symbol lies between the lns and the ltyp. Hence - -- construct a new location covering this gap, to insert the mew - -- params. This span has been specifically inserted into the - -- TokenTree when it is initially loaded. - let ne = GHC.srcSpanEnd $ GHC.getLoc $ glast "addParamsToSigs" lns - ls = GHC.srcSpanStart $ lt - replaceSpan = GHC.mkSrcSpan ne ls - newStr = ":: " ++ (intercalate " -> " $ map printSigComponent ts) ++ " -> " - logm $ "addParamsToSigs:replaceSpan=" ++ showGhc replaceSpan - logm $ "addParamsToSigs:newStr=[" ++ newStr ++ "]" - let newToks = basicTokenise newStr - void $ putToksForSpan replaceSpan newToks - let typ' = foldl addOneType ltyp ts - sigOk <- isNewSignatureOk ts - logm $ "addParamsToSigs:(sigOk,newStr)=" ++ show (sigOk,newStr) - if sigOk - then return $ Just (GHC.L l (GHC.TypeSig lns typ')) - else error $ "\nNew type signature may fail type checking: " ++ newStr ++ "\n" - where - addOneType :: GHC.LHsType GHC.Name -> GHC.Type -> GHC.LHsType GHC.Name - addOneType et t = GHC.noLoc (GHC.HsFunTy (GHC.noLoc hst) et) - where - hst = typeToHsType t - -addParamsToSigs np ls = error $ "addParamsToSigs: no match for:" ++ showGhc (np,ls) - --- --------------------------------------------------------------------- - -printSigComponent :: GHC.Type -> String -printSigComponent x = ppType x - --- --------------------------------------------------------------------- - --- |Fail any signature having a forall in it. --- TODO: this is unnecesarily restrictive, but needs --- a) proper reversing of GHC.Type to GHC.LhsType --- b) some serious reverse type inference to ensure that the --- constraints are modified properly to merge the old signature --- part and the new. -isNewSignatureOk :: [GHC.Type] -> RefactGhc Bool -isNewSignatureOk types = do - -- NOTE: under some circumstances enabling Rank2Types or RankNTypes - -- can resolve the type conflict, this can potentially be checked - -- for. - -- NOTE2: perhaps proceed and reload the tentative refactoring into - -- the GHC session and accept it only if it type checks - let - r = SYB.everythingStaged SYB.TypeChecker (++) [] - ([] `SYB.mkQ` usesForAll) types - usesForAll (GHC.ForAllTy _ _) = [1::Int] - usesForAll _ = [] - - -- logm $ "isNewSignatureOk:r=" ++ show r - return $ emptyList r - --- --------------------------------------------------------------------- - --- TODO: perhaps move this to TypeUtils --- TODO: complete this -typeToHsType :: GHC.Type -> GHC.HsType GHC.Name -typeToHsType (GHC.TyVarTy v) = GHC.HsTyVar (Var.varName v) -typeToHsType (GHC.AppTy t1 t2) = GHC.HsAppTy (GHC.noLoc $ typeToHsType t1) - (GHC.noLoc $ typeToHsType t2) - -typeToHsType t@(GHC.TyConApp _tc _ts) = tyConAppToHsType t - -typeToHsType (GHC.FunTy t1 t2) = GHC.HsFunTy (GHC.noLoc $ typeToHsType t1) - (GHC.noLoc $ typeToHsType t2) -#if __GLASGOW_HASKELL__ > 704 -typeToHsType (GHC.ForAllTy _v t) = GHC.HsForAllTy GHC.Explicit (GHC.HsQTvs [] []) (GHC.noLoc []) (GHC.noLoc $ typeToHsType t) -#else -typeToHsType (GHC.ForAllTy _v t) = GHC.HsForAllTy GHC.Explicit [] (GHC.noLoc []) (GHC.noLoc $ typeToHsType t) -#endif - -#if __GLASGOW_HASKELL__ > 704 -typeToHsType (GHC.LitTy (GHC.NumTyLit i)) = GHC.HsTyLit (GHC.HsNumTy i) -typeToHsType (GHC.LitTy (GHC.StrTyLit s)) = GHC.HsTyLit (GHC.HsStrTy s) -#endif - -{- -data Type - = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) - - | AppTy -- See Note [AppTy invariant] - Type - Type -- ^ Type application to something other than a 'TyCon'. Parameters: - -- - -- 1) Function: must /not/ be a 'TyConApp', - -- must be another 'AppTy', or 'TyVarTy' - -- - -- 2) Argument type - - | TyConApp -- See Note [AppTy invariant] - TyCon - [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. - -- Invariant: saturated appliations of 'FunTyCon' must - -- use 'FunTy' and saturated synonyms must use their own - -- constructors. However, /unsaturated/ 'FunTyCon's - -- do appear as 'TyConApp's. - -- Parameters: - -- - -- 1) Type constructor being applied to. - -- - -- 2) Type arguments. Might not have enough type arguments - -- here to saturate the constructor. - -- Even type synonyms are not necessarily saturated; - -- for example unsaturated type synonyms - -- can appear as the right hand side of a type synonym. - - | FunTy - Type - Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@ - -- See Note [Equality-constrained types] - - | ForAllTy - Var -- Type or kind variable - Type -- ^ A polymorphic type - - | LitTy TyLit -- ^ Type literals are simillar to type constructors. - --} - -tyConAppToHsType :: GHC.Type -> GHC.HsType GHC.Name -tyConAppToHsType (GHC.TyConApp tc _ts) - | GHC.isFunTyCon tc = r "isFunTyCon" - | GHC.isAlgTyCon tc = r "isAlgTyCon" - | GHC.isTupleTyCon tc = r "isTupleTyCon" - | GHC.isSynTyCon tc = r "isSynTyCon" - | GHC.isPrimTyCon tc = r "isPrimTyCon" -#if __GLASGOW_HASKELL__ > 704 - | GHC.isPromotedDataCon tc = r "isPromotedDataTyCon" - | GHC.isPromotedTyCon tc = r "isPromotedTyCon" -#endif - where - -#if __GLASGOW_HASKELL__ > 704 - r str = GHC.HsTyLit (GHC.HsStrTy $ GHC.mkFastString str) -#else - r str = error $ "tyConAppToHsType: " ++ str ++ " unexpected:" ++ (SYB.showData SYB.TypeChecker 0 r) -#endif - -tyConAppToHsType t@(GHC.TyConApp _tc _ts) - = error $ "tyConAppToHsType: unexpected:" ++ (SYB.showData SYB.TypeChecker 0 t) - -{- -HsType -HsForAllTy HsExplicitFlag (LHsTyVarBndrs name) (LHsContext name) (LHsType name) -HsTyVar name -HsAppTy (LHsType name) (LHsType name) -HsFunTy (LHsType name) (LHsType name) -HsListTy (LHsType name) -HsPArrTy (LHsType name) -HsTupleTy HsTupleSort [LHsType name] -HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) -HsParTy (LHsType name) -HsIParamTy HsIPName (LHsType name) -HsEqTy (LHsType name) (LHsType name) -HsKindSig (LHsType name) (LHsKind name) -HsQuasiQuoteTy (HsQuasiQuote name) -HsSpliceTy (HsSplice name) FreeVars PostTcKind -HsDocTy (LHsType name) LHsDocString -HsBangTy HsBang (LHsType name) -HsRecTy [ConDeclField name] -HsCoreTy Type -HsExplicitListTy PostTcKind [LHsType name] -HsExplicitTupleTy [PostTcKind] [LHsType name] -HsTyLit HsTyLit -HsWrapTy HsTyWrapper (HsType name) --} - - - - -{- - = -- | The function type constructor, @(->)@ - FunTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity - } - - -- | Algebraic type constructors, which are defined to be those - -- arising @data@ type and @newtype@ declarations. All these - -- constructors are lifted and boxed. See 'AlgTyConRhs' for more - -- information. - | AlgTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, - - tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the type constructor. - -- Invariant: length tyvars = arity - -- Precisely, this list scopes over: - -- - -- 1. The 'algTcStupidTheta' - -- 2. The cached types in 'algTyConRhs.NewTyCon' - -- 3. The family instance types if present - -- - -- Note that it does /not/ scope over the data constructors. - tyConCType :: Maybe CType, -- The C type that should be used - -- for this type when using the FFI - -- and CAPI - - algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT syntax? - -- If so, that doesn't mean it's a true GADT; - -- only that the "where" form was used. - -- This field is used only to guide pretty-printing - - algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type - -- (always empty for GADTs). - -- A \"stupid theta\" is the context to the left - -- of an algebraic type declaration, - -- e.g. @Eq a@ in the declaration - -- @data Eq a => T a ...@. - - algTcRhs :: AlgTyConRhs, -- ^ Contains information about the - -- data constructors of the algebraic type - - algTcRec :: RecFlag, -- ^ Tells us whether the data type is part - -- of a mutually-recursive group or not - - algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon' - -- for derived 'TyCon's representing class - -- or family instances, respectively. - -- See also 'synTcParent' - } - - -- | Represents the infinite family of tuple type constructors, - -- @()@, @(a,b)@, @(# a, b #)@ etc. - | TupleTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, - tyConTupleSort :: TupleSort, - tyConTyVars :: [TyVar], - dataCon :: DataCon -- ^ Corresponding tuple data constructor - } - - -- | Represents type synonyms - | SynTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, - - tyConTyVars :: [TyVar], -- Bound tyvars - - synTcRhs :: SynTyConRhs, -- ^ Contains information about the - -- expansion of the synonym - - synTcParent :: TyConParent -- ^ Gives the family declaration 'TyCon' - -- of 'TyCon's representing family instances - - } - - -- | Primitive types; cannot be defined in Haskell. This includes - -- the usual suspects (such as @Int#@) as well as foreign-imported - -- types and kinds - | PrimTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance - -- of the arity of a primtycon is! - - primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are - -- boxed (represented by pointers). This 'PrimRep' - -- holds that information. - -- Only relevant if tc_kind = * - - isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted - -- (may not contain bottom) - -- but foreign-imported ones may be lifted - - tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, - -- holds the name of the imported thing - } - - -- | Represents promoted data constructor. - | PromotedDataCon { -- See Note [Promoted data constructors] - tyConUnique :: Unique, -- ^ Same Unique as the data constructor - tyConName :: Name, -- ^ Same Name as the data constructor - tyConArity :: Arity, - tc_kind :: Kind, -- ^ Translated type of the data constructor - dataCon :: DataCon -- ^ Corresponding data constructor - } - - -- | Represents promoted type constructor. - | PromotedTyCon { - tyConUnique :: Unique, -- ^ Same Unique as the type constructor - tyConName :: Name, -- ^ Same Name as the type constructor - tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times - tc_kind :: Kind, -- ^ Always TysPrim.superKind - ty_con :: TyCon -- ^ Corresponding type constructor - } - - deriving Typeable - --} - ---------------------------------End of Lifting----------------------------------------- - -{-Refactoring : demote a function/pattern binding(simpe or complex) to the declaration where it is used. - Descritption: if a declaration D, say, is only used by another declaration F,say, then D can be - demoted into the local declaration list (where clause) in F. - So currently, D can not be demoted if more than one declaration use it. - - In a multi-module context, a top-level definition can not be demoted if it is used - by other modules. In the case that the demoted identifer is in the hiding list of - import declaration in a client module, it should be removed from the hiding list. - - Function name:demote - parameters: fileName--current file name. - mod -- the scoped abstract syntax tree of the module. - pn -- the function/pattern name to be demoted. - --} - -demote' :: - GHC.ModuleName - -- -> FilePath - -- -> (ParseResult,[PosToken]) - -> GHC.Located GHC.Name - -> RefactGhc [ApplyRefacResult] -demote' modName (GHC.L _ pn) = do - renamed <- getRefactRenamed - if isFunOrPatName pn renamed - then do - isTl <- isTopLevelPN pn - if isTl && isExplicitlyExported pn renamed - then error "This definition can not be demoted, as it is explicitly exported by the current module!" - else do -- (mod',((toks',m),_))<-doDemoting pn fileName mod toks - (refactoredMod,_) <- applyRefac (doDemoting pn) RSAlreadyLoaded - -- isTl <- isTopLevelPN pn - if isTl && modIsExported modName renamed - then do let demotedDecls'= definingDeclsNames [pn] (hsBinds renamed) True False - declaredPns = nub $ concatMap definedPNs demotedDecls' - clients <- clientModsAndFiles modName - logm $ "demote':clients=" ++ (showGhc clients) - refactoredClients <-mapM (demotingInClientMod declaredPns) clients - -- return (refactoredMod:[]) - return (refactoredMod:refactoredClients) - else do return [refactoredMod] - else error "\nInvalid cursor position!" - - --- |Do refactoring in the client module, that is: --- a) Check whether the identifier is used in the module body --- b) If the identifier is not used but is hided by the import --- declaration, then remove it from the hiding. -demotingInClientMod :: - [GHC.Name] -> TargetModule - -> RefactGhc ApplyRefacResult -demotingInClientMod pns targetModule@(_,modSummary) = do - void $ activateModule targetModule - (refactoredMod,_) <- applyRefac (doDemotingInClientMod pns (GHC.ms_mod modSummary)) RSAlreadyLoaded - return refactoredMod - - -doDemotingInClientMod :: [GHC.Name] -> GHC.Module -> RefactGhc () -doDemotingInClientMod pns modName = do - renamed@(_g,imps,exps,_docs) <- getRefactRenamed - if any (\pn->findPN pn (hsBinds renamed) || findPN pn (exps)) pns - then error $ "This definition can not be demoted, as it is used in the client module '"++(showGhc modName)++"'!" - else if any (\pn->findPN pn imps) pns - -- TODO: reinstate this - then do -- (mod',((ts',m),_))<-runStateT (rmItemsFromImport mod pns) ((ts,unmodified),(-1000,0)) - return () - else return () - -doDemoting :: GHC.Name -> RefactGhc () -doDemoting pn = do - - clearRefactDone -- Only do this action once - - renamed <- getRefactRenamed - -- logm $ "MoveDef.doDemoting:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ - - -- everywhereMStaged' is top-down, does all - renamed' <- everywhereMStaged' SYB.Renamer (SYB.mkM demoteInMod - `SYB.extM` demoteInMatch - `SYB.extM` demoteInPat - `SYB.extM` demoteInLet - `SYB.extM` demoteInStmt - ) renamed - -- error ("doDemoting:renamed'=" ++ (showGhc renamed')) - putRefactRenamed renamed' - -- ren <- getRefactRenamed - -- error ("doDemoting:ren=" ++ (showGhc ren)) - showLinesDebug "doDemoting done" - return () - where - --1. demote from top level - -- demoteInMod (mod@(HsModule loc name exps imps ds):: HsModuleP) - demoteInMod (renamed :: GHC.RenamedSource) - | not $ emptyList decls - = do - logm "MoveDef:demoteInMod" -- ++AZ++ - demoted <- doDemoting' renamed pn - return demoted - where - decls = (definingDeclsNames [pn] (hsBinds renamed) False False) - demoteInMod x = return x - - --2. The demoted definition is a local decl in a match - -- demoteInMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP) - demoteInMatch (match@(GHC.Match _pats _mt (GHC.GRHSs _ ds))::GHC.Match GHC.Name) - -- was | definingDecls [pn] ds False False/=[] - | not $ emptyList (definingDeclsNames [pn] (hsBinds ds) False False) - = do - logm "MoveDef:demoteInMatch" -- ++AZ++ - done <- getRefactDone - match' <- if (not done) - then doDemoting' match pn - else return match - return match' - demoteInMatch x = return x - - --3. The demoted definition is a local decl in a pattern binding - -- demoteInPat (pat@(Dec (HsPatBind loc p rhs ds))::HsDeclP) - demoteInPat (pat@((GHC.PatBind _p rhs _ _ _))::GHC.HsBind GHC.Name) - -- was | definingDecls [pn] ds False False /=[] - | not $ emptyList (definingDeclsNames [pn] (hsBinds rhs) False False) - = do - logm "MoveDef:demoteInPat" -- ++AZ++ - done <- getRefactDone - pat' <- if (not done) - then doDemoting' pat pn - else return pat - return pat' - demoteInPat x = return x - - --4: The demoted definition is a local decl in a Let expression - -- demoteInLet (letExp@(Exp (HsLet ds e))::HsExpP) - demoteInLet (letExp@(GHC.L _ (GHC.HsLet ds _e))::GHC.LHsExpr GHC.Name) - -- was | definingDecls [pn] ds False False/=[] - | not $ emptyList (definingDeclsNames [pn] (hsBinds ds) False False) - = do - logm "MoveDef:demoteInLet" -- ++AZ++ - done <- getRefactDone - letExp' <- if (not done) - then doDemoting' letExp pn - else return letExp - return letExp' - demoteInLet x = return x - - -- TODO: the rest of these cases below -{- - --5. The demoted definition is a local decl in a case alternative. - demoteInAlt (alt@(HsAlt loc p rhs ds)::(HsAlt (HsExpP) (HsPatP) [HsDeclP])) - | definingDecls [pn] ds False False /=[] - = doDemoting' alt pn - demoteInAlt _=mzero --} - - --6.The demoted definition is a local decl in a Let statement. - -- demoteInStmt (letStmt@(HsLetStmt ds stmts):: (HsStmt (HsExpP) (HsPatP) [HsDeclP])) - demoteInStmt (letStmt@(GHC.LetStmt binds)::GHC.Stmt GHC.Name) - -- was | definingDecls [pn] ds False False /=[] - | not $ emptyList (definingDeclsNames [pn] (hsBinds binds) False False) - = do - logm "MoveDef:demoteInStmt" -- ++AZ++ - done <- getRefactDone - letStmt' <- if (not done) - then doDemoting' letStmt pn - else return letStmt - return letStmt' - demoteInStmt x =return x - - -- TODO: the rest of these cases below -{- - failure=idTP `adhocTP` mod - where - mod (m::HsModuleP) - = error "Refactoring failed!" --SHOULD GIVE MORE DETAILED ERROR MESSAGE --} - - - --- |Demote the declaration of 'pn' in the context of 't'. -doDemoting' :: (HsValBinds t, UsedByRhs t) => t -> GHC.Name -> RefactGhc t -doDemoting' t pn = do - let origDecls = hsBinds t - demotedDecls'= definingDeclsNames [pn] origDecls True False - declaredPns = nub $ concatMap definedPNs demotedDecls' - pnsUsed = usedByRhs t declaredPns - logm $ "doDemoting':(pn,declaredPns)=" ++ showGhc (pn,declaredPns) - -- logm $ "doDemoting':t=" ++ (SYB.showData SYB.Renamer 0 t) - logm $ "doDemoting':(declaredPns,pnsUsed)=" ++ showGhc (declaredPns,pnsUsed) - r <- if not pnsUsed -- (usedByRhs t declaredPns) - then do - -- drawTokenTree "" -- ++AZ++ debug - let demotedDecls = definingDeclsNames [pn] (hsBinds t) True True - let - otherBinds = (deleteFirstsBy sameBind (hsBinds t) demotedDecls) - -- uselist = uses declaredPns otherBinds - {- From 'hsDecls t' to 'hsDecls t \\ demotedDecls'. - Bug fixed 06/09/2004 to handle direct recursive function. - -} - -- uselist = concatMap (\r -> if (emptyList r) then [] else ["Used"]) $ map (\b -> uses declaredPns [b]) otherBinds - xx = map (\b -> (b,uses declaredPns [b])) otherBinds - useCount = sum $ concatMap snd xx - -- logm $ "doDemoting': uses xx=" ++ (showGhc xx) - -- logm $ "doDemoting': uses useCount=" ++ (show useCount) - - case useCount of - 0 ->do error "\n Nowhere to demote this function!\n" - 1 -> --This function is only used by one friend function - do - logm "MoveDef.doDemoting':target location found" -- ++AZ++ - - (f,_d) <- hsFreeAndDeclaredPNs demotedDecls - (ds,removedDecl,_sigRemoved) <- rmDecl pn False t - - (t',demotedSigs) <- rmTypeSigs declaredPns ds - - let (GHC.L ssd _) = removedDecl - demotedToks <- getToksForSpan ssd - - -- TODO: move this to its own fn - let getToksForMaybeSig (GHC.L ss _) = do - sigToks <- getToksForSpan ss - return sigToks - - demotedSigToksLists <- mapM getToksForMaybeSig demotedSigs - let demotedSigToks = concat demotedSigToksLists - -- end TODO - - logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns) -- ++AZ++ - - --get those variables declared at where the demotedDecls will be demoted to - -- let dl = map (flip declaredNamesInTargetPlace ds) declaredPns - dl <- mapM (flip declaredNamesInTargetPlace ds) declaredPns - logm $ "mapM declaredNamesInTargetPlace done" - --make sure free variable in 'f' do not clash with variables in 'dl', - --otherwise do renaming. - let clashedNames=filter (\x-> elem (id x) (map id f)) $ (nub.concat) dl - --rename clashed names to new names created automatically,update TOKEN STREAM as well. - if clashedNames/=[] - then error ("The identifier(s):" ++ showGhc clashedNames ++ - ", declared in where the definition will be demoted to, will cause name clash/capture" - ++" after demoting, please do renaming first!") - --ds'<-foldM (flip (autoRenameLocalVar True)) ds clashedNames - else --duplicate demoted declarations to the right place. - do - logm $ "MoveDef: about to duplicateDecls" - ds'' <- duplicateDecls declaredPns removedDecl demotedSigs (Just (demotedSigToks ++ demotedToks)) (hsBinds ds) - logm $ "MoveDef:duplicateDecls done" - - return (replaceBinds t' ds'') - _ ->error "\nThis function/pattern binding is used by more than one friend bindings\n" - - else error "This function can not be demoted as it is used in current level!\n" - - return r - - where - ---find how many matches/pattern bindings use 'pn'------- - -- uses :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> [Int] - uses pns t2 - = concatMap used t2 - where - - used :: GHC.LHsBind GHC.Name -> [Int] - used (GHC.L _ (GHC.FunBind _n _ (GHC.MatchGroup matches _) _ _ _)) - = concatMap (usedInMatch pns) matches - - used (GHC.L _ (GHC.PatBind pat rhs _ _ _)) - -- was | hsPNs p `intersect` pns ==[] && any (flip findPN pat) pns - | (not $ findPNs pns pat) && findPNs pns rhs - = [1::Int] - used _ = [] - - usedInMatch pns (GHC.L _ (GHC.Match pats _ rhs)) - -- was | isNothing (find (==pname) pns) && any (flip findPN match) pns - | (not $ findPNs pns pats) && findPNs pns rhs - = [1::Int] - usedInMatch _ _ = [] - - - -- duplicate demotedDecls to the right place (the outer most level where it is used). - duplicateDecls :: [GHC.Name] -- ^ function names to be demoted - -> GHC.LHsBind GHC.Name -- ^Bind being demoted - -> [GHC.LSig GHC.Name] -- ^Signatures being demoted, if any - -> Maybe [PosToken] -- ^Tokens if provided - -> [GHC.LHsBind GHC.Name] -- ^Binds of original top level entiity, including src and dst - -> RefactGhc [GHC.LHsBind GHC.Name] - duplicateDecls pns demoted dsig dtoks decls - -- = do everywhereMStaged SYB.Renamer (SYB.mkM dupInMatch - = do - -- logm "duplicateDecls:clearing done" -- ++AZ++ - -- clearRefactDone - everywhereMStaged' SYB.Renamer (SYB.mkM dupInMatch -- top-down approach - -- = do somewhereMStaged SYB.Renamer (SYB.mkM dupInMatch -- need working MonadPlus for somewhereMStaged - `SYB.extM` dupInPat) decls - {- - = do applyTP (once_tdTP (failTP `adhocTP` dupInMatch - `adhocTP` dupInPat)) decls - --error (show decls' ++ "\n" ++ prettyprint decls') - -- rmDecl (ghead "moveDecl3" pns) False =<PName->t->m [PName] - declaredNamesInTargetPlace pn=applyTU (stop_tdTU (failTU - `adhocTU` inMatch - `adhocTU` inPat)) - -} - declaredNamesInTargetPlace :: (SYB.Data t) - => GHC.Name -> t - -- -> RefactGhc [GHC.Name] - -> RefactGhc [GHC.Name] - - declaredNamesInTargetPlace pn' t' = do - logm $ "declaredNamesInTargetPlace:pn=" ++ (showGhc pn') - res <- applyTU (stop_tdTUGhc (failTU - `adhocTU` inMatch - `adhocTU` inPat)) t' - logm $ "declaredNamesInTargetPlace:res=" ++ (showGhc res) - return res - where - -- inMatch (match@(HsMatch loc1 name pats rhs ds)::HsMatchP) - inMatch ((GHC.Match _pats _ rhs) :: GHC.Match GHC.Name) - | findPN pn' rhs = do - logm $ "declaredNamesInTargetPlace:inMatch" - fds <- hsFDsFromInside rhs - return $ snd fds - -- (return.snd) =<< hsFDsFromInside rhs - -- inMatch _ = mzero - inMatch _ = return mzero - - -- inPat (pat@(Dec (HsPatBind loc p rhs ds)):: HsDeclP) - inPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name) - |findPN pn' rhs = do - logm $ "declaredNamesInTargetPlace:inPat" - fds <- hsFDsFromInside pat - return $ snd fds - -- (return.snd) =<< hsFDsFromInside pat - -- inPat _= mzero - inPat _= return mzero - - - --- --------------------------------------------------------------------- - - - - -{- foldParams:remove parameters in the demotedDecls if possible - parameters: pn -- the function/pattern name to be demoted in PName format - match--where the demotedDecls will be demoted to - demotedDecls -- the declarations to be demoted. - example: - module Test where demote 'sq' module Test where - sumSquares x y ===> sumSquares x y =(sq 0) + (sq y) - = sq x 0+ sq x y where sq y=x ^ y - sq x y=x^y --} ---PROBLEM: TYPE SIGNATURE SHOULD BE CHANGED. ---- TEST THIS FUNCTION!!! -foldParams :: [GHC.Name] -- ^The (list?) function name being demoted - -> GHC.Match GHC.Name -- ^The RHS of the place to receive the demoted decls - -> [GHC.LHsBind GHC.Name] -- ^Binds of original top level entiity, including src and dst - -> GHC.LHsBind GHC.Name -- ^The decls being demoted - -> [GHC.LSig GHC.Name] -- ^Signatures being demoted, if any - -> Maybe [PosToken] -- ^Tokens if provided - -> RefactGhc (GHC.Match GHC.Name) -foldParams pns ((GHC.Match pats mt rhs)::GHC.Match GHC.Name) _decls demotedDecls dsig dtoks - - =do - logm $ "MoveDef.foldParams entered" - -- logm $ "MoveDef.foldParams:match=" ++ (SYB.showData SYB.Renamer 0 match) - - let matches=concatMap matchesInDecls [GHC.unLoc demotedDecls] - pn=ghead "foldParams" pns --pns /=[] - params <- allParams pn rhs [] - if (length.nub.map length) params==1 -- have same number of param - && ((length matches)==1) -- only one 'match' in the demoted declaration - then do - let patsInDemotedDecls=(patsInMatch.(ghead "foldParams")) matches - subst=mkSubst patsInDemotedDecls params - fstSubst=map fst subst - sndSubst=map snd subst - - -- logm $ "MoveDef.foldParams before rmParamsInParent" - rhs' <- rmParamsInParent pn sndSubst rhs - -- logm $ "MoveDef.foldParams after rmParamsInParent" - - -- ls<-mapM hsFreeAndDeclaredPNs sndSubst - -- ls <- mapM hsFreeAndDeclaredPNs sndSubst - ls <- mapM hsFreeAndDeclaredPNs sndSubst - -- newNames contains the newly introduced names to the demoted decls--- - -- let newNames=(map pNtoName (concatMap fst ls)) \\ (map pNtoName fstSubst) - let newNames=((concatMap fst ls)) \\ (fstSubst) - --There may be name clashing because of introducing new names. - clashedNames<-getClashedNames fstSubst newNames (ghead "foldParams" matches) - - logm $ "MoveDef.foldParams about to foldInDemotedDecls" - - -- decls' <- foldInDemotedDecls pns clashedNames subst decls - -- let demotedDecls''' = definingDeclsNames pns decls' True False - demotedDecls''' <- foldInDemotedDecls pns clashedNames subst [demotedDecls] - logm $ "MoveDef.foldParams foldInDemotedDecls done" - - let [(GHC.L declSpan _)] = demotedDecls''' - declToks <- getToksForSpan declSpan - -- logm $ "MoveDef.foldParams addDecl adding to (hsBinds):[" ++ (SYB.showData SYB.Renamer 0 $ hsBinds rhs') ++ "]" -- ++AZ++ - rhs'' <- addDecl rhs' Nothing (ghead "foldParams 2" demotedDecls''',[],Just declToks) False - logm $ "MoveDef.foldParams addDecl done 1" - return (GHC.Match pats mt rhs'') - else do -- moveDecl pns match False decls True - -- return (HsMatch loc1 name pats rhs (ds++demotedDecls)) -- no parameter folding - -- logm $ "MoveDef.foldParams about to addDecl:dtoks=" ++ (show dtoks) - -- drawTokenTree "" -- ++AZ++ debug - rhs' <- addDecl rhs Nothing (demotedDecls,dsig,dtoks) False - logm $ "MoveDef.foldParams addDecl done 2" - return (GHC.Match pats mt rhs') - - -- return match - where - - -- matchesInDecls ((Dec (HsFunBind loc matches))::HsDeclP)=matches - matchesInDecls (GHC.FunBind _ _ (GHC.MatchGroup matches _) _ _ _) = matches - matchesInDecls _x = [] - - -- patsInMatch ((HsMatch loc1 name pats rhs ds)::HsMatchP) - -- =pats - patsInMatch (GHC.L _ (GHC.Match pats' _ _)) = pats' - - -- demotedDecls = map GHC.unLoc $ definingDeclsNames pns decls True False - - - foldInDemotedDecls :: [GHC.Name] -- ^The (list?) of names to be demoted - -> [GHC.Name] -- ^Any names that clash - -> [(GHC.Name, GHC.HsExpr GHC.Name)] -- ^Parameter substitutions required - -> [GHC.LHsBind GHC.Name] -- ^Binds of original top level entiity, including src and dst - -> RefactGhc [GHC.LHsBind GHC.Name] - foldInDemotedDecls pns' clashedNames subst decls - = everywhereMStaged SYB.Renamer (SYB.mkM worker) decls - where - -- worker (match@(HsMatch loc1 (PNT pname _ _) pats rhs ds)::HsMatchP) - worker (match@(GHC.FunBind (GHC.L _ pname) _ (GHC.MatchGroup _matches _) _ _ _) :: GHC.HsBind GHC.Name) - | isJust (find (==pname) pns') - = do - match' <- foldM (flip (autoRenameLocalVar True)) match clashedNames - match'' <- foldM replaceExpWithUpdToks match' subst - rmParamsInDemotedDecls (map fst subst) match'' - - worker x = return x - - ------Get all of the paramaters supplied to pn --------------------------- - {- eg. sumSquares x1 y1 x2 y2 = rt x1 y1 + rt x2 y2 - rt x y = x+y - demote 'rt' to 'sumSquares', - 'allParams pn rhs []' returns [[x1,x2],[y1,y2]] - where pn is 'rt' and rhs is 'rt x1 y1 + rt x2 y2' - -} - - allParams :: GHC.Name -> GHC.GRHSs GHC.Name -> [[GHC.HsExpr GHC.Name]] - -> RefactGhc [[GHC.HsExpr GHC.Name]] - allParams pn rhs1 initial -- pn: demoted function/pattern name. - =do -- p<-getOneParam pn rhs - let p = getOneParam pn rhs1 - -- putStrLn (show p) - if (nonEmptyList p) then do rhs' <- rmOneParam pn rhs1 - allParams pn rhs' (initial++[p]) - else return initial - where - getOneParam :: (SYB.Data t) => GHC.Name -> t -> [GHC.HsExpr GHC.Name] - getOneParam pn1 - = SYB.everythingStaged SYB.Renamer (++) [] - ([] `SYB.mkQ` worker) - -- =applyTU (stop_tdTU (failTU `adhocTU` worker)) - where - worker :: GHC.HsExpr GHC.Name -> [GHC.HsExpr GHC.Name] - worker (GHC.HsApp e1 e2) - |(expToName e1==pn1) = [GHC.unLoc e2] - worker _ = [] - rmOneParam :: (SYB.Data t) => GHC.Name -> t -> RefactGhc t - rmOneParam pn1 t - -- This genuinely needs to be done once only. Damn. - -- =applyTP (stop_tdTP (failTP `adhocTP` worker)) - = do - -- _ <- clearRefactDone - everywhereMStaged' SYB.Renamer (SYB.mkM worker) t - where - {- - worker :: GHC.HsExpr GHC.Name -> RefactGhc (GHC.HsExpr GHC.Name) - worker e@(GHC.HsApp e1 e2 ) = do -- The param being removed is e2 - done <- getRefactDone - case (not done) && expToName e1==pn1 of - True -> do setRefactDone - return (GHC.unLoc e1) - False -> return e - worker x = return x - -} - worker (GHC.HsApp e1 _e2 ) -- The param being removed is e2 - |expToName e1==pn1 = return (GHC.unLoc e1) - worker x = return x -{- - AST output - - addthree x y z - - becomes - - (HsApp - (L {test/testdata/Demote/WhereIn6.hs:10:17-28} - (HsApp - (L {test/testdata/Demote/WhereIn6.hs:10:17-26} - (HsApp - (L {test/testdata/Demote/WhereIn6.hs:10:17-24} - (HsVar {Name: WhereIn6.addthree})) - (L {test/testdata/Demote/WhereIn6.hs:10:26} - (HsVar {Name: x})))) - (L {test/testdata/Demote/WhereIn6.hs:10:28} - (HsVar {Name: y})))) - (L {test/testdata/Demote/WhereIn6.hs:10:30} - (HsVar {Name: z}))) - ------ - (HsApp - (HsApp - (HsApp - (HsVar {Name: WhereIn6.addthree})) - (HsVar {Name: x})))) - (HsVar {Name: y})))) - (HsVar {Name: z}))) - ------ - - sq p x - - becomes - - (HsApp - (HsApp - (HsVar {Name: Demote.WhereIn4.sq})) - (HsVar {Name: p})))) - (HsVar {Name: x}))) - ----- - sq x - - becomes - - (HsApp - (HsVar {Name: sq})) - (HsVar {Name: x}))) --} - - - -----------remove parameters in demotedDecls------------------------------- - rmParamsInDemotedDecls :: [GHC.Name] -> GHC.HsBind GHC.Name - -> RefactGhc (GHC.HsBind GHC.Name) - rmParamsInDemotedDecls ps bind - -- = error $ "rmParamsInDemotedDecls: (ps,bind)=" ++ (showGhc (ps,bind)) -- ++AZ++ - -- =applyTP (once_tdTP (failTP `adhocTP` worker)) - = everywhereMStaged SYB.Renamer (SYB.mkM worker) bind - -- where worker ((HsMatch loc1 name pats rhs ds)::HsMatchP) - where worker (GHC.Match pats2 typ rhs1) - = do - let pats'=filter (\x->not ((patToPNT x /= Nothing) && - elem (gfromJust "rmParamsInDemotedDecls" $ patToPNT x) ps)) pats2 - - let (startPos,endPos) = getBiggestStartEndLoc pats2 - if (emptyList pats') - then removeToksForPos (startPos,endPos) - else -- updateToksWithPos (startPos,endPos) pats' prettyprint False - updateToksWithPos (startPos,endPos) pats' pprPat False - - -- pats'' <- update pats pats' pats - - return (GHC.Match pats' typ rhs1) - - pprPat pat = intercalate " " $ map (\p -> (prettyprint p )) pat - - ----------remove parameters in the parent functions' rhs------------------- - --Attention: PNT i1 _ _==PNT i2 _ _ = i1 =i2 - rmParamsInParent :: GHC.Name -> [GHC.HsExpr GHC.Name] -> GHC.GRHSs GHC.Name - -> RefactGhc (GHC.GRHSs GHC.Name) - rmParamsInParent pn es - -- =applyTP (full_buTP (idTP `adhocTP` worker)) - = everywhereMStaged SYB.Renamer (SYB.mkM worker) - where worker expr@(GHC.L _ (GHC.HsApp e1 e2)) - -- was | findPN pn e1 && (elem (GHC.unLoc e2) es) - | findPN pn e1 && (elem (showGhc (GHC.unLoc e2)) (map (showGhc) es)) - = update expr e1 expr - worker (expr@(GHC.L _ (GHC.HsPar e1))) - |pn==expToName e1 - = update expr e1 expr - worker x =return x - - - getClashedNames oldNames newNames match - = do (_f,d) <- hsFDsFromInside match - -- ds' <- mapM (flip hsVisiblePNs match) oldNames - ds' <- mapM (flip hsVisiblePNs match) oldNames - -- return clashed names - return (filter (\x->elem ({- pNtoName -} x) newNames) --Attention: nub - ( nub (d `union` (nub.concat) ds'))) - - ----- make Substitions between formal and actual parameters.----------------- - mkSubst :: [GHC.LPat GHC.Name] -> [[GHC.HsExpr GHC.Name]] -> [(GHC.Name,GHC.HsExpr GHC.Name)] - mkSubst pats1 params - = catMaybes (zipWith (\x y -> if (patToPNT x/=Nothing) && (length (nub $ map showGhc y)==1) - then Just (gfromJust "mkSubst" $ patToPNT x,(ghead "mkSubst") y) - else Nothing) pats1 params) - - --- |substitute an old expression by new expression -replaceExpWithUpdToks :: (SYB.Data t) - => t -> (GHC.Name, GHC.HsExpr GHC.Name) - -> RefactGhc t -replaceExpWithUpdToks decls subst - -- = applyTP (full_buTP (idTP `adhocTP` worker)) decls - = everywhereMStaged' SYB.Renamer (SYB.mkM worker) decls - where worker (e@(GHC.L l _)::GHC.LHsExpr GHC.Name) - |(expToName e/=defaultName) && (expToName e)==(fst subst) - = update e (GHC.L l (snd subst)) e - worker x=return x - - --- | return True if pn is a local function/pattern name -isLocalFunOrPatName :: SYB.Data t => GHC.Name -> t -> Bool -isLocalFunOrPatName pn scope - = isLocalPN pn && isFunOrPatName pn scope - --- --------------------------------------------------------------------- - --- |Divide a declaration list into three parts (before, parent, after) --- according to the PNT, where 'parent' is the first decl containing --- the PNT, 'before' are those decls before 'parent' and 'after' are --- those decls after 'parent'. - -divideDecls :: - SYB.Data t => - [t] -> GHC.Located GHC.Name -> ([t], [t], [t]) -divideDecls ds pnt - -- = error "undefined divideDecls" - = let (before,after)=break (\x->findPNT pnt x) ds - in if (not $ emptyList after) - then (before, [ghead "divideDecls" after], tail after) - else (ds,[],[]) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +module Language.Haskell.Refact.Refactoring.MoveDef + ( liftToTopLevel + , liftOneLevel + , demote + -- ,liftingInClientMod + ) where + +import qualified Data.Generics as SYB +import qualified GHC.SYB.Utils as SYB +import qualified Data.Generics.Zipper as Z + + +import qualified Exception as GHC +import qualified FastString as GHC +import qualified GHC as GHC +import qualified Name as GHC +import qualified RdrName as GHC +import qualified TyCon as GHC +import qualified TypeRep as GHC +import qualified Var as Var + +import Control.Exception +import Control.Monad.State +import Data.Foldable +import Data.List +import Data.Maybe + +import qualified Language.Haskell.GhcMod as GM +import Language.Haskell.Refact.API + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint + +import Data.Generics.Strafunski.StrategyLib.StrategyLib + +import System.Directory + +-- import Debug.Trace + +-- --------------------------------------------------------------------- + +-- data Direction = UptoTopLevel | UpOneLevel | Down + +{--------This function handles refactorings involving moving a definition-------- + + According to the Haskell's syntax, a declaration may occur in one of +the following six contexts: + + 1. A top level declaration in the module: + old: HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds + new: (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString) + HsGroup hs_valds :: HsValBinds id ... + + 2. A local declaration in a Match: (of a FunBind) + old: HsMatch SrcLoc i [p] (HsRhs e) ds + new: Match [LPat id] (Maybe (LHsType id)) (GRHSs id) + + 3. A local declaration in a pattern binding: + old: HsPatBind SrcLoc p (HsRhs e) ds + new: PatBind (LPat idL) (GRHSs idR) PostTcType NameSet (Maybe tickish) + + 4. A local declaration in a Let expression: + old: HsLet ds e + new: HsLet (HsLocalBinds id) (LHsExpr id) + + 5. A local declaration in a Case alternative: + old: HsAlt SrcLoc p (HsRhs e) ds + new: HsCase (LHsExpr id) (MatchGroup id) + new is same as in a FunBind. + + 6. A local declaration in a Do statement: + old: HsLetStmt ds (HsStmt e p ds) + new: LetStmt (HsLocalBindsLR idL idR) + in context GRHS [LStmt id] (LHsExpr id) +-} + +-- | Lift a definition to the top level +liftToTopLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath] +liftToTopLevel settings opts fileName (row,col) = do + absFileName <- canonicalizePath fileName + runRefacSession settings opts (compLiftToTopLevel absFileName (row,col)) + +compLiftToTopLevel :: FilePath -> SimpPos + -> RefactGhc [ApplyRefacResult] +compLiftToTopLevel fileName (row,col) = do + parseSourceFileGhc fileName + renamed <- getRefactRenamed + parsed <- getRefactParsed + + let (Just (modName,_)) = getModuleName parsed + let maybePn = locToName (row, col) renamed + case maybePn of + Just pn -> liftToTopLevel' modName pn + _ -> error "\nInvalid cursor position!\n" + + +{- Refactoring Names: 'liftToTopLevel' + + This refactoring lifts a local function/pattern binding to the top + level of the module, so as to make it accessible to other functions in + the current module, and those modules that import current module. + + In the current implementation, a definition will be lifted only if + none of the identifiers defined in this definition will cause name + clash/capture problems in the current module after lifting. + + In the case that the whole current module is exported implicitly, + the lifted identifier will be exported automatically after lifting. If + the identifier will cause name clash/ambiguous occurrence problem in a + client module, it will be hided in the import declaration of the + client module (Note: this might not be the best solution, we prefer + hiding it in the server module instead of in the client module in the + final version). + + In the case of indirect importing, it might be time-consuming to + trace whether the lifted identifier will cause any problem in a client + module that indirectly imports the current module. The current + solution is: suppose a defintion is lifted to top level in module A, + and module A is imported and exported by module B, then the lifted + identifier will be hided in the import declaration of B no matter + whether it causes problems in module B or not. + + Function name: liftToTopLevel + parameters: fileName--current file name. + mod -- the scoped abstract syntax tree of the module. + pn -- the function/pattern name to be lifted. +-} +liftToTopLevel' :: GHC.ModuleName -- -> (ParseResult,[PosToken]) -> FilePath + -> GHC.Located GHC.Name + -> RefactGhc [ApplyRefacResult] +liftToTopLevel' modName pn@(GHC.L _ n) = do + renamed <- getRefactRenamed + targetModule <- getRefactTargetModule + logm $ "liftToTopLevel':pn=" ++ (showGhc pn) + if isLocalFunOrPatName n renamed + then do + (refactoredMod,declPns) <- applyRefac liftToMod RSAlreadyLoaded + + logm $ "liftToTopLevel' applyRefac done " + + if modIsExported modName renamed + then do clients <- clientModsAndFiles targetModule + logm $ "liftToTopLevel':(clients,declPns)=" ++ (showGhc (clients,declPns)) + refactoredClients <- mapM (liftingInClientMod modName declPns) clients + return (refactoredMod:(concat refactoredClients)) + else do return [refactoredMod] + else error "\nThe identifier is not a local function/pattern name!" + + where + {-step1: divide the module's top level declaration list into three parts: + 'parent' is the top level declaration containing the lifted declaration, + 'before' and `after` are those declarations before and after 'parent'. + step2: get the declarations to be lifted from parent, bind it to liftedDecls + step3: remove the lifted declarations from parent and extra arguments may be introduce. + step4. test whether there are any names need to be renamed. + -} + liftToMod = do + renamed <- getRefactRenamed + parsed <- getRefactParsed + declsp <- liftT $ hsDecls parsed + (before,parent,after) <- divideDecls declsp pn + {- ++AZ++ : hsBinds does not return class or instance definitions + when (isClassDecl $ ghead "liftToMod" parent) + $ error "Sorry, the refactorer cannot lift a definition from a class declaration!" + when (isInstDecl $ ghead "liftToMod" parent) + $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!" + -} + nameMap <- getRefactNameMap + -- declsParent <- liftT $ hsDecls (ghead "liftToMod" parent) + -- logm $ "liftToMod:(declsParent)=" ++ (showGhc declsParent) + let liftedDecls = definingDeclsRdrNames nameMap [n] parent True True + declaredPns = nub $ concatMap (definedNamesRdr nameMap) liftedDecls + liftedSigs = definingSigsRdrNames nameMap declaredPns parent + mLiftedSigs = liftedSigs + + -- TODO: what about declarations between this + -- one and the top level that are used in this one? + + pns <- pnsNeedRenaming parsed parent liftedDecls declaredPns + logm $ "liftToMod:(pns needing renaming)=" ++ (showGhc pns) + + let dd = getDeclaredVars $ hsBinds renamed + logm $ "liftToMod:(ddd)=" ++ (showGhc dd) + + if pns == [] + then do + (parent',liftedDecls',mLiftedSigs') <- addParamsToParentAndLiftedDecl n dd parent liftedDecls mLiftedSigs + + let defName = (ghead "liftToMod" (definedNamesRdr nameMap (ghead "liftToMod2" parent'))) + parsed' <- liftT $ replaceDecls parsed (before++parent'++after) + parsed2 <- moveDecl1 parsed' (Just defName) [GHC.unLoc pn] liftedDecls' + declaredPns mLiftedSigs' + putRefactParsed parsed2 emptyAnns + + return declaredPns + + else askRenamingMsg pns "lifting" + + + +-- --------------------------------------------------------------------- + +-- | Move a definition one level up from where it is now +liftOneLevel :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath] +liftOneLevel settings opts fileName (row,col) = do + absFileName <- canonicalizePath fileName + runRefacSession settings opts (compLiftOneLevel absFileName (row,col)) + +compLiftOneLevel :: FilePath -> SimpPos + -> RefactGhc [ApplyRefacResult] +compLiftOneLevel fileName (row,col) = do + parseSourceFileGhc fileName + renamed <- getRefactRenamed + parsed <- getRefactParsed + + let (Just (modName,_)) = getModuleName parsed + let maybePn = locToName (row, col) renamed + case maybePn of + Just pn -> do + rs <- liftOneLevel' modName pn + logm $ "compLiftOneLevel:rs=" ++ (show $ (refactDone rs,map (\((_,d),_) -> d) rs)) + if (refactDone rs) + then return rs + else error ( "Lifting this definition failed. "++ + " This might be because that the definition to be "++ + "lifted is defined in a class/instance declaration.") + _ -> error "\nInvalid cursor position!\n" + +{- Refactoring Names: 'liftOneLevel' + Description: + this refactoring lifts a local function/pattern binding only one level up. + By 'lifting one-level up' , I mean: + + case1: In a module (HsModule SrcLoc ModuleName (Maybe [HsExportSpecI i]) [HsImportDeclI i] ds): + A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration. + + new: (HsModule mmn mexp imps ds mdepr _haddock) + In pactice this means processing + + a. Matches in a FunBind + (Match mln pats _typ (GRHSs grhs ds)) + b. A PatBind + (PatBind lhs (GRHSs grhs ds) _typ _fvs _ticks) + + and lifting a decl D from ds to the top. + + VarBinds and AbsBinds are introduced by the type checker, so can be ignored here. + A PatSynBind does not have decls in it, so is ignored. + + + case2: In a match ( HsMatch SrcLoc i [p] (HsRhs e) ds) : + A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration. + A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to + other declaration list in 'e' + + (in a FunBind) + new: (Match mln pats _typ (GRHSs grhs lb)) + + + case3: In a pattern binding (HsPatBind SrcLoc p (HsRhs e) ds): + A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration. + A declaration D,say,in the rhs expression 'e' will be lifted to 'ds' if D is Not local to + other declaration list in 'e' + + new: (PatBind lhs (GRHSs grhs ds) _typ _fvs _ticks) + + + case4: In the Let expression (Exp (HsLet ds e): + A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration. + A declaration D, say, in the expression 'e' will be lifted to 'ds' if D is not local to + other declaration list in 'e' + + new: HsLet ds e + + + case5: In the case Alternative expression:(HsAlt loc p rhs ds) + A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration. + A declaration D in 'rhs' will be lifted to 'ds' if D is not local to other declaration + list in 'rhs'. + + new: HsCase (LHsExpr id) (MatchGroup id) + new is same as in a FunBind. + + + case6: In the do statement expression:(HsLetStmt ds stmts) + A local declaration D will be lifted to the same level as the 'ds', if D is in the + where clause of one of ds's element declaration. + A declaration D in 'stmts' will be lifted to 'ds' if D is not local to other declaration + list in 'stmts'. + + new: LetStmt (HsLocalBindsLR idL idR) + in context GRHS [LStmt id] (LHsExpr id) + + +Function name: liftOneLevel +parameters: fileName--current file name. + mod -- the scoped abstract syntax tree of the module. + pn -- the function/pattern name to be lifted. + +-} + +liftOneLevel' :: GHC.ModuleName + -> GHC.Located GHC.Name + -> RefactGhc [ApplyRefacResult] + +liftOneLevel' modName pn@(GHC.L _ n) = do + renamed <- getRefactRenamed + targetModule <- getRefactTargetModule + if isLocalFunOrPatName n renamed + then do + (refactoredMod,(b,pns)) <- applyRefac doLiftOneLevel RSAlreadyLoaded + logm $ "liftOneLevel':main refactoring done:(p,pns)=" ++ showGhc (b,pns) + if b && modIsExported modName renamed + then do + logm $ "liftOneLevel':looking for clients" + clients <- clientModsAndFiles targetModule + logm $ "liftOneLevel':(clients,pns)=" ++ (showGhc (clients,pns)) + refactoredClients <- mapM (liftingInClientMod modName pns) clients + return (refactoredMod:concat refactoredClients) + else do return [refactoredMod] + else error "\nThe identifer is not a function/pattern name!" + + where + doLiftOneLevel = do + logm $ "in doLiftOneLevel" + parsed <- getRefactParsed + logDataWithAnns "doLiftOneLevel:parsed" parsed + nm <- getRefactNameMap + ans <- liftT getAnnsT + zp <- ztransformStagedM SYB.Parser + (Nothing + `SYB.mkQ` (liftToModQ nm ans) + `SYB.extQ` (liftToMatchQ nm ans) + `SYB.extQ` (liftToLetQ nm ans) + ) (Z.toZipper parsed) + let parsed' = Z.fromZipper zp + putRefactParsed parsed' emptyAnns + liftedToTopLevel pn parsed' + + where + isMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Bool + isMatch _ = True + + isHsLet :: GHC.LHsExpr GHC.RdrName -> Bool + isHsLet (GHC.L _ (GHC.HsLet _ _)) = True + isHsLet _ = False + + -- ------------------------ + + liftToModQ :: + NameMap -> Anns + -> GHC.ParsedSource + -> Maybe (SYB.Stage + -> Z.Zipper GHC.ParsedSource + -> RefactGhc (Z.Zipper GHC.ParsedSource)) + liftToModQ nm ans (p :: GHC.ParsedSource) + | nonEmptyList candidateBinds + = Just (doLiftZ p declsp) + | otherwise = Nothing + where + (declsp ,_,_) = runTransform ans (hsDecls p) + doOne bs = (definingDeclsRdrNames nm [n] declsbs False False,bs) + where + (declsbs,_,_) = runTransform ans (hsDeclsGeneric bs) + + candidateBinds = map snd + $ filter (\(l,_bs) -> nonEmptyList l) + $ map doOne + $ declsp + + getHsDecls ans t = decls + where (decls,_,_) = runTransform ans (hsDeclsGeneric t) + + -- ------------------------ + + liftToMatchQ :: (SYB.Data a) + => NameMap -> Anns + -> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) + -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a)) + liftToMatchQ nm ans (m@(GHC.L _ (GHC.Match _ _pats _mtyp (GHC.GRHSs _rhs ds)))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + | (nonEmptyList (definingDeclsRdrNames nm [n] (getHsDecls ans ds) False False)) + = Just (doLiftZ m (getHsDecls ans ds)) + | otherwise = Nothing + + -- ------------------------ + + liftToLetQ :: SYB.Data a + => NameMap -> Anns + -> GHC.LHsExpr GHC.RdrName -> Maybe (SYB.Stage -> Z.Zipper a -> RefactGhc (Z.Zipper a)) + liftToLetQ nm ans ll@(GHC.L _ (GHC.HsLet ds _e)) + | nonEmptyList (definingDeclsRdrNames nm [n] (getHsDecls ans ds) False False) + = Just (doLiftZ ll (getHsDecls ans ll)) + | otherwise = Nothing + liftToLetQ _ _ _ = Nothing + + -- ------------------------ + + doLiftZ :: (SYB.Data t,SYB.Data a) + => t -- ^Item containing the decls which contain the ones to be lifted + -> [GHC.LHsDecl GHC.RdrName] -- ^decls containing the ones to be lifted. + -- ++AZ++:TODO: these are redundant, can be pulled out of t + -> SYB.Stage -- ++AZ++:TODO: get rid of this + -> Z.Zipper a + -> RefactGhc (Z.Zipper a) + doLiftZ ds decls _stage z = + do + logm $ "doLiftZ entered" + logDataWithAnns "doLiftZ:ds" ds + logDataWithAnns "doLiftZ:decls" decls + + let zu = case (Z.up z) of + Just zz -> fromMaybe (error $ "MoveDef.liftToLet.1" ++ SYB.showData SYB.Parser 0 decls) + $ upUntil (False `SYB.mkQ` isMatch + `SYB.extQ` isHsLet + ) + zz + Nothing -> z + + let + wtop (ren::GHC.ParsedSource) = do + logm $ "wtop entered" + nm <- getRefactNameMap + let (_,DN dd) = (hsFreeAndDeclaredRdr nm ren) + -- ++AZ++ : TODO: get rid of worker in favour of + -- workerTop + worker ren decls pn dd + -- workerTop ren decls dd + + + wmatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) + -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + wmatch (m@(GHC.L _ (GHC.Match _mln _pats _typ grhss))) = do + logm $ "wmatch entered:" ++ SYB.showData SYB.Parser 0 m + nm <- getRefactNameMap + let (_,DN dd) = hsFreeAndDeclaredRdr nm grhss + + decls' <- liftT $ hsDecls m + workerTop m decls' dd + + wlet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) + wlet l@(GHC.L _ (GHC.HsLet dsl _e)) = do + logm $ "wlet entered " + nm <- getRefactNameMap + let (_,DN dd) = hsFreeAndDeclaredRdr nm dsl + dsl' <- workerTop l decls dd + return dsl' + wlet x = return x + + ds' <- Z.transM ( SYB.mkM wtop + `SYB.extM` wmatch + `SYB.extM` wlet + ) zu + + return ds' + + -- ---------------------------------------- + + + -- This is currently used for everything but the top level + workerTop :: (HasDecls t) + => t -- ^The destination of the lift operation + -> [GHC.LHsDecl GHC.RdrName] -- ^ list containing the decl to be + -- lifted + -> [GHC.Name] -- ^Declared variables in the destination + -> RefactGhc t + workerTop dest ds dd + =do + logm $ "MoveDef.worker: dest" ++ SYB.showData SYB.Parser 0 dest + logm $ "MoveDef.workerTop: ds=" ++ (showGhc ds) + done <- getRefactDone + if done then return dest + else do + setRefactDone + let parent = dest + nm <- getRefactNameMap + let liftedDecls = definingDeclsRdrNames' nm [n] parent + declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls + logm $ "MoveDef.workerTop: n=" ++ (showGhc n) + logm $ "MoveDef.workerTop: liftedDecls=" ++ (showGhc liftedDecls) + pns <- pnsNeedRenaming dest parent liftedDecls declaredPns + logm $ "MoveDef.workerTop: pns=" ++ (showGhc pns) + if pns==[] + then do + (parent',liftedDecls',mLiftedSigs')<-addParamsToParentAndLiftedDecl n dd + parent liftedDecls [] + logm $ "MoveDef.workerTop: liftedDecls'=" ++ (showGhc liftedDecls') + --True means the new decl will be at the same level with its parant. + let toMove = parent' + pdecls <- liftT $ hsDecls toMove + -- logm $ "MoveDef.workerTop:toMove=" ++ SYB.showData SYB.Parser 0 toMove + -- logm $ "MoveDef.workerTop:pdecls=" ++ (showGhc pdecls) + let mAfter = case pdecls of + [] -> Nothing + _ -> (Just (ghead "worker" (definedNamesRdr nm (glast "workerTop" ds)))) + dest' <- moveDecl1 toMove + mAfter + [n] liftedDecls' declaredPns mLiftedSigs' + return dest' + else askRenamingMsg pns "lifting" + + -- ---------------------------------------- + + -- TODO: get rid of this in favour of workerTop + worker :: (HasDecls t) + => t -- ^The destination of the lift operation + -> [GHC.LHsDecl GHC.RdrName] -- ^ list containing the decl to be + -- lifted + -> GHC.Located GHC.Name -- ^ The name of the decl to be lifted + -> [GHC.Name] -- ^Declared variables in the destination + -> RefactGhc t + worker dest ds pnn dd + =do + -- logm $ "MoveDef.worker: dest" ++ (showGhc dest) + logm $ "MoveDef.worker: ds=" ++ (showGhc ds) + done <- getRefactDone + if done then return dest + else do + setRefactDone + (before,parent,after) <- divideDecls ds pnn -- parent is misnomer, it is the decl to be moved + logm $ "MoveDef.worker:(before,parent,after)" ++ showGhc (before,parent,after) + nm <- getRefactNameMap + let liftedDecls = definingDeclsRdrNames nm [n] parent True True + declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls + pns <- pnsNeedRenaming dest parent liftedDecls declaredPns + logm $ "MoveDef.worker: pns=" ++ (showGhc pns) + if pns==[] + then do + (parent',liftedDecls',mLiftedSigs')<-addParamsToParentAndLiftedDecl n dd + parent liftedDecls [] + --True means the new decl will be at the same level with its parant. + toMove <- liftT $ replaceDecls dest (before++parent'++after) + dest' <- moveDecl1 toMove + (Just (ghead "worker" (definedNamesRdr nm (ghead "worker" parent')))) + [n] liftedDecls' declaredPns mLiftedSigs' + return dest' + else askRenamingMsg pns "lifting" + + +-- --------------------------------------------------------------------- + +-- | Move a definition one level down +demote :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> IO [FilePath] +demote settings opts fileName (row,col) = do + absFileName <- canonicalizePath fileName + runRefacSession settings opts (compDemote absFileName (row,col)) + +compDemote ::FilePath -> SimpPos + -> RefactGhc [ApplyRefacResult] +compDemote fileName (row,col) = do + parseSourceFileGhc fileName + renamed <- getRefactRenamed + parsed <- getRefactParsed + + -- TODO: make the next one an API call, that also gets the + -- parsed source + let (Just (modName,_)) = getModuleName parsed + let maybePn = locToName (row, col) renamed + case maybePn of + Just pn -> demote' modName pn + _ -> error "\nInvalid cursor position!\n" + +-- --------------------------------------------------------------------- + +moveDecl1 :: (SYB.Data t) + => t -- ^ The syntax element to update + -> Maybe GHC.Name -- ^ If specified, add defn after this one + + -> [GHC.Name] -- ^ The first one is the decl to move + -> [GHC.LHsDecl GHC.RdrName] + -> [GHC.Name] -- ^ The signatures to remove. May be multiple if + -- decl being moved has a patbind. + -> [GHC.LSig GHC.RdrName] -- ^ lifted decls signature if present + -> RefactGhc t -- ^ The updated syntax element (and tokens in monad) +moveDecl1 t defName ns mliftedDecls sigNames mliftedSigs = do + logm $ "moveDecl1:(defName,ns,sigNames,mliftedDecls)=" ++ showGhc (defName,ns,sigNames,mliftedDecls) + logm $ "moveDecl1:(t)=" ++ SYB.showData SYB.Parser 0 (t) + + -- TODO: rmDecl can now remove the sig at the same time. + (t'',_sigsRemoved) <- rmTypeSigs sigNames t + -- logm $ "moveDecl1:after rmTypeSigs:t''" ++ SYB.showData SYB.Parser 0 t'' + logm $ "moveDecl1:mliftedSigs=" ++ showGhc mliftedSigs + (t',_declRemoved,_sigRemoved) <- rmDecl (ghead "moveDecl3.1" ns) False t'' + logm $ "moveDecl1:after rmDecl:t'" ++ SYB.showData SYB.Parser 0 t' + let sigs = map wrapSig mliftedSigs + r <- addDecl t' defName (sigs++mliftedDecls,Nothing) + + return r + +-- --------------------------------------------------------------------- + +askRenamingMsg :: [GHC.Name] -> String -> t +askRenamingMsg pns str + = error ("The identifier(s): " ++ (intercalate "," $ map showPN pns) ++ + " will cause name clash/capture or ambiguity occurrence problem after " + ++ str ++", please do renaming first!") + + where + showPN pn = showGhc (pn,GHC.nameSrcLoc pn) + +-- |Get the subset of 'pns' that need to be renamed before lifting. +pnsNeedRenaming :: (SYB.Data t1,SYB.Data t2) => + t1 -> t2 -> t3 -> [GHC.Name] + -> RefactGhc [GHC.Name] +pnsNeedRenaming dest parent _liftedDecls pns + = do + logm $ "MoveDef.pnsNeedRenaming entered:pns=" ++ showGhc pns + r <- mapM pnsNeedRenaming' pns + return (concat r) + where + pnsNeedRenaming' pn + = do + logm $ "MoveDef.pnsNeedRenaming' entered" + nm <- getRefactNameMap + (FN f,DN d) <- hsFDsFromInsideRdr nm dest --f: free variable names that may be shadowed by pn + --d: declaread variables names that may clash with pn + logm $ "MoveDef.pnsNeedRenaming':(f,d)=" ++ showGhc (f,d) + vs <- hsVisiblePNsRdr nm pn parent --vs: declarad variables that may shadow pn + logm $ "MoveDef.pnsNeedRenaming':vs=" ++ showGhc vs + let vars = map pNtoName (nub (f `union` d `union` vs) \\ [pn]) -- `union` inscpNames + isInScope <- isInScopeAndUnqualifiedGhc (pNtoName pn) Nothing + logm $ "MoveDef.pnsNeedRenaming:(f,d,vs,vars,isInScope)=" ++ (showGhc (f,d,vs,vars,isInScope)) + if elem (pNtoName pn) vars || isInScope && findEntity pn dest + then return [pn] + else return [] + pNtoName = showGhc + +-- --------------------------------------------------------------------- + +addParamsToParent :: (SYB.Data t) => GHC.Name -> [GHC.RdrName] -> t -> RefactGhc t +addParamsToParent _pn [] t = return t +addParamsToParent pn params t = do + logm $ "addParamsToParent:(pn,params)" ++ (showGhc (pn,params)) + addActualParamsToRhs pn params t + + +-- |Do refactoring in the client module. that is to hide the identifer +-- in the import declaration if it will cause any problem in the +-- client module. +liftingInClientMod :: GHC.ModuleName -> [GHC.Name] -> TargetModule + -> RefactGhc [ApplyRefacResult] +liftingInClientMod serverModName pns targetModule = do + logm $ "liftingInClientMod:targetModule=" ++ (show targetModule) + getTargetGhc targetModule + parsed <- getRefactParsed + clientModule <- getRefactModule + logm $ "liftingInClientMod:clientModule=" ++ (showGhc clientModule) + modNames <- willBeUnQualImportedBy serverModName + logm $ "liftingInClientMod:modNames=" ++ (showGhc modNames) + if isJust modNames + then do + pns' <- namesNeedToBeHided clientModule (gfromJust "liftingInClientMod" modNames) pns + let pnsRdr' = map GHC.nameRdrName pns' + logm $ "liftingInClientMod:pns'=" ++ (showGhc pns') + if (nonEmptyList pns') + then do (refactoredMod,_) <- applyRefac (addHiding serverModName parsed pnsRdr') RSAlreadyLoaded + return [refactoredMod] + else return [] + else return [] + +-- --------------------------------------------------------------------- + +-- |Test whether an identifier defined in the modules specified by +-- 'names' will be exported by current module. +willBeExportedByClientMod :: [GHC.ModuleName] -> GHC.RenamedSource -> Bool +willBeExportedByClientMod names renamed = + let (_,_,exps,_) = renamed + in if isNothing exps + then False + else any isJust $ map (\y-> (find (\x-> (simpModule x==Just y)) (gfromJust "willBeExportedByClientMod" exps))) names + where simpModule (GHC.L _ (GHC.IEModuleContents (GHC.L _ m))) = Just m + simpModule _ = Nothing + +-- |get the module name or alias name by which the lifted identifier +-- will be imported automatically. +-- TODO: maybe move this into TypeUtils +-- willBeUnQualImportedBy::HsName.ModuleName->HsModuleP->Maybe [HsName.ModuleName] +willBeUnQualImportedBy :: GHC.ModuleName -> RefactGhc (Maybe [GHC.ModuleName]) +willBeUnQualImportedBy modName = do + (_,imps,_,_) <- getRefactRenamed + let ms = filter (\(GHC.L _ (GHC.ImportDecl _ (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as h)) + -> modName == modName1 && (not isQualified) && (isNothing h || (isJust h && ((fst (fromJust h)) == True)))) + imps + + res = if (emptyList ms) then Nothing + else Just $ nub $ map getModName ms + + getModName (GHC.L _ (GHC.ImportDecl _ (GHC.L _ modName2) _qualify _source _safe _isQualified _isImplicit as _h)) + = if isJust as then simpModName (fromJust as) + else modName2 + + simpModName m = m + + logm $ "willBeUnQualImportedBy:(ms,res)=" ++ (showGhc (ms,res)) + + return res + +-- --------------------------------------------------------------------- + +-- |get the subset of 'pns', which need to be hided in the import +-- declaration in module 'mod' +-- Note: these are newly exported from the module, so we cannot use +-- the GHC name resolution i nthis case. +namesNeedToBeHided :: GHC.Module -> [GHC.ModuleName] -> [GHC.Name] + -> RefactGhc [GHC.Name] +namesNeedToBeHided clientModule modNames pns = do + renamed <- getRefactRenamed + parsed <- getRefactParsed + logm $ "namesNeedToBeHided:willBeExportedByClientMod=" ++ (show $ willBeExportedByClientMod modNames renamed) + gnames <- GHC.getNamesInScope + let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames + logm $ "namesNeedToBeHided:(clientInscopes)=" ++ (showGhc (clientInscopes)) + + pnsMapped <- mapM getLocalEquiv pns + logm $ "namesNeedToBeHided:pnsMapped=" ++ (showGhc pnsMapped) + + let pnsMapped' = filter (\(_,_,ns) -> not $ emptyList ns) pnsMapped + + if willBeExportedByClientMod modNames renamed + then return pns + else do + ff <- mapM (needToBeHided parsed) pnsMapped' + return $ concat ff + where + -- | Strip the package prefix from the name and return the + -- stripped name together with any names in the local module that + -- may match the stripped one + getLocalEquiv :: GHC.Name -> RefactGhc (GHC.Name,String,[GHC.Name]) + getLocalEquiv pn = do + let pnStr = stripPackage $ showGhc pn + logm $ "MoveDef getLocalEquiv: about to parseName:" ++ (show pnStr) + ecns <- GHC.gtry $ GHC.parseName pnStr + let cns = case ecns of + Left (_e::SomeException) -> [] + Right v -> v + logm $ "MoveDef getLocalEquiv: cns:" ++ (showGhc cns) + return (pn,pnStr,cns) + + stripPackage :: String -> String + stripPackage str = reverse s + where + (s,_) = break (== '.') $ reverse str + + needToBeHided :: GHC.ParsedSource -> (GHC.Name,String,[GHC.Name]) -> RefactGhc [GHC.Name] + needToBeHided parsed (pn,_pnStr,pnsLocal) = do + let uwoq = map (\n -> usedWithoutQualR n parsed) pnsLocal + + -- logm $ "needToBeHided:(hsBinds renamed)=" ++ (showGhc (hsBinds renamed)) + logm $ "needToBeHided:(pn,uwoq)=" ++ (showGhc (pn,uwoq)) + + if (any (== True) uwoq --the same name is used in the module unqualifiedly or + --is exported unqualifiedly by an Ent decl + + -- TODO: ++AZ++ check if next line needs to be reinstated + -- was || any (\m -> causeNameClashInExports oldPN pn m renamed) modNames) + || False) + then return [pn] + else return [] + + +-- **************************************************************************************************************-- + +-- --------------------------------------------------------------------- + +liftedToTopLevel :: GHC.Located GHC.Name -> GHC.ParsedSource -> RefactGhc (Bool,[GHC.Name]) +liftedToTopLevel pnt@(GHC.L _ pn) parsed = do + -- logm $ "liftedToTopLevel entered" + nm <- getRefactNameMap + -- logm $ "liftedToTopLevel:got nm" + decls <- liftT $ hsDecls parsed + let topDecs = definingDeclsRdrNames nm [pn] decls False False + -- ++AZ++ :TODO: we are not updating the nameMap to reflect moved decls + if nonEmptyList topDecs + then do + (_, parent,_) <- divideDecls decls pnt + let declsp = parent + let liftedDecls = definingDeclsRdrNames nm [pn] declsp False False + declaredPns = nub $ concatMap (definedNamesRdr nm) liftedDecls + return (True, declaredPns) + else return (False, []) + +-- --------------------------------------------------------------------- + +addParamsToParentAndLiftedDecl :: (SYB.Data t) => + GHC.Name -- ^name of decl being lifted + -> [GHC.Name] -- ^Declared names in parent + -> t -- ^parent + -> [GHC.LHsDecl GHC.RdrName] -- ^ decls being lifted + -> [GHC.LSig GHC.RdrName] -- ^ lifted decls signature if present + -> RefactGhc (t, [GHC.LHsDecl GHC.RdrName], [GHC.LSig GHC.RdrName]) +addParamsToParentAndLiftedDecl pn dd parent liftedDecls mLiftedSigs + =do + logm $ "addParamsToParentAndLiftedDecl:liftedDecls=" ++ (showGhc liftedDecls) + nm <- getRefactNameMap + let (FN ef,_) = hsFreeAndDeclaredRdr nm parent + let (FN lf,_) = hsFreeAndDeclaredRdr nm liftedDecls + + logm $ "addParamsToParentAndLiftedDecl:(ef,lf)=" ++ showGhc (ef,lf) + + -- parameters to be added to pn because of lifting + let newParamsNames = ((nub lf) \\ (nub ef)) \\ dd + newParams = map GHC.nameRdrName newParamsNames + + logm $ "addParamsToParentAndLiftedDecl:(newParams,ef,lf,dd)=" ++ (showGhc (newParams,ef,lf,dd)) + + if newParams /= [] + then if (any isComplexPatDecl liftedDecls) + then error "This pattern binding cannot be lifted, as it uses some other local bindings!" + else do -- first remove the decls to be lifted, so they are not disturbed + (parent'',liftedDecls'',_msig) <- rmDecl pn False parent + + parent' <- addParamsToParent pn newParams parent'' + + liftedDecls' <- addParamsToDecls [liftedDecls''] pn newParams + + mLiftedSigs' <- mapM (addParamsToSigs newParamsNames) mLiftedSigs + + logm $ "addParamsToParentAndLiftedDecl:mLiftedSigs'=" ++ showGhc mLiftedSigs' + + return (parent',liftedDecls', mLiftedSigs') + else return (parent,liftedDecls,mLiftedSigs) + +-- --------------------------------------------------------------------- + +-- TODO: perhaps move this to TypeUtils +addParamsToSigs :: [GHC.Name] -> GHC.LSig GHC.RdrName -> RefactGhc (GHC.LSig GHC.RdrName) +addParamsToSigs [] ms = return ms +addParamsToSigs newParams (GHC.L l (GHC.TypeSig lns ltyp pns)) = do + mts <- mapM getTypeForName newParams + let ts = catMaybes mts + logm $ "addParamsToSigs:ts=" ++ showGhc ts + logDataWithAnns "addParamsToSigs:ts=" ts + let newStr = ":: " ++ (intercalate " -> " $ map printSigComponent ts) ++ " -> " + logm $ "addParamsToSigs:newStr=[" ++ newStr ++ "]" + typ' <- liftT $ foldlM addOneType ltyp (reverse ts) + sigOk <- isNewSignatureOk ts + logm $ "addParamsToSigs:(sigOk,newStr)=" ++ show (sigOk,newStr) + if sigOk + then return (GHC.L l (GHC.TypeSig lns typ' pns)) + else error $ "\nNew type signature may fail type checking: " ++ newStr ++ "\n" + where + addOneType :: GHC.LHsType GHC.RdrName -> GHC.Type -> Transform (GHC.LHsType GHC.RdrName) + addOneType et t = do + hst <- typeToLHsType t + ss1 <- uniqueSrcSpanT + hst1 <- case t of + (GHC.FunTy _ _) -> do + ss <- uniqueSrcSpanT + let t1 = GHC.L ss (GHC.HsParTy hst) + setEntryDPT hst (DP (0,0)) + addSimpleAnnT t1 (DP (0,0)) [((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] + return t1 + _ -> return hst + let typ = GHC.L ss1 (GHC.HsFunTy hst1 et) + + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))] + return typ + +addParamsToSigs np ls = error $ "addParamsToSigs: no match for:" ++ showGhc (np,ls) + +-- --------------------------------------------------------------------- + +printSigComponent :: GHC.Type -> String +printSigComponent x = ppType x + +-- --------------------------------------------------------------------- + +-- |Fail any signature having a forall in it. +-- TODO: this is unnecesarily restrictive, but needs +-- a) proper reversing of GHC.Type to GHC.LhsType +-- b) some serious reverse type inference to ensure that the +-- constraints are modified properly to merge the old signature +-- part and the new. +isNewSignatureOk :: [GHC.Type] -> RefactGhc Bool +isNewSignatureOk types = do + -- NOTE: under some circumstances enabling Rank2Types or RankNTypes + -- can resolve the type conflict, this can potentially be checked + -- for. + -- NOTE2: perhaps proceed and reload the tentative refactoring into + -- the GHC session and accept it only if it type checks + let + r = SYB.everythingStaged SYB.TypeChecker (++) [] + ([] `SYB.mkQ` usesForAll) types + usesForAll (GHC.ForAllTy _ _) = [1::Int] + usesForAll _ = [] + + return $ emptyList r + +-- --------------------------------------------------------------------- + +-- TODO: perhaps move this to TypeUtils +-- TODO: complete this +typeToLHsType :: GHC.Type -> Transform (GHC.LHsType GHC.RdrName) +typeToLHsType (GHC.TyVarTy v) = do + ss <- uniqueSrcSpanT + let typ = GHC.L ss (GHC.HsTyVar (GHC.nameRdrName $ Var.varName v)) + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] + return typ + +typeToLHsType (GHC.AppTy t1 t2) = do + t1' <- typeToLHsType t1 + t2' <- typeToLHsType t2 + ss <- uniqueSrcSpanT + return $ GHC.L ss (GHC.HsAppTy t1' t2') + +typeToLHsType t@(GHC.TyConApp _tc _ts) = tyConAppToHsType t + +typeToLHsType (GHC.FunTy t1 t2) = do + t1' <- typeToLHsType t1 + t2' <- typeToLHsType t2 + ss <- uniqueSrcSpanT + let typ = GHC.L ss (GHC.HsFunTy t1' t2') + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnRarrow),DP (0,1))] + return typ + +typeToLHsType (GHC.ForAllTy _v t) = do + t' <- typeToLHsType t + ss1 <- uniqueSrcSpanT + ss2 <- uniqueSrcSpanT + return $ GHC.L ss1 (GHC.HsForAllTy GHC.Explicit Nothing (GHC.HsQTvs [] []) (GHC.L ss2 []) t') + +typeToLHsType (GHC.LitTy (GHC.NumTyLit i)) = do + ss <- uniqueSrcSpanT + let typ = GHC.L ss (GHC.HsTyLit (GHC.HsNumTy (show i) i)) :: GHC.LHsType GHC.RdrName + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] + return typ + +typeToLHsType (GHC.LitTy (GHC.StrTyLit s)) = do + ss <- uniqueSrcSpanT + let typ = GHC.L ss (GHC.HsTyLit (GHC.HsStrTy "" s)) :: GHC.LHsType GHC.RdrName + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] + return typ + + +{- +data Type + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) + + | AppTy -- See Note [AppTy invariant] + Type + Type -- ^ Type application to something other than a 'TyCon'. Parameters: + -- + -- 1) Function: must /not/ be a 'TyConApp', + -- must be another 'AppTy', or 'TyVarTy' + -- + -- 2) Argument type + + | TyConApp -- See Note [AppTy invariant] + TyCon + [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. + -- Invariant: saturated appliations of 'FunTyCon' must + -- use 'FunTy' and saturated synonyms must use their own + -- constructors. However, /unsaturated/ 'FunTyCon's + -- do appear as 'TyConApp's. + -- Parameters: + -- + -- 1) Type constructor being applied to. + -- + -- 2) Type arguments. Might not have enough type arguments + -- here to saturate the constructor. + -- Even type synonyms are not necessarily saturated; + -- for example unsaturated type synonyms + -- can appear as the right hand side of a type synonym. + + | FunTy + Type + Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@ + -- See Note [Equality-constrained types] + + | ForAllTy + Var -- Type or kind variable + Type -- ^ A polymorphic type + + | LitTy TyLit -- ^ Type literals are simillar to type constructors. + +-} + +tyConAppToHsType :: GHC.Type -> Transform (GHC.LHsType GHC.RdrName) +tyConAppToHsType (GHC.TyConApp tc _ts) = r (show $ GHC.tyConName tc) + where + r str = do + ss <- uniqueSrcSpanT + let typ = GHC.L ss (GHC.HsTyLit (GHC.HsStrTy str $ GHC.mkFastString str)) :: GHC.LHsType GHC.RdrName + addSimpleAnnT typ (DP (0,0)) [((G GHC.AnnVal),DP (0,1))] + return typ + +-- tyConAppToHsType t@(GHC.TyConApp _tc _ts) +-- = error $ "tyConAppToHsType: unexpected:" ++ (SYB.showData SYB.TypeChecker 0 t) + +{- +HsType +HsForAllTy HsExplicitFlag (LHsTyVarBndrs name) (LHsContext name) (LHsType name) +HsTyVar name +HsAppTy (LHsType name) (LHsType name) +HsFunTy (LHsType name) (LHsType name) +HsListTy (LHsType name) +HsPArrTy (LHsType name) +HsTupleTy HsTupleSort [LHsType name] +HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) +HsParTy (LHsType name) +HsIParamTy HsIPName (LHsType name) +HsEqTy (LHsType name) (LHsType name) +HsKindSig (LHsType name) (LHsKind name) +HsQuasiQuoteTy (HsQuasiQuote name) +HsSpliceTy (HsSplice name) FreeVars PostTcKind +HsDocTy (LHsType name) LHsDocString +HsBangTy HsBang (LHsType name) +HsRecTy [ConDeclField name] +HsCoreTy Type +HsExplicitListTy PostTcKind [LHsType name] +HsExplicitTupleTy [PostTcKind] [LHsType name] +HsTyLit HsTyLit +HsWrapTy HsTyWrapper (HsType name) +-} + + +--------------------------------End of Lifting----------------------------------------- + +{-Refactoring : demote a function/pattern binding(simpe or complex) to the declaration where it is used. + Descritption: if a declaration D, say, is only used by another declaration F,say, then D can be + demoted into the local declaration list (where clause) in F. + So currently, D can not be demoted if more than one declaration use it. + + In a multi-module context, a top-level definition can not be demoted if it is used + by other modules. In the case that the demoted identifer is in the hiding list of + import declaration in a client module, it should be removed from the hiding list. + + Function name:demote + parameters: fileName--current file name. + mod -- the scoped abstract syntax tree of the module. + pn -- the function/pattern name to be demoted. + +-} + +demote' :: + GHC.ModuleName + -- -> FilePath + -- -> (ParseResult,[PosToken]) + -> GHC.Located GHC.Name + -> RefactGhc [ApplyRefacResult] +demote' modName (GHC.L _ pn) = do + renamed <- getRefactRenamed + targetModule <- getRefactTargetModule + if isFunOrPatName pn renamed + then do + isTl <- isTopLevelPN pn + if isTl && isExplicitlyExported pn renamed + then error "This definition can not be demoted, as it is explicitly exported by the current module!" + else do + (refactoredMod,declaredPns) <- applyRefac (doDemoting pn) RSAlreadyLoaded + if isTl && modIsExported modName renamed + then do + logm $ "demote':isTl && isExported" + clients <- clientModsAndFiles targetModule + logm $ "demote':clients=" ++ (showGhc clients) + refactoredClients <-mapM (demotingInClientMod declaredPns) clients + return (refactoredMod:refactoredClients) + else do return [refactoredMod] + else error "\nInvalid cursor position!" + + +-- |Do refactoring in the client module, that is: +-- a) Check whether the identifier is used in the module body +-- b) If the identifier is not used but is hided by the import +-- declaration, then remove it from the hiding. +demotingInClientMod :: + [GHC.Name] -> TargetModule + -> RefactGhc ApplyRefacResult +demotingInClientMod pns targetModule = do + logm $ "demotingInClientMod:(pns,targetModule)=" ++ showGhc (pns,targetModule) + getTargetGhc targetModule + modu <- getRefactModule + (refactoredMod,_) <- applyRefac (doDemotingInClientMod pns modu) RSAlreadyLoaded + return refactoredMod + + +doDemotingInClientMod :: [GHC.Name] -> GHC.Module -> RefactGhc () +doDemotingInClientMod pns modName = do + logm $ "doDemotingInClientMod:(pns,modName)=" ++ showGhc (pns,modName) + renamed@(_g,imps,exps,_docs) <- getRefactRenamed + if any (\pn->findPN pn (hsBinds renamed) || findPN pn (exps)) pns + then error $ "This definition can not be demoted, as it is used in the client module '"++(showGhc modName)++"'!" + else if any (\pn->findPN pn imps) pns + -- TODO: reinstate this + then do -- (mod',((ts',m),_))<-runStateT (rmItemsFromImport mod pns) ((ts,unmodified),(-1000,0)) + return () + else return () + +-- --------------------------------------------------------------------- + +doDemoting :: GHC.Name -> RefactGhc [GHC.Name] +doDemoting pn = do + + clearRefactDone -- Only do this action once + + parsed <- getRefactParsed + + parsed' <- everywhereMStaged' SYB.Parser (SYB.mkM demoteInMod + `SYB.extM` demoteInMatch + `SYB.extM` demoteInPat + `SYB.extM` demoteInLet + `SYB.extM` demoteInStmt + ) parsed + putRefactParsed parsed' emptyAnns + nm <- getRefactNameMap + decls <- liftT $ hsDecls parsed + let demotedDecls'= definingDeclsRdrNames nm [pn] decls True False + declaredPnsRdr = nub $ concatMap definedPNsRdr demotedDecls' + declaredPns = map (rdrName2NamePure nm) declaredPnsRdr + return declaredPns + where + --1. demote from top level + demoteInMod x@(parsed :: GHC.ParsedSource) = do + decls <- liftT $ hsDecls parsed + nm <- getRefactNameMap + if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False) + then do + logm "MoveDef:demoteInMod" -- ++AZ++ + demoted <- doDemoting' parsed pn + return demoted + else return x + + --2. The demoted definition is a local decl in a match + demoteInMatch match@(GHC.L _ (GHC.Match _ _pats _mt (GHC.GRHSs _ _ds))::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do + -- decls <- liftT $ hsDecls ds + decls <- liftT $ hsDecls match + nm <- getRefactNameMap + if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False) + then do + logm "MoveDef:demoteInMatch" -- ++AZ++ + done <- getRefactDone + match' <- if (not done) + then doDemoting' match pn + else return match + return match' + else return match + + --3. The demoted definition is a local decl in a pattern binding + demoteInPat x@(pat@(GHC.L _ (GHC.ValD (GHC.PatBind _p (GHC.GRHSs _grhs _lb) _ _ _)))::GHC.LHsDecl GHC.RdrName) = do + decls <- liftT $ hsDeclsPatBindD x + nm <- getRefactNameMap + if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False) + then do + logm "MoveDef:demoteInPat" -- ++AZ++ + done <- getRefactDone + pat' <- if (not done) + then doDemoting' pat pn + else return pat + return pat' + else return x + demoteInPat x = return x + + --4: The demoted definition is a local decl in a Let expression + demoteInLet x@(letExp@(GHC.L _ (GHC.HsLet _ds _e))::GHC.LHsExpr GHC.RdrName) = do + decls <- liftT $ hsDecls x + nm <- getRefactNameMap + if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False) + then do + logm "MoveDef:demoteInLet" -- ++AZ++ + done <- getRefactDone + letExp' <- if (not done) + then doDemoting' letExp pn + else return letExp + return letExp' + else return x + demoteInLet x = return x + + + --6.The demoted definition is a local decl in a Let statement. + -- demoteInStmt (letStmt@(HsLetStmt ds stmts):: (HsStmt (HsExpP) (HsPatP) [HsDeclP])) + demoteInStmt (letStmt@(GHC.L _ (GHC.LetStmt _binds))::GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do + decls <- liftT $ hsDecls letStmt + nm <- getRefactNameMap + if not $ emptyList (definingDeclsRdrNames nm [pn] decls False False) + then do + logm "MoveDef:demoteInStmt" -- ++AZ++ + done <- getRefactDone + letStmt' <- if (not done) + then doDemoting' letStmt pn + else return letStmt + return letStmt' + else return letStmt + demoteInStmt x = return x + + + +-- |Demote the declaration of 'pn' in the context of 't'. +doDemoting' :: (UsedByRhs t) => t -> GHC.Name -> RefactGhc t +doDemoting' t pn = do + nm <- getRefactNameMap + -- origDecls <- liftT $ hsDecls t + origDecls <- liftT $ hsDeclsGeneric t + let + demotedDecls'= definingDeclsRdrNames nm [pn] origDecls True False + declaredPns = nub $ concatMap (definedNamesRdr nm) demotedDecls' + pnsUsed = usedByRhsRdr nm t declaredPns + logm $ "doDemoting':(pn,declaredPns)=" ++ showGhc (pn,declaredPns) + -- logm $ "doDemoting':t=" ++ (SYB.showData SYB.Renamer 0 t) + logm $ "doDemoting':(declaredPns,pnsUsed)=" ++ showGhc (declaredPns,pnsUsed) + r <- if not pnsUsed -- (usedByRhs t declaredPns) + then do + logm $ "doDemoting' no pnsUsed" + -- dt <- liftT $ hsDecls t + let dt = origDecls + let demotedDecls = definingDeclsRdrNames nm [pn] dt True True + otherBinds = (deleteFirstsBy (sameBindRdr nm) dt demotedDecls) + {- From 'hsDecls t' to 'hsDecls t \\ demotedDecls'. + Bug fixed 06/09/2004 to handle direct recursive function. + -} + xx = map (\b -> (b,uses nm declaredPns [b])) otherBinds + useCount = sum $ concatMap snd xx + logm $ "doDemoting': declaredPns=" ++ (showGhc declaredPns) + logm $ "doDemoting': uses xx=" ++ (showGhc xx) + logm $ "doDemoting': uses useCount=" ++ (show useCount) + + case useCount of + 0 ->do error "\n Nowhere to demote this function!\n" + 1 -> --This function is only used by one friend function + do + logm "MoveDef.doDemoting':target location found" -- ++AZ++ + + let (FN f,_d) = hsFreeAndDeclaredRdr nm demotedDecls + (ds,removedDecl,_sigRemoved) <- rmDecl pn False t + (t',demotedSigs) <- rmTypeSigs declaredPns ds + + logDataWithAnns "MoveDef.doDemoting':after rmTypeSigs:demotedSigs=" demotedSigs + + logm $ "MoveDef:declaredPns=" ++ (showGhc declaredPns) -- ++AZ++ + + dl <- mapM (flip declaredNamesInTargetPlace ds) declaredPns + logm $ "mapM declaredNamesInTargetPlace done" + --make sure free variable in 'f' do not clash with variables in 'dl', + --otherwise do renaming. + let clashedNames=filter (\x-> elem (id x) (map id f)) $ (nub.concat) dl + --rename clashed names to new names created automatically,update TOKEN STREAM as well. + if clashedNames/=[] + then error ("The identifier(s):" ++ showGhc clashedNames ++ + ", declared in where the definition will be demoted to, will cause name clash/capture" + ++" after demoting, please do renaming first!") + else --duplicate demoted declarations to the right place. + do + duplicateDecls declaredPns removedDecl demotedSigs t' + {- + logm $ "MoveDef: about to duplicateDecls" + dds <- liftT $ hsDecls t' + ds'' <- duplicateDecls declaredPns removedDecl demotedSigs dds + logm $ "MoveDef:duplicateDecls done" + t'' <- liftT $ replaceDecls t' ds'' + return t'' + -} + _ ->error "\nThis function/pattern binding is used by more than one friend bindings\n" + + else error "This function can not be demoted as it is used in current level!\n" + + return r + + where + ---find how many matches/pattern bindings use 'pn'------- + uses :: NameMap -> [GHC.Name] -> [GHC.LHsDecl GHC.RdrName] -> [Int] + uses nm pns t2 + = concatMap used t2 + where + + used :: GHC.LHsDecl GHC.RdrName -> [Int] + used (GHC.L _ (GHC.ValD (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _))) + = concatMap (usedInMatch pns) matches + + used (GHC.L _ (GHC.ValD (GHC.PatBind pat rhs _ _ _))) + | (not $ findNamesRdr nm pns pat) && findNamesRdr nm pns rhs + = [1::Int] + used _ = [] + + usedInMatch pns' (GHC.L _ (GHC.Match _ pats _ rhs)) + | (not $ findNamesRdr nm pns' pats) && findNamesRdr nm pns' rhs + = [1::Int] + usedInMatch _ _ = [] + + + duplicateDecls :: (SYB.Data t,SYB.Typeable t) + => [GHC.Name] -- ^ function names to be demoted + -> GHC.LHsDecl GHC.RdrName -- ^Bind being demoted + -> [GHC.LSig GHC.RdrName] -- ^Signatures being demoted, if any + -> t + -> RefactGhc t + duplicateDecls pns demoted dsig o = do + logm $ "duplicateDecls:t=" ++ SYB.showData SYB.Parser 0 o + hasDeclsSybTransform workerHsDecls workerBind o + where + workerHsDecls :: forall t. HasDecls t => t -> RefactGhc t + workerHsDecls t' = do + dds <- liftT $ hsDecls t' + ds'' <- duplicateDecls' pns demoted dsig dds + liftT $ replaceDecls t' ds'' + + workerBind :: (GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName)) + workerBind t'@(GHC.L _ (GHC.PatBind{})) = do + dds <- liftT $ hsDeclsPatBind t' + ds'' <- duplicateDecls' pns demoted dsig dds + liftT $ replaceDeclsPatBind t' ds'' + workerBind x = error $ "MoveDef.duplicateDecls.workerBind:unmatched LHsBind:" ++ showGhc x + + + -- duplicate demotedDecls to the right place (the outer most level where it is used). + duplicateDecls' :: [GHC.Name] -- ^ function names to be demoted + -> GHC.LHsDecl GHC.RdrName -- ^Bind being demoted + -> [GHC.LSig GHC.RdrName] -- ^Signatures being demoted, if any + -> [GHC.LHsDecl GHC.RdrName] -- ^Binds of original top + -- level entiity, + -- including src and dst + -> RefactGhc [GHC.LHsDecl GHC.RdrName] + duplicateDecls' pns demoted dsig decls + = do + nm <- getRefactNameMap + everywhereMStaged' SYB.Parser (SYB.mkM (dupInMatch nm) -- top-down approach + `SYB.extM` (dupInPat nm)) decls + where + dupInMatch nm (match@(GHC.L _ (GHC.Match _ pats _mt rhs)) :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + | (not $ findNamesRdr nm pns pats) && findNamesRdr nm pns rhs + = do + done <- getRefactDone + logm $ "duplicateDecls.dupInMatch:value of done=" ++ (show done) -- ++AZ++ + if done + then return match + else do + logm "duplicateDecls:setting done" -- ++AZ++ + setRefactDone + match' <- foldParams pns match decls demoted dsig + return match' + dupInMatch _ x = return x + + dupInPat nm ((GHC.PatBind pat rhs@(GHC.GRHSs grhs lb) ty fvs ticks) :: GHC.HsBind GHC.RdrName) + | (not $ findNamesRdr nm pns pat) && findNamesRdr nm pns rhs + = do + logm $ "duplicateDecls.dupInPat" + let declsToLift = definingDeclsRdrNames' nm pns t + lb' <- moveDecl1 lb Nothing pns declsToLift pns [] + return (GHC.PatBind pat (GHC.GRHSs grhs lb') ty fvs ticks) + dupInPat _ x = return x + + -- demotedDecls = definingDecls pns decls True False + --------------------------------------------------------------------- + + declaredNamesInTargetPlace :: (SYB.Data t) + => GHC.Name -> t + -- -> RefactGhc [GHC.Name] + -> RefactGhc [GHC.Name] + + declaredNamesInTargetPlace pn' t' = do + logm $ "declaredNamesInTargetPlace:pn=" ++ (showGhc pn') + res <- applyTU (stop_tdTU (failTU + `adhocTU` inMatch + `adhocTU` inPat)) t' + logm $ "declaredNamesInTargetPlace:res=" ++ (showGhc res) + return res + where + inMatch ((GHC.Match _ _pats _ rhs) :: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) + | findPN pn' rhs = do + logm $ "declaredNamesInTargetPlace:inMatch" + fds <- hsFDsFromInside rhs + return $ snd fds + inMatch _ = return mzero + + inPat ((GHC.PatBind pat rhs _ _ _) :: GHC.HsBind GHC.Name) + |findPN pn' rhs = do + logm $ "declaredNamesInTargetPlace:inPat" + fds <- hsFDsFromInside pat + return $ snd fds + inPat _= return mzero + +-- --------------------------------------------------------------------- + + +{- foldParams:remove parameters in the demotedDecls if possible + parameters: pn -- the function/pattern name to be demoted in PName format + match--where the demotedDecls will be demoted to + demotedDecls -- the declarations to be demoted. + example: + module Test where demote 'sq' module Test where + sumSquares x y ===> sumSquares x y =(sq 0) + (sq y) + = sq x 0+ sq x y where sq y=x ^ y + sq x y=x^y +-} +--PROBLEM: TYPE SIGNATURE SHOULD BE CHANGED. +--- TEST THIS FUNCTION!!! +foldParams :: [GHC.Name] -- ^The (list?) function name being demoted + -> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -- ^The RHS of the place to receive the demoted decls + -> [GHC.LHsDecl GHC.RdrName] -- ^Binds of original top level entiity, including src and dst + -> GHC.LHsDecl GHC.RdrName -- ^The decls being demoted + -> [GHC.LSig GHC.RdrName] -- ^Signatures being demoted, if any + -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) +foldParams pns match@(GHC.L l (GHC.Match _mfn _pats _mt rhs)) _decls demotedDecls dsig + + =do + logm $ "MoveDef.foldParams entered" + nm <- getRefactNameMap + + let matches = concatMap matchesInDecls [demotedDecls] + pn = ghead "foldParams" pns --pns /=[] + logm $ "MoveDef.foldParams before allParams" + params <- allParams pn rhs [] + logm $ "foldParams:params=" ++ showGhc params + if (length.nub.map length) params==1 -- have same number of param + && ((length matches)==1) -- only one 'match' in the demoted declaration + then do + let patsInDemotedDecls=(patsInMatch.(ghead "foldParams")) matches + subst = mkSubst nm patsInDemotedDecls params + fstSubst = map fst subst + sndSubst = map snd subst + + rhs' <- rmParamsInParent pn sndSubst rhs + + let ls = map (hsFreeAndDeclaredRdr nm) sndSubst + let newNames = ((concatMap (fn . fst) ls)) \\ (fstSubst) + --There may be name clashing because of introducing new names. + clashedNames <- getClashedNames nm fstSubst newNames (ghead "foldParams" matches) + + logm $ "MoveDef.foldParams about to foldInDemotedDecls" + + demotedDecls''' <- foldInDemotedDecls pns clashedNames subst [demotedDecls] + logm $ "MoveDef.foldParams foldInDemotedDecls done" + + let match' = GHC.L l ((GHC.unLoc match) {GHC.m_grhss = rhs' }) + match'' <- addDecl match' Nothing (demotedDecls''',Nothing) + logm $ "MoveDef.foldParams addDecl done 1" + return match'' + else do + logm $ "foldParams:no params" + let sigs = map wrapSig dsig + match' <- addDecl match Nothing (sigs++[demotedDecls],Nothing) + logm "MoveDef.foldParams addDecl done 2" + return match' + + where + + matchesInDecls :: GHC.LHsDecl GHC.RdrName -> [GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)] + matchesInDecls (GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _))) = matches + matchesInDecls _x = [] + + patsInMatch (GHC.L _ (GHC.Match _ pats' _ _)) = pats' + + foldInDemotedDecls :: [GHC.Name] -- ^The (list?) of names to be demoted + -> [GHC.Name] -- ^Any names that clash + -> [(GHC.Name, GHC.HsExpr GHC.RdrName)] -- ^Parameter substitutions required + -> [GHC.LHsDecl GHC.RdrName] -- ^Binds of original top level entity, including src and dst + -> RefactGhc [GHC.LHsDecl GHC.RdrName] + foldInDemotedDecls pns' clashedNames subst decls = do + logm $ "foldInDemotedDecls:(pns',clashedNames,subst)=" ++ showGhc (pns',clashedNames,subst) + logm $ "foldInDemotedDecls:decls=" ++ SYB.showData SYB.Parser 0 decls + nm <- getRefactNameMap + SYB.everywhereMStaged SYB.Parser (SYB.mkM (worker nm) `SYB.extM` (workerBind nm)) decls + where + worker nm (match'@(GHC.L _ (GHC.FunBind ln _ (GHC.MG _matches _ _ _) _ _ _)) :: GHC.LHsBind GHC.RdrName) + = do + logm $ "foldInDemotedDecls:rdrName2NamePure nm ln=" ++ show (rdrName2NamePure nm ln) + if isJust (find (== rdrName2NamePure nm ln) pns') + then do + logm $ "foldInDemotedDecls:found match'" + match'' <- foldM (flip autoRenameLocalVar) match' clashedNames + match''' <- foldM replaceExpWithUpdToks match'' subst + rmParamsInDemotedDecls (map fst subst) match''' + else return match' + worker _ x = return x + + workerBind nm ((GHC.L ll (GHC.ValD d)) :: GHC.LHsDecl GHC.RdrName) + = do + (GHC.L _ d') <- worker nm (GHC.L ll d) + return (GHC.L ll (GHC.ValD d')) + workerBind _ x = return x + + ------Get all of the paramaters supplied to pn --------------------------- + {- eg. sumSquares x1 y1 x2 y2 = rt x1 y1 + rt x2 y2 + rt x y = x+y + demote 'rt' to 'sumSquares', + 'allParams pn rhs []' returns [[x1,x2],[y1,y2]] + where pn is 'rt' and rhs is 'rt x1 y1 + rt x2 y2' + -} + + allParams :: GHC.Name -> GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName) + -> [[GHC.HsExpr GHC.RdrName]] + -> RefactGhc [[GHC.HsExpr GHC.RdrName]] + allParams pn rhs1 initial -- pn: demoted function/pattern name. + =do + nm <- getRefactNameMap + let p = getOneParam nm pn rhs1 + -- putStrLn (show p) + logm $ "allParams:p=" ++ showGhc p + if (nonEmptyList p) + then do rhs' <- rmOneParam pn rhs1 + logDataWithAnns "allParams:rhs'=" rhs' + allParams pn rhs' (initial++[p]) + else return initial + where + getOneParam :: (SYB.Data t) => NameMap -> GHC.Name -> t -> [GHC.HsExpr GHC.RdrName] + getOneParam nm pn1 + = SYB.everythingStaged SYB.Renamer (++) [] + ([] `SYB.mkQ` worker) + -- =applyTU (stop_tdTU (failTU `adhocTU` worker)) + where + worker :: GHC.HsExpr GHC.RdrName -> [GHC.HsExpr GHC.RdrName] + worker (GHC.HsApp e1 e2) + |(expToNameRdr nm e1 == Just pn1) = [GHC.unLoc e2] + worker _ = [] + + rmOneParam :: (SYB.Data t) => GHC.Name -> t -> RefactGhc t + rmOneParam pn1 t + -- This genuinely needs to be done once only. Damn. + -- =applyTP (stop_tdTP (failTP `adhocTP` worker)) + = do + -- _ <- clearRefactDone + nm <- getRefactNameMap + everywhereMStaged' SYB.Parser (SYB.mkM (worker nm)) t + where + worker nm (GHC.L _ (GHC.HsApp e1 _e2 )) -- The param being removed is e2 + |expToNameRdr nm e1 == Just pn1 = return e1 + worker _ x = return x +{- + AST output + + addthree x y z + + becomes + + (HsApp + (L {test/testdata/Demote/WhereIn6.hs:10:17-28} + (HsApp + (L {test/testdata/Demote/WhereIn6.hs:10:17-26} + (HsApp + (L {test/testdata/Demote/WhereIn6.hs:10:17-24} + (HsVar {Name: WhereIn6.addthree})) + (L {test/testdata/Demote/WhereIn6.hs:10:26} + (HsVar {Name: x})))) + (L {test/testdata/Demote/WhereIn6.hs:10:28} + (HsVar {Name: y})))) + (L {test/testdata/Demote/WhereIn6.hs:10:30} + (HsVar {Name: z}))) + +----- + (HsApp + (HsApp + (HsApp + (HsVar {Name: WhereIn6.addthree})) + (HsVar {Name: x})))) + (HsVar {Name: y})))) + (HsVar {Name: z}))) + +----- + + sq p x + + becomes + + (HsApp + (HsApp + (HsVar {Name: Demote.WhereIn4.sq})) + (HsVar {Name: p})))) + (HsVar {Name: x}))) + +---- + sq x + + becomes + + (HsApp + (HsVar {Name: sq})) + (HsVar {Name: x}))) +-} + + + -----------remove parameters in demotedDecls------------------------------- + rmParamsInDemotedDecls :: [GHC.Name] -> GHC.LHsBind GHC.RdrName + -> RefactGhc (GHC.LHsBind GHC.RdrName) + rmParamsInDemotedDecls ps bind + -- =applyTP (once_tdTP (failTP `adhocTP` worker)) + = SYB.everywhereMStaged SYB.Parser (SYB.mkM worker) bind + where worker :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + worker (GHC.Match mfn' pats2 typ rhs1) + = do + nm <- getRefactNameMap + let pats'=filter (\x->not ((patToNameRdr nm x /= Nothing) && + elem (gfromJust "rmParamsInDemotedDecls" $ patToNameRdr nm x) ps)) pats2 + return (GHC.Match mfn' pats' typ rhs1) + + ----------remove parameters in the parent functions' rhs------------------- + rmParamsInParent :: GHC.Name -> [GHC.HsExpr GHC.RdrName] + -> GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName) + -> RefactGhc (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + rmParamsInParent pn es grhss = do + nm <- getRefactNameMap + -- =applyTP (full_buTP (idTP `adhocTP` worker)) + SYB.everywhereMStaged SYB.Renamer (SYB.mkM (worker nm)) grhss + where worker nm expr@(GHC.L _ (GHC.HsApp e1 e2)) + | findNamesRdr nm [pn] e1 && (elem (showGhc (GHC.unLoc e2)) (map (showGhc) es)) + = do + liftT $ transferEntryDPT expr e1 + return e1 + worker nm (expr@(GHC.L _ (GHC.HsPar e1))) + |Just pn==expToNameRdr nm e1 + = do + liftT $ transferEntryDPT expr e1 + return e1 + worker _ x =return x + + + getClashedNames :: NameMap -> [GHC.Name] -> [GHC.Name] + -> GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) + -> RefactGhc [GHC.Name] + getClashedNames nm oldNames newNames match' + = do (_f,DN d) <- hsFDsFromInsideRdr nm match' + ds' <- mapM (flip (hsVisiblePNsRdr nm) match') oldNames + -- return clashed names + return (filter (\x->elem ({- pNtoName -} x) newNames) --Attention: nub + ( nub (d `union` (nub.concat) ds'))) + + ----- make Substitions between formal and actual parameters.----------------- + mkSubst :: NameMap + -> [GHC.LPat GHC.RdrName] -> [[GHC.HsExpr GHC.RdrName]] + -> [(GHC.Name,GHC.HsExpr GHC.RdrName)] + mkSubst nm pats1 params + = catMaybes (zipWith (\x y -> if (patToNameRdr nm x/=Nothing) && (length (nub $ map showGhc y)==1) + then Just (gfromJust "mkSubst" $ patToNameRdr nm x,(ghead "mkSubst") y) + else Nothing) pats1 params) + + +-- |substitute an old expression by new expression +replaceExpWithUpdToks :: (SYB.Data t) + => t -> (GHC.Name, GHC.HsExpr GHC.RdrName) + -> RefactGhc t +replaceExpWithUpdToks decls subst = do + nm <- getRefactNameMap + let + worker (e@(GHC.L l _)::GHC.LHsExpr GHC.RdrName) + |(expToNameRdr nm e) == Just (fst subst) + = update e (GHC.L l (snd subst)) e + worker x=return x + + -- = applyTP (full_buTP (idTP `adhocTP` worker)) decls + everywhereMStaged' SYB.Parser (SYB.mkM worker) decls + + +-- | return True if pn is a local function/pattern name +isLocalFunOrPatName :: SYB.Data t => GHC.Name -> t -> Bool +isLocalFunOrPatName pn scope + = isLocalPN pn && isFunOrPatName pn scope + +-- EOF diff --git a/src/Language/Haskell/Refact/Refactoring/Renaming.hs b/src/Language/Haskell/Refact/Refactoring/Renaming.hs --- a/src/Language/Haskell/Refact/Refactoring/Renaming.hs +++ b/src/Language/Haskell/Refact/Refactoring/Renaming.hs @@ -1,6 +1,6 @@ -module Language.Haskell.Refact.Refactoring.Renaming(rename) where +module Language.Haskell.Refact.Refactoring.Renaming (rename) where --- import qualified Data.Generics.Schemes as SYB +import qualified Data.Generics.Schemes as SYB import qualified Data.Generics.Aliases as SYB import qualified GHC.SYB.Utils as SYB @@ -10,12 +10,10 @@ import Control.Monad import Data.List -import Exception -import Language.Haskell.GhcMod +import qualified Language.Haskell.GhcMod as GM (Options(..)) import Language.Haskell.Refact.API - --- import Language.Haskell.Refact.Utils.GhcVersionSpecific +import System.Directory {-This refactoring renames an indentifier to a user-specified name. @@ -46,65 +44,61 @@ -} -- | Rename the given identifier. -rename :: RefactSettings -> Cradle +rename :: RefactSettings -> GM.Options -> FilePath -> String -> SimpPos -> IO [FilePath] -rename settings cradle fileName newName (row,col) = - runRefacSession settings cradle (comp fileName newName (row,col)) +rename settings opts fileName newName (row,col) = do + absFileName <- canonicalizePath fileName + runRefacSession settings opts (comp absFileName newName (row,col)) -- | Body of the refactoring comp :: FilePath -> String -> SimpPos -> RefactGhc [ApplyRefacResult] comp fileName newName (row,col) = do - logm $ "Renaming.comp: (fileName,newName,(row,col))=" ++ (show (fileName,newName,(row,col))) - getModuleGhc fileName + logm $ "Renaming.comp: (fileName,newName,(row,col))=" ++ show (fileName,newName,(row,col)) + parseSourceFileGhc fileName renamed <- getRefactRenamed parsed <- getRefactParsed - logm $ "comp:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ - -- logm $ "comp:parsed=" ++ (SYB.showData SYB.Parser 0 parsed) -- ++AZ++ modu <- getModule - -- let (Just (modName,_)) = getModuleName parsed - let modName = case (getModuleName parsed) of + targetModule <- getRefactTargetModule + let modName = case getModuleName parsed of Just (mn,_) -> mn Nothing -> GHC.mkModuleName "Main" let maybePn = locToName (row, col) renamed - logm $ "Renamed.comp:maybePn=" ++ (showGhc maybePn) -- ++AZ++ + logm $ "Renamed.comp:maybePn=" ++ showGhc maybePn -- ++AZ++ case maybePn of Just pn@(GHC.L _ n) -> do - logm $ "Renaming:(n,modu)=" ++ (showGhc (n,modu)) - -- let (GHC.L _ rdrName') = gfromJust "Renaming.comp.1" $ locToRdrName (row, col) parsed - -- logm $ "Renaming.comp:rdrName'=" ++ (showGhc rdrName') + logm $ "Renaming:(n,modu)=" ++ showGhc (n,modu) let (GHC.L _ rdrName) = gfromJust "Renaming.comp.2" $ locToRdrName (row, col) parsed let rdrNameStr = GHC.occNameString $ GHC.rdrNameOcc rdrName - logm $ "Renaming: rdrName=" ++ (SYB.showData SYB.Parser 0 rdrName) - logm $ "Renaming: occname rdrName=" ++ (show $ GHC.occNameString $ GHC.rdrNameOcc rdrName) + logm $ "Renaming: rdrName=" ++ SYB.showData SYB.Parser 0 rdrName + logm $ "Renaming: occname rdrName=" ++ show (GHC.occNameString $ GHC.rdrNameOcc rdrName) unless (nameToString n /= newName) $ error "The new name is same as the old name" unless (isValidNewName n rdrNameStr newName) $ error $ "Invalid new name:" ++ newName ++ "!" - logm $ "Renaming.comp: before GHC.nameModule,n=" ++ (showGhc n) - -- let defineMod = GHC.moduleName $ GHC.nameModule n + logm $ "Renaming.comp: before GHC.nameModule,n=" ++ showGhc n let defineMod = case GHC.nameModule_maybe n of Just mn -> GHC.moduleName mn Nothing -> modName -- TODO: why do we have this restriction? - unless (defineMod == modName ) ( error ("This identifier is defined in module " ++ (show defineMod) ++ + unless (defineMod == modName ) ( error ("This identifier is defined in module " ++ GHC.moduleNameString defineMod ++ ", please do renaming in that module!")) - -- logm $ "Renaming.comp:(isMainModule modu,pn)=" ++ (showGhc (isMainModule modu,pn)) - if isMainModule modu && (showGhc pn) == "Main.main" - then error ("The 'main' function defined in a 'Main' module should not be renamed!") + logm $ "Renaming.comp:(isMainModule modu,pn)=" ++ (showGhcQual (isMainModule modu,pn)) + if isMainModule modu && showGhcQual pn == "Main.main" + then error "The 'main' function defined in a 'Main' module should not be renamed!" else do logm $ "Renaming.comp: not main module" newNameGhc <- mkNewGhcName (Just modu) newName (refactoredMod,nIsExported) <- applyRefac (doRenaming pn rdrNameStr newName newNameGhc modName) RSAlreadyLoaded - logm $ "Renaming:nIsExported=" ++ (show nIsExported) + logm $ "Renaming:nIsExported=" ++ show nIsExported if nIsExported --no matter whether this pn is used or not. - then do clients <- clientModsAndFiles modName - logm ("Renaming: clients=" ++ (showGhc clients)) -- ++AZ++ debug + then do clients <- clientModsAndFiles targetModule + logm ("Renaming: clients=" ++ show clients) -- ++AZ++ debug refactoredClients <- mapM (renameInClientMod n newName newNameGhc) clients return $ refactoredMod:(concat refactoredClients) else return [refactoredMod] @@ -119,31 +113,18 @@ doRenaming pn@(GHC.L _ oldn) rdrNameStr newNameStr newNameGhc modName = do logm $ "doRenaming:(pn,rdrNameStr,newNameStr) = " ++ (showGhc (pn,rdrNameStr,newNameStr)) renamed <- getRefactRenamed - {- - r' <- applyTP (once_buTPGhc (failTP `adhocTP` renameInMod - -- `adhocTP` renameInMatch - -- `adhocTP` renameInPattern - -- `adhocTP` renameInExp - -- `adhocTP` renameInAlt - -- `adhocTP` renameInStmts - )) renamed - -} - -- somewhereMStagedBu SYB.Renamer (SYB.mkM renameInMod - void $ everywhereMStaged SYB.Renamer (SYB.mkM renameInMod - ) renamed - logm $ "doRenaming done" + void $ SYB.everywhereM (SYB.mkM renameInMod + ) renamed + logm "doRenaming done" nIsExported <- isExported oldn return nIsExported where -- 1. The name is declared in a module(top level name) - -- renameInMod (mod::HsModuleP) renameInMod :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource renameInMod ren - -- was | isDeclaredIn oldn ren = do | True = do logm $ "renameInMod" renameTopLevelVarName oldn newNameStr newNameGhc modName ren True True - -- renameInMod _ren = mzero renameTopLevelVarName :: GHC.Name -> String -> GHC.Name -> GHC.ModuleName -> GHC.RenamedSource @@ -166,7 +147,6 @@ logm $ "renameTopLevelVarName:(scopeClashNames,intersection)=" ++ (showGhc (scopeClashNames,intersect scopeClashNames f')) logm $ "renameTopLevelVarName:(oldPN,modName)=" ++ (showGhc (oldPN,modName)) if (nonEmptyList $ intersect scopeClashNames f') - -- if elem newNameStr f then error ("The new name will cause ambiguous occurrence problem," ++" please select another new name or qualify the use of ' " ++ newName ++ "' before renaming!\n") -- Another implementation option is to add the qualifier @@ -181,13 +161,11 @@ logm $ "renameTopLevelVarName:basic tests done" - -- isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName Nothing isInScopeUnqual <- isInScopeAndUnqualifiedGhc newName (Just newNameGhc) logm $ "renameTopLevelVarName:after isInScopeUnqual" logm $ "renameTopLevelVarName:oldPN=" ++ showGhc oldPN ds <- hsVisibleNames oldPN renamed logm $ "renameTopLevelVarName:ds computed=" ++ (show ds) - -- '\\[pNtoName oldPN]' handles the case in which the new name is same as the old name if existChecking && elem newName ((nub (ds `union` f)) \\[nameToString oldPN]) then error ("Name '"++newName++"' already existed, or rename '" ++nameToString oldPN++ "' to '"++newName++ @@ -195,72 +173,88 @@ else if exportChecking && isInScopeUnqual -- isInScopeAndUnqualifiedGhc newName Nothing then do logm $ "renameTopLevelVarName start..:should have qualified" - void $ renamePN oldPN newNameGhc True True renamed + parsed <- getRefactParsed + parsed' <- renamePN' oldPN newNameGhc True parsed + putRefactParsed parsed' mempty logm $ "renameTopLevelVarName done:should have qualified" - -- drawTokenTreeDetailed "should be qualified" -- ++AZ++ debug r' <- getRefactRenamed return r' else do logm $ "renameTopLevelVarName start.." - void $ renamePN oldPN newNameGhc True False renamed + parsed <- getRefactParsed + parsed' <- renamePN' oldPN newNameGhc False parsed + putRefactParsed parsed' mempty logm $ "renameTopLevelVarName done" r' <- getRefactRenamed return r' renameInClientMod :: GHC.Name -> String -> GHC.Name -> TargetModule - -> RefactGhc [ApplyRefacResult] -renameInClientMod oldPN newName newNameGhc targetModule@(_,modSummary) = do - logm $ "renameInClientMod:(oldPN,newNameGhc,modSummary)=" ++ (showGhc (oldPN,newNameGhc,targetModule)) -- ++AZ++ - void $ activateModule targetModule - {- ++AZ++ debug stuff -} - names <- ghandle handler (GHC.parseName $ nameToString oldPN) - nameInfo <- mapM GHC.lookupName names - logm $ "renameInClientMod: nameInfo=" ++ (showGhc nameInfo) - {- ++AZ++ debug stuff end -} + -> RefactGhc [ApplyRefacResult] +renameInClientMod oldPN newName newNameGhc targetModule = do + logm $ "renameInClientMod:(oldPN,newNameGhc,targetModule)=" ++ (showGhc (oldPN,newNameGhc,targetModule)) -- ++AZ++ + logm $ "renameInClientMod:(newNameGhc module)=" ++ (showGhc (GHC.nameModule newNameGhc)) -- ++AZ++ + getTargetGhc targetModule renamed <- getRefactRenamed - let modName = GHC.moduleName $ GHC.ms_mod modSummary - -- causeNameClashInExports oldPN newName mod exps - -- logm $ "renameInClientMod:causeNameClashInExports oldPN modName renamed=" ++ (show $ causeNameClashInExports oldPN modName renamed) + modName <- getRefactModuleName + -- We need to find the old name in the module, and get it as a + -- GHC.Name to know what to look for in the call to renamePN', as it + -- checks the GHC.nameUnique value. + -- gnames <- GHC.getNamesInScope + -- let clientModule = GHC.nameModule oldPN + -- let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames + -- logm $ "renameInClientMod:(clientInscopes)=" ++ showGhcQual (clientInscopes) + -- let newNames = filter (\n -> showGhcQual n == showGhcQual oldPN) clientInscopes + newNames <- equivalentNameInNewMod oldPN + logm $ "renameInClientMod:(newNames)=" ++ showGhcQual (newNames) + + -- newNames <- inScopeNames (showGhcQual oldPN) + -- newNamesUnqual <- inScopeNames (showGhc oldPN) + -- logm $ "renameInClientMod:(newNamesUnqual,oldPN)=" ++ showGhcQual (newNamesUnqual,oldPN) + -- logm $ "renameInClientMod:(newNames,oldPN)=" ++ showGhcQual (newNames,oldPN) + -- logm $ "renameInClientMod:(uniques:newNames,oldPN)=" ++ showGhcQual (map GHC.nameUnique newNames,GHC.nameUnique oldPN) + let oldNameGhc = case newNames of + [n] -> n + ns -> error $ "HaRe:renameInClientMod:could not find name to replace,got:" ++ showGhcQual ns + -- There are two different tests we need to do here -- 1. Does the new name clash with some existing name in the -- client mod, in which case it must be qualified -- 2. Is the new name module imported qualified, and so needs to -- be qualified in the replacement, according to the import - isInScopeUnqual <- isInScopeAndUnqualifiedGhc (nameToString oldPN) Nothing - isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName Nothing + isInScopeUnqual <- isInScopeAndUnqualifiedGhc (nameToString oldPN) Nothing + isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName Nothing logm $ "renameInClientMod: (isInScopeAndUnqual,isInScopeUnqualNew)=" ++ (show (isInScopeUnqual,isInScopeUnqualNew)) -- ++AZ++ - -- if qualifier == [] --this name is not imported, but it maybe used in the import list - -- if isInScopeUnqual - if isInScopeUnqualNew + if isInScopeUnqualNew -- ++AZ++: should this be negated? then - -- do (mod', ((ts',m),f))<-runStateT (renamePN oldPN Nothing newName True mod) ((ts,unmodified), fileName) do - (refactoredMod,_) <- applyRefac (refactRenameSimple oldPN newName newNameGhc True) RSAlreadyLoaded + -- (refactoredMod,_) <- applyRefac (refactRenameSimple oldPN newName newNameGhc True) RSAlreadyLoaded + (refactoredMod,_) <- applyRefac (refactRenameSimple oldNameGhc newName newNameGhc True) RSAlreadyLoaded return [refactoredMod] else - do if causeNameClashInExports oldPN newNameGhc modName renamed + do + if causeNameClashInExports oldPN newNameGhc modName renamed then error $"The new name will cause conflicting exports in module "++ show newName ++ ", please select another name!" else do - (refactoredMod,_) <- applyRefac (refactRenameComplex oldPN newName newNameGhc) RSAlreadyLoaded + -- (refactoredMod,_) <- applyRefac (refactRenameComplex oldPN newName newNameGhc) RSAlreadyLoaded + (refactoredMod,_) <- applyRefac (refactRenameComplex oldNameGhc newName newNameGhc) RSAlreadyLoaded -- TODO: implement rest of this return [refactoredMod] where - handler:: (GHC.GhcMonad m) => SomeException -> m [GHC.Name] - handler _ = return [] - refactRenameSimple :: GHC.Name -> String -> GHC.Name -> Bool -> RefactGhc () refactRenameSimple old newStr new useQual = do + logm $ "refactRenameSimple:(old,newStr,new,useQual)=" ++ showGhc (old,newStr,new,useQual) qualifyTopLevelVar newStr - renamed <- getRefactRenamed - logm $ "renameInClientMod.refactRename:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ - void $ renamePN old new True useQual renamed + parsed <- getRefactParsed + parsed' <- renamePN' old new useQual parsed + putRefactParsed parsed' mempty return () refactRenameComplex :: GHC.Name -> String -> GHC.Name -> RefactGhc () refactRenameComplex old new newGhc = do + logm $ "refactRenameComplex:(old,new,newGhc)=" ++ showGhc (old,new,newGhc) qualifyTopLevelVar new worker old new newGhc @@ -268,20 +262,21 @@ qualifyTopLevelVar new = do toQualify <- inScopeNames new logm $ "renameInClientMod.qualifyTopLevelVar:new:toQualify=" ++ (show new) ++ ":" ++ (showGhc toQualify) - -- renamed <- getRefactRenamed - -- renamePN new new True True renamed mapM_ qualifyToplevelName toQualify return () worker :: GHC.Name -> String -> GHC.Name -> RefactGhc () worker oldPN' newName' newNameGhc' = do - logm $ "renameInClientMod.worker" + logm $ "renameInClientMod.worker:(oldPN',newName',newNameGhc')=" ++ showGhc (oldPN',newName',newNameGhc') renamed <- getRefactRenamed + parsed <- getRefactParsed isInScopeUnqualNew <- isInScopeAndUnqualifiedGhc newName' Nothing vs <- hsVisibleNames oldPN' renamed --Does this check names other than variable names? - if elem newName' ((nub vs) \\ [nameToString oldPN']) || isInScopeUnqualNew - then void $ renamePN oldPN' newNameGhc' True True renamed --rename to qualified Name - else void $ renamePN oldPN' newNameGhc' True False renamed -- do not qualify + logm $ "renameInClientMod.worker:(vs,oldPN',isInScopeUnqualNew)=" ++ showGhc (vs,oldPN',isInScopeUnqualNew) + parsed' <- if elem newName' ((nub vs) \\ [nameToString oldPN']) || isInScopeUnqualNew + then renamePN' oldPN' newNameGhc' True parsed --rename to qualified Name + else renamePN' oldPN' newNameGhc' False parsed -- do not qualify + putRefactParsed parsed' mempty return () @@ -309,22 +304,10 @@ (isConId newName) "Invalid type constructor/class name!" - -- classOk = if isClassName oldName && isConId newName - -- then True - -- else error "Invalid class name!" - dataConOk = doTest (GHC.isDataConName oldName) (isConId newName) "Invalid data constructor name!" - -- fieldOk = doTest (isFieldName oldName) - -- (isVarId newName) - -- "Invalid field name!" - - -- instanceOk = doTest (isInstanceName oldName) - -- (isVarId newName) - -- "Invalid class instance name!" - tyVarOk = doTest (GHC.isTyVarName oldName) (isVarId newName) "Invalid type variable name!" @@ -346,5 +329,5 @@ res = tyconOk && dataConOk {- && fieldOk && instanceOk -} && tyVarOk && matchNamesOk - -- res = error $ "isValidNewName:(tyconOk,dataConOk`,fieldOk,instanceOk,tyVarOk,matchNamesOk)=" ++ (show (tyconOk,dataConOk,fieldOk,instanceOk,tyVarOk,matchNamesOk)) +-- EOF diff --git a/src/Language/Haskell/Refact/Refactoring/RoundTrip.hs b/src/Language/Haskell/Refact/Refactoring/RoundTrip.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Refactoring/RoundTrip.hs @@ -0,0 +1,23 @@ +module Language.Haskell.Refact.Refactoring.RoundTrip(roundTrip) where + +import qualified Language.Haskell.GhcMod as GM (Options(..)) +import Language.Haskell.Refact.API + +import System.Directory + +-- --------------------------------------------------------------------- + +-- | Roundtrip the source code, to check that the infrastructure is solid +roundTrip :: RefactSettings -> GM.Options -> FilePath -> IO [FilePath] +roundTrip settings opts fileName = do + absFileName <- canonicalizePath fileName + runRefacSession settings opts (comp absFileName) + +comp :: FilePath -> RefactGhc [ApplyRefacResult] +comp fileName = do + parseSourceFileGhc fileName + (r,_) <- applyRefac (setRefactStreamModified RefacModified) RSAlreadyLoaded + return [r] + +-- EOF + diff --git a/src/Language/Haskell/Refact/Refactoring/Simple.hs b/src/Language/Haskell/Refact/Refactoring/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Refactoring/Simple.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +module Language.Haskell.Refact.Refactoring.Simple(removeBracket) where + +import qualified Data.Generics as SYB + +import qualified GHC as GHC + +import qualified Language.Haskell.GhcMod as GM (Options(..)) +import Language.Haskell.Refact.API + +-- To be moved into HaRe API +import Language.Haskell.GHC.ExactPrint.Transform +import Language.Haskell.GHC.ExactPrint.Types + +import Data.Maybe +import System.Directory + +-- import Debug.Trace + +-- --------------------------------------------------------------------- + +-- | Convert an if expression to a case expression +removeBracket :: RefactSettings -> GM.Options -> FilePath -> SimpPos -> SimpPos -> IO [FilePath] +removeBracket settings opts fileName beginPos endPos = do + absFileName <- canonicalizePath fileName + let applied = (:[]) . fst <$> applyRefac + (removeBracketTransform absFileName beginPos endPos) + (RSFile absFileName) + runRefacSession settings opts applied + +type HsExpr a = GHC.Located (GHC.HsExpr a) +pattern HsPar l s = GHC.L l (GHC.HsPar s) + +removeBracketTransform :: FilePath -> SimpPos -> SimpPos -> RefactGhc () +removeBracketTransform fileName beginPos endPos = do + parseSourceFileGhc fileName + parsed <- getRefactParsed + let expr :: GHC.Located (GHC.HsExpr GHC.RdrName) + expr = fromJust $ locToExp beginPos endPos parsed + removePar :: HsExpr GHC.RdrName -> RefactGhc (HsExpr GHC.RdrName) + removePar e@(HsPar _ s) + | sameOccurrence e expr = do + startAnns <- liftT $ getAnnsT + let oldkey = mkAnnKey e + newkey = mkAnnKey s + newanns = fromMaybe startAnns $ replace oldkey newkey startAnns + setRefactAnns newanns + return s + removePar e = return e + p2 <- SYB.everywhereM (SYB.mkM removePar) parsed + (liftT getAnnsT) >>= putRefactParsed p2 + logm $ "logm: after refactor\n" ++ showGhc p2 + +-- EOF + diff --git a/src/Language/Haskell/Refact/Refactoring/SwapArgs.hs b/src/Language/Haskell/Refact/Refactoring/SwapArgs.hs --- a/src/Language/Haskell/Refact/Refactoring/SwapArgs.hs +++ b/src/Language/Haskell/Refact/Refactoring/SwapArgs.hs @@ -7,22 +7,30 @@ import qualified Name as GHC import qualified GHC -import Language.Haskell.GhcMod +import qualified Language.Haskell.GhcMod as GM (Options(..)) import Language.Haskell.Refact.API +import Data.Generics.Schemes + +import Language.Haskell.GHC.ExactPrint.Types +import System.Directory + + + -- TODO: replace args with specific parameters -swapArgs :: RefactSettings -> Cradle -> [String] -> IO [FilePath] -swapArgs settings cradle args +swapArgs :: RefactSettings -> GM.Options -> [String] -> IO [FilePath] +swapArgs settings opts args = do let fileName = args!!0 row = (read (args!!1)::Int) col = (read (args!!2)::Int) - runRefacSession settings cradle (comp fileName (row,col)) + absFileName <- canonicalizePath fileName + runRefacSession settings opts (comp absFileName (row,col)) comp :: String -> SimpPos -> RefactGhc [ApplyRefacResult] comp fileName (row, col) = do - getModuleGhc fileName + parseSourceFileGhc fileName renamed <- getRefactRenamed let name = locToName (row, col) renamed @@ -47,64 +55,76 @@ -- putStrLn "Completd" -doSwap :: - (GHC.Located GHC.Name) -> RefactGhc () -- m GHC.ParsedSource -doSwap name = do - -- inscopes <- getRefactInscopes - renamed <- getRefactRenamed - -- parsed <- getRefactParsed - reallyDoSwap name renamed - -reallyDoSwap :: (GHC.Located GHC.Name) -> GHC.RenamedSource -> RefactGhc () -reallyDoSwap (GHC.L _s n1) renamed = do - renamed' <- everywhereMStaged SYB.Renamer (SYB.mkM inMod `SYB.extM` inExp `SYB.extM` inType) renamed -- this needs to be bottom up +++ CMB +++ - putRefactRenamed renamed' +doSwap :: (GHC.Located GHC.Name) -> RefactGhc () +doSwap (GHC.L _s n1) = do + parsed <- getRefactParsed + logm $ "doSwap:parsed=" ++ SYB.showData SYB.Parser 0 parsed + nm <- getRefactNameMap + parsed' <- everywhereM (SYB.mkM (inMod nm) + `SYB.extM` (inExp nm) + `SYB.extM` (inType nm) + `SYB.extM` (inTypeDecl nm) + ) parsed + -- this needs to be bottom up +++ CMB +++ + putRefactParsed parsed' emptyAnns return () where -- 1. The definition is at top level... - inMod (_func@(GHC.FunBind (GHC.L x n2) infixity (GHC.MatchGroup matches p) a locals tick)::(GHC.HsBindLR GHC.Name GHC.Name )) - | GHC.nameUnique n1 == GHC.nameUnique n2 - = do logm ("inMatch>" ++ SYB.showData SYB.Parser 0 (GHC.L x n2) ++ "<") + inMod nm ((GHC.FunBind ln2 infixity (GHC.MG matches p m1 m2) a locals tick)::GHC.HsBind GHC.RdrName) + | GHC.nameUnique n1 == GHC.nameUnique (rdrName2NamePure nm ln2) + = do logm ("inMatch>" ++ SYB.showData SYB.Parser 0 ln2 ++ "<") newMatches <- updateMatches matches - return (GHC.FunBind (GHC.L x n2) infixity (GHC.MatchGroup newMatches p) a locals tick) - inMod func = return func + return (GHC.FunBind ln2 infixity (GHC.MG newMatches p m1 m2) a locals tick) + inMod _ func = return func -- 2. All call sites of the function... - inExp expr@((GHC.L _x (GHC.HsApp (GHC.L _y (GHC.HsApp e e1)) e2))::GHC.Located (GHC.HsExpr GHC.Name)) - | GHC.nameUnique (expToName e) == GHC.nameUnique n1 + inExp nm expr@((GHC.L _x (GHC.HsApp (GHC.L _y (GHC.HsApp e e1)) e2))::GHC.LHsExpr GHC.RdrName) + | cond = update e2 e1 =<< update e1 e2 expr - inExp e = return e + where + cond = case (expToNameRdr nm e) of + Nothing -> False + Just n2 -> GHC.nameUnique n2 == GHC.nameUnique n1 + inExp _ e = return e -- 3. Type signature... - inType (GHC.L x (GHC.TypeSig [GHC.L x2 name] types)::GHC.LSig GHC.Name) - | GHC.nameUnique name == GHC.nameUnique n1 - = do let (t1:t2:ts) = tyFunToList types + inType nm (GHC.L x (GHC.TypeSig [lname] types pns)::GHC.LSig GHC.RdrName) + | GHC.nameUnique (rdrName2NamePure nm lname) == GHC.nameUnique n1 + = do + logm $ "doSwap.inType" + let (t1:t2:ts) = tyFunToList types t1' <- update t1 t2 t1 t2' <- update t2 t1 t2 - return (GHC.L x (GHC.TypeSig [GHC.L x2 name] (tyListToFun (t1':t2':ts)))) + return (GHC.L x (GHC.TypeSig [lname] (tyListToFun (t1':t2':ts)) pns)) - inType (GHC.L _x (GHC.TypeSig (n:ns) _types)::GHC.LSig GHC.Name) - | GHC.nameUnique n1 `elem` (map (\(GHC.L _ n') -> GHC.nameUnique n') (n:ns)) - = error "Error in swapping arguments in type signature: signauture bound to muliple entities!" + inType nm (GHC.L _x (GHC.TypeSig (n:ns) _types _)::GHC.LSig GHC.RdrName) + | GHC.nameUnique n1 `elem` (map (\n' -> GHC.nameUnique (rdrName2NamePure nm n')) (n:ns)) + = error "Error in swapping arguments in type signature: signature bound to muliple entities!" - inType ty = return ty + inType _ ty = return ty - tyFunToList (GHC.L _ (GHC.HsForAllTy _ _ _ (GHC.L _ (GHC.HsFunTy t1 t2)))) = t1 : (tyFunToList t2) + inTypeDecl nm (GHC.L l (GHC.SigD s)) = do + (GHC.L _ s') <- inType nm (GHC.L l s) + return (GHC.L l (GHC.SigD s')) + inTypeDecl _ x = return x + + tyFunToList (GHC.L _ (GHC.HsForAllTy _ _ _ _ (GHC.L _ (GHC.HsFunTy t1 t2)))) = t1 : (tyFunToList t2) tyFunToList (GHC.L _ (GHC.HsFunTy t1 t2)) = t1 : (tyFunToList t2) tyFunToList t = [t] + tyListToFun [] = error "SwapArgs.tyListToFun" -- Keep the exhaustiveness checker happy tyListToFun [t1] = t1 tyListToFun (t1:ts) = GHC.noLoc (GHC.HsFunTy t1 (tyListToFun ts)) updateMatches [] = return [] - updateMatches ((GHC.L x (GHC.Match pats nothing rhs)::GHC.Located (GHC.Match GHC.Name)):matches) + updateMatches ((GHC.L x (GHC.Match mfn pats nothing rhs)::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)):matches) = case pats of (p1:p2:ps) -> do p1' <- update p1 p2 p1 p2' <- update p2 p1 p2 matches' <- updateMatches matches - return ((GHC.L x (GHC.Match (p1':p2':ps) nothing rhs)):matches') - [p] -> return [GHC.L x (GHC.Match [p] nothing rhs)] - [] -> return [GHC.L x (GHC.Match [] nothing rhs)] + return ((GHC.L x (GHC.Match mfn (p1':p2':ps) nothing rhs)):matches') + [p] -> return [GHC.L x (GHC.Match mfn [p] nothing rhs)] + [] -> return [GHC.L x (GHC.Match mfn [] nothing rhs)] diff --git a/src/Language/Haskell/Refact/Utils/Binds.hs b/src/Language/Haskell/Refact/Utils/Binds.hs --- a/src/Language/Haskell/Refact/Utils/Binds.hs +++ b/src/Language/Haskell/Refact/Utils/Binds.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId -------------------------------------------------------------------------------- -- Module : TypeUtils @@ -37,388 +40,386 @@ module Language.Haskell.Refact.Utils.Binds ( hsBinds - , replaceBinds , getValBindSigs - , emptyValBinds - -- , unionBinds , HsValBinds(..) ) where --- import Control.Monad.IO.Class () -import Language.Haskell.Refact.Utils.GhcVersionSpecific -import Language.Haskell.TokenUtils.Utils +import Language.Haskell.GHC.ExactPrint.Utils -- Modules from GHC import qualified Bag as GHC -import qualified BasicTypes as GHC import qualified GHC as GHC +import qualified Outputable as GHC -import qualified Data.Generics as SYB +import Data.Generics -- --------------------------------------------------------------------- -getValBindSigs :: GHC.HsValBinds GHC.Name -> [GHC.LSig GHC.Name] +bindsFromDecls :: [GHC.LHsDecl name] -> GHC.HsValBinds name +bindsFromDecls ds = GHC.ValBindsIn (GHC.listToBag binds) sigs + where + binds = concatMap goBind ds + goBind (GHC.L l (GHC.ValD d)) = [(GHC.L l d)] + goBind _ = [] + + sigs = concatMap goSig ds + goSig (GHC.L l (GHC.SigD d)) = [(GHC.L l d)] + goSig _ = [] + +-- --------------------------------------------------------------------- + +getValBindSigs :: GHC.HsValBinds GHC.RdrName -> [GHC.LSig GHC.RdrName] getValBindSigs binds = case binds of - GHC.ValBindsIn _ sigs -> sigs - GHC.ValBindsOut _ sigs -> sigs + GHC.ValBindsIn _ sigs -> sigs + GHC.ValBindsOut _ _sigs -> [] -emptyValBinds :: GHC.HsValBinds GHC.Name +emptyValBinds :: GHC.HsValBinds name emptyValBinds = GHC.ValBindsIn (GHC.listToBag []) [] -unionBinds :: [GHC.HsValBinds GHC.Name] -> GHC.HsValBinds GHC.Name +unionBinds :: [GHC.HsValBinds name] -> GHC.HsValBinds name unionBinds [] = emptyValBinds unionBinds [x] = x unionBinds (x1:x2:xs) = unionBinds ((mergeBinds x1 x2):xs) where - mergeBinds :: GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.Name + mergeBinds :: GHC.HsValBinds name -> GHC.HsValBinds name -> GHC.HsValBinds name mergeBinds (GHC.ValBindsIn b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsIn (GHC.unionBags b1 b2) (s1++s2)) mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsOut b2 s2) = (GHC.ValBindsOut (b1++b2) (s1++s2)) mergeBinds y1@(GHC.ValBindsIn _ _) y2@(GHC.ValBindsOut _ _) = mergeBinds y2 y1 - mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsOut (b1++[(GHC.NonRecursive,b2)]) (s1++s2)) + mergeBinds (GHC.ValBindsOut _ _) (GHC.ValBindsIn _ _) = error $ "unionBinds:cannot merge ValBindsOut and ValBindsIn" -- NOTE: ValBindsIn are found before the Renamer, ValBindsOut after -hsBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name] +hsBinds :: (HsValBinds t name) => t -> [GHC.LHsBind name] hsBinds t = case hsValBinds t of GHC.ValBindsIn binds _sigs -> GHC.bagToList binds GHC.ValBindsOut bs _sigs -> concatMap (\(_,b) -> GHC.bagToList b) bs -replaceBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name] -> t --- replaceBinds t bs = replaceValBinds t (GHC.ValBindsIn (GHC.listToBag bs) []) -replaceBinds t bs = replaceValBinds t (GHC.ValBindsIn (GHC.listToBag bs) sigs) - where - sigs = case hsValBinds t of - GHC.ValBindsIn _ s -> s - GHC.ValBindsOut _ s -> s - -- This class replaces the HsDecls one -class (SYB.Data t) => HsValBinds t where +class (Data t,Data name) => HsValBinds t name | t -> name where -- | Return the binds that are directly enclosed in the -- given syntax phrase. -- hsValBinds :: t -> [GHC.LHsBind GHC.Name] - hsValBinds :: t -> GHC.HsValBinds GHC.Name - - -- | Replace the directly enclosed bind list by the given - -- bind list. Note: This function does not modify the - -- token stream. - -- replaceBinds :: t -> [GHC.LHsBind GHC.Name] -> t - replaceValBinds :: t -> GHC.HsValBinds GHC.Name -> t - - -- | Return True if the specified identifier is declared in the - -- given syntax phrase. - -- isDeclaredIn :: GHC.Name -> t -> Bool + hsValBinds :: t -> GHC.HsValBinds name -- | Return the type class definitions that are directly enclosed -- in the given syntax phrase. Note: only makes sense for -- GHC.RenamedSource - hsTyDecls :: t -> [[GHC.LTyClDecl GHC.Name]] + hsTyDecls :: t -> [[GHC.LTyClDecl name]] -instance HsValBinds (GHC.RenamedSource) where - hsValBinds (grp,_,_,_) = (GHC.hs_valds grp) +instance HsValBinds GHC.ParsedSource GHC.RdrName where + hsValBinds (GHC.L _ (GHC.HsModule _ _ _ ds _ _)) = bindsFromDecls ds - replaceValBinds (grp,imps,exps,docs) binds = (grp',imps,exps,docs) - where - grp' = grp {GHC.hs_valds = binds} + -- hsTyDecls (grp,_,_,_) = map GHC.group_tyclds (GHC.hs_tyclds grp) + hsTyDecls (GHC.L _ (GHC.HsModule _ _ _ _ds _ _)) = [] - hsTyDecls (grp,_,_,_) = (GHC.hs_tyclds grp) +instance HsValBinds GHC.RenamedSource GHC.Name where + hsValBinds (grp,_,_,_) = (GHC.hs_valds grp) + hsTyDecls (grp,_,_,_) = map GHC.group_tyclds (GHC.hs_tyclds grp) -instance HsValBinds (GHC.HsValBinds GHC.Name) where +instance (GHC.DataId name,Data name) + => HsValBinds (GHC.HsValBinds name) name where hsValBinds vb = vb - replaceValBinds _old new = new hsTyDecls _ = [] -instance HsValBinds (GHC.HsGroup GHC.Name) where +instance (GHC.DataId name,Data name) + => HsValBinds (GHC.HsGroup name) name where hsValBinds grp = (GHC.hs_valds grp) - replaceValBinds (GHC.HsGroup b t i d f de fo w a r v doc) binds - = (GHC.HsGroup b' t i d f de fo w a r v doc) - where b' = replaceValBinds b binds - hsTyDecls _ = [] -instance HsValBinds (GHC.HsLocalBinds GHC.Name) where +instance (GHC.DataId name,Data name) + => HsValBinds (GHC.HsLocalBinds name) name where hsValBinds lb = case lb of GHC.HsValBinds b -> b GHC.HsIPBinds _ -> emptyValBinds GHC.EmptyLocalBinds -> emptyValBinds - replaceValBinds (GHC.HsValBinds _b) new = (GHC.HsValBinds new) - replaceValBinds (GHC.HsIPBinds _b) _new = error "undefined replaceValBinds HsIPBinds" - replaceValBinds (GHC.EmptyLocalBinds) new = (GHC.HsValBinds new) - hsTyDecls _ = [] -instance HsValBinds (GHC.GRHSs GHC.Name) where +instance (GHC.DataId name,Data name) + => HsValBinds (GHC.GRHSs name (GHC.LHsExpr name)) name where hsValBinds (GHC.GRHSs _ lb) = hsValBinds lb - replaceValBinds (GHC.GRHSs rhss b) new = (GHC.GRHSs rhss (replaceValBinds b new)) - hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.MatchGroup GHC.Name) where - hsValBinds (GHC.MatchGroup matches _) = hsValBinds matches - - replaceValBinds (GHC.MatchGroup matches a) newBinds - = (GHC.MatchGroup (replaceValBinds matches newBinds) a) +instance (GHC.DataId name,Data name) + => HsValBinds (GHC.MatchGroup name (GHC.LHsExpr name)) name where + hsValBinds (GHC.MG matches _ _ _) = hsValBinds matches hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds [GHC.LMatch GHC.Name] where +instance (GHC.DataId name,Data name) + => HsValBinds [GHC.LMatch name (GHC.LHsExpr name)] name where hsValBinds ms = unionBinds $ map (\m -> hsValBinds $ GHC.unLoc m) ms - replaceValBinds [] _ = error "empty match list in replaceValBinds [GHC.LMatch GHC.Name]" - replaceValBinds ms newBinds = (replaceValBinds (ghead "replaceValBinds" ms) newBinds):(tail ms) - hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.LMatch GHC.Name) where +instance (GHC.DataId name,Data name) + => HsValBinds (GHC.LMatch name (GHC.LHsExpr name)) name where hsValBinds m = hsValBinds $ GHC.unLoc m - replaceValBinds (GHC.L l m) newBinds = (GHC.L l (replaceValBinds m newBinds)) - hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.Match GHC.Name) where - hsValBinds (GHC.Match _ _ grhs) = hsValBinds grhs - - replaceValBinds (GHC.Match p t (GHC.GRHSs rhs _binds)) newBinds - = (GHC.Match p t (GHC.GRHSs rhs binds')) - where - binds' = (GHC.HsValBinds newBinds) +instance (GHC.DataId name,Data name) + => HsValBinds (GHC.Match name (GHC.LHsExpr name)) name where + hsValBinds (GHC.Match _ _ _ grhs) = hsValBinds grhs hsTyDecls _ = [] -instance HsValBinds (GHC.HsBind GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.HsBind name) name where hsValBinds (GHC.PatBind _p rhs _typ _fvs _) = hsValBinds rhs -- TODO: ++AZ++ added for compatibility with hsDecls. hsValBinds (GHC.FunBind _ _ matches _ _ _) = hsValBinds matches - hsValBinds other = error $ "hsValBinds (GHC.HsBind GHC.Name) undefined for:" ++ (showGhc other) - - replaceValBinds (GHC.PatBind p (GHC.GRHSs rhs _binds) typ fvs pt) newBinds - = (GHC.PatBind p (GHC.GRHSs rhs binds') typ fvs pt) - where - binds' = (GHC.HsValBinds newBinds) - replaceValBinds x _newBinds - = error $ "replaceValBinds (GHC.HsBind GHC.Name) undefined for:" ++ (showGhc x) + hsValBinds other = error $ "hsValBinds (GHC.HsBind name) undefined for:" ++ (showGhc other) hsTyDecls _ = [] -instance HsValBinds (GHC.HsExpr GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.HsExpr name) name where hsValBinds (GHC.HsLet ds _) = hsValBinds ds hsValBinds x = error $ "TypeUtils.hsValBinds undefined for:" ++ showGhc x - replaceValBinds (GHC.HsLet binds ex) new = (GHC.HsLet (replaceValBinds binds new) ex) - replaceValBinds old _new = error $ "undefined replaceValBinds (GHC.HsExpr GHC.Name) for:" ++ (showGhc old) - hsTyDecls _ = [] -instance HsValBinds (GHC.Stmt GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.Stmt name (GHC.LHsExpr name)) name where hsValBinds (GHC.LetStmt ds) = hsValBinds ds - hsValBinds other = error $ "hsValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc other) - replaceValBinds (GHC.LetStmt ds) new = (GHC.LetStmt (replaceValBinds ds new)) - replaceValBinds old _new = error $ "replaceValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc old) + hsValBinds other = error $ "hsValBinds (GHC.Stmt name) undefined for:" ++ (showGhc other) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.LHsBinds GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.LHsBinds name) name where hsValBinds binds = hsValBinds $ GHC.bagToList binds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsBinds GHC.Name) undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.LHsBind GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.LHsBind name) name where hsValBinds (GHC.L _ (GHC.FunBind _ _ matches _ _ _)) = hsValBinds matches hsValBinds (GHC.L _ (GHC.PatBind _ rhs _ _ _)) = hsValBinds rhs hsValBinds (GHC.L _ (GHC.VarBind _ rhs _)) = hsValBinds rhs hsValBinds (GHC.L _ (GHC.AbsBinds _ _ _ _ binds)) = hsValBinds binds - - - replaceValBinds (GHC.L l (GHC.FunBind a b matches c d e)) newBinds - = (GHC.L l (GHC.FunBind a b (replaceValBinds matches newBinds) c d e)) - replaceValBinds (GHC.L l (GHC.PatBind a rhs b c d)) newBinds - = (GHC.L l (GHC.PatBind a (replaceValBinds rhs newBinds) b c d)) - replaceValBinds (GHC.L l (GHC.VarBind a rhs b)) newBinds - = (GHC.L l (GHC.VarBind a (replaceValBinds rhs newBinds) b)) - replaceValBinds (GHC.L l (GHC.AbsBinds a b c d binds)) newBinds - = (GHC.L l (GHC.AbsBinds a b c d (replaceValBinds binds newBinds))) + hsValBinds (GHC.L _ (GHC.PatSynBind _)) = error "hsValBinds: PaySynBind to implement" hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds ([GHC.LHsBind GHC.Name]) where +instance (GHC.DataId name,Data name) + => HsValBinds ([GHC.LHsBind name]) name where -- hsValBinds xs = concatMap hsValBinds xs -- As in original hsValBinds xs = GHC.ValBindsIn (GHC.listToBag xs) [] - replaceValBinds _old (GHC.ValBindsIn b _sigs) = GHC.bagToList b - replaceValBinds _old (GHC.ValBindsOut rbinds _sigs) = GHC.bagToList $ GHC.unionManyBags $ map (\(_,b) -> b) rbinds - - -- replaceValBinds old new = error ("replaceValBinds (old,new)=" ++ (showGhc (old,new))) - hsTyDecls _ = [] -instance HsValBinds (GHC.LHsExpr GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.LHsExpr name) name where hsValBinds (GHC.L _ (GHC.HsLet binds _ex)) = hsValBinds binds hsValBinds _ = emptyValBinds - replaceValBinds (GHC.L l (GHC.HsLet binds ex)) newBinds - = (GHC.L l (GHC.HsLet (replaceValBinds binds newBinds) ex)) - replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsExpr GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds [GHC.LGRHS GHC.Name] where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [GHC.LGRHS name (GHC.LHsExpr name)] name where hsValBinds xs = unionBinds $ map hsValBinds xs - replaceValBinds _old _new = error $ "replaceValBinds [GHC.LGRHS GHC.Name] undefined for:" -- ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.LGRHS GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.LGRHS name (GHC.LHsExpr name)) name where hsValBinds (GHC.L _ (GHC.GRHS stmts _expr)) = hsValBinds stmts - replaceValBinds _old _new = error $ "replaceValBinds (GHC.LHGRHS GHC.Name) undefined for:" -- ++ (showGhc _old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds [GHC.LStmt GHC.Name] where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [GHC.LStmt name (GHC.LHsExpr name)] name where hsValBinds xs = unionBinds $ map hsValBinds xs - replaceValBinds old _new = error $ "replaceValBinds [GHC.LStmt GHC.Name] undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.LStmt GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.LStmt name (GHC.LHsExpr name)) name where hsValBinds (GHC.L _ (GHC.LetStmt binds)) = hsValBinds binds hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LStmt GHC.Name) undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds [GHC.LPat GHC.Name] where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [GHC.LPat name] name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.LPat GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.LPat name) name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.Name) where + +instance HsValBinds (GHC.Name) GHC.Name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.Name) undefined for:" ++ (showGhc old) hsTyDecls _ = [] + -- --------------------------------------------------------------------- -instance HsValBinds [GHC.SyntaxExpr GHC.Name] where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [GHC.SyntaxExpr name] name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.SyntaxExpr GHC.Name) undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds [[GHC.LTyClDecl GHC.Name]] where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.TyClGroup name) name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds [[GHC.LTyClDecl GHC.Name]] undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds [GHC.LTyClDecl GHC.Name] where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [GHC.TyClGroup name] name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds [GHC.LTyClDecl GHC.Name] undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.LTyClDecl GHC.Name) where - hsValBinds _ = error $ "hsValBinds (GHC.LTyClDecl GHC.Name) must pull out tcdMeths" - replaceValBinds old _new = error $ "replaceValBinds (GHC.LTyClDecl GHC.Name) undefined for:" ++ (showGhc old) +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [[GHC.LTyClDecl name]] name where + hsValBinds _ = emptyValBinds hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds [GHC.LInstDecl GHC.Name] where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [GHC.LTyClDecl name] name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds [GHC.LInstDecl GHC.Name] undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.LInstDecl GHC.Name) where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LInstDecl GHC.Name) undefined for:" ++ (showGhc old) +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.LTyClDecl name) name where + hsValBinds _ = error $ "hsValBinds (GHC.LTyClDecl name) must pull out tcdMeths" hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.LHsType GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [GHC.LTyFamInstDecl name] name where + hsValBinds _ = error $ "hsValBinds [GHC.LTyFamInstDecl name] must pull out tcdMeths" + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [GHC.LDataFamInstDecl name] name where + hsValBinds _ = error $ "hsValBinds [GHC.LDataFamInstDecl name] must pull out tcdMeths" + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Data name) + => HsValBinds [GHC.LTyFamInstEqn name] name where + hsValBinds _ = error $ "hsValBinds [GHC.LTyFamInstEqn name] must pull out tcdMeths" + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Data name) + => HsValBinds (GHC.LTyFamInstEqn name) name where + hsValBinds _ = error $ "hsValBinds (GHC.LTyFamInstEqn name) must pull out tcdMeths" + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.HsDataDefn name) name where + hsValBinds _ = error $ "hsValBinds (GHC.HsDataDefn name) must pull out tcdMeths" + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.HsTyPats name) name where + hsValBinds _ = error $ "hsValBinds (GHC.HsTyPats name) must pull out tcdMeths" + hsTyDecls _ = [] + +-- --------------------------------------------------------------------- + +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [GHC.LInstDecl name] name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsType GHC.Name) undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds [GHC.LSig GHC.Name] where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.LInstDecl name) name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds [GHC.LSig GHC.Name] undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -instance HsValBinds (GHC.LSig GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [GHC.LHsType name] name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LSig GHC.Name) undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 704 -instance HsValBinds [GHC.LFamInstDecl GHC.Name] where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.LHsType name) name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds [GHC.LFamInstDecl GHC.Name] undefined for:" ++ (showGhc old) hsTyDecls _ = [] -#endif -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 704 -instance HsValBinds (GHC.LFamInstDecl GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds [GHC.LSig name] name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LFamInstDecl GHC.Name) undefined for:" ++ (showGhc old) hsTyDecls _ = [] -#endif -- --------------------------------------------------------------------- -instance HsValBinds (GHC.HsIPBinds GHC.Name) where +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.LSig name) name where hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.HsIPBinds GHC.Name) undefined for:" ++ (showGhc old) hsTyDecls _ = [] -- --------------------------------------------------------------------- + +instance (GHC.OutputableBndr name,GHC.DataId name,Data name) + => HsValBinds (GHC.HsIPBinds name) name where + hsValBinds _ = emptyValBinds + hsTyDecls _ = [] + +-- EOF + diff --git a/src/Language/Haskell/Refact/Utils/ExactPrint.hs b/src/Language/Haskell/Refact/Utils/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/ExactPrint.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +module Language.Haskell.Refact.Utils.ExactPrint + ( + replace + , replaceAnnKey + , copyAnn + ) where + +import qualified GHC as GHC + +import qualified Data.Generics as SYB + +import Language.Haskell.GHC.ExactPrint.Types + +import qualified Data.Map as Map + +-- --------------------------------------------------------------------- + +replaceAnnKey :: (SYB.Data old,SYB.Data new) + => GHC.Located old -> GHC.Located new -> Anns -> Anns +replaceAnnKey old new ans = + case Map.lookup (mkAnnKey old) ans of + Nothing -> ans + Just v -> anns' + where + anns1 = Map.delete (mkAnnKey old) ans + anns' = Map.insert (mkAnnKey new) v anns1 + + +-- --------------------------------------------------------------------- + +copyAnn :: (SYB.Data old,SYB.Data new) + => GHC.Located old -> GHC.Located new -> Anns -> Anns +copyAnn old new ans = + case Map.lookup (mkAnnKey old) ans of + Nothing -> ans + Just v -> anns' + where + anns' = Map.insert (mkAnnKey new) v ans + +-- --------------------------------------------------------------------- + +-- | Replaces an old expression with a new expression +replace :: AnnKey -> AnnKey -> Anns -> Maybe Anns +replace old new ans = do + let as = ans + oldan <- Map.lookup old as + newan <- Map.lookup new as + let newan' = Ann + { annEntryDelta = annEntryDelta oldan + -- , annDelta = annDelta oldan + -- , annTrueEntryDelta = annTrueEntryDelta oldan + , annPriorComments = annPriorComments oldan + , annFollowingComments = annFollowingComments oldan + , annsDP = moveAnns (annsDP oldan) (annsDP newan) + , annSortKey = annSortKey oldan + , annCapturedSpan = annCapturedSpan oldan + } + return ((\anns -> Map.delete old . Map.insert new newan' $ anns) ans) + +-- --------------------------------------------------------------------- + +-- | Shift the first output annotation into the correct place +moveAnns :: [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)] +moveAnns [] xs = xs +moveAnns ((_, dp): _) ((kw, _):xs) = (kw,dp) : xs +moveAnns _ [] = [] + +-- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs b/src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs --- a/src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs +++ b/src/Language/Haskell/Refact/Utils/GhcBugWorkArounds.hs @@ -4,8 +4,8 @@ module Language.Haskell.Refact.Utils.GhcBugWorkArounds ( - bypassGHCBug7351 - , getRichTokenStreamWA + -- bypassGHCBug7351 + getRichTokenStreamWA ) where import qualified Bag as GHC @@ -28,23 +28,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Language.Haskell.Refact.Utils.TypeSyn --- --------------------------------------------------------------------- - --- http://hackage.haskell.org/trac/ghc/ticket/7351 -bypassGHCBug7351 :: [PosToken] -> [PosToken] -bypassGHCBug7351 ts = map go ts - where - go :: (GHC.Located GHC.Token, String) -> (GHC.Located GHC.Token, String) - go rt@(GHC.L (GHC.UnhelpfulSpan _) _t,_s) = rt - go (GHC.L (GHC.RealSrcSpan l) t,s) = (GHC.L (fixCol l) t,s) - - fixCol l = GHC.mkSrcSpan (GHC.mkSrcLoc (GHC.srcSpanFile l) (GHC.srcSpanStartLine l) ((GHC.srcSpanStartCol l) - 1)) - (GHC.mkSrcLoc (GHC.srcSpanFile l) (GHC.srcSpanEndLine l) ((GHC.srcSpanEndCol l) - 1)) - --- --------------------------------------------------------------------- - -- | Replacement for original 'getRichTokenStream' which will return -- the tokens for a file processed by CPP. -- See bug @@ -199,7 +183,7 @@ -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ > 704 -parseError :: GHC.GhcMonad m => GHC.DynFlags -> GHC.SrcSpan -> GHC.MsgDoc -> m b +parseError :: GHC.DynFlags -> GHC.SrcSpan -> GHC.MsgDoc -> m b parseError dflags sspan err = do throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err) #else diff --git a/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs b/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs --- a/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs +++ b/src/Language/Haskell/Refact/Utils/GhcModuleGraph.hs @@ -11,7 +11,6 @@ import FastString import GHC import HscTypes -import Maybes import Panic -- Other imports @@ -66,7 +65,7 @@ -- the full set of nodes, and determining the reachable set from -- the specified node. let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node - | otherwise = ghcError (ProgramError "module does not exist") + | otherwise = panic "module does not exist" in graphFromEdgedVertices (seq root (reachableG graph root)) @@ -127,7 +126,7 @@ , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ (-- see [boot-edges] below - if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile then [] else case lookup_key HsBootFile (ms_mod_name s) of Nothing -> [] @@ -150,8 +149,15 @@ -- If we want keep_hi_boot_nodes, then we do lookup_key with -- the IsBootInterface parameter True; else False +mapCatMaybes :: (a -> Maybe b) -> [a] -> [b] +mapCatMaybes _ [] = [] +mapCatMaybes f (x:xs) = case f x of + Just y -> y : mapCatMaybes f xs + Nothing -> mapCatMaybes f xs + + type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs +type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs {- msKey :: ModSummary -> NodeKey diff --git a/src/Language/Haskell/Refact/Utils/GhcUtils.hs b/src/Language/Haskell/Refact/Utils/GhcUtils.hs --- a/src/Language/Haskell/Refact/Utils/GhcUtils.hs +++ b/src/Language/Haskell/Refact/Utils/GhcUtils.hs @@ -15,12 +15,7 @@ module Language.Haskell.Refact.Utils.GhcUtils ( -- * SYB versions - everythingButStaged - , somethingStaged - , everythingStaged - , somewhereMStaged - , somewhereMStagedBu - , everywhereMStaged + everywhereM' , everywhereMStaged' , everywhereStaged , everywhereStaged' @@ -28,21 +23,7 @@ , listifyStaged -- ** SYB Utility - , checkItemRenamer - - -- * Strafunski StrategyLib versions - , full_tdTUGhc - , stop_tdTUGhc - , stop_tdTPGhc - , allTUGhc' - , once_tdTPGhc - , once_buTPGhc - , oneTPGhc - , allTUGhc - - -- ** Strafunski utility - , checkItemStage' - , checkItemRenamer' + -- , checkItemRenamer -- * Scrap Your Zipper versions , zeverywhereStaged @@ -53,7 +34,6 @@ , zopenStaged' , ztransformStagedM -- ** SYZ utilities - , checkZipperStaged , upUntil , findAbove ) where @@ -65,77 +45,12 @@ import Data.Data import Data.Maybe -import qualified GHC as GHC -import qualified NameSet as GHC -import Data.Generics.Strafunski.StrategyLib.StrategyLib - import qualified Data.Generics.Zipper as Z --- TODO: pass this routine back to syb-utils (when it works properly) --- Question: how to handle partial results in the otherwise step? -everythingButStaged :: SYB.Stage -> (r -> r -> r) -> r -> SYB.GenericQ (r,Bool) -> SYB.GenericQ r -everythingButStaged stage k z f x - | checkItemStage stage x = z - | stop == True = v - | otherwise = foldl k v (gmapQ (everythingButStaged stage k z f) x) - where (v, stop) = f x - - -{- --- | Look up a subterm by means of a maybe-typed filter -something :: GenericQ (Maybe u) -> GenericQ (Maybe u) - --- "something" can be defined in terms of "everything" --- when a suitable "choice" operator is used for reduction --- -something = everything orElse --} - --- | Look up a subterm by means of a maybe-typed filter -somethingStaged :: SYB.Stage -> (Maybe u) -> SYB.GenericQ (Maybe u) -> SYB.GenericQ (Maybe u) - --- "something" can be defined in terms of "everything" --- when a suitable "choice" operator is used for reduction --- -somethingStaged stage z = everythingStaged stage SYB.orElse z - -- --------------------------------------------------------------------- -{- --- | Apply a monadic transformation at least somewhere -somewhere :: MonadPlus m => GenericM m -> GenericM m - --- We try "f" in top-down manner, but descent into "x" when we fail --- at the root of the term. The transformation fails if "f" fails --- everywhere, say succeeds nowhere. --- -somewhere f x = f x `mplus` gmapMp (somewhere f) x --} - --- | Apply a monadic transformation at least somewhere -somewhereMStaged :: MonadPlus m => SYB.Stage -> SYB.GenericM m -> SYB.GenericM m - --- We try "f" in top-down manner, but descent into "x" when we fail --- at the root of the term. The transformation fails if "f" fails --- everywhere, say succeeds nowhere. --- -somewhereMStaged stage f x - | checkItemStage stage x = mzero - | otherwise = f x `mplus` gmapMp (somewhereMStaged stage f) x - --- --------------------------------------------------------------------- - --- | Apply a monadic transformation at least somewhere, in bottom up order -somewhereMStagedBu :: MonadPlus m => SYB.Stage -> SYB.GenericM m -> SYB.GenericM m -somewhereMStagedBu stage f x - | checkItemStage stage x = mzero - -- was | otherwise = f x `mplus` gmapMp (somewhereMStaged stage f) x - | otherwise = gmapMp (somewhereMStagedBu stage f) x `mplus` f x - - --- --------------------------------------------------------------------- - +{- now in ghc-syb -- | Monadic variation on everywhere everywhereMStaged :: Monad m => SYB.Stage -> SYB.GenericM m -> SYB.GenericM m @@ -144,36 +59,50 @@ | checkItemStage stage x = return x | otherwise = do x' <- gmapM (everywhereMStaged stage f) x f x' - +-} -- | Monadic variation on everywhere' everywhereMStaged' :: Monad m => SYB.Stage -> SYB.GenericM m -> SYB.GenericM m -- Top-down order is also reflected in order of do-actions everywhereMStaged' stage f x +#if __GLASGOW_HASKELL__ <= 708 | checkItemStage stage x = return x +#endif | otherwise = do x' <- f x gmapM (everywhereMStaged' stage f) x' +-- | Monadic variation on everywhere' +everywhereM' :: Monad m => SYB.GenericM m -> SYB.GenericM m +-- Top-down order is also reflected in order of do-actions +everywhereM' f x + = do x' <- f x + gmapM (everywhereM' f) x' + -- --------------------------------------------------------------------- -- | Bottom-up transformation everywhereStaged :: SYB.Stage -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a everywhereStaged stage f x +#if __GLASGOW_HASKELL__ <= 708 | checkItemStage stage x = x +#endif | otherwise = (f . gmapT (everywhereStaged stage f)) x -- | Top-down version of everywhereStaged everywhereStaged' :: SYB.Stage -> (forall a. Data a => a -> a) -> forall a. Data a => a -> a everywhereStaged' stage f x +#if __GLASGOW_HASKELL__ <= 708 | checkItemStage stage x = x +#endif | otherwise = (gmapT (everywhereStaged stage f) . f) x -- --------------------------------------------------------------------- -- From @frsoares +#if __GLASGOW_HASKELL__ <= 708 -- | Checks whether the current item is undesirable for analysis in the current -- AST Stage. checkItemStage :: (Typeable a, Data a) => SYB.Stage -> a -> Bool @@ -199,9 +128,10 @@ checkItemRenamer :: (Data a, Typeable a) => a -> Bool checkItemRenamer x = checkItemStage SYB.Renamer x - +#endif +{- now in ghc-syb -- | Staged variation of SYB.everything -- The stage must be provided to avoid trying to modify elements which -- may not be present at all stages of AST processing. @@ -210,17 +140,19 @@ everythingStaged stage k z f x | checkItemStage stage x = z | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) - +-} -- --------------------------------------------------------------------- -- |Perform a query on the immediate subterms only, avoiding holes onelayerStaged :: SYB.Stage -> r -> SYB.GenericQ r -> SYB.GenericQ [r] -onelayerStaged stage z f t = gmapQ stagedF t +onelayerStaged _stage _z f t = gmapQ stagedF t -- onelayerStaged stage z f t = (stagedF t) : gmapQ stagedF t where stagedF x +#if __GLASGOW_HASKELL__ <= 708 | checkItemStage stage x = z +#endif | otherwise = f x -- --------------------------------------------------------------------- @@ -230,7 +162,7 @@ -- may not be present at all stages of AST processing. listifyStaged :: (Data a, Typeable a1) => SYB.Stage -> (a1 -> Bool) -> a -> [a1] -listifyStaged stage p = everythingStaged stage (++) [] ([] `SYB.mkQ` (\x -> [ x | p x ])) +listifyStaged stage p = SYB.everythingStaged stage (++) [] ([] `SYB.mkQ` (\x -> [ x | p x ])) @@ -239,6 +171,7 @@ -- Strafunski StrategyLib adaptations -- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ <= 708 -- | Full type-unifying traversal in top-down order. full_tdTUGhc :: (MonadPlus m, Monoid a) => TU a m -> TU a m @@ -276,14 +209,16 @@ -- Succeed for all children allTPGhc :: MonadPlus m => TP m -> TP m allTPGhc s = ifTP checkItemRenamer' (const failTP) (oneTP s) - +#endif ------------------------------------------ +#if __GLASGOW_HASKELL__ <= 708 -- This section courtesy of @jkoppel (James Koppel) allTUGhc :: (MonadPlus m) => (a -> a -> a) -> a -> TU a m -> TU a m allTUGhc op2 u s = ifTU checkItemRenamer' (const $ constTU u) (allTU op2 u s) - +#endif +#if __GLASGOW_HASKELL__ <= 708 checkItemStage' :: forall m. (MonadPlus m) => SYB.Stage -> TU () m checkItemStage' stage = failTU `adhocTU` postTcType `adhocTU` fixity `adhocTU` nameSet where nameSet = const (guard $ stage `elem` [SYB.Parser,SYB.TypeChecker]) :: GHC.NameSet -> m () @@ -292,6 +227,7 @@ checkItemRenamer' :: (MonadPlus m) => TU () m checkItemRenamer' = checkItemStage' SYB.Renamer +#endif -- --------------------------------------------------------------------- @@ -300,7 +236,9 @@ -- | Apply a generic transformation everywhere in a bottom-up manner. zeverywhereStaged :: (Typeable a) => SYB.Stage -> SYB.GenericT -> Z.Zipper a -> Z.Zipper a zeverywhereStaged stage f z +#if __GLASGOW_HASKELL__ <= 708 | checkZipperStaged stage z = z +#endif | otherwise = Z.trans f (Z.downT g z) where g z' = Z.leftT g (zeverywhereStaged stage f z') @@ -310,7 +248,9 @@ -- returns the original zipper if the query does not pass (check this) zopenStaged :: (Typeable a) => SYB.Stage -> SYB.GenericQ Bool -> Z.Zipper a -> [Z.Zipper a] zopenStaged stage q z +#if __GLASGOW_HASKELL__ <= 708 | checkZipperStaged stage z = [] +#endif | Z.query q z = [z] | otherwise = reverse $ Z.downQ [] g z where @@ -320,7 +260,9 @@ -- leftmost successful location, avoiding holes in the GHC structures zsomewhereStaged :: (MonadPlus m) => SYB.Stage -> SYB.GenericM m -> Z.Zipper a -> m (Z.Zipper a) zsomewhereStaged stage f z +#if __GLASGOW_HASKELL__ <= 708 | checkZipperStaged stage z = return z +#endif | otherwise = Z.transM f z `mplus` Z.downM mzero (g . Z.leftmost) z where g z' = Z.transM f z `mplus` Z.rightM mzero (zsomewhereStaged stage f) z' @@ -343,27 +285,6 @@ | Z.query q z = t stage z | otherwise = return z - -checkZipperStaged :: SYB.Stage -> Z.Zipper a -> Bool -checkZipperStaged stage z - | isJust maybeNameSet = checkItemStage stage (fromJust maybeNameSet) - | isJust maybePostTcType = checkItemStage stage (fromJust maybePostTcType) - | isJust maybeFixity = checkItemStage stage (fromJust maybeFixity) - -- was | isJust maybeHsWithBndrs = checkItemStage stage (fromJust maybeHsWithBndrs) - | otherwise = False - where - maybeNameSet :: Maybe GHC.NameSet - maybeNameSet = Z.getHole z - - maybePostTcType :: Maybe GHC.PostTcType - maybePostTcType = Z.getHole z - - maybeFixity :: Maybe GHC.Fixity - maybeFixity = Z.getHole z - - -- maybeHsWithBndrs :: (Data b) => Maybe (GHC.HsWithBndrs b) - -- maybeHsWithBndrs = Z.getHole z - -- --------------------------------------------------------------------- -- | Climb the tree until a predicate holds @@ -394,7 +315,6 @@ -> Z.Zipper a -> [(Z.Zipper a,b)] zopenStaged' stage q z - | checkZipperStaged stage z = [] | isJust zq = [(z,fromJust zq)] | otherwise = reverse $ Z.downQ [] g z where diff --git a/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs b/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs --- a/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs +++ b/src/Language/Haskell/Refact/Utils/GhcVersionSpecific.hs @@ -4,41 +4,27 @@ -- version of GHC, and should be the only one requiring CPP module Language.Haskell.Refact.Utils.GhcVersionSpecific ( - showGhc - , prettyprint + prettyprint , prettyprint2 , ppType - -- , lexStringToRichTokens - , getDataConstructors , setGhcContext + , showGhcQual ) where import qualified DynFlags as GHC import qualified GHC as GHC -import qualified GHC.Paths as GHC -import qualified Lexer as GHC import qualified Outputable as GHC -import qualified StringBuffer as GHC -import Language.Haskell.Refact.Utils.TypeSyn -- --------------------------------------------------------------------- --- |Show a GHC API structure -showGhc :: (GHC.Outputable a) => a -> String -#if __GLASGOW_HASKELL__ > 704 -showGhc x = GHC.showSDoc GHC.tracingDynFlags $ GHC.ppr x -#else -showGhc x = GHC.showSDoc $ GHC.ppr x -#endif --- --------------------------------------------------------------------- - - prettyprint :: (GHC.Outputable a) => a -> String -#if __GLASGOW_HASKELL__ > 704 +#if __GLASGOW_HASKELL__ > 706 +prettyprint x = GHC.renderWithStyle GHC.unsafeGlobalDynFlags (GHC.ppr x) (GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay) +#elif __GLASGOW_HASKELL__ > 704 prettyprint x = GHC.renderWithStyle GHC.tracingDynFlags (GHC.ppr x) (GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay) #else prettyprint x = GHC.renderWithStyle (GHC.ppr x) (GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay) @@ -47,7 +33,9 @@ -- --------------------------------------------------------------------- prettyprint2 :: (GHC.Outputable a) => a -> String -#if __GLASGOW_HASKELL__ > 704 +#if __GLASGOW_HASKELL__ > 706 +prettyprint2 x = GHC.renderWithStyle GHC.unsafeGlobalDynFlags (GHC.ppr x) (GHC.cmdlineParserStyle) +#elif __GLASGOW_HASKELL__ > 704 prettyprint2 x = GHC.renderWithStyle GHC.tracingDynFlags (GHC.ppr x) (GHC.cmdlineParserStyle) #else prettyprint2 x = GHC.renderWithStyle (GHC.ppr x) (GHC.cmdlineParserStyle) @@ -56,57 +44,25 @@ -- --------------------------------------------------------------------- ppType :: GHC.Type -> String -#if __GLASGOW_HASKELL__ > 704 +#if __GLASGOW_HASKELL__ > 706 +ppType x = GHC.renderWithStyle GHC.unsafeGlobalDynFlags (GHC.pprParendType x) (GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay) +#elif __GLASGOW_HASKELL__ > 704 ppType x = GHC.renderWithStyle GHC.tracingDynFlags (GHC.pprParendType x) (GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay) #else ppType x = GHC.renderWithStyle (GHC.pprParendType x) (GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay) #endif - -- --------------------------------------------------------------------- -{- moved to haskell-token-utils -lexStringToRichTokens :: GHC.RealSrcLoc -> String -> IO [PosToken] -lexStringToRichTokens startLoc str = do - -- error $ "lexStringToRichTokens: (startLoc,str)=" ++ (showGhc (startLoc,str)) -- ++AZ +setGhcContext :: GHC.GhcMonad m => GHC.ModSummary -> m () #if __GLASGOW_HASKELL__ > 704 - GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ do +setGhcContext modSum = GHC.setContext [GHC.IIModule (GHC.moduleName $ GHC.ms_mod modSum)] #else - GHC.defaultErrorHandler GHC.defaultLogAction $ do +setGhcContext modSum = GHC.setContext [GHC.IIModule ( GHC.ms_mod modSum)] #endif - GHC.runGhc (Just GHC.libdir) $ do - dflags <- GHC.getSessionDynFlags - let dflags' = foldl GHC.xopt_set dflags - [GHC.Opt_Cpp, GHC.Opt_ImplicitPrelude, GHC.Opt_MagicHash] - _ <- GHC.setSessionDynFlags dflags' - -- lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] - let res = GHC.lexTokenStream (GHC.stringToStringBuffer str) startLoc dflags' - case res of - GHC.POk _ toks -> return $ GHC.addSourceToTokens startLoc (GHC.stringToStringBuffer str) toks - GHC.PFailed _srcSpan _msg -> error $ "lexStringToRichTokens:" -- ++ (show $ GHC.ppr msg) - - -- addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] -> [(Located Token, String)] --} - -- --------------------------------------------------------------------- -getDataConstructors :: GHC.LHsDecl n -> [GHC.LConDecl n] -#if __GLASGOW_HASKELL__ > 704 -getDataConstructors (GHC.L _ (GHC.TyClD (GHC.TyDecl _ _ (GHC.TyData _ _ _ _ cons _) _))) = cons -#else -getDataConstructors (GHC.L _ (GHC.TyClD (GHC.TyData _ _ _ _ _ _ cons _))) = cons - -- TyClD - Type definitions - -- GHC7.4.2: defines' decl@(GHC.L l (GHC.TyClD (GHC.TyData _ _ name _ _ _ cons _))) - -- GHC7.6.3: defines' decl@(GHC.L l (GHC.TyClD (GHC.TyDecl _name _vars (GHC.TyData _ _ _ _ cons _) _fvs))) -#endif -getDataConstructors _ = [] - --- --------------------------------------------------------------------- +showGhcQual :: (GHC.Outputable a) => a -> String +showGhcQual x = GHC.showSDocForUser GHC.unsafeGlobalDynFlags GHC.alwaysQualify $ GHC.ppr x -setGhcContext :: GHC.GhcMonad m => GHC.ModSummary -> m () -#if __GLASGOW_HASKELL__ > 704 -setGhcContext modSum = GHC.setContext [GHC.IIModule (GHC.moduleName $ GHC.ms_mod modSum)] -#else -setGhcContext modSum = GHC.setContext [GHC.IIModule ( GHC.ms_mod modSum)] -#endif diff --git a/src/Language/Haskell/Refact/Utils/LocUtils.hs b/src/Language/Haskell/Refact/Utils/LocUtils.hs --- a/src/Language/Haskell/Refact/Utils/LocUtils.hs +++ b/src/Language/Haskell/Refact/Utils/LocUtils.hs @@ -2,290 +2,38 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.Refact.Utils.LocUtils( - {- - module HsTokens, - PosToken,simpPos, - -} - unmodified,modified - , simpPos0 - , nullSrcSpan - -- , emptyList, nonEmptyList - -- , showToks - -- , tokenLen - -- ,lengthOfToks - -- , mkToken, mkZeroToken {-,defaultToken, -} - {-whiteSpacesToken -} - , whiteSpaceTokens - , realSrcLocFromTok - , isWhite - , notWhite - , isWhiteSpace - , isWhiteSpaceOrIgnored - , isIgnored - {- - isNestedComment-},isMultiLineComment {-,isOpenBracket,isCloseBracket, -} - ,isOpenSquareBracket,isCloseSquareBracket {- ,isOpenBrace,isConid, - isLit,isWhereOrLet,isWhere,isLet-},isIn {- ,isCase,isDo,isIf,isForall, - isHiding,isModule-} ,isComma, isOpenParen {-,isEqual,isLambda,isIrrefute -},isBar --,isMinus, - ,endsWithNewLn,startsWithNewLn,hasNewLn {- ,startsWithEmptyLn, - lastNonSpaceToken,firstNonSpaceToken -} ,compressPreNewLns,compressEndNewLns - - , lengthOfLastLine - , getToks - -- , replaceToks,replaceTok - -- ,replaceTokNoReAlign - ,deleteToks,doRmWhites -- ,doAddWhites - , srcLocs - , getSrcSpan, getAllSrcLocs - -- , ghcSrcLocs -- Test version - -- , getLocatedStart - -- , getLocatedEnd - , getBiggestStartEndLoc - {- - , getStartEndLoc2, - startEndLoc,extendBothSides -},extendForwards,extendBackwards - , startEndLocIncFowComment{- ,startEndLocIncFowNewLn -} - , startEndLocIncComments, startEndLocIncComments' - {-, - prettyprint ,deleteFromToks, prettyprintGuardsAlt, - -} - -- , tokenise - -- , basicTokenise - -- , prettyprint -- , prettyprintGhc - , prettyprintPatList - , groupTokensByLine - , toksOnSameLine - , addLocInfo - -- , getIndentOffset - , getLineOffset - -- , splitToks - -- , splitOnNewLn - {- - , insertComments, - extractComments, insertTerms - -} - , tokenSrcSpan - , tokenCon - , increaseSrcSpan - , getGhcLoc - , getGhcLocEnd - , getLocatedStart - , getLocatedEnd - , getStartEndLoc - , startEndLocGhc - , realSrcLocEndTok - , fileNameFromTok - , splitToks - , emptyList, nonEmptyList - -- , divideComments - , notWhiteSpace - , isDoubleColon - , isEmpty - , isWhereOrLet - , isWhere - , isLet - , isElse - , isThen - , isOf - , isDo - , getIndentOffset - , splitOnNewLn - , tokenLen - , newLnToken - -- , newLinesToken - -- , monotonicLineToks - , reSequenceToks - , mkToken - , mkZeroToken - , markToken - , isMarked - -- , matchTokenPos - , rmOffsetFromToks + unmodified,modified + , nullSrcSpan + , getSrcSpan + , prettyprintPatList + , getGhcLoc + , getGhcLocEnd + , getLocatedStart + , getLocatedEnd + , ghcSpanStartEnd + , getStartEndLoc + , startEndLocGhc + , emptyList, nonEmptyList ) where import qualified FastString as GHC import qualified GHC as GHC -import qualified Lexer as GHC -import qualified SrcLoc as GHC import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB -import Language.Haskell.Refact.Utils.GhcUtils -import Language.Haskell.Refact.Utils.GhcVersionSpecific -import Language.Haskell.Refact.Utils.Monad -import Language.Haskell.Refact.Utils.TypeSyn - -import Language.Haskell.TokenUtils.GHC.Layout -import Language.Haskell.TokenUtils.TokenUtils -import Language.Haskell.TokenUtils.Types -import Language.Haskell.TokenUtils.Utils - -import Data.Maybe -import Data.List +import Language.Haskell.Refact.Utils.Types -- --------------------------------------------------------------------- -{- -showToks :: [PosToken] -> String -showToks toks = show $ map (\(t@(GHC.L _ tok),s) -> - ((getLocatedStart t, getLocatedEnd t),tok,s)) toks --} -{- moved to haskell-token-utils -instance Show (GHC.GenLocated GHC.SrcSpan GHC.Token) where - show t@(GHC.L _l tok) = show ((getLocatedStart t, getLocatedEnd t),tok) --} - --A flag used to indicate whether the token stream has been modified or not. unmodified, modified :: Bool unmodified = False modified = True ---- some default values---- -simpPos0 :: (Int,Int) -simpPos0 = (0,0) - --- nullSrcSpan :: GHC.SrcSpan --- nullSrcSpan = GHC.UnhelpfulSpan $ GHC.mkFastString "HaRe nullSrcSpan" - ------------------------------------------------- - ---Some functions for checking whether a token is of a specific type of token. - - -isWhite :: PosToken -> Bool -isWhite (GHC.L _ (GHC.ITeof),_) = True -isWhite (GHC.L _ (GHC.ITdocCommentNext _) ,_) = True -isWhite (GHC.L _ (GHC.ITdocCommentPrev _) ,_) = True -isWhite (GHC.L _ (GHC.ITdocCommentNamed _),_) = True -isWhite (GHC.L _ (GHC.ITdocSection _ _) ,_) = True -isWhite (GHC.L _ (GHC.ITdocOptions _) ,_) = True -isWhite (GHC.L _ (GHC.ITdocOptionsOld _) ,_) = True -isWhite (GHC.L _ (GHC.ITlineComment _) ,_) = True -isWhite (GHC.L _ (GHC.ITblockComment _) ,_) = True -isWhite (GHC.L _ _ ,_) = False - -notWhite :: PosToken -> Bool -notWhite = not.isWhite - - -isMultiLineComment :: PosToken -> Bool -isMultiLineComment ((GHC.L _ t),s) = case t of -- ==NestedComment && (isJust (find (=='\n') s)) - GHC.ITblockComment _ -> (isJust (find (=='\n') s)) - _ -> False -{- -isOpenBracket (t,(_,s)) = t==Special && s=="(" -isCloseBracket (t,(_,s)) = t==Special && s==")" --} -isOpenSquareBracket :: PosToken -> Bool -isOpenSquareBracket ((GHC.L _ t),_s) = case t of - GHC.ITobrack -> True - _ -> False -isCloseSquareBracket :: PosToken -> Bool -isCloseSquareBracket ((GHC.L _ t),_s) = case t of - GHC.ITcbrack -> True - _ -> False -{- -isOpenBrace (t,(_,s)) = t==Special && s=="{" -isCloseBrace (t,(_,s)) = t==Special && s=="}" - -isConid (t,(_,_)) = t==Conid -isLit (t,(_,s)) = t==IntLit || t==FloatLit || t==CharLit || t==StringLit --} --- isWhereOrLet t = isWhere t || isLet t -{- -isImport (t, (_,s))= t == Reservedid && s=="import" -isType (t, (_,s))= t == Reservedid && s=="type" -isData (t, (_,s))= t == Reservedid && s=="data" -isFixty (t, (_,s)) = t==Reservedid && (s=="infix" || s=="infixl" || s=="infixr") -isDefault (t, (_,s)) = t == Reservedid && s=="default" -isClass (t, (_,s)) = t == Reservedid && s=="class" -isInstance (t, (_,s)) = t == Reservedid && s=="instance" -isNewtype (t, (_,s)) = t == Reservedid && s=="newtype" - -isIn :: PosToken -> Bool -isIn ((GHC.L _ t),_s) = case t of - GHC.ITin -> True - _ -> False - -isCase (t,(_,s)) = t==Reservedid && s=="case" -isDo (t,(_,s)) = t==Reservedid && s=="do" -isIf (t,(_,s)) = t==Reservedid && s=="if" -isForall (t,(_,s)) = t==Reservedid && s=="forall" -isHiding (t,(_,s)) = s=="hiding" -isModule (t,(_,s)) = t==Reservedid && s=="module" --} -isComma :: PosToken -> Bool -isComma ((GHC.L _ t),_s) = case t of - GHC.ITcomma -> True - _ -> False - -isOpenParen :: PosToken -> Bool -isOpenParen ((GHC.L _ t),_s) = case t of - GHC.IToparen -> True - _ -> False - -{- -isEqual (t,(_,s)) = t==Reservedop && s=="=" -isLambda (t,(_,s)) = t==Reservedop && s=="\\" -isIrrefute (t,(_,s)) = t==Reservedop && s=="~" --} -isBar :: PosToken -> Bool -isBar ((GHC.L _ t),_s) = case t of -- "|" - GHC.ITvbar -> True - _ -> False -{- -isArrow (t,(_,s)) = t==Reservedop && s=="->" -isMinus (t,(_,s)) = t==Varsym && s=="-" --} - ------------------------------------------------------------------ - --- |Returns True if the token ends with '\n' --- ++AZ++: is this meaningful? -endsWithNewLn::PosToken->Bool -endsWithNewLn (_,s) =if s==[] then False - else (glast "endsWithNewLn" s=='\n') - --- |Returns True if the token starts with `\n`. --- ++AZ++: is this meaningful? -startsWithNewLn::PosToken->Bool -startsWithNewLn (_,s) =if s==[] then False - else ((ghead "starsWithNewLn" s)=='\n') - ---Returns True if there is a '\n' in the token. -hasNewLn :: PosToken -> Bool -hasNewLn (GHC.L l _,_) = case l of - GHC.RealSrcSpan ss -> (GHC.srcSpanStartLine ss /= GHC.srcSpanEndLine ss) - _ -> False - - --- |get the last non-ignored token in a token stream. -lastNonSpaceToken::[PosToken] -> PosToken -lastNonSpaceToken toks=case dropWhile isWhiteSpaceOrIgnored (reverse toks) of - [] -> defaultToken - l -> ghead "lastNonSpaceToken" l -{- ---get the first non-space token in a token stream. -firstNonSpaceToken::[PosToken]->PosToken -firstNonSpaceToken toks=case dropWhile isWhiteSpace toks of - [] ->defaultToken - l -> ghead "firstNonSpaceToken" l --} - --- | Remove the extra preceding empty lines. -compressPreNewLns::[PosToken] -> [PosToken] -compressPreNewLns toks = toks - --- |Remove the following extra empty lines. -compressEndNewLns::[PosToken]->[PosToken] -compressEndNewLns toks = toks - ----Restriction: the refactorer should not modify refactorer-modified/created tokens. -defaultToken :: PosToken -defaultToken = (GHC.noLoc (GHC.ITlineComment "defaultToken"), "defaultToken") - +nullSrcSpan :: GHC.SrcSpan +nullSrcSpan = GHC.UnhelpfulSpan $ GHC.mkFastString "HaRe nullSrcSpan" -- --------------------------------------------------------------------- prettyprintPatList :: (t -> String) -> Bool -> [t] -> String @@ -298,6 +46,8 @@ format2 [p] = (prpr p) -- (render.ppi) p format2 (p:ps) = (prpr p) ++ " " ++ format2 ps +-- AZ: This must go, when its user is cleaned up + --Replace Tab by white spaces. (1 Tab=8 white spaces) -- TODO: need to be aware of underlying tab stops, advance to next one only replaceTabBySpaces::String->String @@ -307,333 +57,7 @@ else s:replaceTabBySpaces ss -- --------------------------------------------------------------------- -{- --- | Convert a string into a set of Haskell tokens, following the --- given position, with each line indented by a given column offset if --- required --- TODO: replace 'colOffset withFirstLineIndent' with a Maybe Int ++AZ++ -tokenise :: GHC.RealSrcLoc -> Int -> Bool -> String -> IO [PosToken] -tokenise _ _ _ [] = return [] -tokenise startPos colOffset withFirstLineIndent str - = let str' = case lines str of - (ln:[]) -> addIndent ln ++ if glast "tokenise" str=='\n' then "\n" else "" - (ln:lns)-> addIndent ln ++ "\n" ++ concatMap (\n->replicate colOffset ' '++n++"\n") lns - [] -> [] - str'' = if glast "tokenise" str' == '\n' && glast "tokenise" str /= '\n' - then genericTake (length str' -1) str' - else str' - toks = lexStringToRichTokens startPos str'' - in toks - -- in error $ "tokenise:" ++ (showToks $ head toks) - where - addIndent ln = if withFirstLineIndent - then replicate colOffset ' '++ ln - else ln - --- --------------------------------------------------------------------- - --- |Convert a string into a set of Haskell tokens. It has default --- position and offset, since it will be stitched into place in TokenUtils -basicTokenise :: String -> IO [PosToken] -basicTokenise str = tokenise startPos 0 False str - where - -- startPos = (GHC.mkRealSrcLoc tokenFileMark 0 1) - startPos = (GHC.mkRealSrcLoc (GHC.mkFastString "foo") 0 1) --} --- --------------------------------------------------------------------- - ---Should add cases for literals. -addLocInfo :: (GHC.LHsBind GHC.Name,[PosToken]) - -> RefactGhc (GHC.LHsBind GHC.Name,[PosToken]) -addLocInfo (decl, toks) = return (decl, toks) - --- --------------------------------------------------------------------- - --- |Given a token stream covering multi-lines, calculate the length of the last line --- AZ: should be the last token start col, plus length of token. -lengthOfLastLine::[PosToken]->Int -lengthOfLastLine [] = 0 -lengthOfLastLine toks - -- = let (toks1,toks2)=break hasNewLn $ reverse toks - = let rtoks = reverse toks - x = head rtoks - (toks1,toks2)=break (\x' -> tokenRow x /= tokenRow x') rtoks - -- in if toks2==[] - in if length toks2 == 0 - then sum (map tokenLen toks1) - else sum (map tokenLen toks1) + lastLineLenOfToken (ghead "lengthOfLastLine" toks2) - where - --Compute the length of a token, if the token covers multi-line, only count the last line. - --What about tab keys? - lastLineLenOfToken (_,s)=(length.(takeWhile (\x->x/='\n')).reverse) s - --- --------------------------------------------------------------------- - --- | get a token stream specified by the start and end position. -getToks :: (SimpPos,SimpPos) -> [PosToken] -> [PosToken] -getToks (startPos,endPos) toks = - -- TODO: use splitToks - -- error $ "getToks:startPos=" ++ (show startPos) ++ ",endPos=" ++ (show endPos) ++ ",toks=" ++ (showToks toks) -- ++AZ++ debug - let (_,toks2) = break (\t -> tokenPos t >= startPos) toks - (toks21,_toks22) = break (\t -> tokenPos t > endPos) toks2 - in - (toks21) -- Should add error message for empty list? - -- error $ "getToks:startPos=" ++ (show startPos) ++ ",endPos=" ++ (show endPos) ++ ",toks21=" ++ (showToks toks21) -- ++AZ++ debug - --- --------------------------------------------------------------------- -{- --- |Replace a single token in the token stream by a new token, without --- adjusting the layout. --- Note1: does not re-align, else other later replacements may fail. --- Note2: must keep original end col, to know what the inter-token gap --- was when re-aligning -replaceTokNoReAlign:: [PosToken] -> SimpPos -> PosToken -> [PosToken] -replaceTokNoReAlign toks pos newTok = - toks1 ++ [newTok'] ++ toksRest - where - (toks1,toks2) = break (\t -> tokenPos t >= pos && tokenLen t > 0) toks - toksRest = if (emptyList toks2) then [] else (gtail "replaceTokNoReAlign" toks2) - oldTok = if (emptyList toks2) then newTok else (ghead "replaceTokNoReAlign" toks2) - -- newTok' = markToken $ matchTokenPos oldTok newTok - newTok' = matchTokenPos oldTok newTok --} --- --------------------------------------------------------------------- -{- --- |Transfer the location information from the first param to the second -matchTokenPos :: PosToken -> PosToken -> PosToken -matchTokenPos (GHC.L l _,_) (GHC.L _ t,s) = (GHC.L l t,s) --} --- --------------------------------------------------------------------- - --- | Get the start of the line before the pos, -getLineOffset :: [PosToken] -> SimpPos -> Int -getLineOffset toks pos - = let (ts1, ts2) = break (\t->tokenPos t >= pos) toks - in if (emptyList ts2) - then error "HaRe error: position does not exist in the token stream!" - else let (sl,_) = splitOnNewLn $ reverse ts1 - in tokenCol (glast "getLineOffset" sl) - -- in error ("getOffset: sl=" ++ (showToks sl)) -- ++AZ++ - - --- --------------------------------------------------------------------- - --- |Delete a sequence of tokens specified by the start position and --- end position from the token stream, then adjust the remaining token --- stream to preserve layout -deleteToks:: [PosToken] -> SimpPos -> SimpPos -> [PosToken] -deleteToks toks startPos endPos - = case after of - (_:_) -> let nextPos =tokenPos $ ghead "deleteToks1" after - oldOffset = getIndentOffset toks nextPos - newOffset = getIndentOffset (toks1++before++after) nextPos - in toks1++before++adjustLayout (after++toks22) oldOffset newOffset - -- in error $ "deleteToks:newOffset=" ++ (show (newOffset)) -- ++AZ++ - -- in error $ "deleteToks:after=" ++ (showToks (after)) -- ++AZ++ - _ -> if (emptyList toks22) - then toks1++before - else let toks22'=let nextOffset = getIndentOffset toks (tokenPos (ghead "deleteToks2" toks22)) - in if isMultiLineComment (lastNonSpaceToken toks21) - then whiteSpaceTokens (-1111, 0) (nextOffset-1) ++ toks22 - else toks22 - in if endsWithNewLn (last (toks1++before)) || startsWithNewLn (ghead "deleteToks3" toks22') - then toks1++before++toks22' - --avoiding layout adjustment by adding a `\n', sometimes may produce extra lines. - else toks1++before++[newLnToken (last before)]++toks22' - -- else toks1 ++ before ++ toks22' - where - - (toks1, toks2) = let (ts1, ts2) = break (\t->tokenPos t >= startPos) toks - (ts11, ts12) = break hasNewLn (reverse ts1) - in (reverse ts12, reverse ts11 ++ ts2) - (toks21, toks22)=let (ts1, ts2) = break (\t -> tokenPos t >= endPos) toks2 - (ts11, ts12) = break hasNewLn ts2 - in (ts1++ts11++if (emptyList ts12) then [] else [ghead "deleteToks4" ts12], if (emptyList ts12) then [] else gtail "deleteToks5" ts12) - - -- NOTE: toks === toks1 ++ toks21 ++ toks22, where toks21 are the ones to be deleted - - -- tokens before the tokens to be deleted at the same line - before = takeWhile (\t->tokenPos t tokenPosEnd t <= endPos) toks21 - in if (emptyList ts) then ts -- ++AZ++ error "Sorry, HaRe failed to finish this refactoring. deleteToks" - else ts - --- --------------------------------------------------------------------- - --- | Adjust the layout to compensate the change in the token stream. -adjustLayout:: [PosToken] -> Int -> Int -> [PosToken] -adjustLayout [] _ _ = [] -adjustLayout toks _oldOffset _newOffset = toks -- ++AZ++ temporary while plumbing the rest - --- | remove at most n white space tokens from the beginning of ts -doRmWhites::Int -> [PosToken] -> [PosToken] -doRmWhites 0 ts = ts -doRmWhites _ [] = [] -doRmWhites _ ts = ts - - -{- ---add n white space tokens to the beginning of ts -doAddWhites::Int->[PosToken]->[PosToken] -doAddWhites n []=[] -doAddWhites n ts@(t:_)= whiteSpacesToken (tokenRow t,0) n ++ts --} - --- ++AZ++ : not sure if this is still needed -whiteSpaceTokens :: (Int,Int) -> Int -> [PosToken] -whiteSpaceTokens (_row, _col) _n = [] - --- --------------------------------------------------------------------- - --- | get all the source locations (use locations) in an AST phrase t --- according the the occurrence order of identifiers. -srcLocs::(SYB.Data t) => t -> [SimpPos] -srcLocs t =(nub.srcLocs') t \\ [simpPos0] - where srcLocs'= SYB.everythingStaged SYB.Parser (++) [] - ([] - `SYB.mkQ` pnt - `SYB.extQ` sn - `SYB.extQ` literalInExp - `SYB.extQ` literalInPat) - - pnt :: GHC.GenLocated GHC.SrcSpan GHC.Name -> [SimpPos] - pnt (GHC.L l _) = [getGhcLoc l] - - sn :: GHC.HsModule GHC.RdrName -> [SimpPos] - sn (GHC.HsModule (Just (GHC.L l _)) _ _ _ _ _) = [getGhcLoc l] - sn _ = [] - - literalInExp :: GHC.LHsExpr GHC.Name -> [SimpPos] - literalInExp (GHC.L l _) = [getGhcLoc l] - - literalInPat :: GHC.LPat GHC.Name -> [SimpPos] - literalInPat (GHC.L l _) = [getGhcLoc l] - --- --------------------------------------------------------------------- - -getBiggestStartEndLoc :: (SYB.Data t) => t -> (SimpPos,SimpPos) -getBiggestStartEndLoc t = (start,end) - where - locs = getAllSrcLocs t - start = minimum $ map fst locs - end = maximum $ map snd locs - --- --------------------------------------------------------------------- - --- | Get all the source locations in a given syntax fragment -getAllSrcLocs::(SYB.Data t) => t -> [(SimpPos,SimpPos)] -getAllSrcLocs t = res t - where - res = SYB.everythingStaged SYB.Renamer (++) [] - ([] - `SYB.mkQ` bind - `SYB.extQ` sig - `SYB.extQ` pnt - `SYB.extQ` sn - `SYB.extQ` literalInExp - `SYB.extQ` literalInPat - `SYB.extQ` importDecl - `SYB.extQ` ty - ) - - bind :: GHC.GenLocated GHC.SrcSpan (GHC.HsBind GHC.Name) -> [(SimpPos,SimpPos)] - bind (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)] - - sig :: (GHC.LSig GHC.Name) -> [(SimpPos,SimpPos)] - sig (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)] - - ty :: (GHC.LHsType GHC.Name) -> [(SimpPos,SimpPos)] - ty (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)] - - pnt :: GHC.GenLocated GHC.SrcSpan GHC.Name -> [(SimpPos,SimpPos)] - pnt (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)] - - sn :: GHC.HsModule GHC.RdrName -> [(SimpPos,SimpPos)] - sn (GHC.HsModule (Just (GHC.L l _)) _ _ _ _ _) = [(getGhcLoc l,getGhcLocEnd l)] - sn _ = [] - - literalInExp :: GHC.LHsExpr GHC.Name -> [(SimpPos,SimpPos)] - literalInExp (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)] - - literalInPat :: GHC.LPat GHC.Name -> [(SimpPos,SimpPos)] - literalInPat (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)] - - importDecl :: GHC.LImportDecl GHC.Name -> [(SimpPos,SimpPos)] - importDecl (GHC.L l _) = [(getGhcLoc l,getGhcLocEnd l)] - --- --------------------------------------------------------------------- - --- |Extend the given position backwards to the front of the file while --- the supplied condition holds -extendBackwards :: [PosToken] -> (SimpPos ,SimpPos) -> (PosToken -> Bool) - -> (SimpPos,SimpPos) -extendBackwards toks (startLoc,endLoc) condFun - = let toks1 = takeWhile (\t->tokenPos t /= startLoc) toks - firstLoc = case (dropWhile (not.condFun) (reverse toks1)) of - [] -> startLoc -- is this the correct default? - l -> (tokenPos.ghead "extendBackwards") l - in (firstLoc, endLoc) - --- |Extend the given position forwards to the end of the file while --- the supplied condition holds -extendForwards :: [PosToken] -> (SimpPos ,SimpPos) -> (PosToken -> Bool) - -> (SimpPos,SimpPos) -extendForwards toks (startLoc,endLoc) condFun - = let toks1 = gtail "extendForwards" $ dropWhile (\t->tokenPosEnd t /= endLoc) toks - lastLoc = case (dropWhile (condFun) toks1) of - [] ->endLoc -- is this the correct default? - l ->(tokenPos. ghead "extendForwards") l - in (startLoc, lastLoc) - -{- -------------------Some functions for associating comments with syntax phrases.--------------------------- -{- Note: We assume that a comment before t belongs to t only if there is at most one blank line between them, - and a cooment after t belongs to t only it the comment starts at the last line of t. --} --} - --- |Get the start&end location of syntax phrase t, then extend the end --- location to cover the comment/white spaces or new line which starts --- in the same line as the end location --- TODO: deprecate this in favour of startEndLocIncComments -startEndLocIncFowComment::(SYB.Data t)=>[PosToken]->t->(SimpPos,SimpPos) -startEndLocIncFowComment toks t - = let (startLoc,_endLoc)=getStartEndLoc t - (_,endLocIncComments) = startEndLocIncComments toks t - in (startLoc, endLocIncComments) - - --- --------------------------------------------------------------------- - ---Some functions for fetching a specific field of a token -tokenSrcSpan :: (GHC.Located t1, t) -> GHC.SrcSpan -tokenSrcSpan (GHC.L l _,_) = l - --- TODO: badly named function -tokenCon :: PosToken -> String -tokenCon (_,s) = s - --- --------------------------------------------------------------------- -{- -increaseSrcSpan :: SimpPos -> PosToken -> PosToken -increaseSrcSpan (lineAmount,colAmount) posToken@(lt@(GHC.L _l t), s) - = (GHC.L newL t, s) - where - filename = fileNameFromTok posToken - newL = GHC.mkSrcSpan (GHC.mkSrcLoc filename startLine startCol) - (GHC.mkSrcLoc filename endLine endCol) - (startLine, startCol) = add1 $ getLocatedStart lt - (endLine, endCol) = add1 $ getLocatedEnd lt - - add1 :: (Int, Int) -> (Int, Int) - add1 (r,c) = (r+lineAmount,c+colAmount) - --} --- --------------------------------------------------------------------- - -- | gets the (row,col) of the start of the @GHC.SrcSpan@, or (-1,-1) -- if there is an @GHC.UnhelpfulSpan@ getGhcLoc :: GHC.SrcSpan -> (Int, Int) @@ -654,9 +78,14 @@ -- --------------------------------------------------------------------- +ghcSpanStartEnd :: GHC.SrcSpan -> ((Int, Int), (Int, Int)) +ghcSpanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan) + +-- --------------------------------------------------------------------- + getStartEndLoc :: (SYB.Data t) => t -> (SimpPos,SimpPos) getStartEndLoc t = - -- error $ "getStartEndLoc:" ++ (SYB.showData SYB.Renamer 0 t) + -- error $ "getStartEndLoc:" ++ (SYB.showData SYB.Parser 0 t) let ss = getSrcSpan t in @@ -676,36 +105,6 @@ -- --------------------------------------------------------------------- -realSrcLocFromTok :: PosToken -> GHC.RealSrcLoc -realSrcLocFromTok (GHC.L (GHC.RealSrcSpan srcspan) _,_) = GHC.realSrcSpanStart srcspan -realSrcLocFromTok (GHC.L _ _,_) = GHC.mkRealSrcLoc (GHC.mkFastString "") 1 1 - -realSrcLocEndTok :: PosToken -> GHC.RealSrcLoc -realSrcLocEndTok (GHC.L (GHC.RealSrcSpan srcspan) _,_) = GHC.realSrcSpanEnd srcspan -realSrcLocEndTok (GHC.L _ _,_) = GHC.mkRealSrcLoc (GHC.mkFastString "") 1 1 - -fileNameFromTok :: PosToken -> GHC.FastString -fileNameFromTok (GHC.L (GHC.RealSrcSpan srcspan) _,_) = GHC.srcSpanFile srcspan -fileNameFromTok (GHC.L _ _,_) = GHC.mkFastString "f" - --- --------------------------------------------------------------------- -{- --- | Split the token stream into three parts: the tokens before the --- startPos, the tokens between startPos and endPos, and the tokens --- after endPos. --- Note: The startPos and endPos refer to the startPos of a token only. --- So a single token will have the same startPos and endPos --- NO^^^^ -splitToks::(SimpPos,SimpPos)->[PosToken]->([PosToken],[PosToken],[PosToken]) -splitToks (startPos, endPos) toks = - let (toks1,toks2) = break (\t -> tokenPos t >= startPos) toks - (toks21,toks22) = break (\t -> tokenPos t >= endPos) toks2 - in - (toks1,toks21,toks22) - --} --- ---------------------------------------------------------------------- - -- |Get around lack of instance Eq when simply testing for empty list -- TODO: get rid of this in favour of `null` built in fn emptyList :: [t] -> Bool @@ -716,158 +115,16 @@ nonEmptyList [] = False nonEmptyList _ = True --- | Get the start&end location of t in the token stream, then extend --- the start and end location to cover the preceding and following --- comments. --- --- In this routine, 'then','else','do' and 'in' are treated as comments. -startEndLocIncComments::(SYB.Data t) => [PosToken] -> t -> (SimpPos,SimpPos) -startEndLocIncComments toks t = startEndLocIncComments' toks (getStartEndLoc t) - -{- -startEndLocIncComments' :: [PosToken] -> (SimpPos,SimpPos) -> (SimpPos,SimpPos) -startEndLocIncComments' toks (startLoc,endLoc) = - let - (begin,middle,end) = splitToks (startLoc,endLoc) toks - - notIgnored tt = not (isWhiteSpaceOrIgnored tt) - - (leadinr,leadr) = break notIgnored $ reverse begin - leadr' = filter (\t -> not (isEmpty t)) leadr - prevLine = if (emptyList leadr') then 0 else (tokenRow $ ghead "startEndLocIncComments'1" leadr') - firstLine = if (emptyList middle) then 0 else (tokenRow $ ghead "startEndLocIncComments'1" middle) - (_nonleadComments,leadComments') = divideComments prevLine firstLine $ reverse leadinr - leadComments = dropWhile (\tt -> (isEmpty tt)) leadComments' - - (trail,trailrest) = break notWhiteSpace end - trail' = filter (\t -> not (isEmpty t)) trail - lastLine = if (emptyList middle) - then 0 - else (tokenRow $ glast "startEndLocIncComments'2" middle) - nextLine = if (emptyList trailrest) - then 100000 - else (tokenRow $ ghead "startEndLocIncComments'2" trailrest) - (trailComments,_) = divideComments lastLine nextLine trail' - - middle' = leadComments ++ middle ++ trailComments - in - if (emptyList middle') - then ((0,0),(0,0)) - else ((tokenPos $ ghead "startEndLocIncComments 4" middle'),(tokenPosEnd $ last middle')) - -- --------------------------------------------------------------------- --- |Split a set of comment tokens into the ones that belong with the startLine --- and those that belong with the endLine -divideComments :: Int -> Int -> [PosToken] -> ([PosToken],[PosToken]) -divideComments startLine endLine toks = (first,second) - where - groups = groupBy groupByAdjacent toks - groupLines = map (\ts -> ((tokenRow $ ghead "divideComments" ts,tokenRow $ glast "divideComments" ts),ts)) groups - groupLines' = [((startLine,startLine),[])] ++ groupLines ++ [((endLine,endLine),[])] - groupGaps = go [] groupLines' - -- groupGaps is now a list of gaps followed by the tokens. The - -- last gap has an empty token list, since there is one more gap - -- than token groups - - -- e.g [(0,[comments1]),(3,[comments2]),(1,[]) captures - -- --------------------- - -- b + bar -- ^trailing comment - -- - -- - -- -- leading comment - -- foo x y = - -- ---------------------- - - biggest = maximum $ map fst groupGaps - - (firsts,seconds) = break (\(g,_) -> g >= biggest) groupGaps - - first = concatMap snd firsts - second = concatMap snd seconds - - -- Helpers - groupByAdjacent :: PosToken -> PosToken -> Bool - groupByAdjacent a b = 1 + tokenRow a == tokenRow b - - go :: [(Int,[PosToken])] -> [((Int,Int),[PosToken])] -> [(Int,[PosToken])] - go acc [] = acc - go acc [_x] = acc - go acc (((_s1,e1),_t1):b@((s2,_e2),t2):xs) = go (acc ++ [((s2 - e1),t2)] ) (b:xs) - --} --- --------------------------------------------------------------------- - -isWhiteSpace :: PosToken -> Bool -isWhiteSpace tok = isComment tok || isEmpty tok -{- -notWhiteSpace :: PosToken -> Bool -notWhiteSpace tok = not (isWhiteSpace tok) - --- Tokens that are ignored when allocating tokens to a SrcSpan -isIgnored :: PosToken -> Bool -isIgnored tok = isThen tok || isElse tok || isIn tok || isDo tok --} --- --------------------------------------------------------------------- - -isDoubleColon :: PosToken -> Bool -isDoubleColon ((GHC.L _ (GHC.ITdcolon)), "::") = True -isDoubleColon _ = False - -{- -isEmpty :: PosToken -> Bool -isEmpty ((GHC.L _ (GHC.ITsemi)), "") = True -isEmpty ((GHC.L _ (GHC.ITvocurly)), "") = True -isEmpty ((GHC.L _ _), "") = True -isEmpty _ = False --} --- isWhereOrLet :: PosToken -> Bool --- isWhereOrLet t = isWhere t || isLet t - --- --------------------------------------------------------------------- --- This section is horrible because there is no Eq instance for --- GHC.Token - -{- _ -> False -isWhere :: PosToken -> Bool -isWhere ((GHC.L _ t),_s) = case t of - GHC.ITwhere -> True - -isLet :: PosToken -> Bool -isLet ((GHC.L _ t),_s) = case t of - GHC.ITlet -> True - _ -> False - -isElse :: PosToken -> Bool -isElse ((GHC.L _ t),_s) = case t of - GHC.ITelse -> True - _ -> False - -isThen :: PosToken -> Bool -isThen ((GHC.L _ t),_s) = case t of - GHC.ITthen -> True - _ -> False - -isOf :: PosToken -> Bool -isOf ((GHC.L _ t),_s) = case t of - GHC.ITof -> True - _ -> False - -isDo :: PosToken -> Bool -isDo ((GHC.L _ t),_s) = case t of - GHC.ITdo -> True - _ -> False --} - --- --------------------------------------------------------------------- - -- | Get the first SrcSpan found, in top down traversal getSrcSpan::(SYB.Data t) => t -> Maybe GHC.SrcSpan getSrcSpan t = res t where - res = somethingStaged SYB.Renamer Nothing + res = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` bind + `SYB.extQ` decl `SYB.extQ` sig `SYB.extQ` pnt `SYB.extQ` literalInExp @@ -876,192 +133,29 @@ `SYB.extQ` ty ) - bind :: GHC.GenLocated GHC.SrcSpan (GHC.HsBind GHC.Name) -> Maybe GHC.SrcSpan + bind :: GHC.GenLocated GHC.SrcSpan (GHC.HsBind GHC.RdrName) -> Maybe GHC.SrcSpan bind (GHC.L l _) = Just l - sig :: (GHC.LSig GHC.Name) -> Maybe GHC.SrcSpan + decl :: GHC.GenLocated GHC.SrcSpan (GHC.HsDecl GHC.RdrName) -> Maybe GHC.SrcSpan + decl (GHC.L l _) = Just l + + sig :: (GHC.LSig GHC.RdrName) -> Maybe GHC.SrcSpan sig (GHC.L l _) = Just l - ty :: (GHC.LHsType GHC.Name) -> Maybe GHC.SrcSpan + ty :: (GHC.LHsType GHC.RdrName) -> Maybe GHC.SrcSpan ty (GHC.L l _) = Just l - pnt :: GHC.GenLocated GHC.SrcSpan GHC.Name -> Maybe GHC.SrcSpan + pnt :: GHC.GenLocated GHC.SrcSpan GHC.RdrName -> Maybe GHC.SrcSpan pnt (GHC.L l _) = Just l - literalInExp :: GHC.LHsExpr GHC.Name -> Maybe GHC.SrcSpan + literalInExp :: GHC.LHsExpr GHC.RdrName -> Maybe GHC.SrcSpan literalInExp (GHC.L l _) = Just l - literalInPat :: GHC.LPat GHC.Name -> Maybe GHC.SrcSpan + literalInPat :: GHC.LPat GHC.RdrName -> Maybe GHC.SrcSpan literalInPat (GHC.L l _) = Just l - importDecl :: GHC.LImportDecl GHC.Name -> Maybe GHC.SrcSpan + importDecl :: GHC.LImportDecl GHC.RdrName -> Maybe GHC.SrcSpan importDecl (GHC.L l _) = Just l - --- --------------------------------------------------------------------- -{- --- | Get the indent of the line before, taking into account in-line --- 'where', 'let', 'in' and 'do' tokens -getIndentOffset :: [PosToken] -> SimpPos -> Int -getIndentOffset [] _pos = 1 -getIndentOffset _toks (0,0) = 1 -getIndentOffset toks pos - = let (ts1, ts2) = break (\t->tokenPos t >= pos) toks - in if (emptyList ts2) - then error "HaRe error: position does not exist in the token stream!" - else let (sl,_) = splitOnNewLn $ reverse ts1 - -- sl is the reversed tokens of the previous line - (sls,_) = break isWhereOrLet $ filter (\t -> tokenLen t > 0) sl - firstTok = (glast "getIndentOffset" sls) - in if startLayout firstTok - then if (length sls > 1) - then tokenOffset (last $ init sls) - else 4 + tokenOffset firstTok - else tokenOffset firstTok - - where - tokenOffset t = (tokenCol t) - 1 - - startLayout ((GHC.L _ (GHC.ITdo)),_) = True - startLayout ((GHC.L _ (GHC.ITin)),_) = True - startLayout ((GHC.L _ (GHC.ITlet)),_) = True - startLayout ((GHC.L _ (GHC.ITwhere)),_) = True - startLayout _ = False - --- --------------------------------------------------------------------- - -splitOnNewLn :: [PosToken] -> ([PosToken],[PosToken]) -splitOnNewLn toks = go [] toks - -- ++AZ++ : TODO: is this simpler? : (toks1,toks2)=break (\x' -> tokenRow x /= tokenRow x') rtoks - - where - go [] [] = ([],[]) - go ss [] = (ss,[]) - go [] xs = go [head xs] (tail xs) - go ss xs - | onSameLn (glast "splitOnNewLn" ss) (head xs) = go (ss ++ [head xs]) (tail xs) - | otherwise = (ss,xs) - --} --- --------------------------------------------------------------------- -{- -tokenLen :: PosToken -> Int -tokenLen (_,s) = length s --check this again! need to handle the tab key. --} --- --------------------------------------------------------------------- -{- -newLnToken :: PosToken -> PosToken -newLnToken tok = newLinesToken 1 tok - --- --------------------------------------------------------------------- - -newLinesToken :: Int -> PosToken -> PosToken -newLinesToken jump (GHC.L l _,_) = (GHC.L l' GHC.ITvocurly,"") - where - l' = case l of - GHC.RealSrcSpan ss -> - let - loc = GHC.mkSrcLoc (GHC.srcSpanFile ss) (jump + GHC.srcSpanEndLine ss) 1 - in - GHC.mkSrcSpan loc loc - _ -> l --} --- --------------------------------------------------------------------- - --- groupTokensByLine :: [PosToken] -> [[PosToken]] --- groupTokensByLine xs = groupBy toksOnSameLine xs - -toksOnSameLine :: PosToken -> PosToken -> Bool -toksOnSameLine t1 t2 = tokenRow t1 == tokenRow t2 - --- --------------------------------------------------------------------- -{- --- | sort out line numbering so that they are always monotonically --- increasing. -monotonicLineToks :: [PosToken] -> [PosToken] -monotonicLineToks toks = goMonotonicLineToks (0,0) toks - -goMonotonicLineToks :: SimpPos -> [PosToken] -> [PosToken] -goMonotonicLineToks _ [] = [] -goMonotonicLineToks _ [t] = [t] -goMonotonicLineToks (orow,ocol) (t1:t2:ts) - = t1:goMonotonicLineToks offset' (t2':ts) - where - offset' = if (tokenRow t1 - orow) > (tokenRow t2) - then (orow + (tokenRow t1) - tokenRow t2 + 1, ocol) - else (orow,ocol) - - -- t1' = increaseSrcSpan (orow,ocol) t1 - t2' = increaseSrcSpan offset' t2 --} --- --------------------------------------------------------------------- - --- |Adjust token stream to cater for changes in token length due to --- token renaming -reSequenceToks :: [PosToken] -> [PosToken] -reSequenceToks toks = toks - --- --------------------------------------------------------------------- -{- --- |Compose a new token using the given arguments. -mkToken::GHC.Token -> SimpPos -> String -> PosToken -mkToken t (row,col) c = ((GHC.L l t),c) - where - filename = (GHC.mkFastString "f") - l = GHC.mkSrcSpan (GHC.mkSrcLoc filename row col) (GHC.mkSrcLoc filename row (col + (length c) )) --} -{- -mkZeroToken :: PosToken -mkZeroToken = mkToken GHC.ITsemi (0,0) "" --} --- --------------------------------------------------------------------- -{- -onSameLn :: PosToken -> PosToken -> Bool -onSameLn (GHC.L l1 _,_) (GHC.L l2 _,_) = r1 == r2 - where - (r1,_) = getGhcLoc l1 - (r2,_) = getGhcLoc l2 --} --- --------------------------------------------------------------------- -{- --- |Used as a marker in the filename part of the SrcSpan on modified --- tokens, to trigger re-alignment when retrieving the tokens. -tokenFileMark :: GHC.FastString -tokenFileMark = GHC.mkFastString "HaRe" - --- |Mark a token so that it can be use to trigger layout checking --- later when the toks are retrieved -markToken :: PosToken -> PosToken -markToken tok = tok' - where - (GHC.L l t,s) = tok - tok' = (GHC.L (GHC.RealSrcSpan l') t,s) - - l' = case l of - GHC.RealSrcSpan ss -> - GHC.mkRealSrcSpan - (GHC.mkRealSrcLoc tokenFileMark (GHC.srcSpanStartLine ss) (GHC.srcSpanStartCol ss)) - (GHC.mkRealSrcLoc tokenFileMark (GHC.srcSpanEndLine ss) (GHC.srcSpanEndCol ss)) - - _ -> error $ "markToken: expecting a real SrcSpan, got" -- ++ (showGhc l) - - --- |Does a token have the file mark in it -isMarked :: PosToken -> Bool -isMarked (GHC.L l _,_) = - case l of - GHC.RealSrcSpan ss -> GHC.srcSpanFile ss == tokenFileMark - _ -> False --} --- --------------------------------------------------------------------- - -rmOffsetFromToks :: [PosToken] -> [PosToken] -rmOffsetFromToks [] = [] -rmOffsetFromToks toks = toks' - where - ro' = tokenRow $ head toks - co' = tokenCol $ head toks - -- (ro,co) = srcPosToSimpPos (tokenRow $ head toks, tokenCol $ head toks) - toks' = addOffsetToToks (-ro',-co') toks -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/Monad.hs b/src/Language/Haskell/Refact/Utils/Monad.hs --- a/src/Language/Haskell/Refact/Utils/Monad.hs +++ b/src/Language/Haskell/Refact/Utils/Monad.hs @@ -1,5 +1,10 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -12,72 +17,72 @@ , RefactState(..) , RefactModule(..) , TargetModule + , Targets + , CabalGraph , RefactStashId(..) , RefactFlags(..) , StateStorage(..) -- The GHC Monad - , RefactGhc + , RefactGhc(..) , runRefactGhc , getRefacSettings , defaultSettings , logSettings - , initGhcSession - , loadModuleGraphGhc - , ensureTargetLoaded + , cabalModuleGraphs , canonicalizeGraph + , canonicalizeModSummary , logm ) where +import qualified DynFlags as GHC import qualified GHC as GHC -import qualified GHC.Paths as GHC -import qualified GhcMonad as GHC -import qualified MonadUtils as GHC +import qualified HscTypes as GHC +import qualified Outputable as GHC +import Control.Applicative import Control.Monad.State -import Data.List -import Data.Time.Clock +--import Data.Time.Clock +import Distribution.Helper import Exception -import Language.Haskell.GhcMod -import Language.Haskell.GhcMod.Internal -import Language.Haskell.TokenUtils.Types -import Language.Haskell.Refact.Utils.TypeSyn -import Language.Haskell.TokenUtils.Utils +import qualified Language.Haskell.GhcMod as GM +import qualified Language.Haskell.GhcMod.Internal as GM +import qualified Language.Haskell.GhcMod.Monad.Types as GM +import Language.Haskell.Refact.Utils.Types +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Utils import System.Directory -import System.FilePath.Posix import System.Log.Logger -import qualified Control.Monad.IO.Class as MU +import qualified Data.Map as Map +import qualified Data.Set as Set + +-- Monad transformer stuff +import Control.Monad.Trans.Control ( control, liftBaseOp, liftBaseOp_) + -- --------------------------------------------------------------------- data VerboseLevel = Debug | Normal | Off deriving (Eq,Show) data RefactSettings = RefSet - { rsetGhcOpts :: ![String] - , rsetImportPaths :: ![FilePath] - , rsetExpandSplice :: Bool - , rsetLineSeparator :: LineSeparator - , rsetMainFile :: Maybe [FilePath] - , rsetCheckTokenUtilsInvariant :: !Bool - , rsetVerboseLevel :: !VerboseLevel + { + -- , rsetMainFile :: Maybe [FilePath] + -- TODO: re-instate rsetMainFile for when there is no cabal + -- file. + rsetVerboseLevel :: !VerboseLevel , rsetEnabledTargets :: (Bool,Bool,Bool,Bool) } deriving (Show) -deriving instance Show LineSeparator +-- deriving instance Show LineSeparator defaultSettings :: RefactSettings defaultSettings = RefSet - { rsetGhcOpts = [] - , rsetImportPaths = [] - , rsetExpandSplice = False - , rsetLineSeparator = LineSeparator "\0" - , rsetMainFile = Nothing - , rsetCheckTokenUtilsInvariant = False - , rsetVerboseLevel = Normal + { + rsetVerboseLevel = Normal -- , rsetEnabledTargets = (True,False,True,False) , rsetEnabledTargets = (True,True,True,True) } @@ -91,33 +96,68 @@ data RefactModule = RefMod { rsTypecheckedMod :: !GHC.TypecheckedModule - , rsOrigTokenStream :: ![PosToken] -- ^Original Token stream for the current module - , rsTokenCache :: !(TokenCache PosToken) -- ^Token stream for the current module, maybe modified, in SrcSpan tree form - , rsStreamModified :: !Bool -- ^current module has updated the token stream - } + , rsNameMap :: NameMap + -- ^ Mapping from the names in the ParsedSource to the renamed + -- versions. Note: No strict mark, can be computed lazily. + -- ++AZ++ TODO: Once HaRe can rename again, change rsTokenCache to something more approriate. Ditto rsStreamModified + , rsTokenCache :: !(TokenCache Anns) -- ^Token stream for the current module, maybe modified, in SrcSpan tree form + , rsStreamModified :: !RefacResult -- ^current module has updated the AST + } deriving (Show) + +instance Show GHC.Name where + show n = showGhc n + +deriving instance Show (GHC.Located GHC.Token) + +instance Show GHC.TypecheckedModule where + show t = showGhc (GHC.pm_parsed_source $ GHC.tm_parsed_module t) + data RefactFlags = RefFlags { rsDone :: !Bool -- ^Current traversal has already made a change - } + } deriving (Show) --- | State for refactoring a single file. Holds/hides the token --- stream, which gets updated transparently at key points. +-- | State for refactoring a single file. Holds/hides the ghc-exactprint +-- annotations, which get updated transparently at key points. data RefactState = RefSt - { rsSettings :: !RefactSettings -- ^Session level settings - , rsUniqState :: !Int -- ^ Current Unique creator value, incremented every time it is used - , rsFlags :: !RefactFlags -- ^ Flags for controlling generic traversals - , rsStorage :: !StateStorage -- ^Temporary storage of values - -- while refactoring takes place - , rsGraph :: [TargetGraph] - , rsModuleGraph :: [([FilePath],GHC.ModuleGraph)] - , rsCurrentTarget :: Maybe [FilePath] - , rsModule :: !(Maybe RefactModule) -- ^The current module being refactored - } + { rsSettings :: !RefactSettings -- ^Session level settings + , rsUniqState :: !Int -- ^ Current Unique creator value, incremented + -- every time it is used + , rsSrcSpanCol :: !Int -- ^ Current SrcSpan creator value, incremented + -- every time it is used + , rsFlags :: !RefactFlags -- ^ Flags for controlling generic + -- traversals + , rsStorage :: !StateStorage -- ^Temporary storage of values while + -- refactoring takes place + , rsCurrentTarget :: !(Maybe TargetModule) -- TODO:AZ: push this into rsModule + , rsModule :: !(Maybe RefactModule) -- ^The current module being refactored + } deriving (Show) +{- +Note [rsSrcSpanCol] +~~~~~~~~~~~~~~~~~~~ -type TargetModule = ([FilePath], GHC.ModSummary) +The ghc-exactprint annotations are tied to a SrcSpan, and provide +deltas for the spaces between the elements in the source. -type TargetGraph = ([FilePath],[(Maybe FilePath, GHC.ModSummary)]) +As such, the SrcSpan itself is only used as an index into the +annotation database. +When HaRe needs a new SrcSpan, for this, it generates it from this +field, to ensure uniqueness. +-} + +type TargetModule = GM.ModulePath -- From ghc-mod + +instance GHC.Outputable TargetModule where + ppr t = GHC.text (show t) + + +-- The CabalGraph comes directly from ghc-mod +-- type CabalGraph = Map.Map ChComponentName (GM.GmComponent GMCResolved (Set.Set ModulePath)) +type CabalGraph = Map.Map ChComponentName (GM.GmComponent 'GM.GMCResolved (Set.Set GM.ModulePath)) + +type Targets = [Either FilePath GHC.ModuleName] + -- |Result of parsing a Haskell source file. It is simply the -- TypeCheckedModule produced by GHC. type ParseResult = GHC.TypecheckedModule @@ -126,223 +166,108 @@ -- place data StateStorage = StorageNone | StorageBind (GHC.LHsBind GHC.Name) - | StorageSig (GHC.LSig GHC.Name) + | StorageSig (GHC.LSig GHC.Name) + | StorageBindRdr (GHC.LHsBind GHC.RdrName) + | StorageDeclRdr (GHC.LHsDecl GHC.RdrName) + | StorageSigRdr (GHC.LSig GHC.RdrName) + instance Show StateStorage where - show StorageNone = "StorageNone" + show StorageNone = "StorageNone" show (StorageBind _bind) = "(StorageBind " {- ++ (showGhc bind) -} ++ ")" show (StorageSig _sig) = "(StorageSig " {- ++ (showGhc sig) -} ++ ")" + show (StorageDeclRdr _bind) = "(StorageDeclRdr " {- ++ (showGhc bind) -} ++ ")" + show (StorageBindRdr _bind) = "(StorageBindRdr " {- ++ (showGhc bind) -} ++ ")" + show (StorageSigRdr _sig) = "(StorageSigRdr " {- ++ (showGhc sig) -} ++ ")" -- --------------------------------------------------------------------- -- StateT and GhcT stack -type RefactGhc a = GHC.GhcT (StateT RefactState IO) a - -instance (MU.MonadIO (GHC.GhcT (StateT RefactState IO))) where - liftIO = GHC.liftIO - -instance GHC.MonadIO (StateT RefactState IO) where - liftIO f = MU.liftIO f - -instance ExceptionMonad m => ExceptionMonad (StateT s m) where - gcatch f h = StateT $ \s -> gcatch (runStateT f s) (\e -> runStateT (h e) s) - gblock = mapStateT gblock - gunblock = mapStateT gunblock - - -instance (MonadState RefactState (GHC.GhcT (StateT RefactState IO))) where - get = lift get - put = lift . put - -- state = lift . state - -instance (MonadTrans GHC.GhcT) where - lift = GHC.liftGhcT - -instance (MonadPlus m,Functor m,GHC.MonadIO m,ExceptionMonad m) => MonadPlus (GHC.GhcT m) where - mzero = GHC.GhcT $ \_s -> mzero - x `mplus` y = GHC.GhcT $ \_s -> (GHC.runGhcT (Just GHC.libdir) x) `mplus` (GHC.runGhcT (Just GHC.libdir) y) +newtype RefactGhc a = RefactGhc + { unRefactGhc :: GM.GhcModT (StateT RefactState IO) a + } deriving ( Functor + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadIO + , GM.GmEnv + , GM.GmOut + , GM.MonadIO + , ExceptionMonad + ) -- --------------------------------------------------------------------- --- | Initialise the GHC session, when starting a refactoring. --- This should never be called directly. -initGhcSession :: Cradle -> [FilePath] -> RefactGhc () -initGhcSession cradle importDirs = do - settings <- getRefacSettings - let ghcOptsDirs = - case importDirs of - [] -> (rsetGhcOpts settings) - _ -> ("-i" ++ (intercalate ":" importDirs)):(rsetGhcOpts settings) - let opt = Options { - outputStyle = PlainStyle - , hlintOpts = [] - , ghcOpts = ghcOptsDirs - , operators = False - , detailed = False - , qualified = False - , lineSeparator = rsetLineSeparator settings - } - - -- (_readLog,mcabal) <- initializeFlagsWithCradle opt cradle (options settings) True - initializeFlagsWithCradle opt cradle - -- initializeFlagsWithCradle :: GhcMonad m => Options -> Cradle -> m () - case cradleCabalFile cradle of - Just cabalFile -> do - -- targets <- liftIO $ cabalAllTargets cabal - targets <- liftIO $ getCabalAllTargets cradle cabalFile - -- liftIO $ warningM "HaRe" $ "initGhcSession:targets=" ++ show targets - logm $ "initGhcSession:targets=" ++ show targets - - -- TODO: Cannot load multiple main modules, must try to load - -- each main module and retrieve its module graph, and then - -- set the targets to this superset. - - let targets' = getEnabledTargets settings targets - - case targets' of - ([],[]) -> return () - (libTgts,exeTgts) -> do - -- liftIO $ warningM "HaRe" $ "initGhcSession:tgts=" ++ (show (libTgts,exeTgts)) - logm $ "initGhcSession:(libTgts,exeTgts)=" ++ (show (libTgts,exeTgts)) - -- setTargetFiles tgts - -- void $ GHC.load GHC.LoadAllTargets - - mapM_ loadModuleGraphGhc $ map (\t -> Just [t]) exeTgts - - -- Load the library last, most likely in context - case libTgts of - [] -> return () - _ -> loadModuleGraphGhc (Just libTgts) - - -- moduleGraph <- gets rsModuleGraph - -- logm $ "initGhcSession:rsModuleGraph=" ++ (show moduleGraph) - - Nothing -> do - let maybeMainFile = rsetMainFile settings - loadModuleGraphGhc maybeMainFile - return() +runRefactGhc :: + RefactGhc a -> RefactState -> GM.Options -> IO (a, RefactState) +runRefactGhc comp initState opt = do + ((merr,_log),s) <- runStateT (GM.runGhcModT opt (unRefactGhc comp)) initState + case merr of + Left err -> error (show err) + Right a -> return (a,s) - -- graph <- gets rsGraph - -- liftIO $ warningM "HaRe" $ "initGhcSession:graph=" ++ show graph - return () -{- - where - options opt - | rsetExpandSplice opt = "-w:" : rsetGhcOpts opt - | otherwise = "-Wall" : rsetGhcOpts opt --} -- --------------------------------------------------------------------- +instance GM.GmOut (StateT RefactState IO) where +instance GM.MonadIO (StateT RefactState IO) where + liftIO = liftIO -getCabalAllTargets :: Cradle -> FilePath -> IO ([FilePath],[FilePath],[FilePath],[FilePath]) -getCabalAllTargets cradle cabalFile = do - currentDir <- getCurrentDirectory - -- let cabalDir = gfromJust "getCabalAllTargets" (cradleCabalDir cradle) - let cabalDir = cradleRootDir cradle +instance MonadState RefactState RefactGhc where + get = RefactGhc (lift $ lift get) + put s = RefactGhc (lift $ lift (put s)) - setCurrentDirectory cabalDir +instance GHC.GhcMonad RefactGhc where + getSession = RefactGhc $ GM.unGmlT GM.gmlGetSession + setSession env = RefactGhc $ GM.unGmlT (GM.gmlSetSession env) - pkgDesc <- liftIO $ parseCabalFile cabalFile - (libs,exes,tests,benches) <- liftIO $ cabalAllTargets pkgDesc - setCurrentDirectory currentDir - let libs' = filter (\l -> not (isPrefixOf "Paths_" l)) libs - exes' = addCabalDir exes - tests' = addCabalDir tests - benches' = addCabalDir benches - - addCabalDir ts = map (\t -> combine cabalDir t) ts - - return (libs',exes',tests',benches') +instance GHC.HasDynFlags RefactGhc where + getDynFlags = GHC.hsc_dflags <$> GHC.getSession -- --------------------------------------------------------------------- --- | Load a module graph into the GHC session, starting from main -loadModuleGraphGhc :: - Maybe [FilePath] -> RefactGhc () -loadModuleGraphGhc maybeTargetFiles = do - -- currentDir <- liftIO getCurrentDirectory - -- liftIO $ warningM "HaRe" $ "loadModuleGraphGhc:maybeTargetFiles=" ++ show (maybeTargetFiles,currentDir) - case maybeTargetFiles of - Just targetFiles -> do - loadTarget targetFiles - -- setTargetFiles [targetFile] - -- void $ GHC.load GHC.LoadAllTargets - - graph <- GHC.getModuleGraph - cgraph <- liftIO $ canonicalizeGraph graph - - let canonMaybe filepath = ghandle handler (canonicalizePath filepath) - where - handler :: SomeException -> IO FilePath - handler _e = return filepath - - ctargetFiles <- liftIO $ mapM canonMaybe targetFiles - - settings <- get - put $ settings { -- rsGraph = (rsGraph settings) ++ [(targetFiles,cgraph)] - rsGraph = (rsGraph settings) ++ [(ctargetFiles,cgraph)] - -- , rsModuleGraph = (rsModuleGraph settings) ++ [(targetFiles,graph)] - , rsModuleGraph = (rsModuleGraph settings) ++ [(ctargetFiles,graph)] - , rsCurrentTarget = maybeTargetFiles - } - - -- logm $ "loadModuleGraphGhc:cgraph=" ++ show (map fst cgraph) - -- logm $ "loadModuleGraphGhc:cgraph=" ++ showGhc graph - - return () - Nothing -> return () - return () - --- --------------------------------------------------------------------- +instance ExceptionMonad (StateT RefactState IO) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) -loadTarget :: [FilePath] -> RefactGhc () -loadTarget targetFiles = do - setTargetFiles targetFiles - -- checkSlowAndSet - void $ GHC.load GHC.LoadAllTargets + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r -- --------------------------------------------------------------------- --- | Make sure the given file is the currently loaded target, and load --- it if not. Assumes that all the module graphs had been generated --- before, so these are not updated. -ensureTargetLoaded :: TargetModule -> RefactGhc GHC.ModSummary -ensureTargetLoaded (target,modSum) = do - settings <- get - let currentTarget = rsCurrentTarget settings - if currentTarget == Just target - then return modSum - else do - logm $ "ensureTargetLoaded: loading:" ++ show target - loadTarget target - put $ settings { rsCurrentTarget = Just target} - graph <- GHC.getModuleGraph - let newModSum = filter (\ms -> GHC.ms_mod modSum == GHC.ms_mod ms) graph - return $ ghead "ensureTargetLoaded" newModSum +cabalModuleGraphs :: RefactGhc [GM.GmModuleGraph] +cabalModuleGraphs = RefactGhc doCabalModuleGraphs + where + doCabalModuleGraphs :: (GM.IOish m) => GM.GhcModT m [GM.GmModuleGraph] + doCabalModuleGraphs = do + mcs <- GM.cabalResolvedComponents + let graph = map GM.gmcHomeModuleGraph $ Map.elems mcs + return $ graph -- --------------------------------------------------------------------- canonicalizeGraph :: - [GHC.ModSummary] -> IO [(Maybe (FilePath), GHC.ModSummary)] + [GHC.ModSummary] -> RefactGhc [(Maybe FilePath, GHC.ModSummary)] canonicalizeGraph graph = do - let mm = map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph + mm' <- mapM canonicalizeModSummary graph + return mm' + +canonicalizeModSummary :: (MonadIO m) => + GHC.ModSummary -> m (Maybe FilePath, GHC.ModSummary) +canonicalizeModSummary modSum = do + let modSum' = (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) modSum canon ((Just fp),m) = do fp' <- canonicalizePath fp return $ (Just fp',m) canon (Nothing,m) = return (Nothing,m) - mm' <- mapM canon mm + mm' <- liftIO $ canon modSum' return mm' -- --------------------------------------------------------------------- -runRefactGhc :: - RefactGhc a -> RefactState -> IO (a, RefactState) -runRefactGhc comp initState = do - runStateT (GHC.runGhcT (Just GHC.libdir) comp) initState - getRefacSettings :: RefactGhc RefactSettings getRefacSettings = do s <- get @@ -350,20 +275,6 @@ -- --------------------------------------------------------------------- -getEnabledTargets :: RefactSettings -> ([FilePath],[FilePath],[FilePath],[FilePath]) -> ([FilePath],[FilePath]) -getEnabledTargets settings (libt,exet,testt,bencht) = (targetsLib,targetsExe) - where - (libEnabled, exeEnabled, testEnabled, benchEnabled) = rsetEnabledTargets settings - targetsLib = on libEnabled libt - targetsExe = on exeEnabled exet - ++ on testEnabled testt - ++ on benchEnabled bencht - - on flag xs = if flag then xs else [] - - --- --------------------------------------------------------------------- - logm :: String -> RefactGhc () logm string = do settings <- getRefacSettings @@ -375,10 +286,12 @@ liftIO $ warningM "HaRe" (string) return () +{- timeStamp :: IO String timeStamp = do k <- getCurrentTime return (show k) +-} -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs --- a/src/Language/Haskell/Refact/Utils/MonadFunctions.hs +++ b/src/Language/Haskell/Refact/Utils/MonadFunctions.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} -- | @@ -11,45 +15,35 @@ ( -- * Conveniences for state access - fetchLinesFinal - , fetchOrigToks - , fetchToks -- Deprecated + fetchAnnsFinal , getTypecheckedModule + , getRefactStreamModified + , setRefactStreamModified + , getRefactInscopes + , getRefactRenamed , putRefactRenamed + , getRefactParsed + , putRefactParsed + + -- * Annotations + -- , addRefactAnns + , setRefactAnns + + -- * , putParsedModule , clearParsedModule , getRefactFileName - - -- * TokenUtils API - , replaceToken - , putToksForSpan - , putDeclToksForSpan - , getToksForSpan - -- , getToksForSpanWithIntros - , getToksBeforeSpan - , putToksForPos - , addToksAfterSpan - , addToksAfterPos - , putDeclToksAfterSpan - , removeToksForSpan - , removeToksForPos - , syncDeclToLatestStash - , indentDeclAndToks - - -- * LayoutUtils API - -- , getLayoutForSpan - -- , putDeclLayoutAfterSpan + , getRefactTargetModule + , getRefactModule + , getRefactModuleName + , getRefactNameMap - -- * For debugging - , drawTokenTree - , drawTokenTreeDetailed - , getTokenTree - -- , showPprDebug - , showLinesDebug + -- * New ghc-exactprint interfacing + , liftT -- * State flags for managing generic traversals , getRefactDone @@ -59,271 +53,56 @@ , setStateStorage , getStateStorage - -- , logm + -- * Parsing source + , parseDeclWithAnns - , updateToks - , updateToksWithPos + -- * Utility + , nameSybTransform, nameSybQuery + , fileNameFromModSummary + , mkNewGhcNamePure + , logDataWithAnns + , logAnns + , logParsedSource + -- * For use by the tests only , initRefactModule + , initTokenCacheLayout + , initRdrNameMap ) where import Control.Monad.State +import Data.List -import qualified FastString as GHC import qualified GHC as GHC +import qualified GhcMonad as GHC +import qualified Module as GHC +import qualified Name as GHC +import qualified Unique as GHC -import qualified Data.Data as SYB +import qualified Data.Generics as SYB -import Language.Haskell.Refact.Utils.GhcVersionSpecific -import Language.Haskell.Refact.Utils.LocUtils +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.Haskell.GHC.ExactPrint.Utils + import Language.Haskell.Refact.Utils.Monad -import Language.Haskell.Refact.Utils.TokenUtils import Language.Haskell.Refact.Utils.TypeSyn -import Language.Haskell.TokenUtils.DualTree -import Language.Haskell.TokenUtils.GHC.Layout -import Language.Haskell.TokenUtils.TokenUtils -import Language.Haskell.TokenUtils.Types -import Language.Haskell.TokenUtils.Utils - +import Language.Haskell.Refact.Utils.Types --- import Data.Time.Clock -import Data.Tree --- import System.Log.Logger import qualified Data.Map as Map -- --------------------------------------------------------------------- --- |fetch the possibly modified tokens. Deprecated -fetchToks :: RefactGhc [PosToken] -fetchToks = do - Just tm <- gets rsModule - let toks = retrieveTokensInterim $ (tkCache $ rsTokenCache tm) Map.! mainTid - -- logm $ "fetchToks" ++ (showToks toks) - logm $ "fetchToks (not showing toks" - return toks - --- |fetch the final tokens in Ppr format -fetchLinesFinal :: RefactGhc [Line PosToken] -fetchLinesFinal = do - Just tm <- gets rsModule - let linesVal = retrieveLinesFromLayoutTree $ (tkCache $ rsTokenCache tm) Map.! mainTid - logm $ "fetchLinesFinal (not showing lines)" - return linesVal - --- |fetch the pristine token stream -fetchOrigToks :: RefactGhc [PosToken] -fetchOrigToks = do - logm "fetchOrigToks" +-- |fetch the final annotations +fetchAnnsFinal :: RefactGhc Anns +fetchAnnsFinal = do Just tm <- gets rsModule - return $ rsOrigTokenStream tm - --- |Get the current tokens for a given GHC.SrcSpan. -getToksForSpan :: GHC.SrcSpan -> RefactGhc [PosToken] -getToksForSpan sspan = do - st <- get - let checkInv = rsetCheckTokenUtilsInvariant $ rsSettings st - let Just tm = rsModule st - let (tk',toks) = getTokensNoIntrosFromCache checkInv (rsTokenCache tm) (gs2ss sspan) - let rsModule' = Just (tm {rsTokenCache = tk'}) - put $ st { rsModule = rsModule' } - logm $ "getToksForSpan " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan,toks)) - return toks - - --- |Get the current tokens preceding a given GHC.SrcSpan. -getToksBeforeSpan :: GHC.SrcSpan -> RefactGhc (ReversedToks PosToken) -getToksBeforeSpan sspan = do - st <- get - let Just tm = rsModule st - let (tk', toks) = getTokensBeforeFromCache (rsTokenCache tm) (gs2ss sspan) - let rsModule' = Just (tm {rsTokenCache = tk'}) - put $ st { rsModule = rsModule' } - logm $ "getToksBeforeSpan " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan,toks)) - return toks - - --- |Replace a token occurring in a given GHC.SrcSpan -replaceToken :: GHC.SrcSpan -> PosToken -> RefactGhc () -replaceToken sspan tok = do - logm $ "replaceToken " ++ (showGhc sspan) ++ ":" ++ (showSrcSpanF sspan) ++ (show tok) - st <- get - let Just tm = rsModule st - - let tk' = replaceTokenInCache (rsTokenCache tm) (gs2ss sspan) tok - let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) - put $ st { rsModule = rsModule' } - return () - --- |Replace the tokens for a given GHC.SrcSpan, return new GHC.SrcSpan --- delimiting new tokens -putToksForSpan :: GHC.SrcSpan -> [PosToken] -> RefactGhc GHC.SrcSpan -putToksForSpan sspan toks = do - logm $ "putToksForSpan " ++ (showGhc sspan) ++ ":" ++ (showSrcSpanF sspan) ++ (show toks) - st <- get - let Just tm = rsModule st - - let (tk',newSpan) = putToksInCache (rsTokenCache tm) (gs2ss sspan) toks - let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) - put $ st { rsModule = rsModule' } - return (ss2gs newSpan) - --- |Replace the tokens for a given GHC.SrcSpan, return new GHC.SrcSpan --- delimiting new tokens, and update the AST fragment to reflect it -putDeclToksForSpan :: (SYB.Data t) => GHC.SrcSpan -> GHC.Located t -> [PosToken] - -> RefactGhc (GHC.SrcSpan,GHC.Located t) -putDeclToksForSpan sspan t toks = do - logm $ "putDeclToksForSpan " ++ (showGhc sspan) ++ ":" ++ (showSrcSpanF sspan) ++ (show toks) - st <- get - let Just tm = rsModule st - let (tk',newSpan,t') = putDeclToksInCache (rsTokenCache tm) sspan toks t - let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) - put $ st { rsModule = rsModule' } - return (newSpan,t') - --- |Replace the tokens for a given GHC.SrcSpan, return GHC.SrcSpan --- they are placed in -putToksForPos :: (SimpPos,SimpPos) -> [PosToken] -> RefactGhc GHC.SrcSpan -putToksForPos pos toks = do - logm $ "putToksForPos " ++ (show pos) ++ (showToks toks) - st <- get - let Just tm = rsModule st - let (tk',newSpan) = putToksInCache (rsTokenCache tm) pos toks - let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True }) - put $ st { rsModule = rsModule' } - -- drawTokenTree "" - return (ss2gs newSpan) - --- |Add tokens after a designated GHC.SrcSpan -addToksAfterSpan :: GHC.SrcSpan -> Positioning -> [PosToken] -> RefactGhc GHC.SrcSpan -addToksAfterSpan oldSpan pos toks = do - logm $ "putToksAfterSpan " ++ (showGhc oldSpan) ++ ":" ++ (showSrcSpanF oldSpan) ++ " at " ++ (show pos) ++ ":" ++ (showToks toks) - st <- get - let Just tm = rsModule st - let (tk',newSpan) = addTokensAfterSpanInCache (rsTokenCache tm) (gs2ss oldSpan) pos toks - let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) - put $ st { rsModule = rsModule' } - return (ss2gs newSpan) - --- |Add tokens after a designated position -addToksAfterPos :: (SimpPos,SimpPos) -> Positioning -> [PosToken] -> RefactGhc GHC.SrcSpan -addToksAfterPos pos position toks = do - logm $ "putToksAfterPos " ++ (show pos) ++ " at " ++ (show position) ++ ":" ++ (show toks) - st <- get - let Just tm = rsModule st - -- let mainForest = (tkCache $ rsTokenCache tm) Map.! mainTid - -- let sspan = posToSrcSpan mainForest pos - let (tk',newSpan) = addTokensAfterSpanInCache (rsTokenCache tm) pos position toks - let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) - put $ st { rsModule = rsModule' } - -- logm $ "putToksAfterPos result:" ++ (show forest') ++ "\ntree:\n" ++ (drawTreeEntry forest') - return (ss2gs newSpan) - --- |Add tokens after a designated GHC.SrcSpan, and update the AST --- fragment to reflect it -putDeclToksAfterSpan :: (SYB.Data t) => GHC.SrcSpan -> GHC.Located t -> Positioning -> [PosToken] -> RefactGhc (GHC.Located t) -putDeclToksAfterSpan oldSpan t pos toks = do - logm $ "putDeclToksAfterSpan " ++ (showGhc oldSpan) ++ ":" ++ (show (showSrcSpanF oldSpan,pos,toks)) - st <- get - let Just tm = rsModule st - let forest = getTreeFromCache (gs2ss oldSpan) (rsTokenCache tm) - let (forest',_newSpan, t') = addDeclToksAfterSrcSpan forest oldSpan pos toks t - let tk' = replaceTreeInCache (gs2ss oldSpan) forest' (rsTokenCache tm) - let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) - put $ st { rsModule = rsModule' } - return t' - --- |Remove a GHC.SrcSpan and its associated tokens -removeToksForSpan :: GHC.SrcSpan -> RefactGhc () -removeToksForSpan sspan = do - logm $ "removeToksForSpan " ++ (showGhc sspan) ++ ":" ++ (showSrcSpanF sspan) - st <- get - let Just tm = rsModule st - let tk' = removeToksFromCache (rsTokenCache tm) (gs2ss sspan) - let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) - put $ st { rsModule = rsModule' } - return () - --- |Remove a GHC.SrcSpan and its associated tokens -removeToksForPos :: (SimpPos,SimpPos) -> RefactGhc () -removeToksForPos pos = do - logm $ "removeToksForPos " ++ (show pos) - st <- get - let Just tm = rsModule st - let mainForest = (tkCache $ rsTokenCache tm) Map.! mainTid - let sspan = posToSrcSpan mainForest pos - let tk' = removeToksFromCache (rsTokenCache tm) (gs2ss sspan) - let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) - put $ st { rsModule = rsModule' } - -- drawTokenTree "removeToksForPos result" - return () - --- --------------------------------------------------------------------- - --- |Print the Token Tree for debug purposes -drawTokenTree :: String -> RefactGhc () -drawTokenTree msg = do - st <- get - let Just tm = rsModule st - logm $ msg ++ "\ncurrent token tree:\n" ++ (drawTokenCache (rsTokenCache tm)) - return () - --- --------------------------------------------------------------------- - --- |Print detailed Token Tree for debug purposes -drawTokenTreeDetailed :: String -> RefactGhc () -drawTokenTreeDetailed msg = do - st <- get - let Just tm = rsModule st - logm $ msg ++ "\ncurrent detailed token tree:\n" ++ (drawTokenCacheDetailed (rsTokenCache tm)) - return () - --- --------------------------------------------------------------------- - --- |Get the Token Tree for debug purposes -getTokenTree :: RefactGhc (Tree (Entry PosToken)) -getTokenTree = do - st <- get - let Just tm = rsModule st - let mainForest = (tkCache $ rsTokenCache tm) Map.! mainTid - return mainForest - --- --------------------------------------------------------------------- - -showLinesDebug :: String -> RefactGhc () -showLinesDebug msg = do - pprVal <- fetchLinesFinal - logm $ msg ++ "\ncurrent [Line]:\n" ++ (showGhc pprVal) - return () - --- --------------------------------------------------------------------- - -syncDeclToLatestStash :: (SYB.Data t) => (GHC.Located t) -> RefactGhc (GHC.Located t) -syncDeclToLatestStash t = do - st <- get - let Just tm = rsModule st - let t' = syncAstToLatestCache (rsTokenCache tm) t - return t' + let anns = (tkCache $ rsTokenCache tm) Map.! mainTid + return anns -- --------------------------------------------------------------------- --- | Indent an AST fragment and its associated tokens by a set amount -indentDeclAndToks :: (SYB.Data t) => (GHC.Located t) -> Int -> RefactGhc (GHC.Located t) -indentDeclAndToks t offset = do - let (GHC.L sspan _) = t - logm $ "indentDeclAndToks " ++ (showGhc sspan) ++ ":" ++ (showSrcSpanF sspan) ++ ",offset=" ++ show offset - st <- get - let Just tm = rsModule st - let tk = rsTokenCache tm - let forest = (tkCache tk) Map.! mainTid - let (t',forest') = indentDeclToks syncAST t forest offset - let tk' = tk {tkCache = Map.insert mainTid forest' (tkCache tk) } - let rsModule' = Just (tm {rsTokenCache = tk', rsStreamModified = True}) - put $ st { rsModule = rsModule' } - -- drawTokenTree "indentDeclToks result" - return t' - - getTypecheckedModule :: RefactGhc GHC.TypecheckedModule getTypecheckedModule = do mtm <- gets rsModule @@ -331,11 +110,19 @@ Just tm -> return $ rsTypecheckedMod tm Nothing -> error "HaRe: file not loaded for refactoring" -getRefactStreamModified :: RefactGhc Bool +getRefactStreamModified :: RefactGhc RefacResult getRefactStreamModified = do Just tm <- gets rsModule return $ rsStreamModified tm +-- |For testing +setRefactStreamModified :: RefacResult -> RefactGhc () +setRefactStreamModified rr = do + st <- get + let (Just tm) = rsModule st + put $ st { rsModule = Just (tm { rsStreamModified = rr })} + return () + getRefactInscopes :: RefactGhc InScopes getRefactInscopes = GHC.getNamesInScope @@ -364,30 +151,197 @@ let pm = GHC.tm_parsed_module t return $ GHC.pm_parsed_source pm -putParsedModule - :: GHC.TypecheckedModule -> [PosToken] -> RefactGhc () -putParsedModule tm toks = do +putRefactParsed :: GHC.ParsedSource -> Anns -> RefactGhc () +putRefactParsed parsed newAnns = do st <- get - put $ st { rsModule = initRefactModule tm toks } + mrm <- gets rsModule + let rm = gfromJust "putRefactParsed" mrm + let tm = rsTypecheckedMod rm + -- let tk' = modifyAnns (rsTokenCache rm) (const newAnns) + let tk' = modifyAnns (rsTokenCache rm) (mergeAnns newAnns) + let pm = (GHC.tm_parsed_module tm) { GHC.pm_parsed_source = parsed } + let tm' = tm { GHC.tm_parsed_module = pm } + let rm' = rm { rsTypecheckedMod = tm', rsTokenCache = tk', rsStreamModified = RefacModified } + put $ st {rsModule = Just rm'} + +-- --------------------------------------------------------------------- + +-- |Internal low level interface to access the current annotations from the +-- RefactGhc state. +getRefactAnns :: RefactGhc Anns +getRefactAnns = + (Map.! mainTid) . tkCache . rsTokenCache . gfromJust "getRefactAnns" + <$> gets rsModule + +-- |Internal low level interface to access the current annotations from the +-- RefactGhc state. +setRefactAnns :: Anns -> RefactGhc () +setRefactAnns anns = modifyRefactAnns (const anns) + +-- |Internal low level interface to access the current annotations from the +-- RefactGhc state. +modifyRefactAnns :: (Anns -> Anns) -> RefactGhc () +modifyRefactAnns f = do + st <- get + mrm <- gets rsModule + let rm = gfromJust "modifyRefactAnns" mrm + let tk' = modifyAnns (rsTokenCache rm) f + let rm' = rm { rsTokenCache = tk', rsStreamModified = RefacModified } + put $ st {rsModule = Just rm'} + +-- |Internal low level interface to access the current annotations from the +-- RefactGhc state. +modifyAnns :: TokenCache Anns -> (Anns -> Anns) -> TokenCache Anns +modifyAnns tk f = tk' + where + anns = (tkCache tk) Map.! mainTid + tk' = tk {tkCache = Map.insert mainTid + (f anns) + (tkCache tk) } + +-- ---------------------------------------------------------------------- + +putParsedModule :: GHC.TypecheckedModule -> RefactGhc () +putParsedModule tm = do + st <- get + put $ st { rsModule = initRefactModule tm } + clearParsedModule :: RefactGhc () clearParsedModule = do st <- get put $ st { rsModule = Nothing } +-- --------------------------------------------------------------------- +{- +-- |Replace the Located RdrName in the ParsedSource +replaceRdrName :: GHC.Located GHC.RdrName -> RefactGhc () +replaceRdrName (GHC.L l newName) = do + -- ++AZ++ TODO: move this body to somewhere appropriate + logm $ "replaceRdrName:" ++ showGhcQual (l,newName) + parsed <- getRefactParsed + anns <- getRefactAnns + logm $ "replaceRdrName:before:parsed=" ++ showGhc parsed + let replaceRdr :: GHC.Located GHC.RdrName -> State Anns (GHC.Located GHC.RdrName) + replaceRdr old@(GHC.L ln _) + | l == ln = do + an <- get + let new = (GHC.L l newName) + put $ replaceAnnKey old new an + return new + replaceRdr x = return x + + replaceHsVar :: GHC.LHsExpr GHC.RdrName -> State Anns (GHC.LHsExpr GHC.RdrName) + replaceHsVar (GHC.L ln (GHC.HsVar _)) + | l == ln = return (GHC.L l (GHC.HsVar newName)) + replaceHsVar x = return x + + replaceHsTyVar (GHC.L ln (GHC.HsTyVar _)) + | l == ln = return (GHC.L l (GHC.HsTyVar newName)) + replaceHsTyVar x = return x + + replacePat (GHC.L ln (GHC.VarPat _)) + | l == ln = return (GHC.L l (GHC.VarPat newName)) + replacePat x = return x + + fn :: State Anns GHC.ParsedSource + fn = do + r <- SYB.everywhereM (SYB.mkM replaceRdr + `SYB.extM` replaceHsTyVar + `SYB.extM` replaceHsVar + `SYB.extM` replacePat) parsed + return r + (parsed',anns') = runState fn anns + logm $ "replaceRdrName:after:parsed'=" ++ showGhc parsed' + putRefactParsed parsed' emptyAnns + setRefactAnns anns' + return () +-} + -- --------------------------------------------------------------------- +refactRunTransformId :: Transform a -> RefactGhc a +refactRunTransformId transform = do + u <- gets rsUniqState + ans <- getRefactAnns + let (a,(ans',u'),logLines) = runTransformFrom u ans transform + putUnique u' + setRefactAnns ans' + when (not (null logLines)) $ do + logm $ intercalate "\n" logLines + return a + +-- --------------------------------------------------------------------- + +instance HasTransform RefactGhc where + liftT = refactRunTransformId + +-- --------------------------------------------------------------------- + +putUnique :: Int -> RefactGhc () +putUnique u = do + s <- get + put $ s { rsUniqState = u } + +-- --------------------------------------------------------------------- + +getRefactTargetModule :: RefactGhc TargetModule +getRefactTargetModule = do + mt <- gets rsCurrentTarget + case mt of + Nothing -> error $ "HaRe:getRefactTargetModule:no module loaded" + Just t -> return t + +-- --------------------------------------------------------------------- + getRefactFileName :: RefactGhc (Maybe FilePath) getRefactFileName = do mtm <- gets rsModule case mtm of Nothing -> return Nothing - Just _tm -> do toks <- fetchOrigToks - return $ Just (GHC.unpackFS $ fileNameFromTok $ ghead "getRefactFileName" toks) + Just tm -> return $ Just (fileNameFromModSummary $ GHC.pm_mod_summary + $ GHC.tm_parsed_module $ rsTypecheckedMod tm) -- --------------------------------------------------------------------- +fileNameFromModSummary :: GHC.ModSummary -> FilePath +fileNameFromModSummary modSummary = fileName + where + -- TODO: what if we are loading a compiled only client and do not + -- have the original source? + Just fileName = GHC.ml_hs_file (GHC.ms_location modSummary) + +-- --------------------------------------------------------------------- + +getRefactModule :: RefactGhc GHC.Module +getRefactModule = do + mtm <- gets rsModule + case mtm of + Nothing -> error $ "Hare.MonadFunctions.getRefactModule:no module loaded" + Just tm -> do + let t = rsTypecheckedMod tm + let pm = GHC.tm_parsed_module t + return (GHC.ms_mod $ GHC.pm_mod_summary pm) + +-- --------------------------------------------------------------------- + +getRefactModuleName :: RefactGhc GHC.ModuleName +getRefactModuleName = do + modu <- getRefactModule + return $ GHC.moduleName modu + +-- --------------------------------------------------------------------- + +getRefactNameMap :: RefactGhc NameMap +getRefactNameMap = do + mtm <- gets rsModule + case mtm of + Nothing -> error $ "Hare.MonadFunctions.getRefacNameMap:no module loaded" + Just tm -> return (rsNameMap tm) + +-- --------------------------------------------------------------------- + getRefactDone :: RefactGhc Bool getRefactDone = do flags <- gets rsFlags @@ -420,54 +374,185 @@ -- --------------------------------------------------------------------- +logDataWithAnns :: (SYB.Data a) => String -> a -> RefactGhc () +logDataWithAnns str ast = do + anns <- getRefactAnns + logm $ str ++ showAnnData anns 0 ast + +-- --------------------------------------------------------------------- + +logAnns :: String -> RefactGhc () +logAnns str = do + anns <- getRefactAnns + logm $ str ++ showGhc anns + +-- --------------------------------------------------------------------- + +logParsedSource :: String -> RefactGhc () +logParsedSource str = do + parsed <- getRefactParsed + logDataWithAnns str parsed + +-- --------------------------------------------------------------------- + initRefactModule - :: GHC.TypecheckedModule -> [PosToken] -> Maybe RefactModule -initRefactModule tm toks + :: GHC.TypecheckedModule -> Maybe RefactModule +initRefactModule tm = Just (RefMod { rsTypecheckedMod = tm - , rsOrigTokenStream = toks - -- , rsTokenCache = initTokenCacheLayout (initTokenLayout - , rsTokenCache = initTokenCacheLayout (allocTokens + , rsNameMap = initRdrNameMap tm + , rsTokenCache = initTokenCacheLayout (relativiseApiAnns (GHC.pm_parsed_source $ GHC.tm_parsed_module tm) - toks) - , rsStreamModified = False + (GHC.pm_annotations $ GHC.tm_parsed_module tm)) + , rsStreamModified = RefacUnmodifed }) + +initTokenCacheLayout :: a -> TokenCache a +initTokenCacheLayout a = TK (Map.fromList [((TId 0),a)]) (TId 0) + -- --------------------------------------------------------------------- -updateToks :: (SYB.Data t) - => GHC.Located t -- ^ Old element - -> GHC.Located t -- ^ New element - -> (GHC.Located t -> [Char]) -- ^ pretty printer - -> Bool -- ^ Add trailing newline if required - -> RefactGhc () -- ^ Updates the RefactState -updateToks (GHC.L sspan _) newAST printFun addTrailingNl - = do - logm $ "updateToks " ++ (showGhc sspan) ++ ":" ++ (show (showSrcSpanF sspan)) - let newToks = basicTokenise (printFun newAST) - let newToks' = if addTrailingNl - then newToks ++ [newLnToken (last newToks)] - else newToks - void $ putToksForSpan sspan newToks' - return () +-- |We need the ParsedSource because it more closely reflects the actual source +-- code, but must be able to work with the renamed representation of the names +-- involved. This function constructs a map from every Located RdrName in the +-- ParsedSource to its corresponding name in the RenamedSource. It also deals +-- with the wrinkle that we need to Location of the RdrName to make sure we have +-- the right Name, but not all RdrNames have a Location. +-- This function is called before the RefactGhc monad is active. +initRdrNameMap :: GHC.TypecheckedModule -> NameMap +initRdrNameMap tm = r + where + parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module tm + renamed = gfromJust "initRdrNameMap" $ GHC.tm_renamed_source tm + checkRdr :: GHC.Located GHC.RdrName -> Maybe [(GHC.SrcSpan,GHC.RdrName)] + checkRdr (GHC.L l n@(GHC.Unqual _)) = Just [(l,n)] + checkRdr (GHC.L l n@(GHC.Qual _ _)) = Just [(l,n)] + checkRdr (GHC.L _ _)= Nothing + + checkName :: GHC.Located GHC.Name -> Maybe [GHC.Located GHC.Name] + checkName ln = Just [ln] + + rdrNames = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkRdr ) parsed + names = gfromJust "initRdrNameMap" $ SYB.everything mappend (nameSybQuery checkName) renamed + + nameMap = Map.fromList $ map (\(GHC.L l n) -> (l,n)) names + + -- If the name does not exist (e.g. a TH Splice that has been expanded, make a new one) + -- No attempt is made to make sure that equivalent ones have equivalent names. + lookupName l n i = case Map.lookup l nameMap of + Just v -> v + Nothing -> case n of + GHC.Unqual u -> mkNewGhcNamePure 'h' i Nothing (GHC.occNameString u) + GHC.Qual q u -> mkNewGhcNamePure 'h' i (Just (GHC.Module (GHC.stringToPackageKey "") q)) (GHC.occNameString u) + _ -> error "initRdrNameMap:should not happen" + + r = Map.fromList $ map (\((l,n),i) -> (l,lookupName l n i)) $ zip rdrNames [1..] + -- --------------------------------------------------------------------- -updateToksWithPos :: (SYB.Data t) - => (SimpPos, SimpPos) -- ^Start and end pos of old element - -> t -- ^ New element - -> (t -> [Char]) -- ^ pretty printer - -> Bool -- ^ Add trailing newline if required - -> RefactGhc () -- ^ Updates the RefactState -updateToksWithPos (startPos,endPos) newAST printFun addTrailingNl - = do - -- newToks <- liftIO $ basicTokenise (printFun newAST) - let newToks = basicTokenise (printFun newAST) - let newToks' = if addTrailingNl - then newToks ++ [newLnToken (last newToks)] - else newToks - void $ putToksForPos (startPos,endPos) newToks' +mkNewGhcNamePure :: Char -> Int -> Maybe GHC.Module -> String -> GHC.Name +mkNewGhcNamePure c i maybeMod name = + let un = GHC.mkUnique c i -- H for HaRe :) + n = case maybeMod of + Nothing -> GHC.mkInternalName un (GHC.mkVarOcc name) GHC.noSrcSpan + Just modu -> GHC.mkExternalName un modu (GHC.mkVarOcc name) GHC.noSrcSpan + in n - return () +-- --------------------------------------------------------------------- + +nameSybTransform :: (Monad m,SYB.Typeable t) + => (GHC.Located GHC.RdrName -> m (GHC.Located GHC.RdrName)) -> t -> m t +nameSybTransform changer = q + where + q = SYB.mkM worker + `SYB.extM` workerBind + `SYB.extM` workerExpr + `SYB.extM` workerLIE + `SYB.extM` workerHsTyVarBndr + `SYB.extM` workerLHsType + + worker (pnt :: (GHC.Located GHC.RdrName)) + = changer pnt + + workerBind (GHC.L l (GHC.VarPat name)) + = do + (GHC.L _ n) <- changer (GHC.L l name) + return (GHC.L l (GHC.VarPat n)) + workerBind x = return x + + workerExpr ((GHC.L l (GHC.HsVar name))) + = do + (GHC.L _ n) <- changer (GHC.L l name) + return (GHC.L l (GHC.HsVar n)) + workerExpr x = return x + + workerLIE ((GHC.L l (GHC.IEVar (GHC.L ln name))) :: (GHC.LIE GHC.RdrName)) + = do + (GHC.L _ n) <- changer (GHC.L ln name) + return (GHC.L l (GHC.IEVar (GHC.L ln n))) + workerLIE x = return x + + workerHsTyVarBndr (GHC.L l (GHC.UserTyVar name)) + = do + (GHC.L _ n) <- changer (GHC.L l name) + return (GHC.L l (GHC.UserTyVar n)) + workerHsTyVarBndr x = return x + + workerLHsType (GHC.L l (GHC.HsTyVar name)) + = do + (GHC.L _ n) <- changer (GHC.L l name) + return (GHC.L l (GHC.HsTyVar n)) + workerLHsType x = return x + +-- --------------------------------------------------------------------- + +nameSybQuery :: (SYB.Typeable a, SYB.Typeable t) + => (GHC.Located a -> Maybe r) -> t -> Maybe r +nameSybQuery checker = q + where + q = Nothing `SYB.mkQ` worker + `SYB.extQ` workerBind + `SYB.extQ` workerExpr + `SYB.extQ` workerLIE + `SYB.extQ` workerHsTyVarBndr + `SYB.extQ` workerLHsType + + worker (pnt :: (GHC.Located a)) + = checker pnt + + workerBind (GHC.L l (GHC.VarPat name)) + = checker (GHC.L l name) + workerBind _ = Nothing + + workerExpr ((GHC.L l (GHC.HsVar name))) + = checker (GHC.L l name) + workerExpr _ = Nothing + + workerLIE ((GHC.L _l (GHC.IEVar (GHC.L ln name))) :: (GHC.LIE a)) + = checker (GHC.L ln name) + workerLIE _ = Nothing + + workerHsTyVarBndr ((GHC.L l (GHC.UserTyVar name))) + = checker (GHC.L l name) + workerHsTyVarBndr _ = Nothing + + workerLHsType ((GHC.L l (GHC.HsTyVar name))) + = checker (GHC.L l name) + workerLHsType _ = Nothing + +-- --------------------------------------------------------------------- + +parseDeclWithAnns :: String -> RefactGhc (GHC.LHsDecl GHC.RdrName) +parseDeclWithAnns src = do + let label = " parseDecl df label src) + case r of + Left err -> error (show err) + Right (anns,decl) -> do + -- addRefactAnns anns + liftT $ modifyAnnsT (mergeAnns anns) + return decl -- EOF diff --git a/src/Language/Haskell/Refact/Utils/TokenUtils.hs b/src/Language/Haskell/Refact/Utils/TokenUtils.hs deleted file mode 100644 --- a/src/Language/Haskell/Refact/Utils/TokenUtils.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | --- --- This module contains an API to manage a token stream. --- --- This API is used internally by MonadFunctions and the other utility --- modules, it should probably never be used directly in a refactoring. - -module Language.Haskell.Refact.Utils.TokenUtils ( - -- * Operations at 'TokenCache' level - putDeclToksInCache - , syncAstToLatestCache - - -- * Operations at 'Tree' 'Entry' level - , addDeclToksAfterSrcSpan - , syncAST - - -- * Utility - , posToSrcSpan - , posToSrcSpanTok - - -- * Internal, for testing - , nonCommentSpan - , showSrcSpan - , showSrcSpanF - , ghcSpanStartEnd - , stripForestLineFromGhc - , ghcSrcSpanToForestSpan - , deleteGapsToks - ) where - --- import qualified FastString as GHC -import qualified GHC as GHC - -import qualified Data.Generics as SYB -import qualified GHC.SYB.Utils as SYB - -import Language.Haskell.Refact.Utils.GhcUtils -import Language.Haskell.Refact.Utils.LocUtils -import Language.Haskell.Refact.Utils.TypeSyn - -import Language.Haskell.TokenUtils.GHC.Layout -import Language.Haskell.TokenUtils.TokenUtils -import Language.Haskell.TokenUtils.Types -import Language.Haskell.TokenUtils.Utils - -import Data.Tree -import qualified Data.Map as Map - --- import Debug.Trace --- debug = flip trace - --- --------------------------------------------------------------------- - -ghcSrcSpanToForestSpan :: GHC.SrcSpan -> ForestSpan -ghcSrcSpanToForestSpan sspan = ((ghcLineToForestLine startRow,startCol),(ghcLineToForestLine endRow,endCol)) - where - (startRow,startCol) = getGhcLoc sspan - (endRow,endCol) = getGhcLocEnd sspan - --- --------------------------------------------------------------------- - -putDeclToksInCache :: (SYB.Data t) => - TokenCache PosToken -> GHC.SrcSpan -> [PosToken] -> GHC.Located t - -> (TokenCache PosToken,GHC.SrcSpan,GHC.Located t) -putDeclToksInCache tk sspan toks t = (tk'',ss2gs newSpan,t') - where - (tk'',newSpan) = putToksInCache tk (gs2ss sspan) toks - t' = syncAST t (ss2f newSpan) - --- --------------------------------------------------------------------- - --- |Assuming most recent operation has stashed the old tokens, sync --- the given AST to the most recent stash entry -syncAstToLatestCache :: (SYB.Data t) => TokenCache PosToken -> GHC.Located t -> GHC.Located t -syncAstToLatestCache tk t = t' - where - mainForest = (tkCache tk) Map.! mainTid - (Node (Entry fspan _ _) _) = (tkCache tk) Map.! (tkLastTreeId tk) - pos = forestSpanToGhcPos fspan - sspan = posToSrcSpan mainForest pos - t' = syncAST t (gs2f sspan) - --- --------------------------------------------------------------------- - --- | Process the leaf nodes of a tree to remove all deleted spans -deleteGapsToks :: [Entry PosToken] -> [PosToken] -deleteGapsToks toks = goDeleteGapsToks (0,0) toks - -goDeleteGapsToks :: SimpPos -> [Entry PosToken] -> [PosToken] -goDeleteGapsToks _ [] = [] -goDeleteGapsToks offset [Entry _ _ t] = map (increaseSrcSpan offset) t -goDeleteGapsToks _ [Deleted _ _ _] = [] -goDeleteGapsToks offset (Deleted _ _ _:ts) = goDeleteGapsToks offset ts -goDeleteGapsToks offset [Entry _ _ t,Deleted _ _ _] = map (increaseSrcSpan offset) t -goDeleteGapsToks offset (Entry _ _ t1:e@(Entry _ _ _):ts) = (map (increaseSrcSpan offset) t1) ++goDeleteGapsToks offset (e:ts) -goDeleteGapsToks (fr,fc) (Entry ss _lay1 t1:Deleted _ _ eg:t2:ts) - = t1' ++ goDeleteGapsToks offset' (t2:ts) - where - -- TODO: use actual first and last toks, may be comments - -- TODO: what about deletion within a line? - - (deltaR,_deltaC) = eg - (_,(sr,_sc)) = forestSpanToSimpPos ss - ((dr,_dc),_) = forestSpanToSimpPos $ forestSpanFromEntry t2 - offset' = (fr + (sr - dr) + deltaR, fc) - - t1' = map (increaseSrcSpan (fr,fc)) t1 - --- --------------------------------------------------------------------- - -stripForestLineFromGhc :: GHC.SrcSpan -> GHC.SrcSpan -stripForestLineFromGhc l = l' - where - ((ForestLine _ _ _ ls,_),(_,_)) = ghcSrcSpanToForestSpan l - l' = insertForestLineInSrcSpan (ForestLine False 0 0 ls) l - --- --------------------------------------------------------------------- - --- |Add new tokens belonging to an AST fragment after a given SrcSpan, --- and re-sync the AST fragment to match the new location -addDeclToksAfterSrcSpan :: (SYB.Data t) => - Tree (Entry PosToken) -- ^TokenTree to be modified - -> GHC.SrcSpan -- ^Preceding location for new tokens - -> Positioning - -> [PosToken] -- ^New tokens to be added - -> GHC.Located t -- ^Declaration the tokens belong to, to be synced - -> (Tree (Entry PosToken), GHC.SrcSpan,GHC.Located t) -- ^ updated TokenTree ,SrcSpan location for - -- -> (Tree (Entry PosToken), GHC.SrcSpan,t) -- ^ updated TokenTree ,SrcSpan location for - -- the new tokens in the TokenTree, and - -- updated AST element -addDeclToksAfterSrcSpan forest oldSpan pos toks t = (forest',(ss2gs newSpan),t') - where - (forest',newSpan) = addToksAfterSrcSpan forest (gs2ss oldSpan) pos toks - t' = syncAST t (ss2f newSpan) - --- --------------------------------------------------------------------- - --- |Convert a simple (start,end) position to a SrcSpan belonging to --- the file in the tree -posToSrcSpan :: Tree (Entry PosToken) -> (SimpPos,SimpPos) -> GHC.SrcSpan -posToSrcSpan forest ((rs,cs),(re,ce)) = sspan - where - (GHC.L l _,_) = ghead "posToSrcSpan" $ retrieveTokensInterim forest -- ++AZ++ Ouch, performance?? - sspan = case l of - GHC.RealSrcSpan ss -> - let - locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) rs cs - locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) re ce - in - GHC.mkSrcSpan locStart locEnd - _ -> error "posToSrcSpan: invalid SrcSpan in first tok" - --- --------------------------------------------------------------------- - --- |Convert a simple (start,end) position to a SrcSpan belonging to --- the file in the given token -posToSrcSpanTok :: PosToken -> (SimpPos,SimpPos) -> GHC.SrcSpan -posToSrcSpanTok tok ((rs,cs),(re,ce)) = sspan - where - (GHC.L l _,_) = tok - sspan = case l of - GHC.RealSrcSpan ss -> - let - locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) rs cs - locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) re ce - in - GHC.mkSrcSpan locStart locEnd - _ -> error "posToSrcSpan: invalid SrcSpan in first tok" - --- --------------------------------------------------------------------- -{- --- |Get the start and end position of a SrcSpan --- spanStartEnd :: GHC.SrcSpan -> (SimpPos,SimpPos) --- spanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan) -spanStartEnd :: GHC.SrcSpan -> ForestSpan -spanStartEnd sspan = ((ghcLineToForestLine sr,sc),(ghcLineToForestLine er,ec)) - where - ((sr,sc),(er,ec)) = (getGhcLoc sspan,getGhcLocEnd sspan) --} --- --------------------------------------------------------------------- - -ghcSpanStartEnd :: GHC.SrcSpan -> ((Int, Int), (Int, Int)) -ghcSpanStartEnd sspan = (getGhcLoc sspan,getGhcLocEnd sspan) - --- --------------------------------------------------------------------- - --- |Synchronise a located AST fragment to use a newly created SrcSpan --- in the token tree. --- TODO: Should this indent the tokens as well? -syncAST :: (SYB.Data t) - => GHC.Located t -- ^The AST (or fragment) - -> ForestSpan -- ^The SrcSpan created in the Tree (Entry PosToken) - -> (GHC.Located t) -- ^Updated AST and tokens -syncAST ast@(GHC.L l _t) fspan = GHC.L sspan xx - where - sspan = f2gs fspan - (( sr, sc),( _er, _ec)) = ghcSpanStartEnd l - ((nsr,nsc),(_ner,_nec)) = ghcSpanStartEnd sspan - - rowOffset = nsr - sr - colOffset = nsc - sc - - -- TODO: take cognizance of the ForestLines encoded in srcspans - -- when calculating the offsets etc - syncSpan s = addOffsetToSrcSpan (rowOffset,colOffset) s - - (GHC.L _s xx) = everywhereStaged SYB.Renamer ( - SYB.mkT hsbindlr - `SYB.extT` sig - `SYB.extT` ty - `SYB.extT` name - `SYB.extT` lhsexpr - `SYB.extT` lpat - `SYB.extT` limportdecl - `SYB.extT` lmatch - ) ast - - hsbindlr (GHC.L s b) = (GHC.L (syncSpan s) b) :: GHC.Located (GHC.HsBindLR GHC.Name GHC.Name) - sig (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LSig GHC.Name - ty (GHC.L s typ) = (GHC.L (syncSpan s) typ) :: (GHC.LHsType GHC.Name) - name (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.Located GHC.Name - lhsexpr (GHC.L s e) = (GHC.L (syncSpan s) e) :: GHC.LHsExpr GHC.Name - lpat (GHC.L s p) = (GHC.L (syncSpan s) p) :: GHC.LPat GHC.Name - limportdecl (GHC.L s n) = (GHC.L (syncSpan s) n) :: GHC.LImportDecl GHC.Name - lmatch (GHC.L s m) = (GHC.L (syncSpan s) m) :: GHC.LMatch GHC.Name - --- --------------------------------------------------------------------- - -addOffsetToSrcSpan :: (Int,Int) -> GHC.SrcSpan -> GHC.SrcSpan -addOffsetToSrcSpan (lineOffset,colOffset) sspan = sspan' - where - sspan' = case sspan of - GHC.RealSrcSpan ss -> - let - locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanStartLine ss) (colOffset + GHC.srcSpanStartCol ss) - locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) (lineOffset + GHC.srcSpanEndLine ss) (colOffset + GHC.srcSpanEndCol ss) - in - GHC.mkSrcSpan locStart locEnd - _ -> sspan - --- --------------------------------------------------------------------- - --- EOF diff --git a/src/Language/Haskell/Refact/Utils/TypeSyn.hs b/src/Language/Haskell/Refact/Utils/TypeSyn.hs --- a/src/Language/Haskell/Refact/Utils/TypeSyn.hs +++ b/src/Language/Haskell/Refact/Utils/TypeSyn.hs @@ -18,12 +18,8 @@ type HsDeclsP = GHC.HsGroup GHC.Name --- type InScopes=((Relations.Rel Names.QName (Ents.Ent PosName.Id))) type InScopes = [GHC.Name] --- Additions for GHC -type PosToken = (GHC.Located GHC.Token, String) - type Export = GHC.LIE GHC.RdrName -- --------------------------------------------------------------------- @@ -53,22 +49,23 @@ instance GHC.Outputable GHC.NameSpace where ppr x = GHC.text $ show x -instance GHC.Outputable (GHC.MatchGroup GHC.Name) where - ppr (GHC.MatchGroup ms _ptctyp) = GHC.text "MatchGroup" GHC.<+> GHC.ppr ms +instance GHC.Outputable (GHC.MatchGroup GHC.Name (GHC.LHsExpr GHC.Name)) where + ppr (GHC.MG ms _ _ _) = GHC.text "MatchGroup" GHC.<+> GHC.ppr ms -instance GHC.Outputable (GHC.Match GHC.Name) where - ppr (GHC.Match pats mtyp grhs) = GHC.text "Match" GHC.<+> GHC.ppr pats + +instance GHC.Outputable (GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) where + ppr (GHC.Match _fn pats mtyp grhs) = GHC.text "Match" GHC.<+> GHC.ppr pats GHC.<+> GHC.ppr mtyp GHC.<+> GHC.ppr grhs -instance GHC.Outputable (GHC.GRHSs GHC.Name) where +instance GHC.Outputable (GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name)) where ppr (GHC.GRHSs grhss binds) = GHC.text "GRHSs" GHC.<+> GHC.ppr grhss GHC.<+> GHC.ppr binds -instance GHC.Outputable (GHC.GRHS GHC.Name) where +instance GHC.Outputable (GHC.GRHS GHC.Name (GHC.LHsExpr GHC.Name)) where ppr (GHC.GRHS guards rhs) = GHC.text "GRHS" GHC.<+> GHC.ppr guards GHC.<+> GHC.ppr rhs @@ -84,9 +81,11 @@ GHC.<+> GHC.ppr typ GHC.<+> GHC.ppr doc +instance GHC.Outputable (GHC.TyFamEqn GHC.Name (GHC.LHsTyVarBndrs GHC.Name)) where + ppr (GHC.TyFamEqn name pats rhs) = GHC.text "TyFamEqn" + GHC.<+> GHC.ppr name + GHC.<+> GHC.ppr pats + GHC.<+> GHC.ppr rhs -- --------------------------------------------------------------------- --- type HsModuleP = GHC.Located (GHC.HsModule GHC.RdrName) - --- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/TypeUtils.hs b/src/Language/Haskell/Refact/Utils/TypeUtils.hs --- a/src/Language/Haskell/Refact/Utils/TypeUtils.hs +++ b/src/Language/Haskell/Refact/Utils/TypeUtils.hs @@ -1,4277 +1,2288 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - --------------------------------------------------------------------------------- --- Module : TypeUtils - --- Maintainer : refactor-fp\@kent.ac.uk --- | --- --- This module contains a collection of program analysis and --- transformation functions (the API) that work over the Type --- Decorated AST. Most of the functions defined in the module are --- taken directly from the API, but in some cases are modified to work --- with the type decorated AST. --- --- In particular some new functions have been added to make type --- decorated AST traversals easier. --- --- 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. --- --- This type decorated API is still in development. Any suggestions --- and comments are very much welcome. - - --------------------------------------------------------------------------------- -module Language.Haskell.Refact.Utils.TypeUtils - ( - -- * Program Analysis - -- ** Imports and exports - inScopeInfo, isInScopeAndUnqualified, isInScopeAndUnqualifiedGhc, inScopeNames - , isExported, isExplicitlyExported, modIsExported - - -- ** Variable analysis - , isFieldName - , isClassName - , isInstanceName - ,hsPNs - ,isDeclaredIn - ,hsFreeAndDeclaredPNsOld - ,hsFreeAndDeclaredNameStrings - ,hsFreeAndDeclaredPNs - ,hsFreeAndDeclaredGhc - ,getDeclaredTypes - ,getFvs, getFreeVars, getDeclaredVars - ,hsVisiblePNs, hsVisibleNames - ,hsFDsFromInside, hsFDNamesFromInside - ,hsVisibleDs - - -- ** Property checking - ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName - ,isQualifiedPN, isFunOrPatName, isTypeSig - ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind - ,isComplexPatBind,isFunOrPatBindP,isFunOrPatBindR - ,usedWithoutQualR,isUsedInRhs - - -- ** Getting - ,findPNT,findPN,findAllNameOccurences - ,findPNs, findEntity, findEntity' - ,findIdForName - ,getTypeForName - - ,sameOccurrence - ,defines, definesP,definesTypeSig - -- ,HasModName(hasModName), HasNameSpace(hasNameSpace) - ,sameBind - {- ,usedByRhs -},UsedByRhs(..) - - -- ** Modules and files - -- ,clientModsAndFiles,serverModsAndFiles,isAnExistingMod - -- ,fileNameToModName, strToModName, modNameToStr - , isMainModule - , getModule - - -- ** Locations - ,defineLoc, useLoc, locToExp - ,locToName, locToRdrName - ,getName - - -- * Program transformation - -- ** Adding - ,addDecl, addItemsToImport, addHiding - ,addParamsToDecls, addActualParamsToRhs, addImportDecl, duplicateDecl - -- ** Removing - ,rmDecl, rmTypeSig, rmTypeSigs -- , commentOutTypeSig, rmParams - -- ,rmItemsFromExport, rmSubEntsFromExport, Delete(delete) - - -- ** Updating - -- ,Update(update) - {- ,qualifyPName-},rmQualifier,qualifyToplevelName,renamePN {- ,replaceNameInPN -},autoRenameLocalVar - - -- * Miscellous - -- ** Parsing, writing and showing - {- ,parseSourceFile,writeRefactoredFiles-}, showEntities,showPNwithLoc -- , newProj, addFile, chase - -- ** Locations - -- ,toRelativeLocs, rmLocs - -- ** Default values - ,defaultPN {- ,defaultPNT -},defaultName {-,defaultModName-},defaultExp -- ,defaultPat, defaultExpUnTyped - - - -- ** Identifiers, expressions, patterns and declarations - ,ghcToPN,lghcToPN, expToName - ,nameToString - {- ,expToPNT, expToPN, nameToExp,pNtoExp -},patToPNT {- , patToPN --, nameToPat -},pNtoPat - {- ,definingDecls -}, definedPNs - , definingDeclsNames, definingDeclsNames', definingSigsNames - , definingTyClDeclsNames - , allNames - -- ,simplifyDecl - - -- ** Others - , mkRdrName,mkNewGhcName,mkNewName,mkNewToplevelName - - -- The following functions are not in the the API yet. - , causeNameClashInExports {- , inRegion , unmodified -} - - , removeOffset - - -- * Typed AST traversals (added by CMB) - -- * Miscellous - -- ,removeFromInts, getDataName, checkTypes, getPNs, getPN, getPNPats, mapASTOverTAST - - -- * Debug stuff - , getDeclAndToks, getSigAndToks - , getToksForDecl, removeToksOffset -- ++AZ++ remove this after debuggging - , getParsedForRenamedLPat - , getParsedForRenamedName - , getParsedForRenamedLocated - -- , allPNT - -- , allPNTLens - -- , newNameTok - , stripLeadingSpaces - -- , lookupNameGhc - ) where - --- import Control.Monad.IO.Class () -import Control.Monad.State -import Data.Char -import Data.List -import Data.Maybe -import Data.Monoid -import Exception - -import Language.Haskell.Refact.Utils.Binds -import Language.Haskell.Refact.Utils.GhcUtils -import Language.Haskell.Refact.Utils.GhcVersionSpecific -import Language.Haskell.Refact.Utils.LocUtils -import Language.Haskell.Refact.Utils.Monad -import Language.Haskell.Refact.Utils.MonadFunctions -import Language.Haskell.Refact.Utils.TokenUtils -import Language.Haskell.Refact.Utils.TypeSyn - -import Language.Haskell.TokenUtils.GHC.Layout -import Language.Haskell.TokenUtils.TokenUtils -import Language.Haskell.TokenUtils.Types -import Language.Haskell.TokenUtils.Utils - --- Modules from GHC -import qualified Bag as GHC --- import qualified BasicTypes as GHC -import qualified FastString as GHC -import qualified GHC as GHC --- import qualified Lexer as GHC hiding (getSrcLoc) -import qualified Module as GHC -import qualified Name as GHC -import qualified NameSet as GHC -import qualified Outputable as GHC -import qualified RdrName as GHC -import qualified SrcLoc as GHC -import qualified UniqSet as GHC -import qualified Unique as GHC -import qualified Var as GHC - -import qualified Data.Generics as SYB -import qualified GHC.SYB.Utils as SYB - -import Data.Generics.Strafunski.StrategyLib.StrategyLib hiding (liftIO,MonadPlus,mzero) - --- --------------------------------------------------------------------- - --- | For free variables -data FreeNames = FN [GHC.Name] - --- | For declared variables -data DeclaredNames = DN [GHC.Name] - -instance Show FreeNames where - show (FN ls) = "FN " ++ showGhc ls - -instance Show DeclaredNames where - show (DN ls) = "DN " ++ showGhc ls - -instance Monoid FreeNames where - mempty = FN [] - mappend (FN a) (FN b) = FN (a `mappend` b) - -instance Monoid DeclaredNames where - mempty = DN [] - mappend (DN a) (DN b) = DN (a `mappend` b) - - -emptyFD :: (FreeNames,DeclaredNames) -emptyFD = (FN [], DN []) - --- --------------------------------------------------------------------- --- |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, GHC.NameSpace, GHC.ModuleName, Maybe GHC.ModuleName)] -- ^ The result -inScopeInfo names = nub $ map getEntInfo $ names - where - getEntInfo name - =(showGhc name, - GHC.occNameSpace $ GHC.nameOccName name, - GHC.moduleName $ GHC.nameModule name, - getQualMaybe $ GHC.nameRdrName name) - - getQualMaybe rdrName = case rdrName of - GHC.Qual modName _occName -> Just modName - _ -> Nothing - - - --- | 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 n names - = isJust $ find (\ (x, _,_, qual) -> x == n && isNothing qual ) $ inScopeInfo names - --- | Return True if the identifier is inscope and can be used without --- a qualifier. The identifier name string may have a qualifier --- already --- NOTE: may require qualification based on name clash with an --- existing identifier. -isInScopeAndUnqualifiedGhc :: - String -- ^ The identifier name. - -> (Maybe GHC.Name) -- ^ Existing name, to be excluded from test, if - -- known - -> RefactGhc Bool -- ^ The result. -isInScopeAndUnqualifiedGhc n maybeExising = do - names <- ghandle handler (GHC.parseName n) - logm $ "isInScopeAndUnqualifiedGhc:(n,(maybeExising,names))=" ++ (show n) ++ ":" ++ (showGhc (maybeExising,names)) - ctx <- GHC.getContext - logm $ "isInScopeAndUnqualifiedGhc:ctx=" ++ (showGhc ctx) - let nameList = case maybeExising of - Nothing -> names - -- Just n' -> filter (\x -> (GHC.nameUnique x) /= (GHC.nameUnique n')) names - Just n' -> filter (\x -> (showGhc x) /= (showGhc n')) names - logm $ "isInScopeAndUnqualifiedGhc:(n,nameList)=" ++ (show n) ++ ":" ++ (showGhc nameList) - return $ nameList /= [] - - where - handler:: SomeException -> RefactGhc [GHC.Name] - handler e = do - logm $ "isInScopeAndUnqualifiedGhc.handler e=" ++ (show e) - return [] - -inScopeNames :: String -- ^ The identifier name. - -> RefactGhc [GHC.Name] -- ^ The result. -inScopeNames n = do - names <- ghandle handler (GHC.parseName n) - logm $ "inScopeNames:(n,names)=" ++ (show n) ++ ":" ++ (showGhc names) - return $ names - - where - handler:: SomeException -> RefactGhc [GHC.Name] - handler e = do - logm $ "inScopeNames.handler e=" ++ (show e) - return [] - --- --------------------------------------------------------------------- --- | Show a PName in a format like: 'pn'(at row:r, col: c). -showPNwithLoc:: GHC.Located GHC.Name -> String -showPNwithLoc pn@(GHC.L l _n) - = let (r,c) = getGhcLoc l - -- in " '"++pNtoName pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")" - in " '"++showGhc pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")" - --- --------------------------------------------------------------------- - -defaultPN :: PName -defaultPN = PN (mkRdrName "nothing") - -defaultName :: GHC.Name -defaultName = n - where - un = GHC.mkUnique 'H' 0 -- H for HaRe :) - n = GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc "nothing") - --- | Default expression. -defaultExp::HsExpP --- defaultExp=Exp (HsId (HsVar defaultPNT)) -defaultExp=GHC.HsVar $ mkRdrName "nothing" - - -mkRdrName :: String -> GHC.RdrName -mkRdrName s = GHC.mkVarUnqual (GHC.mkFastString s) - --- | Make a new GHC.Name, using the Unique Int sequence stored in the --- RefactState. -mkNewGhcName :: Maybe GHC.Module -> String -> RefactGhc GHC.Name -mkNewGhcName maybeMod name = do - s <- get - u <- gets rsUniqState - put s { rsUniqState = (u+1) } - - let un = GHC.mkUnique 'H' (u+1) -- H for HaRe :) - -- n = GHC.mkSystemName un (GHC.mkVarOcc name) - n = case maybeMod of - Nothing -> GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc name) - Just modu -> GHC.mkExternalName un modu (GHC.mkVarOcc name) nullSrcSpan - return n - -mkNewToplevelName :: GHC.Module -> String -> GHC.SrcSpan -> RefactGhc GHC.Name -mkNewToplevelName modid name defLoc = do - s <- get - u <- gets rsUniqState - put s { rsUniqState = (u+1) } - - let un = GHC.mkUnique 'H' (u+1) -- H for HaRe :) - -- n = GHC.mkSystemName un (GHC.mkVarOcc name) - -- n = GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc name) - - -- mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name - n = GHC.mkExternalName un modid (GHC.mkVarOcc name) defLoc - return n - ---------------------------------------------------------------------------- - - --- |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 suffix - =let newName=if suffix==0 then oldName - else oldName++"_"++ show suffix - in if elem newName fds - then mkNewName oldName fds (suffix+1) - else newName - --- --------------------------------------------------------------------- - --- | Return True if the current module is exported either by default --- or by specifying the module name in the export. -modIsExported:: GHC.ModuleName -- ^ The module name - -> GHC.RenamedSource -- ^ The AST of the module - -> Bool -- ^ The result -modIsExported modName (_g,_emps,mexps,_mdocs) - = let - modExported (GHC.L _ (GHC.IEModuleContents name)) = name == modName - modExported _ = False - - moduleExports = filter modExported $ fromMaybe [] mexps - - in if isNothing mexps - then True - else (nonEmptyList moduleExports) - --- --------------------------------------------------------------------- - --- | Return True if an identifier is exported by the module currently --- being refactored. -isExported :: GHC.Name -> RefactGhc Bool -isExported n = do - typechecked <- getTypecheckedModule - let modInfo = GHC.tm_checked_module_info typechecked - return $ GHC.modInfoIsExportedName modInfo n - --- --------------------------------------------------------------------- - --- | Return True if an identifier is explicitly exported by the module. -isExplicitlyExported::GHC.Name -- ^ The identifier - ->GHC.RenamedSource -- ^ The AST of the module - ->Bool -- ^ The result -isExplicitlyExported pn (_g,_imps,exps,_docs) - = findEntity pn exps - --- --------------------------------------------------------------------- - - --- | Check if the proposed new name will conflict with an existing export -causeNameClashInExports:: GHC.Name -- ^ The original name - -> GHC.Name -- ^ The new name - -> GHC.ModuleName -- ^ The identity of the module - -> GHC.RenamedSource -- ^ The AST of the module - -> Bool -- ^ The result - --- Note that in the abstract representation of exps, there is no qualified entities. -causeNameClashInExports pn newName modName renamed@(_g,imps,maybeExps,_doc) - = let exps = fromMaybe [] maybeExps - varExps = filter isImpVar exps - -- TODO: make withoutQual part of the API - withoutQual n = showGhc $ GHC.localiseName n - modNames=nub (concatMap (\(GHC.L _ (GHC.IEVar x))->if withoutQual x== withoutQual newName - then [GHC.moduleName $ GHC.nameModule x] - else []) varExps) - res = (isExplicitlyExported pn renamed) && - ( any (modIsUnQualifedImported renamed) modNames - || elem modName modNames) - in res - where - isImpVar (GHC.L _ x) = case x of - GHC.IEVar _ -> True - _ -> False - - modIsUnQualifedImported _mod' modName' - =let -- imps =hsModImports mod - -- imp@(GHC.L _ (GHC.ImportDecl (GHC.L _ modName) qualify _source _safe isQualified _isImplicit as h)) - in isJust $ find (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as _h)) - -> modName1 == modName' && (not isQualified)) imps - -- in isJust $ find (\(HsImportDecl _ (SN modName1 _) qualify _ h) -> modName == modName1 && (not qualify)) imps - - --- Original seems to be --- 1. pick up any module names in the export list with same unQual - -- part as the new name --- 2. Check if the old is exported explicitly --- 3. if so, if the new module is exported unqualified --- or belongs to the current module --- then it will cause a clash - --- --------------------------------------------------------------------- --- | Collect the free and declared variables (in the GHC.Name 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. --- Expects RenamedSource -hsFreeAndDeclaredPNsOld:: (SYB.Data t) => t -> ([GHC.Name],[GHC.Name]) -hsFreeAndDeclaredPNsOld t = res - where - fd = hsFreeAndDeclaredPNs' t - (f,d) = fromMaybe ([],[]) fd - res = (f \\ d, d) - -hsFreeAndDeclaredPNs':: (SYB.Data t) => t -> Maybe ([GHC.Name],[GHC.Name]) -hsFreeAndDeclaredPNs' t = do - (f,d) <- hsFreeAndDeclared' - let (f',d') = (nub f, nub d) - -- return (f' \\ d',d') - return (f',d') - -- hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp - - where - - hsFreeAndDeclared' = applyTU (stop_tdTUGhc (failTU - `adhocTU` expr - `adhocTU` pattern - `adhocTU` binds - `adhocTU` bindList - `adhocTU` match - `adhocTU` stmts - `adhocTU` rhs - )) t - - -- TODO: ++AZ++ Note:After renaming, HsBindLR has field bind_fvs - -- containing locally bound free vars - - -- expr -- - expr (GHC.HsVar n) = return ([n],[]) - - expr (GHC.OpApp e1 (GHC.L _ (GHC.HsVar n)) _ e2) = do - efed <- hsFreeAndDeclaredPNs' [e1,e2] - fd <- addFree n efed - return fd - - expr ((GHC.HsLam (GHC.MatchGroup matches _)) :: GHC.HsExpr GHC.Name) = - hsFreeAndDeclaredPNs' matches - - expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.Name) = - do - (df,dd) <- hsFreeAndDeclaredPNs' decls - (ef,_) <- hsFreeAndDeclaredPNs' e - return ((df `union` (ef \\ dd)),[]) - - expr (GHC.RecordCon (GHC.L _ n) _ e) = do - fd <- (hsFreeAndDeclaredPNs' e) - addFree n fd --Need Testing - - expr (GHC.EAsPat (GHC.L _ n) e) = do - fd <- (hsFreeAndDeclaredPNs' e) - addFree n fd - - expr _ = mzero - - - -- rhs -- - rhs ((GHC.GRHSs g ds) :: GHC.GRHSs GHC.Name) - = do (df,dd) <- hsFreeAndDeclaredPNs' g - (ef,ed) <- hsFreeAndDeclaredPNs' ds - return (df ++ ef, dd ++ ed) - - - -- pat -- - pattern (GHC.VarPat n) = return ([],[n]) - -- It seems all the GHC pattern match syntax elements end up - -- with GHC.VarPat - - pattern _ = mzero - -- pattern _ = return ([],[]) - - bindList (ds :: [GHC.LHsBind GHC.Name]) - =do (f,d) <- hsFreeAndDeclaredList ds - return (f\\d,d) - -- bindList _ = mzero - - -- match and patBind, same type-- - binds ((GHC.FunBind (GHC.L _ n) _ (GHC.MatchGroup matches _) _ _fvs _) :: GHC.HsBind GHC.Name) - = do - (pf,_pd) <- hsFreeAndDeclaredPNs' matches - - return (pf \\ [n] ,[n]) - - -- patBind -- - binds (GHC.PatBind pat prhs _ ds _) = - do - (pf,pd) <- hsFreeAndDeclaredPNs' pat - (rf,rd) <- hsFreeAndDeclaredPNs' prhs - return (pf `union` (rf \\pd),pd ++ GHC.uniqSetToList ds ++ rd) - - binds _ = mzero - - match ((GHC.Match pats _mtype mrhs) :: GHC.Match GHC.Name ) - = do - (pf,pd) <- hsFreeAndDeclaredPNs' pats - (rf,rd) <- hsFreeAndDeclaredPNs' mrhs - return ((pf `union` (rf \\ (pd `union` rd))),[]) - - -- stmts -- - stmts ((GHC.BindStmt pat expre _bindOp _failOp) :: GHC.Stmt GHC.Name) = do - -- TODO ++AZ++ : Not sure it is meaningful to pull - -- anything out of bindOp/failOp - (pf,pd) <- hsFreeAndDeclaredPNs' pat - (ef,_ed) <- hsFreeAndDeclaredPNs' expre - let sf1 = [] - return (pf `union` ef `union` (sf1\\pd),[]) -- pd) -- Check this - - stmts ((GHC.LetStmt binds') :: GHC.Stmt GHC.Name) = - hsFreeAndDeclaredPNs' binds' - - stmts _ = mzero - - - addFree :: GHC.Name -> ([GHC.Name],[GHC.Name]) - -> Maybe ([GHC.Name],[GHC.Name]) - addFree free (fr,de) = return ([free] `union` fr, de) - - 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. -hsFreeAndDeclaredNameStrings::(SYB.Data t,GHC.Outputable t) => t -> RefactGhc ([String],[String]) -hsFreeAndDeclaredNameStrings t = do - (f1,d1) <- hsFreeAndDeclaredPNs t - return ((nub.map showGhc) f1, (nub.map showGhc) d1) - - -hsFreeAndDeclaredPNs :: (SYB.Data t, GHC.Outputable t) => t -> RefactGhc ([GHC.Name],[GHC.Name]) -hsFreeAndDeclaredPNs t = do - -- logm $ "hsFreeAndDeclaredPNs:t=" ++ (showGhc t) - (FN f,DN d) <- hsFreeAndDeclaredGhc t - return (f,d) - --- --------------------------------------------------------------------- - --- | Collect the free and declared variables (in the GHC.Name 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. --- TODO: use GHC.NameSet instead of lists for FreeNames/DeclaredNames --- NOTE: The GHC fvs fields only carry non-GHC values, as they are --- used in the renaming process -hsFreeAndDeclaredGhc :: (SYB.Data t, GHC.Outputable t) => t -> RefactGhc (FreeNames,DeclaredNames) -hsFreeAndDeclaredGhc t = do - -- logm $ "hsFreeAndDeclaredGhc:t=" ++ showGhc t - (FN f,DN d) <- res - let f' = nub f - let d' = nub d - -- logm $ "hsFreeAndDeclaredGhc:res=" ++ showGhc (f',d') - return (FN (f' \\ d'), DN d') - - where - res = (const err -- emptyFD - `SYB.extQ` renamed - `SYB.extQ` lhsbind - `SYB.extQ` hsbind - `SYB.extQ` lhsbinds - `SYB.extQ` lhsbindslrs - `SYB.extQ` lhsbindslr - `SYB.extQ` hslocalbinds - `SYB.extQ` hsvalbinds - `SYB.extQ` lpats - `SYB.extQ` lpat -#if __GLASGOW_HASKELL__ > 704 - `SYB.extQ` bndrs -#endif - `SYB.extQ` ltydecls - `SYB.extQ` ltydecl -#if __GLASGOW_HASKELL__ > 704 - `SYB.extQ` lfaminstdecls - `SYB.extQ` lfaminstdecl -#endif - `SYB.extQ` lsigs - `SYB.extQ` lsig - `SYB.extQ` lexprs - `SYB.extQ` lexpr - `SYB.extQ` expr - `SYB.extQ` name - `SYB.extQ` lstmts - `SYB.extQ` lstmt - `SYB.extQ` lhstype - `SYB.extQ` hstype - `SYB.extQ` grhs_s - `SYB.extQ` grhs - `SYB.extQ` grhsss - `SYB.extQ` grhss - `SYB.extQ` matchgroup - `SYB.extQ` lmatches - `SYB.extQ` lmatch - `SYB.extQ` hsrecordbinds - `SYB.extQ` hsrecordbind - ) t - - renamed :: GHC.RenamedSource -> RefactGhc (FreeNames,DeclaredNames) - renamed (g,_i,_e,_d) = do - gfds <- hsFreeAndDeclaredGhc $ GHC.hs_valds g - let tds = concatMap getDeclaredTypes $ concat (GHC.hs_tyclds g) - return $ gfds <> (FN [],DN tds) - - - lhsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lhsbinds bs = do - (FN fn,DN dn) <- recurseList bs - let r = (FN (fn \\ dn),DN dn) - -- logm $ "hsFreeAndDeclaredGhc.hsbinds:r=" ++ (show r) - return r - - lhsbind :: GHC.LHsBind GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lhsbind (GHC.L _ b) = hsFreeAndDeclaredGhc b - - -- ----------------------- - - hsbind :: GHC.HsBind GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - hsbind b@(GHC.FunBind _n _ (GHC.MatchGroup matches _) _ _ _) = do - -- logm $ "hsFreeAndDeclaredGhc.hsbind:b=" ++ (showGhc b) - let d = GHC.collectHsBindBinders b - -- let pats = concatMap (\(GHC.L _ (GHC.Match pat _ _)) -> pat) matches - (fp,_dp) <- hsFreeAndDeclaredGhc matches - -- logm $ "hsFreeAndDeclaredGhc.hsbind:(fp,_dp)=" ++ (show (fp,_dp)) - -- logm $ "hsFreeAndDeclaredGhc.hsbind:(d)=" ++ (showGhc (d)) - let r = (fp,DN []) <> (FN [],DN d) - -- logm $ "hsFreeAndDeclaredGhc.hsbind:r=" ++ (show (r)) - return $ r - hsbind b@(GHC.PatBind pa rhs _ _ _) = do - -- logm $ "hsFreeAndDeclaredGhc.hsbind.PatBind:b=" ++ (showGhc b) - let d = GHC.collectHsBindBinders b - (FN fr,DN _dr) <- hsFreeAndDeclaredGhc rhs - (fp,_) <- lpat pa - -- logm $ "hsFreeAndDeclaredGhc.hsbind.PatBind:f=" ++ (showGhc fr) - return $ (fp,DN []) <> (FN fr,DN d) - hsbind b = do - -- logm $ "hsFreeAndDeclaredGhc.hsbind:b=" ++ (showGhc b) - let d = GHC.collectHsBindBinders b - return (FN [],DN d) - - -- ----------------------- - - lhsbindslrs :: [GHC.LHsBindsLR GHC.Name GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lhsbindslrs bs = recurseList bs - - -- ----------------------- - - lhsbindslr :: GHC.LHsBindsLR GHC.Name GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lhsbindslr bs = do - hsFreeAndDeclaredGhc $ GHC.bagToList bs - - hslocalbinds :: GHC.HsLocalBinds GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - hslocalbinds (GHC.HsValBinds binds) = hsFreeAndDeclaredGhc binds - hslocalbinds (GHC.HsIPBinds binds) = hsFreeAndDeclaredGhc binds - hslocalbinds GHC.EmptyLocalBinds = return emptyFD - - - hsvalbinds :: GHC.HsValBinds GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - hsvalbinds (GHC.ValBindsIn binds sigs) = do - bfds <- hsFreeAndDeclaredGhc binds - sfds <- hsFreeAndDeclaredGhc sigs - return $ bfds <> sfds - hsvalbinds (GHC.ValBindsOut binds sigs) = do - bfds <- hsFreeAndDeclaredGhc $ map snd binds - sfds <- hsFreeAndDeclaredGhc sigs - return $ bfds <> sfds - - -- ----------------------- - - lpats :: [GHC.LPat GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lpats xs = recurseList xs - - -- ----------------------- - - lpat :: GHC.LPat GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lpat lp@(GHC.L _ p) = do - -- logm $ "hsFreeAndDeclaredGhc.lpat:" ++ (showGhc lp) - let - dn = GHC.collectPatBinders lp - - -- logm $ "hsFreeAndDeclaredGhc.lpat p=" ++ (SYB.showData SYB.Renamer 0 p) - - (FN fn,DN _dn) <- pat p - -- logm $ "hsFreeAndDeclaredGhc.lpat:(fn,dn)=" ++ (showGhc (fn,dn)) - return (FN fn,DN dn) - - pat :: GHC.Pat GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - pat (GHC.WildPat _) = return emptyFD - pat (GHC.VarPat n) = return (FN [],DN [n]) - pat (GHC.LazyPat (GHC.L _ p)) = pat p - pat (GHC.AsPat (GHC.L _ n) (GHC.L _ p)) = do - fd <- pat p - return $ (FN [], DN [n]) <> fd - pat (GHC.ParPat (GHC.L _ p)) = pat p - pat (GHC.BangPat (GHC.L _ p)) = pat p - pat (GHC.ListPat ps _) = do - fds <- mapM pat $ map GHC.unLoc ps - return $ mconcat fds - pat (GHC.TuplePat ps _ _) = do - fds <- mapM pat $ map GHC.unLoc ps - return $ mconcat fds - pat (GHC.PArrPat ps _) = do - fds <- mapM pat $ map GHC.unLoc ps - return $ mconcat fds - pat (GHC.ConPatIn (GHC.L _ n) det) = do - -- logm $ "hsFreeAndDeclaredGhc.pat.ConPatIn:details=" ++ (SYB.showData SYB.Renamer 0 det) - (FN f,DN _d) <- details det - return $ (FN [n],DN []) <> (FN [],DN f) - -- pat (GHC.ConPatOut ) - pat (GHC.ViewPat e (GHC.L _ p) _) = do - fde <- hsFreeAndDeclaredGhc e - fdp <- pat p - return $ fde <> fdp - -- pat (GHC.QuasiQuotePat _) - pat (GHC.LitPat _) = return emptyFD - pat (GHC.NPat _ _ _) = return emptyFD - pat (GHC.NPlusKPat (GHC.L _ n) _ _ _) = return (FN [],DN [n]) - pat _p@(GHC.SigPatIn (GHC.L _ p) b) = do - fdp <- pat p - (FN fb,DN _db) <- hsFreeAndDeclaredGhc b -#if __GLASGOW_HASKELL__ > 704 - return $ fdp <> (FN fb,DN []) -#else - return $ fdp <> (FN _db,DN []) -#endif - pat (GHC.SigPatOut (GHC.L _ p) _) = pat p - pat (GHC.CoPat _ p _) = pat p - - pat p = error $ "hsFreeAndDeclaredGhc.pat:unimplemented:" ++ (showGhc p) - - -- HsConDetails (LPat id) (HsRecFields id (LPat id)) - details :: GHC.HsConPatDetails GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - details (GHC.PrefixCon args) = do - -- logm $ "hsFreeAndDeclaredGhc.details:args=" ++ (showGhc args) - fds <- mapM pat $ map GHC.unLoc args - return $ mconcat fds - details (GHC.RecCon recf) = - recfields recf - details (GHC.InfixCon arg1 arg2) = do - fds <- mapM pat $ map GHC.unLoc [arg1,arg2] - return $ mconcat fds - - -- Note: this one applies to HsRecFields in LPats - recfields :: (GHC.HsRecFields GHC.Name (GHC.LPat GHC.Name)) -> RefactGhc (FreeNames,DeclaredNames) - recfields (GHC.HsRecFields fields _) = do - let args = map (\(GHC.HsRecField _ (GHC.L _ arg) _) -> arg) fields - fds <- mapM pat args - return $ mconcat fds - - -- ----------------------- - -#if __GLASGOW_HASKELL__ > 704 - bndrs :: GHC.HsWithBndrs (GHC.LHsType GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) - bndrs (GHC.HsWB (GHC.L _ thing) _kindVars _typeVars) = do - (_ft,DN dt) <- hsFreeAndDeclaredGhc thing - -- logm $ "hsFreeAndDeclaredGhc.bndrs (_ft,dt)=" ++ show (_ft,DN dt) - return (FN dt,DN []) -#endif - - -- ----------------------- - - ltydecls :: [GHC.LTyClDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - ltydecls ds = do - fds <- mapM hsFreeAndDeclaredGhc ds - return $ mconcat fds - - ltydecl :: GHC.LTyClDecl GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - ltydecl (GHC.L _ (GHC.ForeignType (GHC.L _ n) _)) = return (FN [],DN [n]) - - ltydecl (GHC.L _ (GHC.TyFamily _ (GHC.L _ n) _bndrs _)) = return (FN [],DN [n]) -#if __GLASGOW_HASKELL__ > 704 - ltydecl (GHC.L _ (GHC.TyDecl (GHC.L _ n) _bndrs _defn fvs)) - = return (FN (GHC.nameSetToList fvs),DN [n]) -#else - ltydecl (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind _cons _derivs)) - = return (FN [],DN [n]) -- TODO: calc fvs for cons - ltydecl (GHC.L _ (GHC.TySynonym (GHC.L _ n) _vars _pats _rhs)) - = return (FN [],DN [n]) -- TODO fvs? -#endif -#if __GLASGOW_HASKELL__ > 704 - ltydecl (GHC.L _ (GHC.ClassDecl _ctx (GHC.L _ n) _tyvars - _fds _sigs meths ats atds _docs fvs)) = do -#else - ltydecl (GHC.L _ (GHC.ClassDecl _ctx (GHC.L _ n) _tyvars - _fds _sigs meths ats atds _docs)) = do -#endif - (_,md) <- hsFreeAndDeclaredGhc meths - (_,ad) <- hsFreeAndDeclaredGhc ats - (_,atd) <- hsFreeAndDeclaredGhc atds -#if __GLASGOW_HASKELL__ > 704 - return (FN (GHC.nameSetToList fvs),DN [n] <> md <> ad <> atd) -#else - return (FN [],DN [n] <> md <> ad <> atd) -- TODO: fvs -#endif - -#if __GLASGOW_HASKELL__ > 704 - lfaminstdecls :: [GHC.LFamInstDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lfaminstdecls ds = do - fds <- mapM hsFreeAndDeclaredGhc ds - return $ mconcat fds -#endif - -#if __GLASGOW_HASKELL__ > 704 - lfaminstdecl :: GHC.LFamInstDecl GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lfaminstdecl _f@(GHC.L _ (GHC.FamInstDecl (GHC.L _ n) _pats _defn fvs)) = do - -- logm $ "hsFreeAndDeclaredGhc.lfaminstdecl:" ++ showGhc _f - return (FN (GHC.nameSetToList fvs), DN [n]) -#else - -- lfaminstdecl (GHC.L _ (GHC.InstDecl typ binds sigs decls)) -#endif - - -- ----------------------- - - lsigs :: [GHC.LSig GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lsigs ss = do - fds <- mapM hsFreeAndDeclaredGhc ss - return $ mconcat fds - - -- ----------------------- - - lsig :: GHC.LSig GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lsig (GHC.L _ (GHC.TypeSig ns typ)) = do - tfds <- hsFreeAndDeclaredGhc typ - return $ (FN [],DN (map GHC.unLoc ns)) <> tfds - lsig (GHC.L _ (GHC.GenericSig n typ)) = do - tfds <- hsFreeAndDeclaredGhc typ - return $ (FN [],DN (map GHC.unLoc n)) <> tfds - lsig (GHC.L _ (GHC.IdSig _)) = return emptyFD - lsig (GHC.L _ (GHC.InlineSig _ _)) = return emptyFD - lsig (GHC.L _ (GHC.SpecSig n typ _)) = do - tfds <- hsFreeAndDeclaredGhc typ - return $ (FN [],DN [GHC.unLoc n]) <> tfds - lsig (GHC.L _ (GHC.SpecInstSig _)) = return emptyFD - lsig (GHC.L _ (GHC.FixSig _)) = return emptyFD - - -- ----------------------- - - lexprs :: [GHC.LHsExpr GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lexprs es = recurseList es - - -- ----------------------- - - lexpr :: GHC.LHsExpr GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lexpr (GHC.L _ e) = hsFreeAndDeclaredGhc e - - -- ----------------------- - - expr :: GHC.HsExpr GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - expr ((GHC.HsVar n)) = return (FN [n],DN []) - - expr ((GHC.HsIPVar _)) = return emptyFD - - expr ((GHC.HsOverLit _)) = return emptyFD - - expr ((GHC.HsLit _)) = return emptyFD - - expr ((GHC.HsLam mg)) = hsFreeAndDeclaredGhc mg - -#if __GLASGOW_HASKELL__ > 704 - expr ((GHC.HsLamCase _ mg)) = hsFreeAndDeclaredGhc mg -#endif - - expr ((GHC.HsApp e1 e2)) = do - fde1 <- hsFreeAndDeclaredGhc e1 - fde2 <- hsFreeAndDeclaredGhc e2 - return $ fde1 <> fde2 - - expr ((GHC.OpApp e1 eop _fix e2)) = do - fde1 <- hsFreeAndDeclaredGhc e1 - fdeop <- hsFreeAndDeclaredGhc eop - fde2 <- hsFreeAndDeclaredGhc e2 - return $ fde1 <> fdeop <> fde2 - - expr ((GHC.NegApp e _)) = hsFreeAndDeclaredGhc e - - expr ((GHC.HsPar e)) = hsFreeAndDeclaredGhc e - - expr ((GHC.SectionL e1 e2)) = do - fde1 <- hsFreeAndDeclaredGhc e1 - fde2 <- hsFreeAndDeclaredGhc e2 - return $ fde1 <> fde2 - - expr ((GHC.SectionR e1 e2)) = do - fde1 <- hsFreeAndDeclaredGhc e1 - fde2 <- hsFreeAndDeclaredGhc e2 - return $ fde1 <> fde2 - - expr ((GHC.ExplicitTuple args _boxity)) = do - let argse = concatMap bb args - bb (GHC.Missing _) = [] - bb (GHC.Present a) = [a] - - fds <- mapM hsFreeAndDeclaredGhc argse - return $ mconcat fds - - expr ((GHC.HsCase e body)) = do - fdes <- hsFreeAndDeclaredGhc e - fdbs <- hsFreeAndDeclaredGhc body - return $ fdes <> fdbs - - expr ((GHC.HsIf _ms e1 e2 e3)) = do - fde1 <- hsFreeAndDeclaredGhc e1 - fde2 <- hsFreeAndDeclaredGhc e2 - fde3 <- hsFreeAndDeclaredGhc e3 - return $ fde1 <> fde2 <> fde3 - -#if __GLASGOW_HASKELL__ > 704 - expr ((GHC.HsMultiIf _typ rhs)) - = hsFreeAndDeclaredGhc rhs -#endif - - expr ((GHC.HsLet binds e)) = do - fdb <- hsFreeAndDeclaredGhc binds - fde <- hsFreeAndDeclaredGhc e - return $ fdb <> fde - - expr ((GHC.HsDo _ctx stmts _typ)) - = hsFreeAndDeclaredGhc stmts - - expr ((GHC.ExplicitList _typ es)) - = hsFreeAndDeclaredGhc es - - expr ((GHC.ExplicitPArr _typ es)) - = hsFreeAndDeclaredGhc es - - expr ((GHC.RecordCon (GHC.L _ n) _typ binds)) = do - fdb <- hsFreeAndDeclaredGhc binds - return $ (FN [],DN [n]) <> fdb - - expr ((GHC.RecordUpd e1 binds _cons _typ1 _typ2)) = do - fde <- hsFreeAndDeclaredGhc e1 - fdb <- hsFreeAndDeclaredGhc binds - return $ fde <> fdb - - expr ((GHC.ExprWithTySig e _typ)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.ExprWithTySigOut e _typ)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.ArithSeq _typ as)) = do - fds <- case as of - GHC.From e -> hsFreeAndDeclaredGhc e - GHC.FromThen e1 e2 -> recurseList [e1,e2] - GHC.FromTo e1 e2 -> recurseList [e1,e2] - GHC.FromThenTo e1 e2 e3 -> recurseList [e1,e2,e3] - return fds - - expr ((GHC.PArrSeq _typ as)) - = hsFreeAndDeclaredGhc as - - expr ((GHC.HsSCC _ e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsCoreAnn _ e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsBracket (GHC.ExpBr b))) - = hsFreeAndDeclaredGhc b - expr ((GHC.HsBracket (GHC.PatBr b))) - = hsFreeAndDeclaredGhc b - expr ((GHC.HsBracket (GHC.DecBrL b))) - = hsFreeAndDeclaredGhc b - expr ((GHC.HsBracket (GHC.DecBrG b))) - = hsFreeAndDeclaredGhc b - expr ((GHC.HsBracket (GHC.TypBr b))) - = hsFreeAndDeclaredGhc b - expr ((GHC.HsBracket (GHC.VarBr _ n))) - = return (FN [],DN [n]) - - - expr ((GHC.HsBracketOut b _ps)) - = hsFreeAndDeclaredGhc b - - expr ((GHC.HsSpliceE (GHC.HsSplice _ e))) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsQuasiQuoteE _q)) - = return emptyFD - - expr ((GHC.HsProc pa cmd)) = do - fdp <- hsFreeAndDeclaredGhc pa - fdc <- hsFreeAndDeclaredGhc cmd - return $ fdp <> fdc - - expr ((GHC.HsArrApp e1 e2 _typ _atyp _)) = do - fd1 <- hsFreeAndDeclaredGhc e1 - fd2 <- hsFreeAndDeclaredGhc e2 - return $ fd1 <> fd2 - - expr ((GHC.HsArrForm e1 _fix cmds)) = do - fd1 <- hsFreeAndDeclaredGhc e1 - fdc <- hsFreeAndDeclaredGhc cmds - return $ fd1 <> fdc - - expr ((GHC.HsTick _ e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsBinTick _ _ e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsTickPragma _ e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.EWildPat)) = return emptyFD - - expr ((GHC.EAsPat (GHC.L _ n) e)) = do - fde <- hsFreeAndDeclaredGhc e - return $ (FN [],DN [n]) <> fde - - expr ((GHC.EViewPat e1 e2)) = do - fd1 <- hsFreeAndDeclaredGhc e1 - fd2 <- hsFreeAndDeclaredGhc e2 - return $ fd1 <> fd2 - - expr ((GHC.ELazyPat e)) - = hsFreeAndDeclaredGhc e - - expr ((GHC.HsType typ)) - = hsFreeAndDeclaredGhc typ - - expr ((GHC.HsWrap _wrap e)) - = hsFreeAndDeclaredGhc e - - -- ----------------------- - - name :: GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - name n = return (FN [],DN [n]) - - -- ----------------------- - lstmts :: [GHC.LStmt GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lstmts ss = recurseList ss - - - lstmt :: GHC.LStmt GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lstmt (GHC.L _ (GHC.LastStmt e _)) = hsFreeAndDeclaredGhc e - lstmt (GHC.L _ (GHC.BindStmt pa e _ _)) = do - fdp <- hsFreeAndDeclaredGhc pa - fde <- hsFreeAndDeclaredGhc e - return (fdp <> fde) - lstmt (GHC.L _ (GHC.ExprStmt e _ _ _)) = hsFreeAndDeclaredGhc e - lstmt (GHC.L _ (GHC.LetStmt bs)) = hsFreeAndDeclaredGhc bs -#if __GLASGOW_HASKELL__ > 704 - lstmt (GHC.L _ (GHC.ParStmt ps _ _)) = hsFreeAndDeclaredGhc ps -#else - lstmt (GHC.L _ (GHC.ParStmt ps _ _ _)) = hsFreeAndDeclaredGhc ps -#endif - lstmt (GHC.L _ (GHC.TransStmt _ stmts _ using mby _ _ _)) = do - fds <- hsFreeAndDeclaredGhc stmts - fdu <- hsFreeAndDeclaredGhc using - fdb <- case mby of - Nothing -> return emptyFD - Just e -> hsFreeAndDeclaredGhc e - return $ fds <> fdu <> fdb - lstmt (GHC.L _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _)) = hsFreeAndDeclaredGhc stmts - - -- ----------------------- - - lhstype :: GHC.LHsType GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lhstype (GHC.L _ typ) = hstype typ - - -- ----------------------- - - hstype :: GHC.HsType GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - hstype (GHC.HsForAllTy _ _ _ typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsTyVar n) = return (FN [],DN [n]) - hstype (GHC.HsAppTy t1 t2) = recurseList [t1,t2] - hstype (GHC.HsFunTy t1 t2) = recurseList [t1,t2] - hstype (GHC.HsListTy typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsPArrTy typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsTupleTy _ typs) = recurseList typs - hstype (GHC.HsOpTy t1 _ t2) = recurseList [t1,t2] - hstype (GHC.HsParTy typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsIParamTy _ typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsEqTy t1 t2) = recurseList [t1,t2] - hstype (GHC.HsKindSig t1 t2) = recurseList [t1,t2] - hstype (GHC.HsQuasiQuoteTy _) = return emptyFD - hstype (GHC.HsSpliceTy _ fvs _) = return (FN (GHC.nameSetToList fvs),DN []) - hstype (GHC.HsDocTy _ typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsBangTy _ typ) = hsFreeAndDeclaredGhc typ - hstype (GHC.HsRecTy cons) = recurseList cons - hstype (GHC.HsCoreTy _) = return emptyFD - hstype (GHC.HsExplicitListTy _ typs) = recurseList typs - hstype (GHC.HsExplicitTupleTy _ typs) = recurseList typs -#if __GLASGOW_HASKELL__ > 704 - hstype (GHC.HsTyLit _) = return emptyFD -#endif - hstype (GHC.HsWrapTy _ typ) = hsFreeAndDeclaredGhc typ - - - -- ----------------------- - - grhs_s :: [GHC.LGRHS GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - grhs_s gs = recurseList gs - - -- ----------------------- - - grhs :: GHC.LGRHS GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - grhs (GHC.L _ (GHC.GRHS stmts e)) = do - fds <- hsFreeAndDeclaredGhc stmts - fde <- hsFreeAndDeclaredGhc e - return $ fds <> fde - - -- ----------------------- - - grhsss :: [GHC.GRHSs GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - grhsss gs = recurseList gs - - -- ----------------------- - - grhss :: GHC.GRHSs GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - grhss (GHC.GRHSs g binds) = do - (fg,_dg) <- hsFreeAndDeclaredGhc g - fdb <- hsFreeAndDeclaredGhc binds - return $ (fg,DN[]) <> fdb - - -- ----------------------- - - matchgroup :: GHC.MatchGroup GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - matchgroup (GHC.MatchGroup matches _) = recurseList matches - - -- ----------------------- - - lmatches :: [GHC.LMatch GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) - lmatches ms = recurseList ms - - -- ----------------------- - - lmatch :: GHC.LMatch GHC.Name -> RefactGhc (FreeNames,DeclaredNames) - lmatch (GHC.L _ _m@(GHC.Match pats _ rhs)) = do - (fp,DN dp) <- recurseList pats - (FN fr,DN dr) <- hsFreeAndDeclaredGhc rhs - let r = (fp,DN []) <> (FN (fr \\ (dr ++ dp)), DN []) - return $ r - - -- ----------------------- - - hsrecordbinds :: (GHC.HsRecordBinds GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) - hsrecordbinds (GHC.HsRecFields fields _) = recurseList fields - - hsrecordbind :: (GHC.HsRecField GHC.Name (GHC.LHsExpr GHC.Name)) -> RefactGhc (FreeNames,DeclaredNames) - hsrecordbind (GHC.HsRecField (GHC.L _ n) arg _) = do - fda <- hsFreeAndDeclaredGhc arg - return $ (FN [n],DN []) <> fda - - -- ----------------------- - - - err = error $ "hsFreeAndDeclaredGhc:not matched:" ++ (SYB.showData SYB.Renamer 0 t) - - -- --------------------------------- - - recurseList xs = do - fds <- mapM hsFreeAndDeclaredGhc xs - return $ mconcat fds - --- --------------------------------------------------------------------- - --- | Given a RenamedSource LPAT, return the equivalent --- ParsedSource part. --- NOTE: returns pristine ParsedSource, since HaRe does not change it -getParsedForRenamedLPat :: GHC.ParsedSource -> GHC.LPat GHC.Name -> GHC.LPat GHC.RdrName -getParsedForRenamedLPat parsed lpatParam@(GHC.L l _pat) = r - where - mres = res parsed - r = case mres of - Just rr -> rr - Nothing -> error $ "HaRe error: could not find Parsed LPat for" - ++ (SYB.showData SYB.Renamer 0 lpatParam) - - res t = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lpat) t - - lpat :: (GHC.LPat GHC.RdrName) -> (Maybe (GHC.LPat GHC.RdrName)) - lpat p@(GHC.L lp _) - | lp == l || - stripForestLineFromGhc lp == stripForestLineFromGhc l = Just p - lpat _ = Nothing - --- --------------------------------------------------------------------- - --- | Given a RenamedSource Located name, return the equivalent --- ParsedSource part. --- NOTE: returns pristine ParsedSource, since HaRe does not change it -getParsedForRenamedLocated :: ({- SYB.Typeable a, SYB.Data a, -} SYB.Typeable b {- , SYB.Data b -}) - => GHC.Located a -> RefactGhc (GHC.Located b) -getParsedForRenamedLocated (GHC.L l _n) = do - parsed <- getRefactParsed - let - mres = res parsed - r = case mres of - Just rr -> rr - Nothing -> error $ "HaRe error: could not find Parsed Location for" - ++ (showGhc l) - - res t = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t - - lname :: (GHC.Located b) -> (Maybe (GHC.Located b)) - lname p@(GHC.L lp _) - | lp == l || - stripForestLineFromGhc lp == stripForestLineFromGhc l = Just p - lname _ = Nothing - - return r - - --- | Given a RenamedSource Located name, return the equivalent --- ParsedSource part. --- NOTE: returns pristine ParsedSource, since HaRe does not change it -getParsedForRenamedName :: GHC.ParsedSource -> GHC.Located GHC.Name -> GHC.Located GHC.RdrName -getParsedForRenamedName parsed n@(GHC.L l _n) = r - where - mres = res parsed - r = case mres of - Just rr -> rr - Nothing -> error $ "HaRe error: could not find Parsed LPat for" - ++ (SYB.showData SYB.Renamer 0 n) - - res t = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t - - lname :: (GHC.Located GHC.RdrName) -> (Maybe (GHC.Located GHC.RdrName)) - lname p@(GHC.L lp _) - | lp == l || - stripForestLineFromGhc lp == stripForestLineFromGhc l = Just p - lname _ = Nothing - --- --------------------------------------------------------------------- - -getDeclaredTypes :: GHC.LTyClDecl GHC.Name -> [GHC.Name] -getDeclaredTypes (GHC.L _ (GHC.ForeignType (GHC.L _ n) _)) = [n] -getDeclaredTypes (GHC.L _ (GHC.TyFamily _ (GHC.L _ n) _bs _)) = [n] -#if __GLASGOW_HASKELL__ > 704 -getDeclaredTypes (GHC.L _ (GHC.TyDecl (GHC.L _ n) _vars defn _fvs)) = nub $ [n] ++ dsn - where - dsn = getHsTyDefn defn -#else --- data, -getDeclaredTypes (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind cons _derivs)) - = nub $ [n] ++ cs - where - getConDecl (GHC.L _ (GHC.ConDecl (GHC.L _ n2) _ _ _ _ _ _ _)) = n2 - cs = map getConDecl cons --- synonym -getDeclaredTypes (GHC.L _ (GHC.TySynonym (GHC.L _ n) _vars _pats _rhs)) = [n] -#endif -#if __GLASGOW_HASKELL__ > 704 -getDeclaredTypes (GHC.L _ (GHC.ClassDecl _ (GHC.L _ n) _vars _fds sigs meths ats _atdefs _ _fvs)) -#else -getDeclaredTypes (GHC.L _ (GHC.ClassDecl _ (GHC.L _ n) _vars _fds sigs meths ats _atdefs _)) -#endif - = nub $ [n] ++ ssn ++ msn ++ asn - where - getLSig :: GHC.LSig GHC.Name -> [GHC.Name] - getLSig (GHC.L _ (GHC.TypeSig ns _)) = map GHC.unLoc ns - getLSig (GHC.L _ (GHC.GenericSig ns _)) = map GHC.unLoc ns - getLSig (GHC.L _ (GHC.IdSig _n)) = [] - getLSig (GHC.L _ (GHC.InlineSig (GHC.L _ n2) _)) = [n2] - getLSig (GHC.L _ (GHC.SpecSig (GHC.L _ n2) _ _)) = [n2] - getLSig (GHC.L _ (GHC.SpecInstSig _)) = [] - getLSig (GHC.L _ (GHC.FixSig _)) = [] - - ssn = concatMap getLSig sigs - msn = getDeclaredVars $ hsBinds meths - asn = concatMap getDeclaredTypes ats - --- ------------------------------------- - -#if __GLASGOW_HASKELL__ > 704 -getHsTyDefn :: GHC.HsTyDefn GHC.Name -> [GHC.Name] -getHsTyDefn (GHC.TySynonym _) = [] -getHsTyDefn (GHC.TyData _ _ _ _ cons _) = r - where - getConDecl (GHC.L _ (GHC.ConDecl (GHC.L _ n) _ _ _ _ _ _ _)) = n - r = map getConDecl cons -#endif - --- --------------------------------------------------------------------- --- |Experiment with GHC fvs stuff -getFvs :: [GHC.LHsBind GHC.Name] -> [([GHC.Name], GHC.NameSet)] -getFvs bs = concatMap binds bs - where - binds :: (GHC.LHsBind GHC.Name) -> [([GHC.Name],GHC.NameSet)] - binds (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ fvs _)) = [([pname], fvs)] - binds (GHC.L _ (GHC.PatBind p _rhs _ty fvs _)) = [((hsNamess p),fvs)] - binds _ = [] - -getFreeVars :: [GHC.LHsBind GHC.Name] -> [GHC.Name] -getFreeVars bs = concatMap binds bs - where - binds :: (GHC.LHsBind GHC.Name) -> [GHC.Name] - binds (GHC.L _ (GHC.FunBind (GHC.L _ _pname) _ _ _ fvs _)) = (GHC.nameSetToList fvs) - binds (GHC.L _ (GHC.PatBind _p _rhs _ty fvs _)) = (GHC.nameSetToList fvs) - binds _ = [] - -getDeclaredVars :: [GHC.LHsBind GHC.Name] -> [GHC.Name] -getDeclaredVars bs = concatMap vars bs - where - vars :: (GHC.LHsBind GHC.Name) -> [GHC.Name] - vars (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _fvs _)) = [pname] - vars (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = (hsNamess p) - vars _ = [] - --------------------------------------------------------------------------------- --- | Same as `hsVisiblePNs' except that the returned identifiers are --- in String format. -hsVisibleNames:: (FindEntity t1, SYB.Data t1, SYB.Data t2,HsValBinds t2,GHC.Outputable t1) - => t1 -> t2 -> RefactGhc [String] -hsVisibleNames e t = do - d <- hsVisiblePNs e t - return ((nub . map showGhc) d) - ------------------------------------------------------------------------- - --- | Given syntax phrases e and t, if e occurs in t, then return those --- variables which are declared in t and accessible to e, otherwise --- return []. -hsVisiblePNs :: (FindEntity e, SYB.Data e, SYB.Data t,HsValBinds t,GHC.Outputable e) - => e -> t -> RefactGhc [GHC.Name] -hsVisiblePNs e t = do - (DN dn) <- hsVisibleDs e t - return dn - ------------------------------------------------------------------------- - --- | Given syntax phrases e and t, if e occurs in t, then return those --- variables which are declared in t and accessible to e, otherwise --- return []. -hsVisibleDs :: (FindEntity e, SYB.Data e, SYB.Data t,HsValBinds t,GHC.Outputable e) - => e -> t -> RefactGhc DeclaredNames -hsVisibleDs e t = do - -- logm $ "hsVisibleDs:(e,t)=" ++ (SYB.showData SYB.Renamer 0 (e,t)) - (DN d) <- res - return (DN (nub d)) - where - -- TODO: this is effectively a recursive descent approach, where - -- each syntax element processor knows exactly what it needs - -- in terms of sub-elements. Hence as an optimisation, - -- consider calling the relevent element directly, instead - -- of looping back into the main function. - res = (const err -- (DN []) - `SYB.extQ` renamed - `SYB.extQ` valbinds - `SYB.extQ` lhsbindslr - `SYB.extQ` hsbinds - `SYB.extQ` hsbind - `SYB.extQ` hslocalbinds - `SYB.extQ` lmatch - `SYB.extQ` grhss - `SYB.extQ` lgrhs - `SYB.extQ` lexpr - `SYB.extQ` tycldeclss - `SYB.extQ` tycldecls - `SYB.extQ` tycldecl - `SYB.extQ` instdecls - `SYB.extQ` instdecl - `SYB.extQ` lhstype - `SYB.extQ` lsigs - `SYB.extQ` lsig - ) t - - renamed :: GHC.RenamedSource -> RefactGhc DeclaredNames - renamed (g,_i,_ex,_d) - | findEntity e g = do - dfds <- hsVisibleDs e $ GHC.hs_valds g - tfds <- hsVisibleDs e $ GHC.hs_tyclds g - ifds <- hsVisibleDs e $ GHC.hs_instds g - return $ dfds <> tfds <> ifds - renamed _ = return (DN []) - - valbinds :: (GHC.HsValBindsLR GHC.Name GHC.Name) -> RefactGhc DeclaredNames - valbinds vb@(GHC.ValBindsIn bindsBag sigs) - | findEntity e vb = do - fdsb <- mapM (hsVisibleDs e) $ hsBinds bindsBag - fdss <- mapM (hsVisibleDs e) sigs - return $ mconcat fdss <> mconcat fdsb - valbinds vb@(GHC.ValBindsOut binds sigs) - | findEntity e vb = do - logm $ "hsVisibleDs.valbinds:ValBindsOut" - fdsb <- mapM (hsVisibleDs e) $ map snd binds - fdss <- mapM (hsVisibleDs e) sigs - return $ mconcat fdss <> mconcat fdsb - - valbinds _ = do - logm $ "hsVisibleDs.valbinds:not matched" - return (DN []) - - lhsbindslr :: GHC.LHsBindsLR GHC.Name GHC.Name -> RefactGhc DeclaredNames - lhsbindslr bs = do - fds <- mapM (hsVisibleDs e) $ GHC.bagToList bs - return $ mconcat fds - - hsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc DeclaredNames - hsbinds ds - | findEntity e ds = do - fds <- mapM (hsVisibleDs e) ds - return $ mconcat fds - hsbinds _ = return (DN []) - - hsbind :: (GHC.LHsBind GHC.Name) -> RefactGhc DeclaredNames - hsbind ((GHC.L _ (GHC.FunBind _n _ (GHC.MatchGroup matches _) _ _ _))) - | findEntity e matches = do - fds <- mapM (hsVisibleDs e) matches - logm $ "hsVisibleDs.hsbind:fds=" ++ show fds - return $ mconcat fds - hsbind _ = return (DN []) - - hslocalbinds :: (GHC.HsLocalBinds GHC.Name) -> RefactGhc DeclaredNames - hslocalbinds (GHC.HsValBinds binds) - | findEntity e binds = hsVisibleDs e binds - hslocalbinds (GHC.HsIPBinds binds) - | findEntity e binds = hsVisibleDs e binds - hslocalbinds (GHC.EmptyLocalBinds) = return (DN []) - hslocalbinds _ = return (DN []) - - lmatch :: (GHC.LMatch GHC.Name) -> RefactGhc DeclaredNames - lmatch (GHC.L _ (GHC.Match pats _mtyp rhs)) - | findEntity e pats = do - logm $ "hsVisibleDs.lmatch:in pats=" - return (DN []) -- TODO: extend this - | findEntity e rhs = do - ( pf,pd) <- hsFreeAndDeclaredGhc pats - logm $ "hsVisibleDs.lmatch:(pf,pd)=" ++ (show (pf,pd)) - ( rd) <- hsVisibleDs e rhs - return (pd <> rd) - lmatch _ =return (DN []) - - grhss :: (GHC.GRHSs GHC.Name) -> RefactGhc DeclaredNames - grhss (GHC.GRHSs guardedRhss lstmts) - | findEntity e guardedRhss = do - fds <- mapM (hsVisibleDs e) guardedRhss - return $ mconcat fds - | findEntity e lstmts = hsVisibleDs e lstmts - grhss _ = return (DN []) - - lgrhs :: GHC.LGRHS GHC.Name -> RefactGhc DeclaredNames - lgrhs (GHC.L _ (GHC.GRHS stmts ex)) - | findEntity e stmts = hsVisibleDs e stmts - | findEntity e ex = hsVisibleDs e ex - lgrhs _ = return (DN []) - - - lexpr :: GHC.LHsExpr GHC.Name -> RefactGhc DeclaredNames - lexpr (GHC.L _ (GHC.HsVar n)) - | findEntity e n = return (DN [n]) - lexpr (GHC.L _ (GHC.HsLet lbinds expr)) - | findEntity e lbinds || findEntity e expr = do - (_,lds) <- hsFreeAndDeclaredGhc lbinds - (_,eds) <- hsFreeAndDeclaredGhc expr - return $ lds <> eds - - lexpr expr - | findEntity e expr = do - -- logm $ "hsVisibleDs.lexpr.e1:" ++ (showGhc (e1,_eOp,e2)) - (FN efs,_) <- hsFreeAndDeclaredGhc expr - (FN _eefs,DN eeds) <- hsFreeAndDeclaredGhc e - -- return (DN e1fs <> DN eofs <> DN e2fs) - return (DN (efs \\ eeds)) - - lexpr _ = return (DN []) - - - tycldeclss :: [[GHC.LTyClDecl GHC.Name]] -> RefactGhc DeclaredNames - tycldeclss tcds - | findEntity e tcds = do - fds <- mapM (hsVisibleDs e) tcds - return $ mconcat fds - tycldeclss _ = return (DN []) - - tycldecls :: [GHC.LTyClDecl GHC.Name] -> RefactGhc DeclaredNames - tycldecls tcds - | findEntity e tcds = do - fds <- mapM (hsVisibleDs e) tcds - return $ mconcat fds - tycldecls _ = return (DN []) - - tycldecl :: GHC.LTyClDecl GHC.Name -> RefactGhc DeclaredNames - tycldecl tcd - | findEntity e tcd = do - (_,ds) <- hsFreeAndDeclaredGhc tcd - return ds - tycldecl _ = return (DN []) - - instdecls :: [GHC.LInstDecl GHC.Name] -> RefactGhc DeclaredNames - instdecls ds - | findEntity e ds = do - fds <- mapM (hsVisibleDs e) ds - return $ mconcat fds - instdecls _ = return (DN []) - - instdecl :: GHC.LInstDecl GHC.Name -> RefactGhc DeclaredNames -#if __GLASGOW_HASKELL__ > 704 - instdecl (GHC.L _ (GHC.ClsInstD polytyp binds sigs faminsts)) -#else - instdecl (GHC.L _ (GHC.InstDecl polytyp binds sigs faminsts)) -#endif - | findEntity e polytyp = hsVisibleDs e polytyp - | findEntity e binds = hsVisibleDs e binds - | findEntity e sigs = hsVisibleDs e sigs - | findEntity e faminsts = hsVisibleDs e faminsts - instdecl _ = return (DN []) - - lhstype :: GHC.LHsType GHC.Name -> RefactGhc DeclaredNames - lhstype tv@(GHC.L _ (GHC.HsTyVar n)) - | findEntity e tv = return (DN [n]) - lhstype _ = return (DN []) - - -- ----------------------- - - lsigs :: [GHC.LSig GHC.Name] -> RefactGhc DeclaredNames - lsigs ss = do - fds <- mapM (hsVisibleDs e) ss - return $ mconcat fds - - -- ----------------------- - - lsig :: GHC.LSig GHC.Name -> RefactGhc DeclaredNames - lsig (GHC.L _ (GHC.TypeSig _ns typ)) - | findEntity e typ = hsVisibleDs e typ - lsig (GHC.L _ (GHC.GenericSig _n typ)) - | findEntity e typ = hsVisibleDs e typ - lsig (GHC.L _ (GHC.IdSig _)) = return (DN []) - lsig (GHC.L _ (GHC.InlineSig _ _)) = return (DN []) - lsig (GHC.L _ (GHC.SpecSig _n typ _)) - | findEntity e typ = hsVisibleDs e typ - lsig (GHC.L _ (GHC.SpecInstSig _)) = return (DN []) - - lsig _ = return (DN []) - - -- ----------------------- - err = error $ "hsVisibleDs:no match for:" ++ (SYB.showData SYB.Renamer 0 t) - - ------------------------------------------------------------------------- - --- | Return True if the identifier is unqualifiedly used in the given --- syntax phrase. --- usedWithoutQualR :: GHC.Name -> GHC.ParsedSource -> Bool -usedWithoutQualR :: (SYB.Data t) => GHC.Name -> t -> Bool -usedWithoutQualR name parsed = fromMaybe False res - where - res = somethingStaged SYB.Parser Nothing - (Nothing `SYB.mkQ` worker - `SYB.extQ` workerBind - `SYB.extQ` workerExpr - ) parsed - - worker (pname :: GHC.Located GHC.RdrName) = - checkName pname - - workerBind (GHC.L l (GHC.VarPat n) :: (GHC.Located (GHC.Pat GHC.RdrName))) = - checkName (GHC.L l n) - workerBind _ = Nothing - - workerExpr ((GHC.L l (GHC.HsVar n)) :: (GHC.Located (GHC.HsExpr GHC.RdrName))) - = checkName (GHC.L l n) - workerExpr _ = Nothing - - -- ---------------- - - checkName ((GHC.L l pn)::GHC.Located GHC.RdrName) - | ((GHC.rdrNameOcc pn) == (GHC.nameOccName name)) && - -- isUsedInRhs pname parsed && - isUsedInRhs (GHC.L l name) parsed && - GHC.isUnqual pn = Just True - checkName _ = Nothing - - --- --------------------------------------------------------------------- - - --- |`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. --- NOTE: Expects to be given RenamedSource -hsFDsFromInside:: (SYB.Data t) => t-> RefactGhc ([GHC.Name],[GHC.Name]) -hsFDsFromInside t = do - r <- hsFDsFromInside' t - return r - where - hsFDsFromInside' :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name]) - hsFDsFromInside' t1 = do - r1 <- applyTU (once_tdTU (failTU `adhocTU` renamed - `adhocTU` decl - `adhocTU` match - `adhocTU` expr - `adhocTU` stmts )) t1 - -- let (f',d') = fromMaybe ([],[]) r1 - let (f',d') = r1 - return (nub f', nub d') - - renamed :: GHC.RenamedSource -> RefactGhc ([GHC.Name],[GHC.Name]) - renamed ((grp,_,_,_)::GHC.RenamedSource) - = hsFreeAndDeclaredPNs $ GHC.hs_valds grp - - -- Match [LPat id] (Maybe (LHsType id)) (GRHSs id) - match :: GHC.Match GHC.Name -> RefactGhc ([GHC.Name],[GHC.Name]) - match ((GHC.Match pats _type rhs):: GHC.Match GHC.Name ) = do - (pf, pd) <- hsFreeAndDeclaredPNs pats - (rf, rd) <- hsFreeAndDeclaredPNs rhs - return (nub (pf `union` (rf \\ pd)), - nub (pd `union` rd)) - - -- ---------------------- - - decl :: GHC.HsBind GHC.Name -> RefactGhc ([GHC.Name],[GHC.Name]) - decl ((GHC.FunBind (GHC.L _ _) _ (GHC.MatchGroup matches _) _ _ _) :: GHC.HsBind GHC.Name) = - do - fds <- mapM hsFDsFromInside' matches - -- error (show $ nameToString n) - return (nub (concatMap fst fds), nub (concatMap snd fds)) - - decl ((GHC.PatBind p rhs _ _ _) :: GHC.HsBind GHC.Name) = - do - (pf, pd) <- hsFreeAndDeclaredPNs p - (rf, rd) <- hsFreeAndDeclaredPNs rhs - return - (nub (pf `union` (rf \\ pd)), - nub (pd `union` rd)) - - decl ((GHC.VarBind p rhs _) :: GHC.HsBind GHC.Name) = - do - (pf, pd) <- hsFreeAndDeclaredPNs p - (rf, rd) <- hsFreeAndDeclaredPNs rhs - return - (nub (pf `union` (rf \\ pd)), - nub (pd `union` rd)) - - decl _ = return ([],[]) - - -- ---------------------- - - expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.Name) = - do - (df,dd) <- hsFreeAndDeclaredPNs decls - (ef,_) <- hsFreeAndDeclaredPNs e - return (nub (df `union` (ef \\ dd)), nub dd) - - expr ((GHC.HsLam (GHC.MatchGroup matches _)) :: GHC.HsExpr GHC.Name) = - hsFreeAndDeclaredPNs matches - - expr ((GHC.HsCase e (GHC.MatchGroup matches _)) :: GHC.HsExpr GHC.Name) = - do - (ef,_) <- hsFreeAndDeclaredPNs e - (df,dd) <- hsFreeAndDeclaredPNs matches - return (nub (df `union` (ef \\ dd)), nub dd) - - -- expr _ = return ([],[]) - expr _ = mzero - - stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt GHC.Name) = - do - (pf,pd) <- hsFreeAndDeclaredPNs pat - (ef,_ed) <- hsFreeAndDeclaredPNs e1 - (df,dd) <- hsFreeAndDeclaredPNs [e2,e3] - return - (nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), nub (pd `union` dd)) - - stmts ((GHC.LetStmt binds) :: GHC.Stmt GHC.Name) = - hsFreeAndDeclaredPNs binds - - -- stmts _ = return ([],[]) - stmts _ = mzero - - - --- | The same as `hsFDsFromInside` except that the returned variables --- are in the String format -hsFDNamesFromInside::(SYB.Data t) => t -> RefactGhc ([String],[String]) -hsFDNamesFromInside t = do - (f,d) <- hsFDsFromInside t - return - ((nub.map showGhc) f, (nub.map showGhc) d) - --- --------------------------------------------------------------------- --- | True if the name is a field name -isFieldName :: GHC.Name -> Bool -isFieldName _n = error "undefined isFieldName" - --- --------------------------------------------------------------------- --- | True if the name is a field name -isClassName :: GHC.Name -> Bool -isClassName _n = error "undefined isClassName" - --- --------------------------------------------------------------------- --- | True if the name is a class instance -isInstanceName :: GHC.Name -> Bool -isInstanceName _n = error "undefined isInstanceName" - - --- --------------------------------------------------------------------- --- | Collect the identifiers (in PName format) in a given syntax phrase. - -hsPNs::(SYB.Data t)=> t -> [PName] -hsPNs t = (nub.ghead "hsPNs") res - where - res = SYB.everythingStaged SYB.Parser (++) [] ([] `SYB.mkQ` inPnt) t - - inPnt (pname :: GHC.RdrName) = return [(PN pname)] - --- --------------------------------------------------------------------- - --- |Get all the names in the given syntax element -hsNamess :: (SYB.Data t) => t -> [GHC.Name] --- hsNamess t = (nub.ghead "hsNamess") res -hsNamess t = nub $ concat res - where - res = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inName) t - - inName (pname :: GHC.Name) = return [pname] - ------------------------------------------------------------------------------ - -getModule :: RefactGhc GHC.Module -getModule = do - typechecked <- getTypecheckedModule - return $ GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module typechecked - --- --------------------------------------------------------------------- - --- | Return True if a string is a lexically valid variable name. -isVarId :: String -> Bool -isVarId mid = isId mid && isSmall (ghead "isVarId" mid) - where isSmall c=isLower c || c=='_' - --- | Return True if a string is a lexically valid constructor name. -isConId :: String -> Bool -isConId mid = isId mid && isUpper (ghead "isConId" mid) - --- | Return True if a string is a lexically valid operator name. -isOperator :: String->Bool -isOperator mid = mid /= [] && isOpSym (ghead "isOperator" mid) && - isLegalOpTail (tail mid) && not (isReservedOp mid) - where - isOpSym mid' = elem mid' opSymbols - where opSymbols = ['!', '#', '$', '%', '&', '*', '+','.','/','<','=','>','?','@','\'','^','|','-','~'] - - isLegalOpTail tail' = all isLegal tail' - where isLegal c = isOpSym c || c==':' - - isReservedOp mid' = elem mid' reservedOps - where reservedOps = ["..", ":","::","=","\"", "|","<-","@","~","=>"] - --- | Returns True if a string lexically is an identifier. --- *This function should not be exported.* -isId::String->Bool -isId mid = mid/=[] && isLegalIdTail (tail mid) && not (isReservedId mid) - where - isLegalIdTail tail' = all isLegal tail' - where isLegal c=isSmall c|| isUpper c || isDigit c || c=='\'' - - isReservedId mid' = elem mid' 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::GHC.Name -> RefactGhc Bool -isTopLevelPN n = do - typechecked <- getTypecheckedModule - let maybeNames = GHC.modInfoTopLevelScope $ GHC.tm_checked_module_info typechecked - let names = fromMaybe [] maybeNames - return $ n `elem` names - - --- |Return True if a PName is a local PName. -isLocalPN::GHC.Name -> Bool -isLocalPN = GHC.isInternalName --- isLocalPN (PN i (UniqueNames.S _)) = True --- isLocalPN _ = False - --- |Return True if the name has a @GHC.SrcSpan@, i.e. is declared in --- source we care about -isNonLibraryName :: GHC.Name -> Bool -isNonLibraryName n = case (GHC.nameSrcSpan n) of - GHC.UnhelpfulSpan _ -> False - _ -> True - - --- |Return True if a PName is a function\/pattern name defined in t. -isFunOrPatName::(SYB.Data t) => GHC.Name -> t -> Bool -isFunOrPatName pn - =isJust.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) - where - -- worker (decl::HsDeclP) - worker (decl::GHC.LHsBind GHC.Name) - | defines pn decl = Just True - worker _ = Nothing - -------------------------------------------------------------------------------- --- |Return True if a PName is a qualified PName. --- AZ:NOTE: this tests the use instance, the underlying name may be qualified. --- e.g. used name is zip, GHC.List.zip --- NOTE2: not sure if this gives a meaningful result for a GHC.Name -isQualifiedPN :: GHC.Name -> RefactGhc Bool -isQualifiedPN name = return $ GHC.isQual $ GHC.nameRdrName name - - --- | Return True if a declaration is a type signature declaration. -isTypeSig :: GHC.Located (GHC.Sig a) -> Bool -isTypeSig (GHC.L _ (GHC.TypeSig _ _)) = True -isTypeSig _ = False - --- | Return True if a declaration is a function definition. -isFunBindP::HsDeclP -> Bool -isFunBindP (GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _ _))) = True -isFunBindP _ =False - -isFunBindR::GHC.LHsBind t -> Bool -isFunBindR (GHC.L _l (GHC.FunBind _ _ _ _ _ _)) = True -isFunBindR _ =False - --- | Returns True if a declaration is a pattern binding. -isPatBindP::HsDeclP->Bool -isPatBindP (GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) = True -isPatBindP _=False - -isPatBindR::GHC.LHsBind t -> Bool -isPatBindR (GHC.L _ (GHC.PatBind _ _ _ _ _)) = True -isPatBindR _=False - - --- | Return True if a declaration is a pattern binding which only --- defines a variable value. -isSimplePatBind :: (SYB.Data t) => GHC.LHsBind t-> Bool -isSimplePatBind decl = case decl of - (GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) -> hsPNs p /= [] - _ -> False - --- | Return True if a declaration is a pattern binding but not a simple one. -isComplexPatBind::GHC.LHsBind GHC.Name -> Bool -isComplexPatBind decl = case decl of - (GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) -> patToPNT p /= Nothing - _ -> False - --- | Return True if a declaration is a function\/pattern definition. -isFunOrPatBindP::HsDeclP->Bool -isFunOrPatBindP decl = isFunBindP decl || isPatBindP decl - --- | Return True if a declaration is a function\/pattern definition. -isFunOrPatBindR::GHC.LHsBind t -> Bool -isFunOrPatBindR decl = isFunBindR decl || isPatBindR decl - -------------------------------------------------------------------------------- -{- -getValBindSigs :: GHC.HsValBinds GHC.Name -> [GHC.LSig GHC.Name] -getValBindSigs binds = case binds of - GHC.ValBindsIn _ sigs -> sigs - GHC.ValBindsOut _ sigs -> sigs - -emptyValBinds :: GHC.HsValBinds GHC.Name -emptyValBinds = GHC.ValBindsIn (GHC.listToBag []) [] - -unionBinds :: [GHC.HsValBinds GHC.Name] -> GHC.HsValBinds GHC.Name -unionBinds [] = emptyValBinds -unionBinds [x] = x -unionBinds (x1:x2:xs) = unionBinds ((mergeBinds x1 x2):xs) - where - mergeBinds :: GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.Name - mergeBinds (GHC.ValBindsIn b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsIn (GHC.unionBags b1 b2) (s1++s2)) - mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsOut b2 s2) = (GHC.ValBindsOut (b1++b2) (s1++s2)) - mergeBinds y1@(GHC.ValBindsIn _ _) y2@(GHC.ValBindsOut _ _) = mergeBinds y2 y1 - mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsOut (b1++[(GHC.NonRecursive,b2)]) (s1++s2)) --} - --- NOTE: ValBindsIn are found before the Renamer, ValBindsOut after -{- -hsBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name] -hsBinds t = case hsValBinds t of - GHC.ValBindsIn binds _sigs -> GHC.bagToList binds - GHC.ValBindsOut bs _sigs -> concatMap (\(_,b) -> GHC.bagToList b) bs - -replaceBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name] -> t --- replaceBinds t bs = replaceValBinds t (GHC.ValBindsIn (GHC.listToBag bs) []) -replaceBinds t bs = replaceValBinds t (GHC.ValBindsIn (GHC.listToBag bs) sigs) - where - sigs = case hsValBinds t of - GHC.ValBindsIn _ s -> s - GHC.ValBindsOut _ s -> s --} -{- --- This class replaces the HsDecls one -class (SYB.Data t) => HsValBinds t where - - -- | Return the binds that are directly enclosed in the - -- given syntax phrase. - -- hsValBinds :: t -> [GHC.LHsBind GHC.Name] - hsValBinds :: t -> GHC.HsValBinds GHC.Name - - -- | Replace the directly enclosed bind list by the given - -- bind list. Note: This function does not modify the - -- token stream. - -- replaceBinds :: t -> [GHC.LHsBind GHC.Name] -> t - replaceValBinds :: t -> GHC.HsValBinds GHC.Name -> t - - -- | Return True if the specified identifier is declared in the - -- given syntax phrase. - -- isDeclaredIn :: GHC.Name -> t -> Bool - - -- | Return the type class definitions that are directly enclosed - -- in the given syntax phrase. Note: only makes sense for - -- GHC.RenamedSource - hsTyDecls :: t -> [[GHC.LTyClDecl GHC.Name]] --} --- ++AZ++ see if we can get away with one only.. -isDeclaredIn :: (HsValBinds t) => GHC.Name -> t -> Bool -isDeclaredIn name t = nonEmptyList $ definingDeclsNames [name] (hsBinds t) False True - -{- -instance HsValBinds (GHC.RenamedSource) where - hsValBinds (grp,_,_,_) = (GHC.hs_valds grp) - - replaceValBinds (grp,imps,exps,docs) binds = (grp',imps,exps,docs) - where - grp' = grp {GHC.hs_valds = binds} - - hsTyDecls (grp,_,_,_) = (GHC.hs_tyclds grp) - - -instance HsValBinds (GHC.HsValBinds GHC.Name) where - hsValBinds vb = vb - replaceValBinds _old new = new - hsTyDecls _ = [] - -instance HsValBinds (GHC.HsGroup GHC.Name) where - hsValBinds grp = (GHC.hs_valds grp) - - replaceValBinds (GHC.HsGroup b t i d f de fo w a r v doc) binds - = (GHC.HsGroup b' t i d f de fo w a r v doc) - where b' = replaceValBinds b binds - - hsTyDecls _ = [] - -instance HsValBinds (GHC.HsLocalBinds GHC.Name) where - hsValBinds lb = case lb of - GHC.HsValBinds b -> b - GHC.HsIPBinds _ -> emptyValBinds - GHC.EmptyLocalBinds -> emptyValBinds - - replaceValBinds (GHC.HsValBinds _b) new = (GHC.HsValBinds new) - replaceValBinds (GHC.HsIPBinds _b) _new = error "undefined replaceValBinds HsIPBinds" - replaceValBinds (GHC.EmptyLocalBinds) new = (GHC.HsValBinds new) - - hsTyDecls _ = [] - -instance HsValBinds (GHC.GRHSs GHC.Name) where - hsValBinds (GHC.GRHSs _ lb) = hsValBinds lb - - replaceValBinds (GHC.GRHSs rhss b) new = (GHC.GRHSs rhss (replaceValBinds b new)) - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.MatchGroup GHC.Name) where - hsValBinds (GHC.MatchGroup matches _) = hsValBinds matches - - replaceValBinds (GHC.MatchGroup matches a) newBinds - = (GHC.MatchGroup (replaceValBinds matches newBinds) a) - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds [GHC.LMatch GHC.Name] where - hsValBinds ms = unionBinds $ map (\m -> hsValBinds $ GHC.unLoc m) ms - - replaceValBinds [] _ = error "empty match list in replaceValBinds [GHC.LMatch GHC.Name]" - replaceValBinds ms newBinds = (replaceValBinds (ghead "replaceValBinds" ms) newBinds):(tail ms) - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.LMatch GHC.Name) where - hsValBinds m = hsValBinds $ GHC.unLoc m - - replaceValBinds (GHC.L l m) newBinds = (GHC.L l (replaceValBinds m newBinds)) - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - - -instance HsValBinds (GHC.Match GHC.Name) where - hsValBinds (GHC.Match _ _ grhs) = hsValBinds grhs - - replaceValBinds (GHC.Match p t (GHC.GRHSs rhs _binds)) newBinds - = (GHC.Match p t (GHC.GRHSs rhs binds')) - where - binds' = (GHC.HsValBinds newBinds) - - hsTyDecls _ = [] - -instance HsValBinds (GHC.HsBind GHC.Name) where - hsValBinds (GHC.PatBind _p rhs _typ _fvs _) = hsValBinds rhs - - -- TODO: ++AZ++ added for compatibility with hsDecls. - hsValBinds (GHC.FunBind _ _ matches _ _ _) = hsValBinds matches - hsValBinds other = error $ "hsValBinds (GHC.HsBind GHC.Name) undefined for:" ++ (showGhc other) - - replaceValBinds (GHC.PatBind p (GHC.GRHSs rhs _binds) typ fvs pt) newBinds - = (GHC.PatBind p (GHC.GRHSs rhs binds') typ fvs pt) - where - binds' = (GHC.HsValBinds newBinds) - replaceValBinds x _newBinds - = error $ "replaceValBinds (GHC.HsBind GHC.Name) undefined for:" ++ (showGhc x) - - hsTyDecls _ = [] - -instance HsValBinds (GHC.HsExpr GHC.Name) where - hsValBinds (GHC.HsLet ds _) = hsValBinds ds - hsValBinds x = error $ "TypeUtils.hsValBinds undefined for:" ++ showGhc x - - replaceValBinds (GHC.HsLet binds ex) new = (GHC.HsLet (replaceValBinds binds new) ex) - replaceValBinds old _new = error $ "undefined replaceValBinds (GHC.HsExpr GHC.Name) for:" ++ (showGhc old) - - hsTyDecls _ = [] - -instance HsValBinds (GHC.Stmt GHC.Name) where - hsValBinds (GHC.LetStmt ds) = hsValBinds ds - hsValBinds other = error $ "hsValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc other) - replaceValBinds (GHC.LetStmt ds) new = (GHC.LetStmt (replaceValBinds ds new)) - replaceValBinds old _new = error $ "replaceValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc old) - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.LHsBinds GHC.Name) where - hsValBinds binds = hsValBinds $ GHC.bagToList binds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsBinds GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.LHsBind GHC.Name) where - hsValBinds (GHC.L _ (GHC.FunBind _ _ matches _ _ _)) = hsValBinds matches - hsValBinds (GHC.L _ (GHC.PatBind _ rhs _ _ _)) = hsValBinds rhs - hsValBinds (GHC.L _ (GHC.VarBind _ rhs _)) = hsValBinds rhs - hsValBinds (GHC.L _ (GHC.AbsBinds _ _ _ _ binds)) = hsValBinds binds - - - replaceValBinds (GHC.L l (GHC.FunBind a b matches c d e)) newBinds - = (GHC.L l (GHC.FunBind a b (replaceValBinds matches newBinds) c d e)) - replaceValBinds (GHC.L l (GHC.PatBind a rhs b c d)) newBinds - = (GHC.L l (GHC.PatBind a (replaceValBinds rhs newBinds) b c d)) - replaceValBinds (GHC.L l (GHC.VarBind a rhs b)) newBinds - = (GHC.L l (GHC.VarBind a (replaceValBinds rhs newBinds) b)) - replaceValBinds (GHC.L l (GHC.AbsBinds a b c d binds)) newBinds - = (GHC.L l (GHC.AbsBinds a b c d (replaceValBinds binds newBinds))) - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds ([GHC.LHsBind GHC.Name]) where - -- hsValBinds xs = concatMap hsValBinds xs -- As in original - hsValBinds xs = GHC.ValBindsIn (GHC.listToBag xs) [] - - replaceValBinds _old (GHC.ValBindsIn b _sigs) = GHC.bagToList b - replaceValBinds _old (GHC.ValBindsOut rbinds _sigs) = GHC.bagToList $ GHC.unionManyBags $ map (\(_,b) -> b) rbinds - - -- replaceValBinds old new = error ("replaceValBinds (old,new)=" ++ (showGhc (old,new))) - - hsTyDecls _ = [] - -instance HsValBinds (GHC.LHsExpr GHC.Name) where - hsValBinds (GHC.L _ (GHC.HsLet binds _ex)) = hsValBinds binds - hsValBinds _ = emptyValBinds - - replaceValBinds (GHC.L l (GHC.HsLet binds ex)) newBinds - = (GHC.L l (GHC.HsLet (replaceValBinds binds newBinds) ex)) - replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsExpr GHC.Name) undefined for:" ++ (showGhc old) - - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds [GHC.LGRHS GHC.Name] where - hsValBinds xs = unionBinds $ map hsValBinds xs - replaceValBinds _old _new = error $ "replaceValBinds [GHC.LGRHS GHC.Name] undefined for:" -- ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.LGRHS GHC.Name) where - hsValBinds (GHC.L _ (GHC.GRHS stmts _expr)) = hsValBinds stmts - replaceValBinds _old _new = error $ "replaceValBinds (GHC.LHGRHS GHC.Name) undefined for:" -- ++ (showGhc _old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds [GHC.LStmt GHC.Name] where - hsValBinds xs = unionBinds $ map hsValBinds xs - replaceValBinds old _new = error $ "replaceValBinds [GHC.LStmt GHC.Name] undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.LStmt GHC.Name) where - hsValBinds (GHC.L _ (GHC.LetStmt binds)) = hsValBinds binds - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LStmt GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds [GHC.LPat GHC.Name] where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.LPat GHC.Name) where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.Name) where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds [GHC.SyntaxExpr GHC.Name] where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.SyntaxExpr GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds [[GHC.LTyClDecl GHC.Name]] where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds [[GHC.LTyClDecl GHC.Name]] undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds [GHC.LTyClDecl GHC.Name] where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds [GHC.LTyClDecl GHC.Name] undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.LTyClDecl GHC.Name) where - hsValBinds _ = error $ "hsValBinds (GHC.LTyClDecl GHC.Name) must pull out tcdMeths" - replaceValBinds old _new = error $ "replaceValBinds (GHC.LTyClDecl GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds [GHC.LInstDecl GHC.Name] where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds [GHC.LInstDecl GHC.Name] undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.LInstDecl GHC.Name) where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LInstDecl GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.LHsType GHC.Name) where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsType GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds [GHC.LSig GHC.Name] where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds [GHC.LSig GHC.Name] undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.LSig GHC.Name) where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LSig GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ > 704 -instance HsValBinds [GHC.LFamInstDecl GHC.Name] where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds [GHC.LFamInstDecl GHC.Name] undefined for:" ++ (showGhc old) - hsTyDecls _ = [] -#endif - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ > 704 -instance HsValBinds (GHC.LFamInstDecl GHC.Name) where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.LFamInstDecl GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] -#endif - --- --------------------------------------------------------------------- - -instance HsValBinds (GHC.HsIPBinds GHC.Name) where - hsValBinds _ = emptyValBinds - replaceValBinds old _new = error $ "replaceValBinds (GHC.HsIPBinds GHC.Name) undefined for:" ++ (showGhc old) - hsTyDecls _ = [] - --- --------------------------------------------------------------------- --} - --- --------------------------------------------------------------------- - -class (SYB.Data a, SYB.Typeable a) => FindEntity a where - - -- | Returns True is a syntax phrase, say a, is part of another - -- syntax phrase, say b. - -- NOTE: very important: only do a shallow check - findEntity:: (SYB.Data b, SYB.Typeable b) => a -> b -> Bool - --- --------------------------------------------------------------------- - -instance FindEntity GHC.Name where - - findEntity n t = fromMaybe False res - where - res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t - - worker (name::GHC.Name) - | n == name = Just True - worker _ = Nothing - --- --------------------------------------------------------------------- - --- TODO: should the location be matched too in this case? -instance FindEntity (GHC.Located GHC.Name) where - - findEntity n t = fromMaybe False res - where - res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t - - worker (name::GHC.Located GHC.Name) - | n == name = Just True - worker _ = Nothing - - --- --------------------------------------------------------------------- - -instance FindEntity (GHC.Located (GHC.HsExpr GHC.Name)) where - - findEntity e t = fromMaybe False res - where - res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t - - worker (expr::GHC.Located (GHC.HsExpr GHC.Name)) - | sameOccurrence e expr = Just True - worker _ = Nothing - --- --------------------------------------------------------------------- - -instance FindEntity (GHC.Located (GHC.HsBindLR GHC.Name GHC.Name)) where - findEntity e t = fromMaybe False res - where - res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t - - worker (expr::(GHC.Located (GHC.HsBindLR GHC.Name GHC.Name))) - | sameOccurrence e expr = Just True - worker _ = Nothing - -instance FindEntity (GHC.Located (GHC.HsDecl GHC.Name)) where - findEntity d t = fromMaybe False res - where - res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t - - worker (decl::(GHC.Located (GHC.HsDecl GHC.Name))) - | sameOccurrence d decl = Just True - worker _ = Nothing - --- --------------------------------------------------------------------- - - --- | Returns True is a syntax phrase, say a, is part of another syntax --- phrase, say b. --- Expects to be at least Parser output -findEntity':: (SYB.Data a, SYB.Data b) - => a -> b -> Maybe (SimpPos,SimpPos) -findEntity' a b = res - where - -- ++AZ++ do a generic traversal, and see if it matches. - res = somethingStaged SYB.Parser Nothing worker b - - worker :: (SYB.Typeable c,SYB.Data c) - => c -> Maybe (SimpPos,SimpPos) - worker x = if SYB.typeOf a == SYB.typeOf x - -- then Just (getStartEndLoc b == getStartEndLoc a) - then Just (getStartEndLoc x) - else Nothing - --- --------------------------------------------------------------------- - --- |Find those declarations(function\/pattern binding) which define --- the specified GHC.Names. incTypeSig indicates whether the --- corresponding type signature will be included. -definingDeclsNames:: - [GHC.Name] -- ^ The specified identifiers. - ->[GHC.LHsBind GHC.Name] -- ^ A collection of declarations. - ->Bool -- ^ True means to include the type signature. - ->Bool -- ^ True means to look at the local declarations as well. - ->[GHC.LHsBind GHC.Name] -- ^ The result. -definingDeclsNames pns ds _incTypeSig recursive = concatMap defining ds - where - defining decl - = if recursive - then SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl - else defines' decl - where - defines' :: (GHC.LHsBind GHC.Name) -> [GHC.LHsBind GHC.Name] - defines' decl'@(GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) - |isJust (find (==(pname)) pns) = [decl'] - - defines' decl'@(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) - |(hsNamess p) `intersect` pns /= [] = [decl'] - - defines' _ = [] - --- |Find those declarations(function\/pattern binding) which define --- the specified GHC.Names. incTypeSig indicates whether the --- corresponding type signature will be included. -definingDeclsNames':: (SYB.Data t) - => [GHC.Name] -- ^ The specified identifiers. - -> t -- ^ A collection of declarations. - ->[GHC.LHsBind GHC.Name] -- ^ The result. -definingDeclsNames' pns t = defining t - where - defining decl - = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl - where - defines' :: (GHC.LHsBind GHC.Name) -> [GHC.LHsBind GHC.Name] - defines' decl'@(GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) - |isJust (find (==(pname)) pns) = [decl'] - - defines' decl'@(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) - |(hsNamess p) `intersect` pns /= [] = [decl'] - - defines' _ = [] - --- --------------------------------------------------------------------- - --- |Find those type signatures for the specified GHC.Names. -definingSigsNames :: (SYB.Data t) => - [GHC.Name] -- ^ The specified identifiers. - ->t -- ^ A collection of declarations. - ->[GHC.LSig GHC.Name] -- ^ The result. -definingSigsNames pns ds = def ds - where - def decl - = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inSig) decl - where - inSig :: (GHC.LSig GHC.Name) -> [GHC.LSig GHC.Name] - inSig (GHC.L l (GHC.TypeSig ns t)) - | defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t))] - inSig _ = [] - - defines' (p::[GHC.Located GHC.Name]) - = filter (\(GHC.L _ n) -> n `elem` pns) p - --- --------------------------------------------------------------------- - --- |Find those declarations which define the specified GHC.Names. -definingTyClDeclsNames:: (SYB.Data t) - => [GHC.Name] -- ^ The specified identifiers. - -> t -- ^ A collection of declarations. - ->[GHC.LTyClDecl GHC.Name] -- ^ The result. -definingTyClDeclsNames pns t = defining t - where - defining decl - = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl - where - defines' :: (GHC.LTyClDecl GHC.Name) -> [GHC.LTyClDecl GHC.Name] - defines' decl'@(GHC.L _ (GHC.ForeignType (GHC.L _ pname) _ )) - |isJust (find (==(pname)) pns) = [decl'] - - -- NOTE: GHC 7.4.2 returns family instances as TyData, GHC 7.6.3 - -- returns them as a separate FamInstDecl - - defines' decl'@(GHC.L _ (GHC.TyFamily _ (GHC.L _ pname) _ _)) - |isJust (find (==(pname)) pns) = [decl'] - -#if __GLASGOW_HASKELL__ > 704 - defines' decl'@(GHC.L _ (GHC.TyDecl (GHC.L _ pname) _ _ _)) -#else - defines' decl'@(GHC.L _ (GHC.TyData _ _ (GHC.L _ pname) _ _ _ __ _)) -#endif - |isJust (find (==(pname)) pns) = [decl'] - -#if __GLASGOW_HASKELL__ > 704 -#else - defines' decl'@(GHC.L _ (GHC.TySynonym (GHC.L _ pname) _ _ _)) - |isJust (find (==(pname)) pns) = [decl'] -#endif - -#if __GLASGOW_HASKELL__ > 704 - defines' decl'@(GHC.L _ (GHC.ClassDecl _ (GHC.L _ pname) _ _ _ _ _ _ _ _)) -#else - defines' decl'@(GHC.L _ (GHC.ClassDecl _ (GHC.L _ pname) _ _ _ _ _ _ _)) -#endif - |isJust (find (==(pname)) pns) = [decl'] - - defines' _ = [] - --- --------------------------------------------------------------------- - --- TODO: AZ: pretty sure this can be simplified, depends if we need to --- manage transformed stuff too though. - --- | Return True if syntax phrases t1 and t2 refer to the same one. -sameOccurrence :: (GHC.Located t) -> (GHC.Located t) -> Bool -sameOccurrence (GHC.L l1 _) (GHC.L l2 _) - = l1 == l2 - - --- --------------------------------------------------------------------- - --- | Return True if the function\/pattern binding defines the --- specified identifier. -defines:: GHC.Name -> GHC.LHsBind GHC.Name -> Bool -defines n (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) - = pname == n -defines n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) - = elem n (hsNamess p) -defines _ _= False - -definesP::PName->HsDeclP->Bool -definesP pn (GHC.L _ (GHC.ValD (GHC.FunBind (GHC.L _ pname) _ _ _ _ _))) - = PN pname == pn -definesP pn (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) - = elem pn (hsPNs p) -definesP _ _= False - - --- | Return True if the declaration defines the type signature of the --- specified identifier. -definesTypeSig :: GHC.Name -> GHC.LSig GHC.Name -> Bool -definesTypeSig pn (GHC.L _ (GHC.TypeSig names _typ)) = elem pn $ map (\(GHC.L _ n)->n) names -definesTypeSig _ _ =False - - -{- --- | Return True if the declaration defines the type signature of the specified identifier. -isTypeSigOf :: PNT -> HsDeclP -> Bool -isTypeSigOf pnt (TiDecorate.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::GHC.LHsBind GHC.Name -> [GHC.Name] -definedPNs (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) = [pname] -definedPNs (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = (hsNamess p) -definedPNs (GHC.L _ (GHC.VarBind pname _rhs _)) = [pname] - --- TODO: what about GHC.AbsBinds? -definedPNs _ = [] - - --------------------------------------------------------------------------------- - -sameBind :: GHC.LHsBind GHC.Name -> GHC.LHsBind GHC.Name -> Bool -sameBind b1 b2 = (definedPNs b1) == (definedPNs b2) - --- --------------------------------------------------------------------- - --- TODO: is this the same is isUsedInRhs? -class (SYB.Data t) => UsedByRhs t where - - -- | Return True if any of the GHC.Name's appear in the given - -- syntax element - usedByRhs:: t -> [GHC.Name] -> Bool - -instance UsedByRhs GHC.RenamedSource where - - -- Defined like this in the original - usedByRhs _renamed _pns = False - -- usedByRhs renamed pns = usedByRhs (hsValBinds renamed) pns -- ++AZ++ - -instance UsedByRhs (GHC.LHsBinds GHC.Name) where - usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) $ GHC.bagToList binds - -instance UsedByRhs (GHC.HsValBinds GHC.Name) where - usedByRhs (GHC.ValBindsIn binds _sigs) pns = usedByRhs (GHC.bagToList binds) pns - usedByRhs (GHC.ValBindsOut binds _sigs) pns = or $ map (\(_,b) -> usedByRhs b pns) binds - -instance UsedByRhs (GHC.Match GHC.Name) where - usedByRhs (GHC.Match _ _ (GHC.GRHSs rhs _)) pns -- = usedByRhs (hsValBinds rhs) pns - = findPNs pns rhs - -instance UsedByRhs [GHC.LHsBind GHC.Name] where - usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) binds - -instance UsedByRhs (GHC.HsBind GHC.Name) where - usedByRhs (GHC.FunBind _ _ matches _ _ _) pns = findPNs pns matches - usedByRhs (GHC.PatBind _ rhs _ _ _) pns = findPNs pns rhs - usedByRhs (GHC.VarBind _ rhs _) pns = findPNs pns rhs - usedByRhs (GHC.AbsBinds _ _ _ _ _) _pns = False - -instance UsedByRhs (GHC.LHsBind GHC.Name) where - usedByRhs (GHC.L _ bind) pns = usedByRhs bind pns - -instance UsedByRhs (GHC.LHsExpr GHC.Name) where - usedByRhs (GHC.L _ e) pns = usedByRhs e pns - -instance UsedByRhs (GHC.HsExpr GHC.Name) where - usedByRhs (GHC.HsLet _lb e) pns = findPNs pns e - usedByRhs e _pns = error $ "undefined usedByRhs:" ++ (showGhc e) - -instance UsedByRhs (GHC.Stmt GHC.Name) where - usedByRhs (GHC.LetStmt lb) pns = findPNs pns lb - usedByRhs s _pns = error $ "undefined usedByRhs:" ++ (showGhc s) - - --------------------------------------------------------------------------------- - --- |Find the identifier(in GHC.Name format) whose start position is --- (row,col) in the file specified by the fileName, and returns --- `Nothing` if such an identifier does not exist. -locToName::(SYB.Data t) - =>SimpPos -- ^ The row and column number - ->t -- ^ The syntax phrase - -> Maybe (GHC.Located GHC.Name) -- ^ The result -locToName (row,col) t = locToName' SYB.Renamer (row,col) t - --- |Find the identifier(in GHC.RdrName format) whose start position is --- (row,col) in the file specified by the fileName, and returns --- `Nothing` if such an identifier does not exist. -locToRdrName::(SYB.Data t) - =>SimpPos -- ^ The row and column number - ->t -- ^ The syntax phrase - -> Maybe (GHC.Located GHC.RdrName) -- ^ The result -locToRdrName (row,col) t = locToName' SYB.Parser (row,col) t - - --- |Worker for both locToName and locToRdrName. --- NOTE: provides for FunBind MatchGroups where only the first name is --- retained in the AST -locToName'::(SYB.Data t, SYB.Data a, Eq a,GHC.Outputable a) - =>SYB.Stage - ->SimpPos -- ^ The row and column number - ->t -- ^ The syntax phrase - -> Maybe (GHC.Located a) -- ^ The result -locToName' stage (row,col) t = - if res1 /= Nothing - then res1 - else res2 - where - res1 = somethingStaged stage Nothing - (Nothing `SYB.mkQ` worker - `SYB.extQ` workerBind - `SYB.extQ` workerExpr - `SYB.extQ` workerLIE - `SYB.extQ` workerHsTyVarBndr - `SYB.extQ` workerLHsType - ) t - - res2 = somethingStaged stage Nothing - (Nothing `SYB.mkQ` workerFunBind) t - - {- - res = reverse $ everythingStaged SYB.Renamer (++) [] - ([] `SYB.mkQ` workerFunBind `SYB.extQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t - - res' = case res of - [] -> Nothing - xs -> Just (head xs) - -} - -- A FunBind has a MatchGroup, which lists all the possible - -- bindings. Hence - -- x 0 = 0 - -- x y = 2 * y - -- Will have a single FunBind, with name x and using the - -- specific (GHC.L l GHC.Name) of the x on the first line. - -- Attempting to find the variable x on the second line will - -- fail, it needs to be deduced from a FunBind having more - -- than one match. The Located Match includes the original - -- variable name in the location, but not in the match contents - workerFunBind ((GHC.FunBind pnt _ (GHC.MatchGroup matches _) _ _ _) :: (GHC.HsBindLR a a)) - | nonEmptyList match = Just pnt - where - -- match = error $ "locToName':matches=" ++ (showGhc $ map (\(GHC.L l _) -> l) matches) - match = filter inScope (tail matches) - -- match = filter inScope (matches) - workerFunBind _ = Nothing - - worker (pnt :: (GHC.Located a)) - | inScope pnt = Just pnt - worker _ = Nothing - - workerBind pnt@(GHC.L l (GHC.VarPat name) :: (GHC.Located (GHC.Pat a))) - | inScope pnt = Just (GHC.L l name) - workerBind _ = Nothing - - workerExpr (pnt@(GHC.L l (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr a))) - | inScope pnt = Just (GHC.L l name) - workerExpr _ = Nothing - - workerLIE (pnt@(GHC.L l (GHC.IEVar name)) :: (GHC.LIE a)) - | inScope pnt = Just (GHC.L l name) - workerLIE _ = Nothing - -#if __GLASGOW_HASKELL__ > 704 - workerHsTyVarBndr (pnt@(GHC.L l (GHC.UserTyVar name)):: (GHC.LHsTyVarBndr a)) -#else - workerHsTyVarBndr (pnt@(GHC.L l (GHC.UserTyVar name _typ)):: (GHC.LHsTyVarBndr a)) -#endif - | inScope pnt = Just (GHC.L l name) - workerHsTyVarBndr _ = Nothing - - workerLHsType (pnt@(GHC.L l (GHC.HsTyVar name)):: (GHC.LHsType a)) - | inScope pnt = Just (GHC.L l name) - workerLHsType _ = Nothing - - - inScope :: GHC.Located e -> Bool - inScope (GHC.L l _) = - case l of - (GHC.UnhelpfulSpan _) -> False - (GHC.RealSrcSpan ss) -> - -- (GHC.srcSpanFile ss == fileName) && - (GHC.srcSpanStartLine ss <= row) && - (GHC.srcSpanEndLine ss >= row) && - (col >= (GHC.srcSpanStartCol ss)) && - (col <= (GHC.srcSpanEndCol ss)) - - --------------------------------------------------------------------------------- - --- |Find all Located Names in the given Syntax phrase. -allNames::(SYB.Data t) - =>t -- ^ The syntax phrase - ->[GHC.Located GHC.Name] -- ^ The result -allNames t - = res - where - res = SYB.everythingStaged SYB.Parser (++) [] - ([] `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t - - worker (pnt :: (GHC.Located GHC.Name)) - = [pnt] - -- worker _ = [] - - workerBind (GHC.L l (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name))) - = [(GHC.L l name)] - workerBind _ = [] - - workerExpr ((GHC.L l (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name))) - = [(GHC.L l name)] - workerExpr _ = [] - - - --------------------------------------------------------------------------------- - --- |Find the identifier with the given name. This looks through the --- given syntax phrase for the first GHC.Name which matches. Because --- it is Renamed source, the GHC.Name will include its defining --- location. Returns Nothing if the name is not found. - -getName::(SYB.Data t)=> String -- ^ The name to find - -> t -- ^ The syntax phrase - -> Maybe GHC.Name -- ^ The result -getName str t - = res - where - res = somethingStaged SYB.Renamer Nothing - (Nothing `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t - - worker ((GHC.L _ n) :: (GHC.Located GHC.Name)) - | showGhc n == str = Just n - worker _ = Nothing - - workerBind (GHC.L _ (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name))) - | showGhc name == str = Just name - workerBind _ = Nothing - - - workerExpr ((GHC.L _ (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name))) - | showGhc name == str = Just name - workerExpr _ = Nothing - --- --------------------------------------------------------------------- - --- | 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. - -addImportDecl :: - GHC.RenamedSource - -> GHC.ModuleName - -> Maybe GHC.FastString -- ^qualifier - -> Bool -> Bool -> Bool - -> Maybe String -- ^alias - -> Bool - -> [GHC.Name] - -> RefactGhc GHC.RenamedSource -addImportDecl (groupedDecls,imp, b, c) modName pkgQual source safe qualify alias hide idNames - = do - toks <- fetchToks - let toks1 - =if length imps' > 0 - then let (_startLoc, endLoc) = getStartEndLoc $ last imps' - toks1' = getToks ((1,1),endLoc) toks - in toks1' - else if not $ isEmptyGroup groupedDecls - then - let startLoc = fst $ startEndLocIncComments toks groupedDecls - (toks1', _toks2') = break (\t ->tokenPos t==startLoc) toks - in toks1' - else toks - - -- drawTokenTreeDetailed "before starting" - logm $ "addImportDecl:toks =" ++ show toks - logm $ "addImportDecl:toks1=" ++ show toks1 - - let lastTok = ghead "addImportDecl" $ dropWhile isWhiteSpace $ reverse toks1 - let startPos = tokenPos lastTok - let endPos = tokenPosEnd lastTok - - let newToks = basicTokenise (showGhc impDecl) - logm $ "addImportDecl:newToks=" ++ (show newToks) -- ++AZ++ - void $ addToksAfterPos (startPos,endPos) (PlaceOffset 1 0 1) newToks - return (groupedDecls, (imp++[(mkNewLSomething impDecl)]), b, c) - where - - alias' = case alias of - Just stringName -> Just $ GHC.mkModuleName stringName - _ -> Nothing - - impDecl = GHC.ImportDecl { - GHC.ideclName = mkNewLModuleName modName - , GHC.ideclPkgQual = pkgQual - , GHC.ideclSource = source - , GHC.ideclSafe = safe - , GHC.ideclQualified = qualify - , GHC.ideclImplicit = False - , GHC.ideclAs = alias' - , GHC.ideclHiding = - (if idNames == [] && hide == False then - Nothing - else - (Just (hide, map mkNewEnt idNames))) - } - imps' = rmPreludeImports imp - - mkNewLSomething :: a -> GHC.Located a - mkNewLSomething a = (GHC.L l a) where - filename = (GHC.mkFastString "f") - l = GHC.mkSrcSpan (GHC.mkSrcLoc filename 1 1) (GHC.mkSrcLoc filename 1 1) - - - mkNewLModuleName :: GHC.ModuleName -> GHC.Located GHC.ModuleName - mkNewLModuleName moduName = mkNewLSomething moduName - --- --------------------------------------------------------------------- - -isEmptyGroup :: GHC.HsGroup id -> Bool -isEmptyGroup x = (==0) $ sum $ - [valds, tyclds, instds, derivds, fixds, defds, fords, warnds, annds, ruleds, vects, docs] - where - valds = size $ GHC.hs_valds x - - size :: GHC.HsValBindsLR idL idR -> Int - size (GHC.ValBindsIn lhsBinds sigs) = (length sigs) + (length . GHC.bagToList $ lhsBinds) - size (GHC.ValBindsOut recFlags lsigs) = (length lsigs) + (length recFlags) - - tyclds = length $ GHC.hs_tyclds x - - instds = length $ GHC.hs_instds x - - derivds = length $ GHC.hs_derivds x - - fixds = length $ GHC.hs_fixds x - - defds = length $ GHC.hs_defds x - - fords = length $ GHC.hs_fords x - - warnds = length $ GHC.hs_warnds x - - annds = length $ GHC.hs_annds x - - ruleds = length $ GHC.hs_ruleds x - - vects = length $ GHC.hs_vects x - - docs = length $ GHC.hs_docs x - - --- | Remove ImportDecl from the imports list, commonly returned from a RenamedSource type, so it can --- be further processed. ---rmPreludeImports :: [GHC.Located (GHC.ImportDecl GHC.Name)] -> [GHC.Located (GHC.ImportDecl GHC.Name)] -rmPreludeImports :: - [GHC.Located (GHC.ImportDecl GHC.Name)] - -> [GHC.Located (GHC.ImportDecl GHC.Name)] -rmPreludeImports = filter isPrelude where - isPrelude = (/="Prelude") . GHC.moduleNameString . GHC.unLoc . GHC.ideclName . GHC.unLoc - - --- --------------------------------------------------------------------- - --- |Make a new set of tokens, originating at (0,0), for a given --- declaration and optional signature. --- NOTE: This function returns tokens originating at (0,0), to be --- stitched in at the right place by TokenUtils -makeNewToks :: (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken]) - -> RefactGhc [PosToken] -makeNewToks (decl, maybeSig, declToks) = do - let - declStr = case declToks of - Just ts -> "\n" ++ (unlines $ dropWhile (\l -> l == "") $ lines $ GHC.showRichTokenStream $ reAlignMarked ts) - Nothing -> "\n"++(prettyprint decl)++"\n\n" - sigStr = case declToks of - Just _ts -> "" - Nothing -> "\n" ++ (intercalate "\n" $ map prettyprint maybeSig) - -- logm $ "makeNewToks:declStr=[" ++ declStr ++ "]" - let newToks = tokenise ((0,0),(0,0)) 0 True (sigStr ++ declStr) - return newToks - --- --------------------------------------------------------------------- - --- | Adding a declaration to the declaration list of the given syntax --- phrase. 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:: (SYB.Data t,HsValBinds t) - => t -- ^The AST to be updated - -> Maybe GHC.Name -- ^If this is Just, then the declaration - -- will be added right after this - -- identifier's definition. - -> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken]) - -- ^ The declaration with optional signatures to be added, - -- in both AST and Token stream format (optional). If - -- signature and tokens provided, the tokens should - -- include the signature too - -> Bool -- ^ True means the declaration is a - -- toplevel declaration. - -> RefactGhc t - -addDecl parent pn (decl, msig, declToks) topLevel - = if isJust pn - then appendDecl parent (gfromJust "addDecl" pn) (decl, msig, declToks) - else if topLevel - then addTopLevelDecl (decl, msig, declToks) parent - else addLocalDecl parent (decl,msig,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 :: (SYB.Data t, HsValBinds t) - => (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken]) - -> t -> RefactGhc t - addTopLevelDecl (newDecl, maybeSig, maybeDeclToks) parent' - = do let binds = hsValBinds parent' - decls = hsBinds parent' - (decls1,decls2) = break (\x->isFunOrPatBindR x {- was || isTypeSig x -}) decls - - newToks <- makeNewToks (newDecl,maybeSig,maybeDeclToks) - logm $ "addTopLevelDecl:newToks=" ++ (show newToks) - - let Just sspan = if (emptyList decls2) - then getSrcSpan (glast "addTopLevelDecl" decls1) - else getSrcSpan (ghead "addTopLevelDecl" decls2) - - decl' <- putDeclToksAfterSpan sspan newDecl (PlaceOffset 2 0 2) newToks - - return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds)))) - - appendDecl :: (SYB.Data t, HsValBinds t) - => t -- ^Original AST - -> GHC.Name -- ^Name to add the declaration after - -> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken]) -- ^declaration and maybe sig/tokens - -> RefactGhc t -- ^updated AST - appendDecl parent' pn' (newDecl, maybeSig, declToks') - = do let binds = hsValBinds parent' - -- logm $ "appendDecl:declToks=" ++ (show declToks') - newToks <- makeNewToks (newDecl,maybeSig,declToks') - -- logm $ "appendDecl:newToks=" ++ (show newToks) - - let Just sspan = getSrcSpan $ ghead "appendDecl" after - decl' <- putDeclToksAfterSpan sspan newDecl (PlaceOffset 2 0 2) newToks - - let decls1 = before ++ [ghead "appendDecl14" after] - decls2 = gtail "appendDecl15" after - {- - case maybeSig of - Nothing -> return (replaceBinds parent (decls1++[decl']++decls2)) - Just sig -> return (replaceValBinds parent (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (sig:(getValBindSigs binds)))) - -} - return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds)))) - where - decls = hsBinds parent' - (before,after) = break (defines pn') decls -- Need to handle the case that 'after' is empty? - - - addLocalDecl :: (SYB.Data t, HsValBinds t) - => t -> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken]) - -> RefactGhc t - addLocalDecl parent' (newFun, maybeSig, newFunToks) - =do - let binds = hsValBinds parent' - - let (startLoc@((_,prevCol)),endLoc) - = if (emptyList localDecls) - then getStartEndLoc parent' - else getStartEndLoc localDecls - - let newToks = basicTokenise newSource - - (newFun',_) <- addLocInfo (newFun, newToks) - - let rowIndent = 1 - - if (emptyList localDecls) - then - void $ addToksAfterPos (startLoc,endLoc) (PlaceOffset rowIndent 4 2) newToks - else - void $ addToksAfterPos (startLoc,endLoc) (PlaceAbsCol (rowIndent+1) prevCol 2) newToks - - - return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag ((hsBinds parent' ++ [newFun']))) (maybeSig++(getValBindSigs binds)))) - where - localDecls = hsBinds parent' - - -- TODO: where tokens are passed in, first normalise them to - -- the left column before adding in the where clause part - newSource = if (emptyList localDecls) - then "where\n"++ concatMap (\l-> " "++l++"\n") (lines newFun') - else ("" ++ newFun'++"\n") - where - newFun' = unlines $ stripLeadingSpaces $ lines $ sigStr ++ newFunBody - newFunBody = case newFunToks of - Just ts -> unlines $ dropWhile (\l -> l == "") $ lines $ GHC.showRichTokenStream $ reAlignMarked ts - Nothing -> prettyprint newFun - - sigStr = case newFunToks of - Just _ts -> "" - Nothing -> if (emptyList maybeSig) - then "" - else (intercalate "\n" $ map prettyprint maybeSig) ++ "\n" - --- --------------------------------------------------------------------- - --- |Take a list of strings and return a list with the longest prefix --- of spaces removed -stripLeadingSpaces :: [String] -> [String] -stripLeadingSpaces xs = map (drop n) xs - where - n = minimum $ map oneLen xs - - oneLen x = length prefix - where - (prefix,_) = break (/=' ') x - --- --------------------------------------------------------------------- - --- | add items to the hiding list of an import declaration which --- imports the specified module. -addHiding:: - GHC.ModuleName -- ^ The imported module name - ->GHC.RenamedSource -- ^ The current module - ->[GHC.Name] -- ^ The items to be added - ->RefactGhc GHC.RenamedSource -- ^ The result (with token stream updated) -addHiding a b c = addItemsToImport' a b c Hide - --- | Creates a new entity for hiding a name in an ImportDecl. -mkNewEnt :: GHC.Name -> GHC.LIE GHC.Name -mkNewEnt pn = (GHC.L l (GHC.IEVar pn)) - where - filename = (GHC.mkFastString "f") - l = GHC.mkSrcSpan (GHC.mkSrcLoc filename 1 1) (GHC.mkSrcLoc filename 1 1) - --- | Represents the operation type we want to select on addItemsToImport' -data ImportType = Hide -- ^ Used for addHiding - | Import -- ^ Used for addItemsToImport - --- | Add identifiers (given by the third argument) to the explicit entity list in the declaration importing the --- specified module name. This function does nothing if the import declaration does not have an explicit entity list. -addItemsToImport:: - GHC.ModuleName -- ^ The imported module name - ->GHC.RenamedSource -- ^ The current module - ->[GHC.Name] -- ^ The items to be added --- ->Maybe GHC.Name -- ^ The condition identifier. - ->RefactGhc GHC.RenamedSource -- ^ The result (with token stream updated) -addItemsToImport a b c = addItemsToImport' a b c Import - --- | Add identifiers (given by the third argument) to the explicit entity list in the declaration importing the --- specified module name. If the ImportType argument is Hide, then the items will be added to the "hiding" --- list. If it is Import, they will be added to the explicit import entries. This function does nothing if --- the import declaration does not have an explicit entity list and ImportType is Import. -addItemsToImport':: - GHC.ModuleName -- ^ The imported module name - ->GHC.RenamedSource -- ^ The current module - ->[GHC.Name] -- ^ The items to be added --- ->Maybe GHC.Name -- ^ The condition identifier. - ->ImportType -- ^ Whether to hide the names or import them. Uses special data for clarity. - ->RefactGhc GHC.RenamedSource -- ^ The result (with token stream updated) -addItemsToImport' serverModName (g,imps,e,d) pns impType = do - imps' <- mapM inImport imps - return (g,imps',e,d) - where - isHide = case impType of - Hide -> True - Import -> False - - inImport :: GHC.LImportDecl GHC.Name -> RefactGhc (GHC.LImportDecl GHC.Name) - inImport imp@(GHC.L _ (GHC.ImportDecl (GHC.L _ modName) _qualify _source _safe isQualified _isImplicit _as h)) - | serverModName == modName && not isQualified -- && (if isJust pn then findPN (gfromJust "addItemsToImport" pn) h else True) - = case h of - Nothing -> insertEnts imp [] True - Just (_isHide, ents) -> insertEnts imp ents False - inImport x = return x - - insertEnts :: - GHC.LImportDecl GHC.Name - -> [GHC.LIE GHC.Name] - -> Bool - -> RefactGhc ( GHC.LImportDecl GHC.Name ) - insertEnts imp ents isNew = - if isNew && not isHide then return imp - else do - toks <- fetchToks - let (startPos,endPos) = getStartEndLoc imp - ((GHC.L l t),s) = ghead "addHiding" $ reverse $ getToks (startPos,endPos) toks - start = getGhcLoc l - end = getGhcLocEnd l - - beginning = - if isNew then - s ++ (if isHide then " hiding " else " ")++"(" - else "," - ending = if isNew then ")" else s - - newToken=mkToken t start (beginning++showEntities showGhc pns ++ending) - -- toks'=replaceToks toks start end [newToken] - -- toks'=replaceTok toks start newToken - - void $ putToksForPos (start,end) [newToken] - - return (replaceHiding imp (Just (isHide, (map mkNewEnt pns)++ents))) - - - replaceHiding (GHC.L l (GHC.ImportDecl mn q src safe isQ isImp as _h)) h1 = - (GHC.L l (GHC.ImportDecl mn q src safe isQ isImp as h1)) - --- --------------------------------------------------------------------- - -addParamsToDecls:: - [GHC.LHsBind GHC.Name] -- ^ A declaration list where the function is defined and\/or used. - ->GHC.Name -- ^ The function name. - ->[GHC.Name] -- ^ The parameters to be added. - ->Bool -- ^ Modify the token stream or not. - ->RefactGhc [GHC.LHsBind GHC.Name] -- ^ The result. - -addParamsToDecls decls pn paramPNames modifyToks = do - logm $ "addParamsToDecls (pn,paramPNames,modifyToks)=" ++ (showGhc (pn,paramPNames,modifyToks)) - -- logm $ "addParamsToDecls: decls=" ++ (SYB.showData SYB.Renamer 0 decls) - if (paramPNames/=[]) - then mapM addParamToDecl decls - else return decls - where - addParamToDecl :: GHC.LHsBind GHC.Name -> RefactGhc (GHC.LHsBind GHC.Name) - addParamToDecl (GHC.L l1 (GHC.FunBind (GHC.L l2 pname) i (GHC.MatchGroup matches ptt) co fvs t)) - | pname == pn - = do matches' <- mapM addParamtoMatch matches - return (GHC.L l1 (GHC.FunBind (GHC.L l2 pname) i (GHC.MatchGroup matches' ptt) co fvs t)) - where - -- addParamtoMatch (HsMatch loc fun pats rhs decls) - addParamtoMatch (GHC.L l (GHC.Match pats mtyp rhs)) - = do rhs' <- addActualParamsToRhs modifyToks pn paramPNames rhs - let pats' = map GHC.noLoc $ map pNtoPat paramPNames - _pats'' <- if modifyToks - then do -- TODO: What happens if pats is [] - -- Will only happen if there is a single match only. - logm $ "addParamtoMatch:l=" ++ (showGhc l) - if emptyList pats - then addFormalParams (Left l2) pats' - else addFormalParams (Right pats) pats' - return pats' - - else return pats' - -- return (HsMatch loc fun (pats'++pats) rhs' decls) - return (GHC.L l (GHC.Match (pats'++pats) mtyp rhs')) - - -- addParamToDecl (TiDecorate.Dec (HsPatBind loc p rhs ds)) - addParamToDecl (GHC.L l1 (GHC.PatBind pat@(GHC.L _l2 (GHC.VarPat p)) rhs ty fvs t)) - | p == pn - = do _rhs'<-addActualParamsToRhs modifyToks pn paramPNames rhs - let pats' = map GHC.noLoc $ map pNtoPat paramPNames - _pats'' <- if modifyToks then do _ <- addFormalParams (Right [pat]) pats' - return pats' - else return pats' - -- return (TiDecorate.Dec (HsFunBind loc [HsMatch loc (patToPNT p) pats' rhs ds])) - return (GHC.L l1 (GHC.PatBind pat rhs ty fvs t)) - addParamToDecl x=return x - - --- | Add tokens corresponding to the new parameters to the end of the --- syntax element provided -addFormalParams - :: Either GHC.SrcSpan [(GHC.LPat GHC.Name)] -- location: SrcSpan only - -- if no existing params, else list - -- of current params - -> [(GHC.LPat GHC.Name)] -- params to add - -> RefactGhc () -addFormalParams place newParams - = do - -- logm $ "addFormalParams:(place,newParams):" ++ (SYB.showData SYB.Renamer 0 (place,newParams)) - -- newToks <- liftIO $ basicTokenise (prettyprintPatList prettyprint True newParams) - let newStr = (prettyprintPatList prettyprint True newParams) - - case place of - Left l@(GHC.RealSrcSpan _ss) -> do - let newToks' = tokenise (gs2ss l) 0 False newStr - let newToks = map markToken newToks' - _ <- addToksAfterSpan l PlaceAdjacent newToks - return () - Left ss -> error $ "addFormalParams: expecting RealSrcSpan, got:" ++ (showGhc ss) - Right pats -> do - let l = GHC.combineLocs (ghead "addFormalParams" pats) (glast "addFormalParams" pats) - -- logm $ "addFormalParams:(l,pats)=" ++ (SYB.showData SYB.Renamer 0 (l,pats)) - toks <- getToksForSpan l - - let oldStr = GHC.showRichTokenStream $ rmOffsetFromToks toks - let combinedToks = tokenise (gs2ss $ tokenSrcSpan $ ghead "addFormalParams" toks) - 0 False (newStr ++ " " ++ oldStr) - - _ <- putToksForSpan l combinedToks - - return () - - -- drawTokenTree "after addFormalParams" - -- drawTokenTreeDetailed "after addFormalParams" - --- --------------------------------------------------------------------- - -addActualParamsToRhs :: (SYB.Typeable t, SYB.Data t) => - Bool -> GHC.Name -> [GHC.Name] -> t -> RefactGhc t -addActualParamsToRhs modifyToks pn paramPNames rhs = do - -- logm $ "addActualParamsToRhs:rhs=" ++ (SYB.showData SYB.Renamer 0 $ rhs) - - -- = applyTP (stop_tdTP (failTP `adhocTP` worker)) - - r <- applyTP (stop_tdTPGhc (failTP `adhocTP` grhs)) rhs - -- r <- everywhereMStaged SYB.Renamer (SYB.mkM grhs) rhs - return r - where - - -- |Limit the action to actual RHS elements - grhs :: (GHC.GRHSs GHC.Name) -> RefactGhc (GHC.GRHSs GHC.Name) - grhs (GHC.GRHSs g lb) = do - -- logm $ "addActualParamsToRhs.grhs:g=" ++ (SYB.showData SYB.Renamer 0 g) - g' <- everywhereMStaged SYB.Renamer (SYB.mkM worker) g - return (GHC.GRHSs g' lb) - - worker :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name)) - worker oldExp@(GHC.L l2 (GHC.HsVar pname)) - | pname == pn = do - -- logm $ "addActualParamsToRhs:oldExp=" ++ (SYB.showData SYB.Renamer 0 oldExp) - let newExp' = foldl addParamToExp oldExp paramPNames - let newExp = (GHC.L l2 (GHC.HsPar newExp')) - -- TODO: updateToks must add a space at the end of the - -- new exp - if modifyToks then do _ <- updateToks oldExp newExp prettyprint False - return newExp - else return newExp - worker x = return x - - addParamToExp :: (GHC.LHsExpr GHC.Name) -> GHC.Name -> (GHC.LHsExpr GHC.Name) - addParamToExp expr param = GHC.noLoc (GHC.HsApp expr (GHC.noLoc (GHC.HsVar param))) - - -{- -Required end result : (sq pow) x + sumSquares xs - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-46} - (OpApp - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-30} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:21-28} - (HsPar - (L {test/testdata/LiftToToplevel/D2.hs:6:22-27} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:22-23} - (HsVar {Name: LiftToToplevel.D2.sq})) - (L {test/testdata/LiftToToplevel/D2.hs:6:25-27} - (HsVar {Name: pow})))))) - (L {test/testdata/LiftToToplevel/D2.hs:6:30} - (HsVar {Name: x})))) - - (L {test/testdata/LiftToToplevel/D2.hs:6:32} - (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} - (L {test/testdata/LiftToToplevel/D2.hs:6:34-46} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:34-43} - (HsVar {Name: LiftToToplevel.D2.sumSquares})) - (L {test/testdata/LiftToToplevel/D2.hs:6:45-46} - (HsVar {Name: xs}))))))))] - -Alternate, no parens : sq pow x + sumSquares xs - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-44} - (OpApp - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-28} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:21-26} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:21-22} - (HsVar {Name: LiftToToplevel.D2.sq})) - (L {test/testdata/LiftToToplevel/D2.hs:6:24-26} - (HsVar {Name: pow})))) - (L {test/testdata/LiftToToplevel/D2.hs:6:28} - (HsVar {Name: x})))) - - - (L {test/testdata/LiftToToplevel/D2.hs:6:30} - (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} - (L {test/testdata/LiftToToplevel/D2.hs:6:32-44} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:32-41} - (HsVar {Name: LiftToToplevel.D2.sumSquares})) - (L {test/testdata/LiftToToplevel/D2.hs:6:43-44} - (HsVar {Name: xs}))))))))] - - -Original : sq x + sumSquares xs - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-40} - (OpApp - - (L {test/testdata/LiftToToplevel/D2.hs:6:21-24} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:21-22} - (HsVar {Name: sq})) - (L {test/testdata/LiftToToplevel/D2.hs:6:24} - (HsVar {Name: x})))) - - - (L {test/testdata/LiftToToplevel/D2.hs:6:26} - (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} - (L {test/testdata/LiftToToplevel/D2.hs:6:28-40} - (HsApp - (L {test/testdata/LiftToToplevel/D2.hs:6:28-37} - (HsVar {Name: LiftToToplevel.D2.sumSquares})) - (L {test/testdata/LiftToToplevel/D2.hs:6:39-40} - (HsVar {Name: xs}))))))))] - --} - --- --------------------------------------------------------------------- - --- | Duplicate a function\/pattern binding declaration under a new name --- right after the original one. Also updates the token stream. -duplicateDecl::(SYB.Data t) => - [GHC.LHsBind GHC.Name] -- ^ The declaration list - ->t -- ^ Any signatures are in here - ->GHC.Name -- ^ The identifier whose definition is to be duplicated - ->GHC.Name -- ^ The new name (possibly qualified) - ->RefactGhc [GHC.LHsBind GHC.Name] -- ^ The result -duplicateDecl decls sigs n newFunName - = do - let Just sspan = getSrcSpan funBinding - toks <- getToksForSpan sspan - -- lay <- getLayoutForSpan sspan - - newSpan <- case typeSig of - [] -> return sspan - _ -> do - let Just sspanSig = getSrcSpan typeSig - toksSig <- getToksForSpan sspanSig - -- laySig <- getLayoutForSpan sspanSig - - let colStart = tokenCol $ ghead "duplicateDecl.sig" - $ dropWhile isWhiteSpace toksSig - - typeSig' <- putDeclToksAfterSpan sspan (ghead "duplicateDecl" typeSig) (PlaceAbsCol 2 colStart 0) toksSig - _typeSig'' <- renamePN n newFunName True False typeSig' - - let (GHC.L sspanSig' _) = typeSig' - - return sspanSig' - - let rowOffset = case typeSig of - [] -> 2 - _ -> 1 - - let colStart = tokenCol $ ghead "duplicateDecl.decl" - $ dropWhile isWhiteSpace toks - - funBinding' <- putDeclToksAfterSpan newSpan (ghead "duplicateDecl" funBinding) (PlaceAbsCol rowOffset colStart 2) toks - funBinding'' <- renamePN n newFunName True False funBinding' - - -- return (typeSig'++funBinding') -- ++AZ++ TODO: reinstate this - return [funBinding''] - where - declsToDup = definingDeclsNames [n] decls True False -- ++AZ++ should recursive be set true? - funBinding = filter isFunOrPatBindR declsToDup --get the fun binding. - typeSig = definingSigsNames [n] sigs - --- --------------------------------------------------------------------- - --- | Remove the declaration (and the type signature is the second --- parameter is True) that defines the given identifier from the --- declaration list. -rmDecl:: (SYB.Data t) - => GHC.Name -- ^ The identifier whose definition is to be removed. - -> Bool -- ^ True means including the type signature. - -> t -- ^ The AST fragment containting the declarations - -> RefactGhc - (t, - GHC.LHsBind GHC.Name, - Maybe (GHC.LSig GHC.Name)) -- ^ The result and the removed - -- declaration, with SrcSpans - -- adjusted to reflect the stashed - -- tokens and the possibly removed - -- siganture -rmDecl pn incSig t = do - logm $ "rmDecl:(pn,incSig)= " ++ (showGhc (pn,incSig)) -- ++AZ++ - -- drawTokenTreeDetailed "rmDecl.entry tree" -- ++AZ++ 'in' present - setStateStorage StorageNone - t2 <- everywhereMStaged' SYB.Renamer (SYB.mkM inLet) t -- top down - -- drawTokenTreeDetailed "rmDecl.entry after inLet" -- ++AZ++ 'in' missing - -- drawTokenTree "rmDecl.entry after inLet" -- ++AZ++ 'in' missing - t' <- everywhereMStaged' SYB.Renamer (SYB.mkM inDecls `SYB.extM` inGRHSs) t2 -- top down - - -- applyTP (once_tdTP (failTP `adhocTP` inDecls)) t - -- t' <- everywhereMStaged SYB.Renamer (SYB.mkM inDecls) t - (t'',sig') <- if incSig - then rmTypeSig pn t' - else return (t', Nothing) - storage <- getStateStorage - let decl' = case storage of - StorageBind bind -> bind - x -> error $ "rmDecl: unexpected value in StateStorage:" ++ (show x) - return (t'',decl',sig') - where - inGRHSs ((GHC.GRHSs a localDecls)::GHC.GRHSs GHC.Name) - -- was | not $ emptyList (snd (break (defines pn) decls)) -- /=[] - | not $ emptyList (snd (break (defines pn) (hsBinds localDecls))) -- /=[] - = do - let decls = hsBinds localDecls - -- logm $ "rmDecl:inGRHSs decls=" ++ (SYB.showData SYB.Renamer 0 $ decls) - -- logm $ "rmDecl:inGRHSs localDecls=" ++ (SYB.showData SYB.Renamer 0 $ localDecls) - let (_decls1, decls2) = break (defines pn) decls - decl = ghead "rmDecl" decls2 - topLevel <- isTopLevelPN pn - decls' <- case topLevel of - True -> rmTopLevelDecl decl decls - False -> rmLocalDecl decl decls - return (GHC.GRHSs a (replaceBinds localDecls decls')) - inGRHSs x = return x - - inDecls (decls::[GHC.LHsBind GHC.Name]) - | not $ emptyList (snd (break (defines pn) decls)) -- /=[] - = do let (_decls1, decls2) = break (defines pn) decls - decl = ghead "rmDecl" decls2 - -- error $ (render.ppi) t -- ecl ++ (show decl) - topLevel <- isTopLevelPN pn - case topLevel of - True -> rmTopLevelDecl decl decls - False -> rmLocalDecl decl decls - inDecls x = return x - - inLet :: GHC.LHsExpr GHC.Name -> RefactGhc (GHC.LHsExpr GHC.Name) - inLet (GHC.L ss (GHC.HsLet localDecls expr@(GHC.L l _))) - | not $ emptyList (snd (break (defines pn) (hsBinds localDecls))) - = do - -- putSrcSpan ss -- Make sure the tree includes a SrcSpan for - -- the HsLet, for when it is replaced later - - let decls = hsBinds localDecls - let (decls1, decls2) = break (defines pn) decls - decl = ghead "rmDecl" decls2 - - -- drawTokenTreeDetailed "rmDecl.inLet tree" -- ++AZ++ present - toks <- getToksForSpan l - -- drawTokenTreeDetailed "rmDecl.inLet tree" -- ++AZ++ missing - -- toks <- getToksForSpanWithIntros l - removeToksForPos (getStartEndLoc decl) - -- drawTokenTree "rmDecl.inLet after removeToksForPos" - decl' <- syncDeclToLatestStash decl - setStateStorage (StorageBind decl') - -- drawTokenTree "rmDecl.inLet after syncDeclToLatestStash" - case length decls of - 1 -> do -- Removing the last declaration - -- logm $ "rmDecl.inLet:length decls = 1: expr=" ++ (SYB.showData SYB.Renamer 0 expr) - -- putToksForSpan ss toks - (_,expr') <- putDeclToksForSpan ss expr $ dropWhile (\tok -> isEmpty tok || isIn tok) toks - -- drawTokenTree "rmDecl.inLet after putToksForSpan" - return expr' - _ -> do - logm $ "rmDecl.inLet:length decls /= 1" - -- drawTokenTreeDetailed "rmDecl.inLet tree" - let decls2' = gtail "inLet" decls2 - return $ (GHC.L ss (GHC.HsLet (replaceBinds localDecls (decls1 ++ decls2')) expr)) - - inLet x = return x - - - rmTopLevelDecl :: GHC.LHsBind GHC.Name -> [GHC.LHsBind GHC.Name] - -> RefactGhc [GHC.LHsBind GHC.Name] - rmTopLevelDecl decl decls - =do - logm $ "rmTopLevelDecl:" -- ++AZ++ - - removeToksForPos (getStartEndLoc decl) - decl' <- syncDeclToLatestStash decl - setStateStorage (StorageBind decl') - - let (decls1, decls2) = break (defines pn) decls - decls2' = gtail "rmTopLevelDecl 1" decls2 - return $ (decls1 ++ decls2') - -- 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 :: GHC.LHsBind GHC.Name -> [GHC.LHsBind GHC.Name] - -> RefactGhc [GHC.LHsBind GHC.Name] - rmLocalDecl decl@(GHC.L sspan _) decls - = do - - -- TODO: The let/in version is wrapped in a GHC.HsLet expression. - -- The sspan of HsLet runs from the let keyword to the end of - -- the in clause. - -- (GHC.L l (HsLet (HsLocalBinds id) (LHsExpr id)) - -- So we must remove the tokens from the start of l to the - -- start of the LHsExpr - - logm $ "rmLocalDecl: decls=" ++ (showGhc decls) - -- drawTokenTreeDetailed $ "Before getToksForSpan :" ++ (show sspan) -- ++AZ++ - prevToks <- getToksBeforeSpan sspan -- Need these before - -- sspan is deleted - removeToksForPos (getStartEndLoc decl) - decl' <- syncDeclToLatestStash decl - setStateStorage (StorageBind decl') - - case length decls of - 1 -> do - -- Get rid of preceding where or let token - let startPos = getGhcLoc sspan - --divide the token stream. - (_toks1,toks2)=break (\t1->tokenPos t1 < startPos) $ reversedToks prevToks - --get the 'where' or 'let' token - rvToks1 = dropWhile (not.isWhereOrLet) toks2 - --There must be a 'where' or 'let', so rvToks1 can not be empty. - whereOrLet = ghead "rmLocalDecl:whereOrLet" rvToks1 - --drop the 'where' 'or 'let' token - -- rmEndPos = tokenPosEnd $ ghead "rmLocalDecl.2" toks2 - rmEndPos = tokenPosEnd whereOrLet - rmStartPos = tokenPos whereOrLet - - -- logm $ "rmLocalDecl: where/let tokens:" ++ (show (_toks1,toks2)) -- ++AZ++ - logm $ "rmLocalDecl: where/let tokens are at" ++ (show (rmStartPos,rmEndPos)) -- ++AZ++ - removeToksForPos (rmStartPos,rmEndPos) - - return () - _ -> return () - - let (decls1, decls2) = break (defines pn) decls - decls2' = gtail "rmLocalDecl 3" decls2 - return $ (decls1 ++ decls2') - --- --------------------------------------------------------------------- - --- | Remove multiple type signatures -rmTypeSigs :: (SYB.Data t) => - [GHC.Name] -- ^ The identifiers whose type signatures are to be removed. - -> t -- ^ The declarations - -> RefactGhc (t,[GHC.LSig GHC.Name]) - -- ^ The result and removed signatures, if there - -- were any -rmTypeSigs pns t = do - (t',demotedSigsMaybe) <- foldM (\(tee,ds) n -> do { (tee',d) <- rmTypeSig n tee; return (tee', ds++[d])}) (t,[]) pns - return (t',catMaybes demotedSigsMaybe) - - --- | Remove the type signature that defines the given identifier's --- type from the declaration list. -rmTypeSig :: (SYB.Data t) => - GHC.Name -- ^ The identifier whose type signature is to be removed. - -> t -- ^ The declarations - -> RefactGhc (t,Maybe (GHC.LSig GHC.Name)) - -- ^ The result and removed signature, if there - -- was one -rmTypeSig pn t - = do - -- logm $ "rmTypeSig:t=" ++ (SYB.showData SYB.Renamer 0 t) - - setStateStorage StorageNone - t' <- everywhereMStaged SYB.Renamer (SYB.mkM inSigs) t - storage <- getStateStorage - let sig' = case storage of - StorageSig sig -> Just sig - StorageNone -> Nothing - x -> error $ "rmTypeSig: unexpected value in StateStorage:" ++ (show x) - return (t',sig') - where - inSigs (sigs::[GHC.LSig GHC.Name]) - | not $ emptyList (snd (break (definesTypeSig pn) sigs)) -- /=[] - = do - let (decls1,decls2)= break (definesTypeSig pn) sigs - let sig@(GHC.L sspan (GHC.TypeSig names typ)) = ghead "rmTypeSig" decls2 - if length names > 1 - then do - -- We have the following cases - -- [pn,x..], [..x,pn,y..], [..x,pn] - -- We must handle the commas correctly in - -- all cases - -- so [pn,x..] : take front comma - -- [..x,pn,y..] : take either front or back comma, - -- but only one - -- [..x,pn] : take back comma - let newSig=(GHC.L sspan (GHC.TypeSig (filter (\(GHC.L _ x) -> x /= pn) names) typ)) - - toks <- getToksForSpan sspan - logm $ "rmTypeSig: fetched toks:" ++ (show toks) -- ++AZ++ - let pnt = ghead "rmTypeSig" (filter (\(GHC.L _ x) -> x == pn) names) - (startPos1, endPos1) = - let (startPos1', endPos1') = getStartEndLoc pnt - in if gfromJust "rmTypeSig" (elemIndex pnt names) == 0 - then extendForwards toks (startPos1',endPos1') isComma - else extendBackwards toks (startPos1',endPos1') isComma - toks' = deleteToks toks startPos1 endPos1 - void $ putToksForSpan sspan toks' - - -- Construct the old signature, by keeping the - -- signature part but discarding the other names - let oldSig = (GHC.L sspan (GHC.TypeSig [pnt] typ)) - sig'@(GHC.L sspan' _) <- syncDeclToLatestStash oldSig - let typeLoc = extendBackwards toks (getStartEndLoc typ) isDoubleColon - let (_,typTok,_) = splitToks typeLoc toks - let (_,pntTok,_) = splitToks (getStartEndLoc pnt) toks - void $ putToksForSpan sspan' (pntTok ++ typTok) - setStateStorage (StorageSig sig') - - - return (decls1++[newSig]++tail decls2) - else do - removeToksForSpan sspan - sig' <- syncDeclToLatestStash sig - setStateStorage (StorageSig sig') - return (decls1++tail decls2) - inSigs x = return x - -{- - [ - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:15:7-14} - (TypeSig - [ - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:15:7} {Name: h})] - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:15:12-14} - (HsTyVar {Name: GHC.Types.Int})))), - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:16:7-14} - (TypeSig - [ - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:16:7} {Name: t})] - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:16:12-14} - (HsTyVar {Name: GHC.Types.Int})))), - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:7-22} - (TypeSig - [ - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:7-9} {Name: tup})] - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:14-22} - (HsTupleTy - (HsBoxedOrConstraintTuple) - [ - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:15-17} - (HsTyVar {Name: GHC.Types.Int})), - (L {test/testdata/LiftToToplevel/PatBindIn1.hs:17:19-21} - (HsTyVar {Name: GHC.Types.Int}))]))))] --} - --- --------------------------------------------------------------------- - - --- TODO: Is this function needed with GHC? - --- | Remove the qualifier from the given identifiers in the given syntax phrase. -rmQualifier:: (SYB.Data t) - =>[GHC.Name] -- ^ The identifiers. - ->t -- ^ The syntax phrase. - ->RefactGhc t -- ^ The result. -rmQualifier pns t = - -- error "undefined rmQualifier" - everywhereMStaged SYB.Renamer (SYB.mkM rename) t - where - rename ((GHC.L l pn)::GHC.Located GHC.Name) - | elem pn pns - = do do -- toks <- fetchToks - -- let toks' = replaceToks toks (row,col) (row,col) [mkToken Varid (row,col) s] - let (rs,_) = break (=='.') $ reverse $ showGhc pn -- ++TODO: replace this with the appropriate formulation - s = reverse rs - {- TODO: reinstate token update if required - let (row,col) = getGhcLoc l - let toks' = replaceToks toks (row,col) (row,col) [mkToken (GHC.ITvarid (GHC.mkFastString s)) (row,col) s] - putToks toks' modified - -} - return (GHC.L l (GHC.mkInternalName (GHC.nameUnique pn) (GHC.mkVarOcc s) l)) - rename x = return x - --- --------------------------------------------------------------------- - --- | Replace all occurences of a top level GHC.Name with a qualified version. -qualifyToplevelName :: GHC.Name -> RefactGhc () -qualifyToplevelName n = do - renamed <- getRefactRenamed - -- logm $ "qualifyToplevelName:renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) - _ <- renamePN n n True True renamed - return () - --- --------------------------------------------------------------------- - --- | 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. --- TODO: the syntax phrase is required to be GHC.Located, not sure how --- to specify this without breaking the everywhereMStaged call - -renamePN::(SYB.Data t) - =>GHC.Name -- ^ The identifier to be renamed. - ->GHC.Name -- ^ The new name, including possible qualifier - ->Bool -- ^ True means modifying the token stream as well. - ->Bool -- ^ True means use the qualified form for - -- the new name. - ->t -- ^ The syntax phrase - ->RefactGhc t -renamePN oldPN newName updateTokens useQual t = do - -- = error $ "renamePN: sspan=" ++ (showGhc sspan) -- ++AZ++ - -- logm $ "renamePN': (oldPN,newName)=" ++ (showGhc (oldPN,newName)) - -- logm $ "renamePN: t=" ++ (SYB.showData SYB.Renamer 0 t) - -- Note: bottom-up traversal - let isRenamed = somethingStaged SYB.Renamer Nothing - (Nothing `SYB.mkQ` isRenamedSource `SYB.extQ` isRenamedGroup) t - - - t' <- if isRenamed == (Just True) - then - everywhereMStaged SYB.Renamer - (SYB.mkM renameRenamedSource - `SYB.extM` renameGroup - ) t - else - renamePNworker oldPN newName updateTokens useQual t - -- t'' <- adjustLayoutAfterRename oldPN newName t' - return t' - where - isRenamedSource :: GHC.RenamedSource -> Maybe Bool - isRenamedSource (_g,_i,_e,_d) = Just True - - isRenamedGroup :: GHC.HsGroup GHC.Name -> Maybe Bool - isRenamedGroup _g = Just True - - -- --------------------------------- - - renameRenamedSource :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource - renameRenamedSource (g,i,e,d) = do - i' <- renamePNworker oldPN newName updateTokens False i - e' <- renamePNworker oldPN newName updateTokens useQual e - return (g,i',e',d) - - renameGroup :: (GHC.HsGroup GHC.Name) -> RefactGhc (GHC.HsGroup GHC.Name) - renameGroup g - = do - logm $ "renamePN:renameGroup" - g' <- renamePNworker oldPN newName updateTokens useQual g - return g' - -- renameGroup x = return x - --- --------------------------------------------------------------------- - --- | 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. --- TODO: the syntax phrase is required to be GHC.Located, not sure how --- to specify this without breaking the everywhereMStaged call -renamePNworker::(SYB.Data t) - =>GHC.Name -- ^ The identifier to be renamed. - ->GHC.Name -- ^ The new name, including possible qualifier - ->Bool -- ^ True means modifying the token stream as well. - ->Bool -- ^ True means use the qualified form for - -- the new name. - ->t -- ^ The syntax phrase - ->RefactGhc t -renamePNworker oldPN newName updateTokens useQual t = do - -- logm $ "renamePN: (oldPN,newName)=" ++ (showGhc (oldPN,newName)) - -- Note: bottom-up traversal (no ' at end) - everywhereMStaged SYB.Renamer (SYB.mkM rename - -- everywhereMStaged' SYB.Renamer (SYB.mkM rename - `SYB.extM` renameVar - `SYB.extM` renameTyVar - `SYB.extM` renameHsTyVarBndr - `SYB.extM` renameLIE - `SYB.extM` renameLPat - `SYB.extM` renameTypeSig - `SYB.extM` renameFunBind - ) t - where - rename :: (GHC.Located GHC.Name) -> RefactGhc (GHC.Located GHC.Name) - rename (GHC.L l n) - | (GHC.nameUnique n == GHC.nameUnique oldPN) - = do - logm $ "renamePNworker:rename at :" ++ (show l) ++ (showSrcSpanF l) - -- drawTokenTree "before worker" -- ++AZ++ debug - worker useQual l Nothing - return (GHC.L l newName) - rename x = return x - - renameVar :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name)) - renameVar v@(GHC.L l (GHC.HsVar n)) - | (GHC.nameUnique n == GHC.nameUnique oldPN) - = do - logm $ "renamePNworker:renameVar at :" ++ (showGhc l) - - -- Get the original qualification, if any - rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsExpr GHC.RdrName)) - let (GHC.L _ (GHC.HsVar mqn)) = rn - let mrnq = GHC.isQual_maybe mqn - logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq)) - - worker useQual l mrnq - return (GHC.L l (GHC.HsVar newName)) - renameVar x = return x - - -- HsTyVar {Name: Renaming.D1.Tree})) - renameTyVar :: (GHC.Located (GHC.HsType GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsType GHC.Name)) - renameTyVar v@(GHC.L l (GHC.HsTyVar n)) - | (GHC.nameUnique n == GHC.nameUnique oldPN) - = do - logm $ "renamePNworker:renameTyVar at :" ++ (showGhc l) - - -- Get the original qualification, if any - rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsType GHC.RdrName)) - let (GHC.L _ (GHC.HsTyVar mqn)) = rn - let mrnq = GHC.isQual_maybe mqn - logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq)) - - worker useQual l mrnq - return (GHC.L l (GHC.HsTyVar newName)) - renameTyVar x = return x - - - renameHsTyVarBndr :: (GHC.LHsTyVarBndr GHC.Name) -> RefactGhc (GHC.LHsTyVarBndr GHC.Name) -#if __GLASGOW_HASKELL__ > 704 - renameHsTyVarBndr v@(GHC.L l (GHC.UserTyVar n)) -#else - renameHsTyVarBndr v@(GHC.L l (GHC.UserTyVar n typ)) -#endif - | (GHC.nameUnique n == GHC.nameUnique oldPN) - = do - logm $ "renamePNworker:renameHsTyVarBndr at :" ++ (showGhc l) - - -- Get the original qualification, if any - rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsTyVarBndr GHC.RdrName)) -#if __GLASGOW_HASKELL__ > 704 - let (GHC.L _ (GHC.UserTyVar mqn)) = rn -#else - let (GHC.L _ (GHC.UserTyVar mqn _)) = rn -#endif - let mrnq = GHC.isQual_maybe mqn - logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq)) - - worker useQual l mrnq -#if __GLASGOW_HASKELL__ > 704 - return (GHC.L l (GHC.UserTyVar newName)) -#else - return (GHC.L l (GHC.UserTyVar newName typ)) -#endif - renameHsTyVarBndr x = return x - - -- --------------------------------- - - renameLIE :: (GHC.LIE GHC.Name) -> RefactGhc (GHC.LIE GHC.Name) - renameLIE (GHC.L l (GHC.IEVar n)) - | (GHC.nameUnique n == GHC.nameUnique oldPN) - = do - -- logm $ "renamePNworker:renameLIE.IEVar at :" ++ (showGhc l) - worker useQual l Nothing - return (GHC.L l (GHC.IEVar newName)) - - renameLIE (GHC.L l (GHC.IEThingAbs n)) - | (GHC.nameUnique n == GHC.nameUnique oldPN) - = do - -- logm $ "renamePNworker:renameLIE.IEThingAbs at :" ++ (showGhc l) - worker useQual l Nothing - return (GHC.L l (GHC.IEThingAbs newName)) - - renameLIE (GHC.L l (GHC.IEThingAll n)) - | (GHC.nameUnique n == GHC.nameUnique oldPN) - = do - -- logm $ "renamePNworker:renameLIE.IEThingAll at :" ++ (showGhc l) - worker useQual l Nothing - return (GHC.L l (GHC.IEThingAll newName)) - - -- TODO: check inside the ns here too - renameLIE (GHC.L l (GHC.IEThingWith n ns)) - | (GHC.nameUnique n == GHC.nameUnique oldPN) - = do - logm $ "renamePNworker:renameLIE.IEThingWith at :" ++ (showGhc l) - worker useQual l Nothing - return (GHC.L l (GHC.IEThingWith newName ns)) - | any (\nn -> (GHC.nameUnique nn == GHC.nameUnique oldPN)) ns - = do - -- We have to find the right token, no locations to help - toks <- getToksForSpan l - -- find the opening parenthesis - let (_,pt) = break isOpenParen $ filter (not . isWhiteSpaceOrIgnored) toks - -- logm $ "renamePNworker:renameLIE.IEThingWith ns pt=" ++ (show pt) - let nstoks = gtail "renamePNworker" pt - let unQualOld = (GHC.occNameString $ GHC.getOccName oldPN) - -- logm $ "renamePNworker:renameLIE.IEThingWith unquaOld=" ++ (show unQualOld) - let _tok@(GHC.L lt _,_) = ghead "renamePNworker" $ filter (\tt -> tokenCon tt == showGhc oldPN || tokenCon tt == unQualOld) nstoks - -- logm $ "renamePNworker:renameLIE.IEThingWith ns tok=" ++ (show _tok) - logm $ "renamePNworker:renameLIE.IEThingWith ns at :" ++ (showGhc lt) - worker useQual lt Nothing - -- TODO: update ns - return (GHC.L l (GHC.IEThingWith newName ns)) - - renameLIE x = do - -- logm $ "renamePNworker:renameLIE miss for :" ++ (showGhc x) - return x - - -- --------------------------------- - - - renameLPat :: (GHC.LPat GHC.Name) -> RefactGhc (GHC.LPat GHC.Name) - renameLPat v@(GHC.L l (GHC.VarPat n)) - | (GHC.nameUnique n == GHC.nameUnique oldPN) - = do - logm $ "renamePNworker:renameLPat at :" ++ (showGhc l) - - -- Get the original qualification, if any - rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LPat GHC.RdrName)) - let (GHC.L _ (GHC.VarPat mqn)) = rn - let mrnq = GHC.isQual_maybe mqn - logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq)) - - worker False l mrnq - return (GHC.L l (GHC.VarPat newName)) - renameLPat x = return x - - renameFunBind :: (GHC.LHsBindLR GHC.Name GHC.Name) -> RefactGhc (GHC.LHsBindLR GHC.Name GHC.Name) - renameFunBind (GHC.L l (GHC.FunBind (GHC.L ln n) fi (GHC.MatchGroup matches typ) co fvs tick)) - | (GHC.nameUnique n == GHC.nameUnique oldPN) || (GHC.nameUnique n == GHC.nameUnique newName) - = do -- Need to (a) rename the actual funbind name - -- NOTE: due to bottom-up traversal, (a) should - -- already have been done. - -- (b) rename each of 'tail matches' - -- (head is renamed in (a) ) - -- logm $ "renamePNWorker.renameFunBind" - worker False ln Nothing - -- Now do (b) - logm $ "renamePNWorker.renameFunBind.renameFunBind:starting matches" - let w (GHC.L lm _match) = worker False lm' Nothing - where - ((GHC.L lm' _),_) = newNameTok False lm oldPN - mapM_ w $ tail matches - logm $ "renamePNWorker.renameFunBind.renameFunBind.renameFunBind:matches done" - return (GHC.L l (GHC.FunBind (GHC.L ln newName) fi (GHC.MatchGroup matches typ) co fvs tick)) - renameFunBind x = return x - - renameTypeSig :: (GHC.LSig GHC.Name) -> RefactGhc (GHC.LSig GHC.Name) - renameTypeSig (GHC.L l (GHC.TypeSig ns typ)) - = do - -- logm $ "renamePNWorker:renameTypeSig" - _ns' <- renamePN oldPN newName updateTokens False ns - -- Has already been renamed, make sure qualifier is removed - ns' <- renamePN newName newName updateTokens False ns - typ' <- renamePN oldPN newName updateTokens False typ - -- logm $ "renamePNWorker:renameTypeSig done" - return (GHC.L l (GHC.TypeSig ns' typ')) - renameTypeSig x = return x - - -- The param l is only useful for the start of the token pos - worker :: Bool -> GHC.SrcSpan -> Maybe (GHC.ModuleName, GHC.OccName) -> RefactGhc () - worker useQual' l mmo - = do if updateTokens - then do - newTok <- case mmo of - Nothing -> return $ newNameTok useQual' l newName - Just (modu,_) -> do - newName' <- mkNewGhcName (Just $ GHC.mkModule GHC.mainPackageId modu) (GHC.occNameString $ GHC.getOccName newName) - return $ newNameTok True l newName' - -- replaceToken l (markToken $ newNameTok useQual' l newName) - replaceToken l (markToken $ newTok) - return () - else return () - ----------------------------------------------------------------------------------------- --- | 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:: (HsValBinds t) - =>Bool -- ^ True means modfiying the token stream as well. - ->GHC.Name -- ^ The identifier. - ->t -- ^ The syntax phrase. - -> RefactGhc t -- ^ The result. -autoRenameLocalVar modifyToks pn t = do - logm $ "autoRenameLocalVar: (modifyToks,pn)=" ++ (showGhc (modifyToks,pn)) - -- = everywhereMStaged SYB.Renamer (SYB.mkM renameInMatch) - if isDeclaredIn pn t - then do t' <- worker t - return t' - else do return t - - where - worker tt =do (f,d) <- hsFDNamesFromInside tt - ds <- hsVisibleNames pn (hsValBinds tt) - let newNameStr=mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1 - newName <- mkNewGhcName Nothing newNameStr - if modifyToks - then renamePN pn newName True False tt - else renamePN pn newName False False tt - --- --------------------------------------------------------------------- - --- | Show a list of entities, the parameter f is a function that --- specifies how to format an entity. -showEntities:: (t->String) -> [t] ->String -showEntities _ [] = "" -showEntities f [pn] = f pn -showEntities f (pn:pns) =f pn ++ "," ++ showEntities f pns - - --- --------------------------------------------------------------------- - -isMainModule :: GHC.Module -> Bool -isMainModule modu = GHC.modulePackageId modu == GHC.mainPackageId - --- --------------------------------------------------------------------- - --- | Return the identifier's defining location. --- defineLoc::PNT->SrcLoc -defineLoc :: GHC.Located GHC.Name -> GHC.SrcLoc -defineLoc (GHC.L _ name) = GHC.nameSrcLoc name - --- | Return the identifier's source location. --- useLoc::PNT->SrcLoc -useLoc:: (GHC.Located GHC.Name) -> GHC.SrcLoc --- useLoc (GHC.L l _) = getGhcLoc l -useLoc (GHC.L l _) = GHC.srcSpanStart l - --- --------------------------------------------------------------------- - --- | Return True if the identifier is used in the RHS if a --- function\/pattern binding. -isUsedInRhs::(SYB.Data t) => (GHC.Located GHC.Name) -> t -> Bool -isUsedInRhs pnt t = useLoc pnt /= defineLoc pnt && not (notInLhs) - where - notInLhs = fromMaybe False $ somethingStaged SYB.Parser Nothing - (Nothing `SYB.mkQ` inMatch `SYB.extQ` inDecl) t - where - inMatch ((GHC.FunBind name _ (GHC.MatchGroup _matches _) _ _ _) :: GHC.HsBind t) - | isJust (find (sameOccurrence pnt) [name]) = Just True - inMatch _ = Nothing - - inDecl ((GHC.TypeSig is _) :: GHC.Sig t) - |isJust (find (sameOccurrence pnt) is) = Just True - inDecl _ = Nothing - --- --------------------------------------------------------------------- --- | Find all occurrences with location of the given name -findAllNameOccurences :: (SYB.Data t) => GHC.Name -> t -> [(GHC.Located GHC.Name)] -findAllNameOccurences name t - = res - where - res = SYB.everythingStaged SYB.Renamer (++) [] - ([] `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t - - worker (ln@(GHC.L _l n) :: (GHC.Located GHC.Name)) - | GHC.nameUnique n == GHC.nameUnique name = [ln] - worker _ = [] - - workerBind (GHC.L l (GHC.VarPat n) :: (GHC.Located (GHC.Pat GHC.Name))) - | GHC.nameUnique n == GHC.nameUnique name = [(GHC.L l n)] - workerBind _ = [] - - workerExpr (GHC.L l (GHC.HsVar n) :: (GHC.Located (GHC.HsExpr GHC.Name))) - | GHC.nameUnique n == GHC.nameUnique name = [(GHC.L l n)] - workerExpr _ = [] - --- --------------------------------------------------------------------- - --- | Return True if the identifier occurs in the given syntax phrase. -findPNT::(SYB.Data t) => GHC.Located GHC.Name -> t -> Bool -findPNT (GHC.L _ pn) = findPN pn - --- | Return True if the identifier occurs in the given syntax phrase. -findPN::(SYB.Data t)=> GHC.Name -> t -> Bool -findPN pn - = isJust.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) - where - worker (n::GHC.Name) - | GHC.nameUnique pn == GHC.nameUnique n = Just True - worker _ = Nothing - --- | Return True if any of the specified PNames ocuur in the given syntax phrase. -findPNs::(SYB.Data t)=> [GHC.Name] -> t -> Bool -findPNs pns - = isJust.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) - where - uns = map GHC.nameUnique pns - - worker (n::GHC.Name) - | elem (GHC.nameUnique n) uns = Just True - worker _ = Nothing - --- | Return the type checked `GHC.Id` corresponding to the given --- `GHC.Name` - --- TODO: there has to be a simpler way, using the appropriate GHC internals -findIdForName :: GHC.Name -> RefactGhc (Maybe GHC.Id) -findIdForName n = do - tm <- getTypecheckedModule - let t = GHC.tm_typechecked_source tm - let r = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) t - worker (i::GHC.Id) - | (GHC.nameUnique n) == (GHC.varUnique i) = Just i - worker _ = Nothing - return r - --- --------------------------------------------------------------------- - -getTypeForName :: GHC.Name -> RefactGhc (Maybe GHC.Type) -getTypeForName n = do - mId <- findIdForName n - case mId of - Nothing -> return Nothing - Just i -> return $ Just (GHC.varType i) - --- --------------------------------------------------------------------- - --- | Given the syntax phrase, find the largest-leftmost expression --- contained in the region specified by the start and end position, if --- found. -locToExp:: (SYB.Data t,SYB.Typeable n) => - SimpPos -- ^ The start position. - -> SimpPos -- ^ The end position. - -> t -- ^ The syntax phrase. - -> Maybe (GHC.Located (GHC.HsExpr n)) -- ^ The result. -locToExp beginPos endPos t = res - where - res = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` expr) t - - expr :: GHC.Located (GHC.HsExpr n) -> (Maybe (GHC.Located (GHC.HsExpr n))) - expr e - |inScope e = Just e - expr _ = Nothing - - inScope :: GHC.Located e -> Bool - inScope (GHC.L l _) = - let - (startLoc,endLoc) = case l of - (GHC.RealSrcSpan ss) -> - ((GHC.srcSpanStartLine ss,GHC.srcSpanStartCol ss), - (GHC.srcSpanEndLine ss,GHC.srcSpanEndCol ss)) - (GHC.UnhelpfulSpan _) -> ((0,0),(0,0)) - in - (startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && (endLoc<=endPos) - --------------------------------------------------------------------------------- - - -ghcToPN :: GHC.RdrName -> PName -ghcToPN rdr = PN rdr - -lghcToPN :: GHC.Located GHC.RdrName -> PName -lghcToPN (GHC.L _ rdr) = PN rdr - - --- | If an expression consists of only one identifier then return this --- identifier in the GHC.Name format, otherwise return the default Name -expToName:: GHC.Located (GHC.HsExpr GHC.Name) -> GHC.Name -expToName (GHC.L _ (GHC.HsVar pnt)) = pnt -expToName (GHC.L _ (GHC.HsPar e)) = expToName e -expToName _ = defaultName - - -nameToString :: GHC.Name -> String -nameToString name = showGhc name - --- | If a pattern consists of only one identifier then return this --- identifier, otherwise return Nothing -patToPNT::GHC.LPat GHC.Name -> Maybe GHC.Name -patToPNT (GHC.L _ (GHC.VarPat n)) = Just n -patToPNT _ = Nothing - - --- | Compose a pattern from a pName. -pNtoPat :: GHC.Name -> GHC.Pat GHC.Name -pNtoPat pname = GHC.VarPat pname - -- =let loc=srcLoc pname - -- in (TiDecorate.Pat (HsPId (HsVar (PNT pname Value (N (Just loc)))))) - --- --------------------------------------------------------------------- - --- TODO: This should use the TokenUtils API -getToksForDecl :: SYB.Data t => - t -> [PosToken] -> [PosToken] -getToksForDecl decl toks - = let (startPos, endPos) = startEndLocIncComments toks decl - (toks1, _) =let(ts1,(_t:ts2'))= break (\t -> tokenPos t >= endPos) toks - in (ts1, ts2') - in dropWhile (\t -> tokenPos t < startPos {- was || isNewLn t -}) toks1 - --- --------------------------------------------------------------------- - --- TODO: this is currently only used in a test --- Get the toks for a declaration, and adjust its offset to 0. -getDeclAndToks :: (HsValBinds t) - => GHC.Name -> Bool -> [PosToken] -> t - -> ([GHC.LHsBind GHC.Name],[PosToken]) -getDeclAndToks pn _incSig toks t = - let - decls = definingDeclsNames [pn] (hsBinds t) True True - declToks = getToksForDecl decls toks - - in (decls, removeToksOffset declToks) - --- --------------------------------------------------------------------- - --- TODO: this is currently only used in a test --- | Get the signature and tokens for a declaration -getSigAndToks :: (SYB.Data t) => GHC.Name -> t -> [PosToken] - -> Maybe (GHC.LSig GHC.Name,[PosToken]) -getSigAndToks pn t toks - = case (getSig pn t) of - Nothing -> Nothing - Just sig -> Just (sig, removeToksOffset $ getToksForDecl sig toks) - - --- --------------------------------------------------------------------- - --- | Normalise a set of tokens to start at the offset of the first one -removeToksOffset :: [PosToken] -> [PosToken] -removeToksOffset toks = toks' - where - toks' = case toks of - [] -> [] - _ -> removeOffset offset toks - where - (_r,c) = tokenPos $ head toks - offset = c -- getIndentOffset toks (r+1,c) - --- --------------------------------------------------------------------- - --- | Remove at most `offset` whitespaces from each line in the tokens - --- TODO: move this function to LocUtils.hs --- TODO: add a test for this -removeOffset :: Int -> [PosToken] -> [PosToken] --- removeOffset offset toks = error $ "removeOffset:offset=" ++ (show offset) -- ++AZ++ -removeOffset offset toks = map (\(t,s) -> (adjust t,s)) toks - where - adjust (GHC.L l t) = (GHC.L l' t) - where - l' = case l of - GHC.RealSrcSpan ss -> - let - locs = GHC.mkSrcLoc (GHC.srcSpanFile ss) (GHC.srcSpanStartLine ss) ((GHC.srcSpanStartCol ss) - offset) - loce = GHC.mkSrcLoc (GHC.srcSpanFile ss) (GHC.srcSpanEndLine ss) ((GHC.srcSpanEndCol ss) - offset) - -- loc = GHC.mkSrcLoc (GHC.srcSpanFile ss) (1 + GHC.srcSpanEndLine ss) 0 - in - GHC.mkSrcSpan locs loce - _ -> l - --- --------------------------------------------------------------------- - --- | Get signature for a declaration -getSig :: (SYB.Data t) => GHC.Name -> t - -> Maybe (GHC.LSig GHC.Name) -getSig pn t = maybeSig - where - maybeSig = if (emptyList sigList) - then Nothing - else Just $ head sigList - - sigList = SYB.everythingStaged SYB.Renamer (++) [] - ([] `SYB.mkQ` inDecls) t - - inDecls (sigs::[GHC.LSig GHC.Name]) - | not $ emptyList (snd (break (definesTypeSig pn) sigs)) -- /=[] - = let (_decls1,decls2)= break (definesTypeSig pn) sigs - sig@(GHC.L l (GHC.TypeSig names typ)) = ghead "getSigsAndToks" decls2 -- as decls2/=[], no problem with head - sig' = if length names > 1 - then (GHC.L l (GHC.TypeSig (filter (\(GHC.L _ x) -> x /= pn) names) typ)) - else sig - in [sig'] - inDecls _ = [] - --- --------------------------------------------------------------------- - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-------------------------------------------------------------------------------- +-- Module : TypeUtils + +-- Maintainer : refactor-fp\@kent.ac.uk +-- | +-- +-- This module contains a collection of program analysis and +-- transformation functions (the API) that work over the Type +-- Decorated AST. Most of the functions defined in the module are +-- taken directly from the API, but in some cases are modified to work +-- with the type decorated AST. +-- +-- In particular some new functions have been added to make type +-- decorated AST traversals easier. +-- +-- 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. +-- +-- This type decorated API is still in development. Any suggestions +-- and comments are very much welcome. + + +-------------------------------------------------------------------------------- +module Language.Haskell.Refact.Utils.TypeUtils + ( + -- * Program Analysis + -- ** Imports and exports + inScopeInfo, isInScopeAndUnqualified, isInScopeAndUnqualifiedGhc, inScopeNames + , isExported, isExplicitlyExported, modIsExported + , equivalentNameInNewMod + + -- ** Property checking + ,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName + ,isQualifiedPN, isFunOrPatName, isTypeSig, isTypeSigDecl + ,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind,isSimplePatDecl + ,isComplexPatBind,isComplexPatDecl,isFunOrPatBindP,isFunOrPatBindR + ,usedWithoutQualR,isUsedInRhs + + -- ** Getting + ,findNameInRdr + ,findPNT,findPN,findAllNameOccurences + ,findPNs, findNamesRdr, findEntity, findEntity' + ,findIdForName + ,getTypeForName + + ,defines, definesP,definesTypeSig,definesTypeSigRdr + -- ,HasModName(hasModName), HasNameSpace(hasNameSpace) + ,sameBind,sameBindRdr + {- ,usedByRhs -},UsedByRhs(..) + + -- ** Modules and files + -- ,clientModsAndFiles,serverModsAndFiles,isAnExistingMod + -- ,fileNameToModName, strToModName, modNameToStr + , isMainModule + , getModule + + -- ** Locations + ,defineLoc, useLoc, locToExp + ,locToName, locToRdrName + ,getName + + -- * Program transformation + -- ** Adding + ,addDecl, addItemsToImport, addHiding + ,addParamsToDecls, addActualParamsToRhs, addImportDecl, duplicateDecl + -- ** Removing + ,rmDecl, rmTypeSig, rmTypeSigs -- , commentOutTypeSig, rmParams + -- ,rmItemsFromExport, rmSubEntsFromExport, Delete(delete) + + -- ** Updating + -- ,Update(update) + {- ,qualifyPName-},rmQualifier,qualifyToplevelName,{- renamePN, -} renamePN' {- ,replaceNameInPN -},autoRenameLocalVar + + -- * Miscellous + -- ** Parsing, writing and showing + {- ,parseSourceFile,writeRefactoredFiles-}, showEntities,showPNwithLoc -- , newProj, addFile, chase + -- ** Locations + -- ,toRelativeLocs, rmLocs + -- ** Default values + ,defaultPN {- ,defaultPNT -},defaultName {-,defaultModName-},defaultExp -- ,defaultPat, defaultExpUnTyped + + + -- ** Identifiers, expressions, patterns and declarations + ,ghcToPN,lghcToPN, expToName, expToNameRdr + ,nameToString + ,patToNameRdr + {- ,expToPNT, expToPN, nameToExp,pNtoExp -},patToPNT {- , patToPN --, nameToPat -},pNtoPat + + -- ** Others + , divideDecls + , mkRdrName,mkNewGhcName,mkNewName,mkNewToplevelName + + -- The following functions are not in the the API yet. + , causeNameClashInExports {- , inRegion , unmodified -} + + -- , removeOffset + + , declsSybTransform + -- , hasDeclsSybTransform + + -- * Typed AST traversals (added by CMB) + -- * Miscellous + -- ,removeFromInts, getDataName, checkTypes, getPNs, getPN, getPNPats, mapASTOverTAST + + -- * Debug stuff + -- , getDeclAndToks, getSigAndToks + -- , getToksForDecl, removeToksOffset -- ++AZ++ remove this after debuggging + , getParsedForRenamedLPat + , getParsedForRenamedName + , getParsedForRenamedLocated + -- , allPNT + -- , allPNTLens + , rdrNameFromName + , stripLeadingSpaces + -- , lookupNameGhc + ) where + +import Control.Monad.State +import Data.Char +import Data.Foldable +import Data.List +import Data.Maybe +import Exception + +import Language.Haskell.Refact.Utils.ExactPrint +import Language.Haskell.Refact.Utils.GhcUtils +import Language.Haskell.Refact.Utils.GhcVersionSpecific +import Language.Haskell.Refact.Utils.LocUtils +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions +import Language.Haskell.Refact.Utils.TypeSyn +import Language.Haskell.Refact.Utils.Types +import Language.Haskell.Refact.Utils.Variables + +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils + + +-- Modules from GHC +import qualified Bag as GHC +import qualified FastString as GHC +import qualified GHC as GHC +import qualified Module as GHC +import qualified Name as GHC +-- import qualified Outputable as GHC +import qualified RdrName as GHC +import qualified Unique as GHC +import qualified Var as GHC + +import qualified Data.Generics as SYB +import qualified GHC.SYB.Utils as SYB + +import qualified Data.Map as Map + +import Data.Generics.Strafunski.StrategyLib.StrategyLib hiding (liftIO,MonadPlus,mzero) + +-- --------------------------------------------------------------------- +-- |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, GHC.NameSpace, GHC.ModuleName, Maybe GHC.ModuleName)] -- ^ The result +inScopeInfo names = nub $ map getEntInfo $ names + where + getEntInfo name + =(showGhc name, + GHC.occNameSpace $ GHC.nameOccName name, + GHC.moduleName $ GHC.nameModule name, + getQualMaybe $ GHC.nameRdrName name) + + getQualMaybe rdrName = case rdrName of + GHC.Qual modName _occName -> Just modName + _ -> Nothing + + + +-- | 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 n names + = isJust $ find (\ (x, _,_, qual) -> x == n && isNothing qual ) $ inScopeInfo names + +-- | Return True if the identifier is inscope and can be used without +-- a qualifier. The identifier name string may have a qualifier +-- already +-- NOTE: may require qualification based on name clash with an +-- existing identifier. +isInScopeAndUnqualifiedGhc :: + String -- ^ The identifier name. + -> (Maybe GHC.Name) -- ^ Existing name, to be excluded from test, if + -- known + -> RefactGhc Bool -- ^ The result. +isInScopeAndUnqualifiedGhc n maybeExising = do + names <- ghandle handler (GHC.parseName n) + logm $ "isInScopeAndUnqualifiedGhc:(n,(maybeExising,names))=" ++ (show n) ++ ":" ++ (showGhc (maybeExising,names)) + ctx <- GHC.getContext + logm $ "isInScopeAndUnqualifiedGhc:ctx=" ++ (showGhc ctx) + let nameList = case maybeExising of + Nothing -> names + Just n' -> filter (\x -> (showGhcQual x) /= (showGhcQual n')) names + logm $ "isInScopeAndUnqualifiedGhc:(n,nameList)=" ++ (show n) ++ ":" ++ (showGhc nameList) + return $ nameList /= [] + + where + handler:: SomeException -> RefactGhc [GHC.Name] + handler e = do + logm $ "isInScopeAndUnqualifiedGhc.handler e=" ++ (show e) + return [] + +-- --------------------------------------------------------------------- + +-- |Return all 'GHC.Name's that correspond to the given string, in the current +-- module. + +-- Note: this returns a list because TH constructor names do not have the +-- correct namespace so the two variants are returned, constructor and +-- non-constructor. I suspect that when this is looked up only one will ever +-- come through. Hence we should only ever see 0 or 1 names here. +inScopeNames :: String -- ^ The identifier name. + -> RefactGhc [GHC.Name] -- ^ The result. +inScopeNames n = do + names <- ghandle handler (GHC.parseName n) + logm $ "inScopeNames:(n,names)=" ++ (show n) ++ ":" ++ (showGhc names) + return $ names + + where + handler:: SomeException -> RefactGhc [GHC.Name] + handler e = do + logm $ "inScopeNames.handler e=" ++ (show e) + return [] + +-- --------------------------------------------------------------------- + +-- |Given a 'GHC.Name' defined in one module, find the equivalent one in the +-- currently loaded module. This is required otherwise name equality checking +-- based on 'GHC.nameUnique' will fail. +equivalentNameInNewMod :: GHC.Name -> RefactGhc [GHC.Name] +equivalentNameInNewMod old = do + -- we have to do it this way otherwise names imported qualified will not be + -- detected + gnames <- GHC.getNamesInScope + let clientModule = GHC.nameModule old + let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames + let newNames = filter (\n -> showGhcQual n == showGhcQual old) clientInscopes + return newNames + +-- --------------------------------------------------------------------- +-- | Show a PName in a format like: 'pn'(at row:r, col: c). +showPNwithLoc:: GHC.Located GHC.Name -> String +showPNwithLoc pn@(GHC.L l _n) + = let (r,c) = getGhcLoc l + -- in " '"++pNtoName pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")" + in " '"++showGhc pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")" + +-- --------------------------------------------------------------------- + +defaultPN :: PName +defaultPN = PN (mkRdrName "nothing") + +defaultName :: GHC.Name +defaultName = n + where + un = GHC.mkUnique 'H' 0 -- H for HaRe :) + n = GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc "nothing") + +-- | Default expression. +defaultExp::HsExpP +-- defaultExp=Exp (HsId (HsVar defaultPNT)) +defaultExp=GHC.HsVar $ mkRdrName "nothing" + +mkRdrName :: String -> GHC.RdrName +mkRdrName s = GHC.mkVarUnqual (GHC.mkFastString s) + +-- --------------------------------------------------------------------- + +-- | Make a new GHC.Name, using the Unique Int sequence stored in the +-- RefactState. +mkNewGhcName :: Maybe GHC.Module -> String -> RefactGhc GHC.Name +mkNewGhcName maybeMod name = do + s <- get + u <- gets rsUniqState + put s { rsUniqState = (u+1) } + return (mkNewGhcNamePure 'H' (u + 1) maybeMod name) + + +-- --------------------------------------------------------------------- + +mkNewToplevelName :: GHC.Module -> String -> GHC.SrcSpan -> RefactGhc GHC.Name +mkNewToplevelName modid name defLoc = do + s <- get + u <- gets rsUniqState + put s { rsUniqState = (u+1) } + + let un = GHC.mkUnique 'H' (u+1) -- H for HaRe :) + n = GHC.mkExternalName un modid (GHC.mkVarOcc name) defLoc + return n + +--------------------------------------------------------------------------- + + +-- |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 suffix + =let newName=if suffix==0 then oldName + else oldName++"_"++ show suffix + in if elem newName fds + then mkNewName oldName fds (suffix+1) + else newName + +-- --------------------------------------------------------------------- + +-- | Return True if the current module is exported either by default +-- or by specifying the module name in the export. +modIsExported:: GHC.ModuleName -- ^ The module name + -> GHC.RenamedSource -- ^ The AST of the module + -> Bool -- ^ The result +modIsExported modName (_g,_emps,mexps,_mdocs) + = let + modExported (GHC.L _ (GHC.IEModuleContents (GHC.L _ name))) = name == modName + modExported _ = False + + moduleExports = filter modExported $ fromMaybe [] mexps + + in if isNothing mexps + then True + else (nonEmptyList moduleExports) + +-- --------------------------------------------------------------------- + +-- | Return True if an identifier is exported by the module currently +-- being refactored. +isExported :: GHC.Name -> RefactGhc Bool +isExported n = do + typechecked <- getTypecheckedModule + let modInfo = GHC.tm_checked_module_info typechecked + return $ GHC.modInfoIsExportedName modInfo n + +-- --------------------------------------------------------------------- + +-- | Return True if an identifier is explicitly exported by the module. +isExplicitlyExported::GHC.Name -- ^ The identifier + ->GHC.RenamedSource -- ^ The AST of the module + ->Bool -- ^ The result +isExplicitlyExported pn (_g,_imps,exps,_docs) + = findEntity pn exps + +-- --------------------------------------------------------------------- + + +-- | Check if the proposed new name will conflict with an existing export +causeNameClashInExports:: GHC.Name -- ^ The original name + -> GHC.Name -- ^ The new name + -> GHC.ModuleName -- ^ The identity of the module + -> GHC.RenamedSource -- ^ The AST of the module + -> Bool -- ^ The result + +-- Note that in the abstract representation of exps, there is no qualified entities. +causeNameClashInExports pn newName modName renamed@(_g,imps,maybeExps,_doc) + = let exps = fromMaybe [] maybeExps + varExps = filter isImpVar exps + -- TODO: make withoutQual part of the API + withoutQual n = showGhc $ GHC.localiseName n + modNames=nub (concatMap (\(GHC.L _ (GHC.IEVar (GHC.L _ x)))->if withoutQual x== withoutQual newName + then [GHC.moduleName $ GHC.nameModule x] + else []) varExps) + res = (isExplicitlyExported pn renamed) && + ( any (modIsUnQualifedImported renamed) modNames + || elem modName modNames) + in res + where + isImpVar (GHC.L _ x) = case x of + GHC.IEVar _ -> True + _ -> False + + modIsUnQualifedImported _mod' modName' + =let -- imps =hsModImports mod + -- imp@(GHC.L _ (GHC.ImportDecl (GHC.L _ modName) qualify _source _safe isQualified _isImplicit as h)) + in isJust $ find (\(GHC.L _ (GHC.ImportDecl _ (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as _h)) + -> modName1 == modName' && (not isQualified)) imps + -- in isJust $ find (\(HsImportDecl _ (SN modName1 _) qualify _ h) -> modName == modName1 && (not qualify)) imps + + +-- Original seems to be +-- 1. pick up any module names in the export list with same unQual + -- part as the new name +-- 2. Check if the old is exported explicitly +-- 3. if so, if the new module is exported unqualified +-- or belongs to the current module +-- then it will cause a clash + +-- --------------------------------------------------------------------- + +-- | Given a RenamedSource LPAT, return the equivalent +-- ParsedSource part. +-- NOTE: returns pristine ParsedSource, since HaRe does not change it +getParsedForRenamedLPat :: GHC.ParsedSource -> GHC.LPat GHC.Name -> GHC.LPat GHC.RdrName +getParsedForRenamedLPat parsed lpatParam@(GHC.L l _pat) = r + where + mres = res parsed + r = case mres of + Just rr -> rr + Nothing -> error $ "HaRe error: could not find Parsed LPat for" + ++ (SYB.showData SYB.Renamer 0 lpatParam) + + res t = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lpat) t + + lpat :: (GHC.LPat GHC.RdrName) -> (Maybe (GHC.LPat GHC.RdrName)) + lpat p@(GHC.L lp _) + | lp == l = Just p + lpat _ = Nothing + +-- --------------------------------------------------------------------- + +-- | Given a RenamedSource Located name, return the equivalent +-- ParsedSource part. +-- NOTE: returns pristine ParsedSource, since HaRe does not change it +getParsedForRenamedLocated :: ({- SYB.Typeable a, SYB.Data a, -} SYB.Typeable b {- , SYB.Data b -}) + => GHC.Located a -> RefactGhc (GHC.Located b) +getParsedForRenamedLocated (GHC.L l _n) = do + parsed <- getRefactParsed + let + mres = res parsed + r = case mres of + Just rr -> rr + Nothing -> error $ "HaRe error: could not find Parsed Location for" + ++ (showGhc l) + + res t = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t + + lname :: (GHC.Located b) -> (Maybe (GHC.Located b)) + lname p@(GHC.L lp _) + | lp == l = Just p + lname _ = Nothing + + return r + + +-- | Given a RenamedSource Located name, return the equivalent +-- ParsedSource part. +-- NOTE: returns pristine ParsedSource, since HaRe does not change it +getParsedForRenamedName :: GHC.ParsedSource -> GHC.Located GHC.Name -> GHC.Located GHC.RdrName +getParsedForRenamedName parsed n@(GHC.L l _n) = r + where + mres = res parsed + r = case mres of + Just rr -> rr + Nothing -> error $ "HaRe error: could not find Parsed LPat for" + ++ (SYB.showData SYB.Renamer 0 n) + + res t = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t + + lname :: (GHC.Located GHC.RdrName) -> (Maybe (GHC.Located GHC.RdrName)) + lname p@(GHC.L lp _) + | lp == l = Just p + lname _ = Nothing + +------------------------------------------------------------------------ + +-- | Return True if the identifier is unqualifiedly used in the given +-- syntax phrase. +-- usedWithoutQualR :: GHC.Name -> GHC.ParsedSource -> Bool +usedWithoutQualR :: (SYB.Data t) => GHC.Name -> t -> Bool +usedWithoutQualR name parsed = fromMaybe False res + where + res = SYB.somethingStaged SYB.Parser Nothing + (Nothing `SYB.mkQ` worker + `SYB.extQ` workerBind + `SYB.extQ` workerExpr + ) parsed + + worker (pname :: GHC.Located GHC.RdrName) = + checkName pname + + workerBind (GHC.L l (GHC.VarPat n) :: (GHC.Located (GHC.Pat GHC.RdrName))) = + checkName (GHC.L l n) + workerBind _ = Nothing + + workerExpr ((GHC.L l (GHC.HsVar n)) :: (GHC.Located (GHC.HsExpr GHC.RdrName))) + = checkName (GHC.L l n) + workerExpr _ = Nothing + + -- ---------------- + + checkName ((GHC.L l pn)::GHC.Located GHC.RdrName) + | ((GHC.rdrNameOcc pn) == (GHC.nameOccName name)) && + -- isUsedInRhs pname parsed && + isUsedInRhs (GHC.L l name) parsed && + GHC.isUnqual pn = Just True + checkName _ = Nothing + + +----------------------------------------------------------------------------- + +getModule :: RefactGhc GHC.Module +getModule = do + typechecked <- getTypecheckedModule + return $ GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module typechecked + +-- --------------------------------------------------------------------- + +-- | Return True if a string is a lexically valid variable name. +isVarId :: String -> Bool +isVarId mid = isId mid && isSmall (ghead "isVarId" mid) + where isSmall c=isLower c || c=='_' + +-- | Return True if a string is a lexically valid constructor name. +isConId :: String -> Bool +isConId mid = isId mid && isUpper (ghead "isConId" mid) + +-- | Return True if a string is a lexically valid operator name. +isOperator :: String -> Bool +isOperator mid = mid /= [] && isOpSym (ghead "isOperator" mid) && + isLegalOpTail (tail mid) && not (isReservedOp mid) + where + isOpSym mid' = elem mid' opSymbols + where opSymbols = ['!', '#', '$', '%', '&', '*', '+','.','/','<','=','>','?','@','\'','^','|','-','~'] + + isLegalOpTail tail' = all isLegal tail' + where isLegal c = isOpSym c || c==':' + + isReservedOp mid' = elem mid' reservedOps + where reservedOps = ["..", ":","::","=","\"", "|","<-","@","~","=>"] + +-- | Returns True if a string lexically is an identifier. +-- *This function should not be exported.* +isId::String->Bool +isId mid = mid/=[] && isLegalIdTail (tail mid) && not (isReservedId mid) + where + isLegalIdTail tail' = all isLegal tail' + where isLegal c=isSmall c|| isUpper c || isDigit c || c=='\'' + + isReservedId mid' = elem mid' 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::GHC.Name -> RefactGhc Bool +isTopLevelPN n = do + typechecked <- getTypecheckedModule + let maybeNames = GHC.modInfoTopLevelScope $ GHC.tm_checked_module_info typechecked + let names = fromMaybe [] maybeNames + return $ n `elem` names + + +-- |Return True if a PName is a local PName. +isLocalPN::GHC.Name -> Bool +isLocalPN = GHC.isInternalName +-- isLocalPN (PN i (UniqueNames.S _)) = True +-- isLocalPN _ = False + +-- |Return True if the name has a @GHC.SrcSpan@, i.e. is declared in +-- source we care about +isNonLibraryName :: GHC.Name -> Bool +isNonLibraryName n = case (GHC.nameSrcSpan n) of + GHC.UnhelpfulSpan _ -> False + _ -> True + + +-- |Return True if a PName is a function\/pattern name defined in t. +isFunOrPatName::(SYB.Data t) => GHC.Name -> t -> Bool +isFunOrPatName pn + =isJust . SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) + where + -- worker (decl::HsDeclP) + worker (decl::GHC.LHsBind GHC.Name) + | defines pn decl = Just True + worker _ = Nothing + +------------------------------------------------------------------------------- +-- |Return True if a PName is a qualified PName. +-- AZ:NOTE: this tests the use instance, the underlying name may be qualified. +-- e.g. used name is zip, GHC.List.zip +-- NOTE2: not sure if this gives a meaningful result for a GHC.Name +isQualifiedPN :: GHC.Name -> RefactGhc Bool +isQualifiedPN name = return $ GHC.isQual $ GHC.nameRdrName name + + +-- | Return True if a declaration is a type signature declaration. +isTypeSig :: GHC.LSig a -> Bool +isTypeSig (GHC.L _ (GHC.TypeSig _ _ _)) = True +isTypeSig _ = False + +-- | Return True if a declaration is a type signature declaration. +isTypeSigDecl :: GHC.LHsDecl a -> Bool +isTypeSigDecl (GHC.L _ (GHC.SigD (GHC.TypeSig _ _ _))) = True +isTypeSigDecl _ = False + +-- | Return True if a declaration is a function definition. +isFunBindP::HsDeclP -> Bool +isFunBindP (GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _ _))) = True +isFunBindP _ =False + +isFunBindR::GHC.LHsBind t -> Bool +isFunBindR (GHC.L _l (GHC.FunBind _ _ _ _ _ _)) = True +isFunBindR _ =False + +-- | Returns True if a declaration is a pattern binding. +isPatBindP::HsDeclP->Bool +isPatBindP (GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) = True +isPatBindP _=False + +isPatBindR::GHC.LHsBind t -> Bool +isPatBindR (GHC.L _ (GHC.PatBind _ _ _ _ _)) = True +isPatBindR _=False + + +-- | Return True if a declaration is a pattern binding which only +-- defines a variable value. +isSimplePatDecl :: (GHC.DataId t) => GHC.LHsDecl t-> Bool +isSimplePatDecl decl = case decl of + (GHC.L _l (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) -> hsPNs p /= [] + _ -> False + +-- | Return True if a declaration is a pattern binding which only +-- defines a variable value. +isSimplePatBind :: (GHC.DataId t) => GHC.LHsBind t-> Bool +isSimplePatBind decl = case decl of + (GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) -> hsPNs p /= [] + _ -> False + +-- | Return True if a declaration is a pattern binding but not a simple one. +isComplexPatDecl::GHC.LHsDecl name -> Bool +isComplexPatDecl (GHC.L l (GHC.ValD decl)) = isComplexPatBind (GHC.L l decl) +isComplexPatDecl _ = False + +-- | Return True if a LHsBin is a pattern binding but not a simple one. +isComplexPatBind::GHC.LHsBind name -> Bool +isComplexPatBind decl + = case decl of + (GHC.L _l (GHC.PatBind (GHC.L _ (GHC.VarPat _)) _rhs _ty _fvs _)) -> True + _ -> False + +-- | Return True if a declaration is a function\/pattern definition. +isFunOrPatBindP :: HsDeclP -> Bool +isFunOrPatBindP decl = isFunBindP decl || isPatBindP decl + +-- | Return True if a declaration is a function\/pattern definition. +isFunOrPatBindR :: GHC.LHsBind t -> Bool +isFunOrPatBindR decl = isFunBindR decl || isPatBindR decl + +-- --------------------------------------------------------------------- + + +-- | Returns True is a syntax phrase, say a, is part of another syntax +-- phrase, say b. +-- Expects to be at least Parser output +findEntity':: (SYB.Data a, SYB.Data b) + => a -> b -> Maybe (SimpPos,SimpPos) +findEntity' a b = res + where + -- ++AZ++ do a generic traversal, and see if it matches. + res = SYB.somethingStaged SYB.Parser Nothing worker b + + worker :: (SYB.Data c) + => c -> Maybe (SimpPos,SimpPos) + worker x = if SYB.typeOf a == SYB.typeOf x + -- then Just (getStartEndLoc b == getStartEndLoc a) + then Just (getStartEndLoc x) + else Nothing + +-------------------------------------------------------------------------------- + +sameBindRdr :: NameMap -> GHC.LHsDecl GHC.RdrName -> GHC.LHsDecl GHC.RdrName -> Bool +sameBindRdr nm b1 b2 = (definedNamesRdr nm b1) == (definedNamesRdr nm b2) + +sameBind :: GHC.LHsBind GHC.Name -> GHC.LHsBind GHC.Name -> Bool +sameBind b1 b2 = (definedPNs b1) == (definedPNs b2) + +-- --------------------------------------------------------------------- + +-- TODO: is this the same is isUsedInRhs? +class (SYB.Data t) => UsedByRhs t where + + -- | Return True if any of the GHC.Name's appear in the given + -- syntax element + usedByRhs :: t -> [GHC.Name] -> Bool + usedByRhsRdr :: NameMap -> t -> [GHC.Name] -> Bool + +instance UsedByRhs GHC.RenamedSource where + + -- Not a meaningful question at this level + usedByRhs _renamed _pns = False + usedByRhsRdr _ _ = assert False undefined + +instance UsedByRhs (GHC.HsModule GHC.RdrName) where + + -- Not a meaningful question at this level + usedByRhsRdr _ _parsed _pns = False + usedByRhs _ _ = assert False undefined + +-- ------------------------------------- + +instance (UsedByRhs a) => UsedByRhs (GHC.Located a) where + usedByRhsRdr nm (GHC.L _ d) pns = usedByRhsRdr nm d pns + -- usedByRhs _ _ = assert False undefined + usedByRhs _ la = error $ "usedByRhs:Located a=" ++ SYB.showData SYB.Parser 0 la + +-- ------------------------------------- + +instance UsedByRhs [GHC.LHsDecl GHC.RdrName] where + usedByRhs _ _ = assert False undefined + usedByRhsRdr nm ds pns = or $ map (\d -> usedByRhsRdr nm d pns) ds + +-- ------------------------------------- + +instance UsedByRhs (GHC.HsDecl GHC.RdrName) where + usedByRhs _ _ = assert False undefined + usedByRhsRdr nm de pns = + case de of + GHC.TyClD d -> f d + GHC.InstD d -> f d + GHC.DerivD d -> f d + GHC.ValD d -> f d + GHC.SigD d -> f d + GHC.DefD d -> f d + GHC.ForD d -> f d + GHC.WarningD d -> f d + GHC.AnnD d -> f d + GHC.RuleD d -> f d + GHC.VectD d -> f d + GHC.SpliceD d -> f d + GHC.DocD d -> f d + GHC.RoleAnnotD d -> f d +#if __GLASGOW_HASKELL__ < 711 + GHC.QuasiQuoteD d -> f d +#endif + where + f d' = usedByRhsRdr nm d' pns + +-- ------------------------------------- + +instance UsedByRhs (GHC.TyClDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + usedByRhs _ _ = assert False undefined + +instance UsedByRhs (GHC.InstDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + usedByRhs _ _ = assert False undefined + +instance UsedByRhs (GHC.DerivDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + usedByRhs _ _ = assert False undefined + +instance UsedByRhs (GHC.ForeignDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + usedByRhs _ _ = assert False undefined + +instance UsedByRhs (GHC.WarnDecls GHC.RdrName) where + usedByRhsRdr = assert False undefined + usedByRhs _ _ = assert False undefined + +instance UsedByRhs (GHC.AnnDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + usedByRhs _ _ = assert False undefined + +instance UsedByRhs (GHC.RoleAnnotDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + usedByRhs _ _ = assert False undefined + +instance UsedByRhs (GHC.HsQuasiQuote GHC.RdrName) where + usedByRhsRdr = assert False undefined + usedByRhs _ _ = assert False undefined + +instance UsedByRhs (GHC.DefaultDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + usedByRhs _ _ = assert False undefined + +instance UsedByRhs (GHC.SpliceDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + usedByRhs _ _ = assert False undefined + +instance UsedByRhs (GHC.VectDecl GHC.RdrName) where + usedByRhsRdr = assert False undefined + usedByRhs _ _ = assert False undefined + +instance UsedByRhs (GHC.RuleDecls GHC.RdrName) where + usedByRhs _ _ = assert False undefined + usedByRhsRdr = assert False undefined + +instance UsedByRhs GHC.DocDecl where + usedByRhs _ _ = assert False undefined + usedByRhsRdr = assert False undefined + +instance UsedByRhs (GHC.Sig GHC.RdrName) where + usedByRhsRdr _ _ _ = False + usedByRhs _ = assert False undefined + +-- ------------------------------------- + +instance UsedByRhs (GHC.LHsBinds GHC.Name) where + usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) $ GHC.bagToList binds + usedByRhsRdr _ _ = assert False undefined + +instance UsedByRhs (GHC.HsValBinds GHC.Name) where + usedByRhs (GHC.ValBindsIn binds _sigs) pns = usedByRhs (GHC.bagToList binds) pns + usedByRhs (GHC.ValBindsOut binds _sigs) pns = or $ map (\(_,b) -> usedByRhs b pns) binds + usedByRhsRdr _ _ = assert False undefined + +-- ------------------------------------- + +instance UsedByRhs (GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) where + usedByRhs (GHC.Match _ _ _ (GHC.GRHSs rhs _)) pns -- = usedByRhs (hsValBinds rhs) pns + = findPNs pns rhs + usedByRhsRdr _ _ = assert False undefined + + +instance UsedByRhs (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where + usedByRhsRdr nm (GHC.Match _ _ _ (GHC.GRHSs rhs _)) pns + = findNamesRdr nm pns rhs + + usedByRhs _ _ = assert False undefined + +-- ------------------------------------- + +instance UsedByRhs [GHC.LHsBind GHC.Name] where + usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) binds + usedByRhsRdr _ _ = assert False undefined + +instance UsedByRhs (GHC.HsBind GHC.Name) where + usedByRhs (GHC.FunBind _ _ matches _ _ _) pns = findPNs pns matches + usedByRhs (GHC.PatBind _ rhs _ _ _) pns = findPNs pns rhs + usedByRhs (GHC.VarBind _ rhs _) pns = findPNs pns rhs + usedByRhs (GHC.AbsBinds _ _ _ _ _) _pns = False + usedByRhs (GHC.PatSynBind _) _pns = error "To implement: usedByRhs PaySynBind" + usedByRhsRdr _ _ = assert False undefined + +-- ------------------------------------- + +instance UsedByRhs (GHC.HsBind GHC.RdrName) where + usedByRhs _ _ = assert False undefined + usedByRhsRdr nm (GHC.FunBind _ _ matches _ _ _) pns = findNamesRdr nm pns matches + usedByRhsRdr nm (GHC.PatBind _ rhs _ _ _) pns = findNamesRdr nm pns rhs + usedByRhsRdr nm (GHC.PatSynBind (GHC.PSB _ _ _ rhs _)) pns = findNamesRdr nm pns rhs + usedByRhsRdr nm (GHC.VarBind _ rhs _) pns = findNamesRdr nm pns rhs + usedByRhsRdr _nm (GHC.AbsBinds _ _ _ _ _) _pns = False + +-- ------------------------------------- + +instance UsedByRhs (GHC.HsExpr GHC.Name) where + usedByRhs (GHC.HsLet _lb e) pns = findPNs pns e + usedByRhs e _pns = error $ "undefined usedByRhs:" ++ (showGhc e) + usedByRhsRdr _ _ = assert False undefined + +instance UsedByRhs (GHC.HsExpr GHC.RdrName) where + usedByRhsRdr nm (GHC.HsLet _lb e) pns = findNamesRdr nm pns e + usedByRhsRdr _ e _pns = error $ "undefined usedByRhsRdr:" ++ (showGhc e) + usedByRhs _ _ = assert False undefined + +-- ------------------------------------- + +instance UsedByRhs (GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) where + usedByRhs (GHC.LetStmt lb) pns = findPNs pns lb + usedByRhs s _pns = error $ "undefined usedByRhs:" ++ (showGhc s) + usedByRhsRdr _ _ = assert False undefined + +instance UsedByRhs (GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where + usedByRhsRdr nm (GHC.LetStmt lb) pns = findNamesRdr nm pns lb + usedByRhsRdr _ s _pns = error $ "undefined usedByRhsRdr:" ++ (showGhc s) + usedByRhs _ _ = assert False undefined + +-------------------------------------------------------------------------------- + +-- |Find the identifier with the given name. This looks through the +-- given syntax phrase for the first GHC.Name which matches. Because +-- it is Renamed source, the GHC.Name will include its defining +-- location. Returns Nothing if the name is not found. + +getName::(SYB.Data t)=> String -- ^ The name to find + -> t -- ^ The syntax phrase + -> Maybe GHC.Name -- ^ The result +getName str t + = res + where + res = SYB.somethingStaged SYB.Renamer Nothing + (Nothing `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t + + worker ((GHC.L _ n) :: (GHC.Located GHC.Name)) + | showGhcQual n == str = Just n + worker _ = Nothing + + workerBind (GHC.L _ (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name))) + | showGhcQual name == str = Just name + workerBind _ = Nothing + + + workerExpr ((GHC.L _ (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name))) + | showGhcQual name == str = Just name + workerExpr _ = Nothing + +-- --------------------------------------------------------------------- + +-- | 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. + +addImportDecl :: + GHC.ParsedSource + -> GHC.ModuleName + -> Maybe GHC.FastString -- ^qualifier + -> Bool -> Bool -> Bool + -> Maybe String -- ^alias + -> Bool + -> [GHC.RdrName] + -> RefactGhc GHC.ParsedSource +-- addImportDecl (groupedDecls,imp, b, c) modName pkgQual source safe qualify alias hide idNames +addImportDecl (GHC.L l p) modName pkgQual source safe qualify alias hide idNames + = do + let imp = GHC.hsmodImports p + impDecl <- mkImpDecl + newSpan <- liftT uniqueSrcSpanT + let newImp = GHC.L newSpan impDecl + liftT $ addSimpleAnnT newImp (DP (1,0)) [((G GHC.AnnImport),DP (0,0))] + return (GHC.L l p { GHC.hsmodImports = (imp++[newImp])}) + where + + alias' = case alias of + Just stringName -> Just $ GHC.mkModuleName stringName + _ -> Nothing + + mkImpDecl = do + newSpan1 <- liftT uniqueSrcSpanT + newSpan2 <- liftT uniqueSrcSpanT + newEnts <- mkNewEntList idNames + let lNewEnts = GHC.L newSpan2 newEnts + -- logm $ "addImportDecl.mkImpDecl:adding anns for:" ++ showGhc lNewEnts + liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] + let lmodname = GHC.L newSpan1 modName + liftT $ addSimpleAnnT lmodname (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] + return $ GHC.ImportDecl + { GHC.ideclSourceSrc = Nothing + , GHC.ideclName = lmodname + , GHC.ideclPkgQual = pkgQual + , GHC.ideclSource = source + , GHC.ideclSafe = safe + , GHC.ideclQualified = qualify + , GHC.ideclImplicit = False + , GHC.ideclAs = alias' + , GHC.ideclHiding = + (if idNames == [] && hide == False then + Nothing + else + (Just (hide, lNewEnts))) + } + +-- --------------------------------------------------------------------- +{- +-- | Remove ImportDecl from the imports list, commonly returned from a RenamedSource type, so it can +-- be further processed. +--rmPreludeImports :: [GHC.Located (GHC.ImportDecl GHC.Name)] -> [GHC.Located (GHC.ImportDecl GHC.Name)] +rmPreludeImports :: + [GHC.Located (GHC.ImportDecl GHC.Name)] + -> [GHC.Located (GHC.ImportDecl GHC.Name)] +rmPreludeImports = filter isPrelude where + isPrelude = (/="Prelude") . GHC.moduleNameString . GHC.unLoc . GHC.ideclName . GHC.unLoc +-} + +-- --------------------------------------------------------------------- + +-- | Adding a declaration to the declaration list of the given syntax +-- phrase. 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:: (SYB.Data t,SYB.Typeable t) + => t -- ^The AST to be updated + -> Maybe GHC.Name -- ^If this is Just, then the declaration + -- will be added right after this + -- identifier's definition. + -> ([GHC.LHsDecl GHC.RdrName], Maybe Anns) + -- ^ The declaration with optional signatures to be added, together + -- with optional Annotations. + -> RefactGhc t + +addDecl parent pn (declSig, mDeclAnns) = do + logm $ "addDecl:declSig=" ++ showGhc declSig + case mDeclAnns of + Nothing -> return () + Just declAnns -> -- addRefactAnns declAnns + liftT $ modifyAnnsT (mergeAnns declAnns) + case pn of + Just pn' -> appendDecl parent pn' declSig + Nothing -> addLocalDecl parent declSig + where + setDeclSpacing newDeclSig n c = do + -- First clear any previous indentation + mapM_ (\d -> setPrecedingLinesDeclT d 1 0) newDeclSig + setPrecedingLinesT (ghead "addDecl" newDeclSig) n c + -- mapM_ (\d -> setPrecedingLinesT d 1 0) (gtail "addDecl" newDeclSig) + + appendDecl :: (SYB.Data t) + => t -- ^Original AST + -> GHC.Name -- ^Name to add the declaration after + -> [GHC.LHsDecl GHC.RdrName] -- ^declaration and maybe sig + -> RefactGhc t -- ^updated AST + appendDecl parent1 pn' newDeclSig = do + hasDeclsSybTransform workerHsDecls workerBind parent1 + where + workerHsDecls :: forall t. HasDecls t => t -> RefactGhc t + workerHsDecls parent' = do + logm $ "addDecl.appendDecl:(pn')=" ++ showGhc pn' + liftT $ setDeclSpacing newDeclSig 2 0 + nameMap <- getRefactNameMap + decls <- liftT $ hsDecls parent' + let + (before,after) = break (definesDeclRdr nameMap pn') decls + + logm $ "addDecl.appendDecl:(before,after)=" ++ showGhc (before,after) + let (decls1,decls2) = case after of + [] -> (before,[]) + _ -> (before ++ [ghead "appendDecl14" after], + gtail "appendDecl15" after) + liftT $ replaceDecls parent' (decls1++newDeclSig++decls2) + + workerBind :: (GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName)) + workerBind = assert False undefined + + addLocalDecl :: (SYB.Typeable t,SYB.Data t) + => t -> [GHC.LHsDecl GHC.RdrName] + -> RefactGhc t + addLocalDecl parent' newDeclSig = do + logm $ "addLocalDecl entered" + -- logDataWithAnns "addLocalDecl.parent'" parent' + hasDeclsSybTransform workerHasDecls workerBind parent' + where + workerDecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] + workerDecls decls = do + logm $ "workerDecls entered" + case decls of + [] -> liftT $ setDeclSpacing newDeclSig 2 0 + ds -> do + DP (r,c) <- liftT (getEntryDPT (head ds)) + liftT $ setDeclSpacing newDeclSig r c + liftT $ setPrecedingLinesT (head ds) 2 0 + return (newDeclSig++decls) + + workerHasDecls :: (HasDecls t) => t -> RefactGhc t + workerHasDecls p = do + logm $ "workerHasDecls entered" + decls <- liftT (hsDecls p) + decls' <- workerDecls decls + r <- liftT $ replaceDecls p decls' + return r + + workerBind :: GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName) + workerBind b = do + logm $ "workerBind entered" + case b of + GHC.L l (GHC.FunBind n i (GHC.MG [match] a ptt o) co fvs t) -> do + match' <- workerHasDecls match + return (GHC.L l (GHC.FunBind n i (GHC.MG [match'] a ptt o) co fvs t)) + GHC.L _ (GHC.FunBind _ _ (GHC.MG _matches _ _ _) _ _ _) -> do + error "addDecl:Cannot add a local decl to a FunBind with multiple matches" + p@(GHC.L _ (GHC.PatBind _pat _rhs _ty _fvs _t)) -> do + logm $ "workerBind.PatBind entered" + decls <- liftT (hsDeclsPatBind p) + decls' <- workerDecls decls + r <- liftT $ replaceDeclsPatBind p decls' + return r + + x -> error $ "addLocalDecl.workerBind:not processing:" ++ SYB.showData SYB.Parser 0 x + +-- --------------------------------------------------------------------- +-- +-- --------------------------------------------------------------------- + +rdrNameFromName :: Bool -> GHC.Name -> RefactGhc GHC.RdrName +rdrNameFromName useQual newName = do + mname <- case (GHC.nameModule_maybe newName) of + Just (GHC.Module _ mn) -> return mn + Nothing -> do + GHC.Module _ mn <- getRefactModule + return mn + + if useQual + then return $ GHC.mkRdrQual mname (GHC.nameOccName newName) + else return $ GHC.mkRdrUnqual (GHC.nameOccName newName) + +-- --------------------------------------------------------------------- + +-- |Take a list of strings and return a list with the longest prefix +-- of spaces removed +stripLeadingSpaces :: [String] -> [String] +stripLeadingSpaces xs = map (drop n) xs + where + n = minimum $ map oneLen xs + + oneLen x = length prefix + where + (prefix,_) = break (/=' ') x + +-- --------------------------------------------------------------------- + +-- | add items to the hiding list of an import declaration which +-- imports the specified module. +addHiding:: + GHC.ModuleName -- ^ The imported module name + -> GHC.ParsedSource -- ^ The current module + -> [GHC.RdrName] -- ^ The items to be added + -> RefactGhc GHC.ParsedSource -- ^ The result +addHiding mn p ns = do + logm $ "addHiding called for (module,names):" ++ showGhc (mn,ns) + p' <- addItemsToImport' mn p ns Hide + putRefactParsed p' emptyAnns + return p' + +-- -------------------------------------------------------------------- + +-- | Creates a new entity list for hiding a name in an ImportDecl. +mkNewEntList :: [GHC.RdrName] -> RefactGhc [GHC.LIE GHC.RdrName] +mkNewEntList idNames = do + case idNames of + [] -> return [] + _ -> do + newEntsInit <- mapM (mkNewEnt True) (init idNames) + newEntsLast <- mkNewEnt False (last idNames) + return (newEntsInit ++ [newEntsLast]) + +-- | Creates a new entity for hiding a name in an ImportDecl. +mkNewEnt :: Bool -> GHC.RdrName -> RefactGhc (GHC.LIE GHC.RdrName) +mkNewEnt addCommaAnn pn = do + newSpan <- liftT uniqueSrcSpanT + let lpn = GHC.L newSpan pn + if addCommaAnn + then liftT $ addSimpleAnnT lpn (DP (0,0)) [((G GHC.AnnVal),DP (0,0)),((G GHC.AnnComma),DP (0,0))] + else liftT $ addSimpleAnnT lpn (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] + return (GHC.L newSpan (GHC.IEVar lpn)) + +-- | Represents the operation type we want to select on addItemsToImport' +data ImportType = Hide -- ^ Used for addHiding + | Import -- ^ Used for addItemsToImport + +-- | Add identifiers (given by the third argument) to the explicit entity list in the declaration importing the +-- specified module name. This function does nothing if the import declaration does not have an explicit entity list. +addItemsToImport:: + GHC.ModuleName -- ^ The imported module name + ->GHC.ParsedSource -- ^ The current module + ->[GHC.RdrName] -- ^ The items to be added +-- ->Maybe GHC.Name -- ^ The condition identifier. + ->RefactGhc GHC.ParsedSource -- ^ The result +addItemsToImport mn r ns = addItemsToImport' mn r ns Import + +-- | Add identifiers (given by the third argument) to the explicit entity list in the declaration importing the +-- specified module name. If the ImportType argument is Hide, then the items will be added to the "hiding" +-- list. If it is Import, they will be added to the explicit import entries. This function does nothing if +-- the import declaration does not have an explicit entity list and ImportType is Import. +addItemsToImport':: + GHC.ModuleName -- ^ The imported module name + -> GHC.ParsedSource -- ^ The current module + -> [GHC.RdrName] -- ^ The items to be added +-- ->Maybe GHC.Name -- ^ The condition identifier. + -> ImportType -- ^ Whether to hide the names or import them. Uses special data for clarity. + -> RefactGhc GHC.ParsedSource -- ^ The result +addItemsToImport' serverModName (GHC.L l p) pns impType = do + let imps = GHC.hsmodImports p + imps' <- mapM inImport imps + return $ GHC.L l p {GHC.hsmodImports = imps'} + where + isHide = case impType of + Hide -> True + Import -> False + + inImport :: GHC.LImportDecl GHC.RdrName -> RefactGhc (GHC.LImportDecl GHC.RdrName) + inImport imp@(GHC.L _ (GHC.ImportDecl _st (GHC.L _ modName) _qualify _source _safe isQualified _isImplicit _as h)) + | serverModName == modName && not isQualified -- && (if isJust pn then findPN (gfromJust "addItemsToImport" pn) h else True) + = case h of + Nothing -> insertEnts imp [] True + Just (_isHide, (GHC.L _le ents)) -> insertEnts imp ents False + inImport x = return x + + insertEnts :: + GHC.LImportDecl GHC.RdrName + -> [GHC.LIE GHC.RdrName] + -> Bool -- True means there are already existing entities + -> RefactGhc ( GHC.LImportDecl GHC.RdrName ) + insertEnts imp ents isNew = do + logm $ "addItemsToImport':insertEnts:(imp,ents,isNew):" ++ showGhc (imp,ents,isNew) + if isNew && not isHide then return imp + else do + logm $ "addItemsToImport':insertEnts:doing stuff" + newSpan <- liftT uniqueSrcSpanT + newEnts <- mkNewEntList pns + let lNewEnts = GHC.L newSpan (ents++newEnts) + logm $ "addImportDecl.mkImpDecl:adding anns for:" ++ showGhc lNewEnts + if isHide + then + liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] + else + liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnOpenP),DP (0,0)),((G GHC.AnnCloseP),DP (0,0))] + when (not (null ents)) $ do liftT (addTrailingCommaT (last ents)) + return (replaceHiding imp (Just (isHide, lNewEnts))) + + + replaceHiding (GHC.L l1 (GHC.ImportDecl st mn q src safe isQ isImp as _h)) h1 = + (GHC.L l1 (GHC.ImportDecl st mn q src safe isQ isImp as h1)) + +-- --------------------------------------------------------------------- + +addParamsToDecls:: + [GHC.LHsDecl GHC.RdrName] -- ^ A declaration list where the function is defined and\/or used. + -> GHC.Name -- ^ The function name. + -> [GHC.RdrName] -- ^ The parameters to be added. + -> RefactGhc [GHC.LHsDecl GHC.RdrName] -- ^ The result. + +addParamsToDecls decls pn paramPNames = do + -- logm $ "addParamsToDecls (pn,paramPNames,modifyToks)=" ++ (showGhc (pn,paramPNames,modifyToks)) + -- logm $ "addParamsToDecls: decls=" ++ (SYB.showData SYB.Renamer 0 decls) + nameMap <- getRefactNameMap + if (paramPNames /= []) + then mapM (addParamToDecl nameMap) decls + else return decls + where + addParamToDecl :: NameMap -> GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName) + addParamToDecl nameMap (GHC.L l1 (GHC.ValD (GHC.FunBind lp@(GHC.L l2 pname) i (GHC.MG matches a ptt o) co fvs t))) + | eqRdrNamePure nameMap lp pn + = do + matches' <- mapM addParamtoMatch matches + return (GHC.L l1 (GHC.ValD (GHC.FunBind (GHC.L l2 pname) i (GHC.MG matches' a ptt o) co fvs t))) + where + addParamtoMatch (GHC.L l (GHC.Match fn1 pats mtyp rhs)) + = do + rhs' <- addActualParamsToRhs pn paramPNames rhs + pats' <- liftT $ mapM addParam paramPNames + return (GHC.L l (GHC.Match fn1 (pats'++pats) mtyp rhs')) + + -- TODO: The following will never match, as a PatBind only deals with complex patterns. + addParamToDecl _nameMap x@(GHC.L _l1 (GHC.ValD (GHC.PatBind _pat@(GHC.L _l2 (GHC.VarPat _p)) _rhs _ty _fvs _t))) + = return x + addParamToDecl _ x = return x + + addParam n = do + newSpan <- uniqueSrcSpanT + let vn = (GHC.L newSpan (pNtoPat n)) + addSimpleAnnT vn (DP (0,1)) [((G GHC.AnnVal),DP (0,0))] + return vn + +-- --------------------------------------------------------------------- + +addActualParamsToRhs :: (SYB.Data t) => + GHC.Name -> [GHC.RdrName] -> t -> RefactGhc t +addActualParamsToRhs pn paramPNames rhs = do + logm $ "addActualParamsToRhs:entered:(pn,paramPNames)=" ++ showGhc (pn,paramPNames) + nameMap <- getRefactNameMap + let + -- |Limit the action to actual RHS elements + grhs :: (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + grhs (GHC.GRHSs g lb) = do + g' <- SYB.everywhereMStaged SYB.Renamer (SYB.mkM worker) g + return (GHC.GRHSs g' lb) + + worker :: (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LHsExpr GHC.RdrName) + worker oldExp@(GHC.L l2 (GHC.HsVar pname)) + | eqRdrNamePure nameMap (GHC.L l2 pname) pn + = do + logDataWithAnns "addActualParamsToRhs:oldExp=" oldExp + newExp' <- liftT $ foldlM addParamToExp oldExp paramPNames + + edp <- liftT $ getEntryDPT oldExp + liftT $ setEntryDPT oldExp (DP (0,0)) + l2' <- liftT $ uniqueSrcSpanT + let newExp = (GHC.L l2' (GHC.HsPar newExp')) + liftT $ addSimpleAnnT newExp (DP (0,0)) [(G GHC.AnnOpenP,DP (0,0)),(G GHC.AnnCloseP,DP (0,0))] + liftT $ setEntryDPT newExp edp + return newExp + worker x = return x + + addParamToExp :: (GHC.LHsExpr GHC.RdrName) -> GHC.RdrName -> Transform (GHC.LHsExpr GHC.RdrName) + addParamToExp expr param = do + ss1 <- uniqueSrcSpanT + ss2 <- uniqueSrcSpanT + let var = GHC.L ss2 (GHC.HsVar param) + let expr' = GHC.L ss1 (GHC.HsApp expr var) + addSimpleAnnT var (DP (0,0)) [(G GHC.AnnVal,DP (0,1))] + addSimpleAnnT expr' (DP (0,0)) [] + return expr' + + r <- applyTP (stop_tdTP (failTP `adhocTP` grhs)) rhs + return r + +{- + +The code + + sumSqu (x:xs) = (sq bar2) x + sumSquares xs + +results in + + (GRHSs + [ + ({ LiftToToplevel/D1.hs:(13,15)-(15,16) } + Just (Ann (DP (0,-1)) [] [] [] Nothing Nothing) + (GRHS + [] + ({ LiftToToplevel/D1.hs:13:17-43 } + Just (Ann (DP (0,1)) [] [] [] Nothing Nothing) + (OpApp + ({ LiftToToplevel/D1.hs:13:17-27 } + Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) + (HsApp + ({ LiftToToplevel/D1.hs:13:17-25 } + Just (Ann (DP (0,0)) [] [] [((G AnnOpenP),DP (0,0)),((G AnnCloseP),DP (0,0))] Nothing Nothing) + (HsPar + ({ LiftToToplevel/D1.hs:13:18-24 } + Just (Ann (DP (0,0)) [] [] [] Nothing Nothing) + (HsApp + ({ LiftToToplevel/D1.hs:13:18-19 } + Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: sq}))) + ({ LiftToToplevel/D1.hs:13:21-24 } + Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: bar2}))))))) + ({ LiftToToplevel/D1.hs:13:27 } + Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: x}))))) + ({ LiftToToplevel/D1.hs:13:29 } + Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: +}))) + (PlaceHolder) + ({ LiftToToplevel/D1.hs:13:31-43 } + Just (Ann (DP (0,1)) [] [] [] Nothing Nothing) + (HsApp + ({ LiftToToplevel/D1.hs:13:31-40 } + Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: sumSquares}))) + ({ LiftToToplevel/D1.hs:13:42-43 } + Just (Ann (DP (0,1)) [] [] [((G AnnVal),DP (0,0))] Nothing Nothing) + (HsVar + (Unqual {OccName: xs})))))))))] + +-} +{- +Required end result : (sq pow) x + sumSquares xs + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-46} + (OpApp + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-30} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:21-28} + (HsPar + (L {test/testdata/LiftToToplevel/D2.hs:6:22-27} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:22-23} + (HsVar {Name: LiftToToplevel.D2.sq})) + (L {test/testdata/LiftToToplevel/D2.hs:6:25-27} + (HsVar {Name: pow})))))) + (L {test/testdata/LiftToToplevel/D2.hs:6:30} + (HsVar {Name: x})))) + + (L {test/testdata/LiftToToplevel/D2.hs:6:32} + (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} + (L {test/testdata/LiftToToplevel/D2.hs:6:34-46} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:34-43} + (HsVar {Name: LiftToToplevel.D2.sumSquares})) + (L {test/testdata/LiftToToplevel/D2.hs:6:45-46} + (HsVar {Name: xs}))))))))] + +Alternate, no parens : sq pow x + sumSquares xs + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-44} + (OpApp + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-28} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:21-26} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:21-22} + (HsVar {Name: LiftToToplevel.D2.sq})) + (L {test/testdata/LiftToToplevel/D2.hs:6:24-26} + (HsVar {Name: pow})))) + (L {test/testdata/LiftToToplevel/D2.hs:6:28} + (HsVar {Name: x})))) + + + (L {test/testdata/LiftToToplevel/D2.hs:6:30} + (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} + (L {test/testdata/LiftToToplevel/D2.hs:6:32-44} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:32-41} + (HsVar {Name: LiftToToplevel.D2.sumSquares})) + (L {test/testdata/LiftToToplevel/D2.hs:6:43-44} + (HsVar {Name: xs}))))))))] + + +Original : sq x + sumSquares xs + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-40} + (OpApp + + (L {test/testdata/LiftToToplevel/D2.hs:6:21-24} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:21-22} + (HsVar {Name: sq})) + (L {test/testdata/LiftToToplevel/D2.hs:6:24} + (HsVar {Name: x})))) + + + (L {test/testdata/LiftToToplevel/D2.hs:6:26} + (HsVar {Name: GHC.Num.+})) {Fixity: infixl 6} + (L {test/testdata/LiftToToplevel/D2.hs:6:28-40} + (HsApp + (L {test/testdata/LiftToToplevel/D2.hs:6:28-37} + (HsVar {Name: LiftToToplevel.D2.sumSquares})) + (L {test/testdata/LiftToToplevel/D2.hs:6:39-40} + (HsVar {Name: xs}))))))))] + +-} + +-- --------------------------------------------------------------------- + +-- | Duplicate a function\/pattern binding declaration under a new name +-- right after the original one. +duplicateDecl :: + [GHC.LHsDecl GHC.RdrName] -- ^ decls to be updated, containing the original decl (and sig) + ->GHC.Name -- ^ The identifier whose definition is to be duplicated + ->GHC.Name -- ^ The new name (possibly qualified) + ->RefactGhc [GHC.LHsDecl GHC.RdrName] -- ^ The result +duplicateDecl decls n newFunName + = do + logm $ "duplicateDecl entered:(decls,n,newFunName)=" ++ showGhc (decls,n,newFunName) + nm <- getRefactNameMap + let + declsToDup = definingDeclsRdrNames nm [n] decls True False + funBinding = filter isFunOrPatBindP declsToDup --get the fun binding. + typeSig = map wrapSig $ definingSigsRdrNames nm [n] decls + funBinding'' <- renamePN' n newFunName False funBinding + typeSig'' <- renamePN' n newFunName False typeSig + logm $ "duplicateDecl:funBinding''=" ++ showGhc funBinding'' + + funBinding3 <- mapM (\f@(GHC.L _ fb) -> do + newSpan <- liftT uniqueSrcSpanT + let fb' = GHC.L newSpan fb + liftT $ modifyAnnsT (copyAnn f fb') + return fb' + ) (typeSig'' ++ funBinding'') + when (not $ null funBinding3) $ do + liftT $ setEntryDPT (head funBinding3) (DP (2,0)) + liftT $ mapM_ (\d -> setEntryDPT d (DP (1,0))) (tail funBinding3) + let (decls1,decls2) = break (definesDeclRdr nm n) decls + (declsToDup',declsRest) = break (not . definesDeclRdr nm n) decls2 + -- logDataWithAnns "duplicateDecl:funBinding3" funBinding3 + return $ decls1 ++ declsToDup' ++ funBinding3 ++ declsRest + +-- --------------------------------------------------------------------- +-- |Divide a declaration list into three parts (before, parent, after) +-- according to the PNT, where 'parent' is the first decl containing +-- the PNT, 'before' are those decls before 'parent' and 'after' are +-- those decls after 'parent'. + +divideDecls :: SYB.Data t => + [t] -> GHC.Located GHC.Name -> RefactGhc ([t], [t], [t]) +divideDecls ds (GHC.L _ pnt) = do + nm <- getRefactNameMap + let (before,after) = break (\x -> findNameInRdr nm pnt x) ds + return $ if (not $ emptyList after) + then (before, [ghead "divideDecls" after], gtail "divideDecls" after) + else (ds,[],[]) + +-- --------------------------------------------------------------------- + +-- | Remove the declaration (and the type signature is the second +-- parameter is True) that defines the given identifier from the +-- declaration list. +rmDecl:: (SYB.Data t) + => GHC.Name -- ^ The identifier whose definition is to be removed. + -> Bool -- ^ True means including the type signature. + -> t -- ^ The AST fragment containting the declarations, + -- originating from the ParsedSource + -> RefactGhc + (t, + GHC.LHsDecl GHC.RdrName, + Maybe (GHC.LSig GHC.RdrName)) -- ^ The result and the removed declaration + -- and the possibly removed siganture + +rmDecl pn incSig t = do + setStateStorage StorageNone + t' <- everywhereMStaged' SYB.Parser (SYB.mkM inModule + `SYB.extM` inLet + `SYB.extM` inMatch + ) t -- top down + -- applyTP (once_tdTP (failTP `adhocTP` inBinds)) t + storage <- getStateStorage + let decl' = case storage of + StorageDeclRdr decl -> decl + x -> error $ "rmDecl: unexpected value in StateStorage:" ++ (show x) + setStateStorage StorageNone + (t'',sig') <- if incSig + then rmTypeSig pn t' + else return (t', Nothing) + return (t'',decl',sig') + where + inModule (p :: GHC.ParsedSource) + = doRmDeclList p + + inMatch x@(((GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls)))):: (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))) + = doRmDeclList x + + inLet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) + inLet letExpr@(GHC.L _ (GHC.HsLet _localDecls expr)) + = do + isDone <- getDone + if isDone + then return letExpr + else do + nameMap <- getRefactNameMap + -- decls <- liftT $ hsDecls localDecls + decls <- liftT $ hsDecls letExpr + let (decls1,decls2) = break (definesDeclRdr nameMap pn) decls + if not $ emptyList decls2 + then do + let decl = ghead "rmDecl" decls2 + setStateStorage (StorageDeclRdr decl) + case length decls of + 1 -> do -- Removing the last declaration + return expr + _ -> do + -- logm $ "rmDecl.inLet:length decls /= 1" + -- let decls2' = gtail "inLet" decls2 + decls' <- doRmDecl decls1 decls2 + letExpr' <- liftT $ replaceDecls letExpr decls' + return letExpr' + -- localDecls' <- liftT $ replaceDecls localDecls decls' + -- return $ (GHC.L ss (GHC.HsLet localDecls' expr)) + else do + -- liftT $ replaceDecls localDecls decls + return letExpr + inLet x = return x + + -- --------------------------------- + + doRmDeclList parent + = do + isDone <- getDone + logm $ "doRmDeclList:isDone=" ++ show isDone + logm $ "doRmDeclList:parent=" ++ SYB.showData SYB.Parser 0 parent + if isDone + then return parent + else do + nameMap <- getRefactNameMap + decls <- liftT $ hsDecls parent + let (decls1,decls2) = break (definesDeclRdr nameMap pn) decls + if not $ emptyList decls2 + then do + -- logDataWithAnns "doRmDeclList:(parent)" (parent) + let decl = ghead "doRmDeclList" decls2 + setStateStorage (StorageDeclRdr decl) + decls' <- doRmDecl decls1 decls2 + parent' <- liftT $ replaceDecls parent decls' + logDataWithAnns "doRmDeclList:(parent')" (parent') + return parent' + else do + -- liftT $ replaceDecls parent decls + return parent + + -- --------------------------------- + + getDone = do + s <- getStateStorage + case s of + StorageNone -> return False + _ -> return True + +-- --------------------------------------------------------------------- + +-- ++AZ++ TODO: I think this has been superseded by hasDeclsSybTransform +declsSybTransform :: (SYB.Typeable a) + => (forall b. HasDecls b => b -> RefactGhc b) + -> a -> RefactGhc a +declsSybTransform transform = mt + where + mt = SYB.mkM inMatch + `SYB.extM` inPatDecl + `SYB.extM` inModule + `SYB.extM` inHsLet + + inModule :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource + inModule (modu :: GHC.ParsedSource) + = transform modu + + inMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + inMatch x@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls))) + = transform x + + inPatDecl ::GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName) + inPatDecl x@(GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) + -- = transform x + = error $ "declsSybTransform:need to reimplement PatBind case" + inPatDecl x = return x + + inHsLet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName) + inHsLet x@(GHC.L _ (GHC.HsLet{})) + = transform x + inHsLet x = return x + + --------------------------------------------------------------------- + +-- |Utility function to remove a decl from the middle of a list, assuming the +-- list has already been split into a (possibly empty) front before the decl, +-- and a back where the head is the decl to be removed. +doRmDecl :: [GHC.LHsDecl GHC.RdrName] -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] +doRmDecl decls1 decls2 + = do + let decls2' = gtail "doRmDecl 1" decls2 + declToRemove = head decls2 + + -- logDataWithAnns "doRmDecl:(decls1,decls2)" (decls1,decls2) + unless (null decls1) $ do liftT $ balanceComments (last decls1) declToRemove + unless (null decls2') $ do liftT $ balanceComments declToRemove (head decls2') + + when (not (null decls2') && null decls1) $ do liftT $ transferEntryDPT declToRemove (head decls2') + when (not (null decls2') && not (null decls1) && not (isTypeSigDecl (last decls1))) + $ do liftT $ transferEntryDPT declToRemove (head decls2') + + -- logDataWithAnns "doRmDecl:(decls2')" (decls2') + return $ (decls1 ++ decls2') + +-- --------------------------------------------------------------------- + +-- | Remove multiple type signatures +rmTypeSigs :: (SYB.Data t) => + [GHC.Name] -- ^ The identifiers whose type signatures are to be removed. + -> t -- ^ The declarations + -> RefactGhc (t,[GHC.LSig GHC.RdrName]) + -- ^ The result and removed signatures, if there + -- were any +rmTypeSigs pns t = do + (t',demotedSigsMaybe) <- foldM (\(tee,ds) n -> do { (tee',d) <- rmTypeSig n tee; return (tee', ds++[d])}) (t,[]) pns + return (t',catMaybes demotedSigsMaybe) + +-- --------------------------------------------------------------------- + +-- | Remove the type signature that defines the given identifier's +-- type from the declaration list. +rmTypeSig :: (SYB.Data t) => + GHC.Name -- ^ The identifier whose type signature is to be removed. + -> t -- ^ The declarations + -> RefactGhc (t,Maybe (GHC.LSig GHC.RdrName)) + -- ^ The result and removed signature, if there + -- was one + + -- NOTE: It may have originated from a SigD, it is up + -- to the calling function to insert this if required +rmTypeSig pn t + = do + setStateStorage StorageNone + t' <- SYB.everywhereMStaged SYB.Renamer (SYB.mkM inMatch `SYB.extM` inPatDecl `SYB.extM` inModule) t + storage <- getStateStorage + let sig' = case storage of + StorageSigRdr sig -> Just sig + StorageNone -> Nothing + x -> error $ "rmTypeSig: unexpected value in StateStorage:" ++ (show x) + return (t',sig') + where + inModule :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource + inModule (modu :: GHC.ParsedSource) + = doRmTypeSig modu + + -- Deals with the distrinct parts of a FunBind + inMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) + -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + inMatch x@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls))) + = doRmTypeSig x + + inPatDecl ::GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName) + inPatDecl x@(GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) = do + decls <- liftT $ hsDeclsPatBindD x + decls' <- doRmTypeSigDecls decls + liftT $ replaceDeclsPatBindD x decls' + + inPatDecl x = return x + + -- ---------------------------------- + + doRmTypeSig :: (HasDecls t) => t -> RefactGhc t + doRmTypeSig parent = do + decls <- liftT $ hsDecls parent + decls' <- doRmTypeSigDecls decls + liftT $ replaceDecls parent decls' + + + doRmTypeSigDecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName] + doRmTypeSigDecls decls = do + isDone <- getDone + if isDone + then return decls + else do + -- logDataWithAnns "doRmTypeSig:decls" decls + nameMap <- getRefactNameMap + let (decls1,decls2)= break (definesSigDRdr nameMap pn) decls + if not $ null decls2 + then do + -- logDataWithAnns "doRmTypeSig:parent" parent + let sig@(GHC.L sspan (GHC.SigD (GHC.TypeSig names typ p))) = ghead "rmTypeSig" decls2 + if length names > 1 + then do + let newNames = filter (\rn -> rdrName2NamePure nameMap rn /= pn) names + newSig = GHC.L sspan (GHC.SigD (GHC.TypeSig newNames typ p)) + + liftT $ removeTrailingCommaT (glast "doRmTypeSig" newNames) + + let pnt = ghead "rmTypeSig" (filter (\rn -> rdrName2NamePure nameMap rn == pn) names) + liftT $ removeTrailingCommaT pnt + + -- Construct the old signature, by keeping the + -- signature part but discarding the other names + newSpan <- liftT uniqueSrcSpanT + let oldSig = (GHC.L newSpan (GHC.TypeSig [pnt] typ p)) + liftT $ modifyAnnsT (copyAnn sig oldSig) + setStateStorage (StorageSigRdr oldSig) + + return (decls1++[newSig]++gtail "doRmTypeSig" decls2) + else do + let [oldSig] = decl2Sig sig + setStateStorage (StorageSigRdr oldSig) + decls' <- doRmDecl decls1 decls2 + return decls' + else do + return decls + + getDone = do + s <- getStateStorage + case s of + StorageNone -> return False + _ -> return True + +-- --------------------------------------------------------------------- + +-- TODO: Is this function needed with GHC? + +-- | Remove the qualifier from the given identifiers in the given syntax phrase. +rmQualifier:: (SYB.Data t) + =>[GHC.Name] -- ^ The identifiers. + ->t -- ^ The syntax phrase. + ->RefactGhc t -- ^ The result. +rmQualifier pns t = do + nm <- getRefactNameMap + SYB.everywhereM (nameSybTransform (rename nm)) t + where + rename nm (ln@(GHC.L l pn)::GHC.Located GHC.RdrName) + | elem (rdrName2NamePure nm ln) pns + = do + -- let (rs,_) = break (=='.') $ reverse $ showGhc pn -- ++TODO: replace this with the appropriate formulation + -- s = reverse rs + -- return (GHC.L l (GHC.mkInternalName (GHC.nameUnique pn) (GHC.mkVarOcc s) l)) + case pn of + GHC.Qual _ n -> return (GHC.L l (GHC.Unqual n)) + _ -> return ln + rename _ x = return x + +-- --------------------------------------------------------------------- + +-- | Replace all occurences of a top level GHC.Name with a qualified version. +qualifyToplevelName :: GHC.Name -> RefactGhc () +qualifyToplevelName n = do + -- renamed <- getRefactRenamed + parsed <- getRefactParsed + parsed' <- renamePN' n n True parsed + putRefactParsed parsed' emptyAnns + return () + +-- --------------------------------------------------------------------- + +data HowToQual = Qualify | NoQualify | PreserveQualify + deriving (Show,Eq) + +-- | Rename each occurrences of the identifier in the given syntax +-- phrase with the new name. + +-- TODO: the syntax phrase is required to be GHC.Located, not sure how +-- to specify this without breaking the everywhereMStaged call + +renamePN'::(SYB.Data t) + =>GHC.Name -- ^ The identifier to be renamed. + ->GHC.Name -- ^ The new name, including possible qualifier + ->Bool -- ^ True means use the qualified form for + -- the new name. + ->t -- ^ The syntax phrase + ->RefactGhc t +renamePN' oldPN newName useQual t = do + -- logm $ "renamePN: (oldPN,newName)=" ++ (showGhc (oldPN,newName)) + -- logm $ "renamePN: t=" ++ (SYB.showData SYB.Parser 0 t) + nameMap <- getRefactNameMap + newNameQual <- rdrNameFromName True newName + newNameUnqual <- rdrNameFromName False newName + newNameRdr <- rdrNameFromName useQual newName + -- logm $ "renamePN: (newNameQual,newNameUnqual,newNameRdr)=" ++ showGhc (newNameQual,newNameUnqual,newNameRdr) + + let + cond :: GHC.Located GHC.RdrName -> Bool + cond (GHC.L ln _) = + case Map.lookup ln nameMap of + Nothing -> False + Just n -> GHC.nameUnique n == GHC.nameUnique oldPN + + -- Decision process for new names + newNameCalcBool :: Bool -> GHC.RdrName -> GHC.RdrName + newNameCalcBool True n = newNameCalc Qualify n + newNameCalcBool False n = newNameCalc NoQualify n + + newNameCalc :: HowToQual -> GHC.RdrName -> GHC.RdrName + newNameCalc uq old = newNameCalc' uq (GHC.isQual_maybe old) + where + newNameCalc' :: HowToQual -> (Maybe (GHC.ModuleName,GHC.OccName)) -> GHC.RdrName + newNameCalc' Qualify (Just (mn,_)) = GHC.Qual mn (GHC.occName newName) + newNameCalc' PreserveQualify (Just (mn,_)) = GHC.Qual mn (GHC.occName newName) + newNameCalc' NoQualify (Just (_n,_)) = GHC.Unqual (GHC.occName newName) + newNameCalc' uq' _ = if uq' == Qualify then newNameQual else newNameUnqual + + rename :: Bool -> GHC.Located GHC.RdrName -> Transform (GHC.Located GHC.RdrName) + rename useQual' old@(GHC.L l n) + | cond (GHC.L l n) + = do + logTr $ "renamePN:rename at :" ++ showGhc l + let nn = newNameCalcBool useQual' n + -- A RdrName Can have a number of constructors, which are used to + -- index the annotations associated with it. Make sure the annotation + -- lines up. + let new = (GHC.L l nn) + modifyAnnsT (replaceAnnKey old new) + + return new + rename _ x = return x + + renameVar :: Bool -> (GHC.Located (GHC.HsExpr GHC.RdrName)) -> Transform (GHC.Located (GHC.HsExpr GHC.RdrName)) + renameVar useQual' (GHC.L l (GHC.HsVar n)) + | cond (GHC.L l n) + = do + logTr $ "renamePN:renameVar at :" ++ (showGhc l) + -- logTr $ "renamePN:renameVar useQual' :" ++ (show useQual') + -- logTr $ "renamePN:renameVar ln :" ++ SYB.showData SYB.Parser 0 (GHC.L l (GHC.HsVar n)) + let + nn = if useQual' + then newNameCalcBool useQual' n + else newNameCalc PreserveQualify n + return (GHC.L l (GHC.HsVar nn)) + renameVar _ x = return x + + -- HsTyVar {Name: Renaming.D1.Tree})) + renameTyVar :: Bool -> (GHC.Located (GHC.HsType GHC.RdrName)) -> Transform (GHC.Located (GHC.HsType GHC.RdrName)) + renameTyVar useQual' (GHC.L l (GHC.HsTyVar n)) + | cond (GHC.L l n) + = do + logTr $ "renamePN:renameTyVar at :" ++ (showGhc l) + let nn = newNameCalcBool useQual' n + return (GHC.L l (GHC.HsTyVar nn)) + renameTyVar _ x = return x + + + renameHsTyVarBndr :: Bool -> GHC.LHsTyVarBndr GHC.RdrName -> Transform (GHC.LHsTyVarBndr GHC.RdrName) + renameHsTyVarBndr useQual' (GHC.L l (GHC.UserTyVar n)) + | cond (GHC.L l n) + = do + logTr $ "renamePN:renameHsTyVarBndr at :" ++ (showGhc l) + let nn = newNameCalcBool useQual' n + return (GHC.L l (GHC.UserTyVar nn)) + renameHsTyVarBndr _ x = return x + + -- --------------------------------- + + renameLIE :: Bool -> (GHC.LIE GHC.RdrName) -> Transform (GHC.LIE GHC.RdrName) + renameLIE useQual' (GHC.L l (GHC.IEVar old@(GHC.L ln n))) + | cond (GHC.L ln n) + = do + -- logTr $ "renamePN:renameLIE.IEVar at :" ++ (showGhc l) + let new = newNameCalcBool useQual' n + + let newn = (GHC.L ln new) + modifyAnnsT (replaceAnnKey old newn) + + return (GHC.L l (GHC.IEVar (GHC.L ln new))) + + renameLIE useQual' (GHC.L l (GHC.IEThingAbs old@(GHC.L ln n))) + | cond (GHC.L l n) + = do + -- logTr $ "renamePN:renameLIE.IEThingAbs at :" ++ (showGhc l) + let new = newNameCalcBool useQual' n + + let newn = (GHC.L ln new) + modifyAnnsT (replaceAnnKey old newn) + + return (GHC.L l (GHC.IEThingAbs (GHC.L ln new))) + + renameLIE useQual' (GHC.L l (GHC.IEThingAll old@(GHC.L ln n))) + | cond (GHC.L ln n) + = do + -- logTr $ "renamePN:renameLIE.IEThingAll at :" ++ (showGhc l) + let new = newNameCalcBool useQual' n + + let newn = (GHC.L ln new) + modifyAnnsT (replaceAnnKey old newn) + + return (GHC.L l (GHC.IEThingAll (GHC.L ln new))) + + -- TODO: check inside the ns here too + renameLIE useQual' (GHC.L l (GHC.IEThingWith old@(GHC.L ln n) ns)) + = do + + old' <- if (cond (GHC.L ln n)) + then do + logTr $ "renamePN:renameLIE.IEThingWith at :" ++ (showGhc l) + let new = newNameCalcBool useQual' n + + let newn = (GHC.L ln new) + modifyAnnsT (replaceAnnKey old newn) + + return (GHC.L ln new) + else return old + + + ns' <- if (any (\(GHC.L lnn nn) -> cond (GHC.L lnn nn)) ns) + then renameTransform useQual' ns + else return ns + return (GHC.L l (GHC.IEThingWith old' ns')) + + renameLIE _ x = do + -- logTr $ "renamePN:renameLIE miss for :" ++ (showGhc x) + return x + + -- --------------------------------- + + renameLPat :: Bool -> (GHC.LPat GHC.RdrName) -> Transform (GHC.LPat GHC.RdrName) + renameLPat useQual' (GHC.L l (GHC.VarPat n)) + | cond (GHC.L l n) + = do + logTr $ "renamePNworker:renameLPat at :" ++ (showGhc l) + let nn = newNameCalcBool useQual' n + return (GHC.L l (GHC.VarPat nn)) + renameLPat _ x = return x + + renameFunBind :: Bool -> GHC.HsBindLR GHC.RdrName GHC.RdrName -> Transform (GHC.HsBindLR GHC.RdrName GHC.RdrName) + renameFunBind _useQual (GHC.FunBind (GHC.L ln n) fi (GHC.MG matches a typ o) co fvs tick) + | cond (GHC.L ln n) + = do -- Need to (a) rename the actual funbind name + -- NOTE: due to bottom-up traversal, (a) should + -- already have been done. + -- (b) rename each of 'tail matches' + -- (head is renamed in (a) ) + -- logTr $ "renamePN.renameFunBind" + -- Now do (b) + logTr $ "renamePN.renameFunBind.renameFunBind:starting matches" + let w lmatch@(GHC.L lm (GHC.Match mln pats typ' grhss)) = do + case mln of + Just (old@(GHC.L lmn _),f) -> do + -- A RdrName Can have a number of constructors, which are used to + -- index the annotations associated with it. Make sure the annotation + -- lines up. + let new = (GHC.L lmn newNameUnqual) + modifyAnnsT (replaceAnnKey old new) + + return (GHC.L lm (GHC.Match (Just (new,f)) pats typ' grhss)) + Nothing -> return lmatch + matches' <- mapM w matches + logTr $ "renamePN.renameFunBind.renameFunBind.renameFunBind:matches done" + return (GHC.FunBind (GHC.L ln newNameRdr) fi (GHC.MG matches' a typ o) co fvs tick) + renameFunBind _ x = return x + + renameImportDecl :: Bool -> (GHC.ImportDecl GHC.RdrName) -> Transform (GHC.ImportDecl GHC.RdrName) + renameImportDecl _useQual (GHC.ImportDecl src mn mq isrc isafe iq ii ma (Just (ij,GHC.L ll ies))) = do + ies' <- mapM (renameLIE False) ies + logTr $ "renamePN'.renameImportDecl:(ies,ies')=" ++ showGhc (ies,ies') + return (GHC.ImportDecl src mn mq isrc isafe iq ii ma (Just (ij,GHC.L ll ies'))) + renameImportDecl _ x = return x + + renameTypeSig :: Bool -> (GHC.Sig GHC.RdrName) -> Transform (GHC.Sig GHC.RdrName) + renameTypeSig _useQual (GHC.TypeSig ns typ p) + = do + logTr $ "renamePN:renameTypeSig" + -- Has already been renamed, make sure qualifier is removed + ns' <- renameTransform False ns + typ' <- renameTransform False typ + logTr $ "renamePN:renameTypeSig done" + return (GHC.TypeSig ns' typ' p) + renameTypeSig _ x = return x + + renameTransform useQual' t' = + -- Note: bottom-up traversal (no ' at end) + (SYB.everywhereM ( + -- (everywhereM' ( + SYB.mkM (rename useQual') + `SYB.extM` (renameVar useQual') + `SYB.extM` (renameTyVar useQual') + `SYB.extM` (renameHsTyVarBndr useQual') + `SYB.extM` (renameLIE useQual') + `SYB.extM` (renameLPat useQual') + `SYB.extM` (renameTypeSig useQual') + `SYB.extM` (renameImportDecl useQual') + `SYB.extM` (renameFunBind useQual') + ) t') + t' <- liftT (renameTransform useQual t) + return t' + +-- --------------------------------------------------------------------- + +-- | Check whether the specified identifier is declared in the given syntax phrase t, +-- if so, rename the identifier by creating a new name automatically. +autoRenameLocalVar:: (SYB.Data t) + => GHC.Name -- ^ The identifier. + -> t -- ^ The syntax phrase. + -> RefactGhc t -- ^ The result. +autoRenameLocalVar pn t = do + logm $ "autoRenameLocalVar: (pn)=" ++ (showGhc (pn)) + -- = everywhereMStaged SYB.Renamer (SYB.mkM renameInMatch) + nm <- getRefactNameMap + decls <- liftT $ hsDeclsGeneric t + if isDeclaredInRdr nm pn decls + then do t' <- worker t + return t' + else do return t + + where + worker :: (SYB.Data t) => t -> RefactGhc t + worker tt + =do (f,d) <- hsFDNamesFromInsideRdr tt + ds <- hsVisibleNamesRdr pn tt + let newNameStr = mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1 + newName <- mkNewGhcName Nothing newNameStr + renamePN' pn newName False tt + +-- --------------------------------------------------------------------- + +-- | Show a list of entities, the parameter f is a function that +-- specifies how to format an entity. +showEntities:: (t->String) -> [t] ->String +showEntities _ [] = "" +showEntities f [pn] = f pn +showEntities f (pn:pns) =f pn ++ "," ++ showEntities f pns + + +-- --------------------------------------------------------------------- + +isMainModule :: GHC.Module -> Bool +isMainModule modu = GHC.modulePackageKey modu == GHC.mainPackageKey + +-- --------------------------------------------------------------------- + +-- | Return the identifier's defining location. +-- defineLoc::PNT->SrcLoc +defineLoc :: GHC.Located GHC.Name -> GHC.SrcLoc +defineLoc (GHC.L _ name) = GHC.nameSrcLoc name + +-- | Return the identifier's source location. +-- useLoc::PNT->SrcLoc +useLoc:: (GHC.Located GHC.Name) -> GHC.SrcLoc +-- useLoc (GHC.L l _) = getGhcLoc l +useLoc (GHC.L l _) = GHC.srcSpanStart l + +-- --------------------------------------------------------------------- + +-- | Return True if the identifier is used in the RHS if a +-- function\/pattern binding. +isUsedInRhs::(SYB.Data t) => (GHC.Located GHC.Name) -> t -> Bool +isUsedInRhs pnt t = useLoc pnt /= defineLoc pnt && not (notInLhs) + where + notInLhs = fromMaybe False $ SYB.somethingStaged SYB.Parser Nothing + (Nothing `SYB.mkQ` inMatch `SYB.extQ` inDecl) t + where + inMatch ((GHC.FunBind name _ (GHC.MG _matches _ _ _) _ _ _) :: GHC.HsBind GHC.Name) + | isJust (find (sameOccurrence pnt) [name]) = Just True + inMatch _ = Nothing + + inDecl ((GHC.TypeSig is _ _) :: GHC.Sig GHC.Name) + |isJust (find (sameOccurrence pnt) is) = Just True + inDecl _ = Nothing + +-- --------------------------------------------------------------------- +-- | Find all occurrences with location of the given name +findAllNameOccurences :: (SYB.Data t) => GHC.Name -> t -> [(GHC.Located GHC.Name)] +findAllNameOccurences name t + = res + where + res = SYB.everythingStaged SYB.Renamer (++) [] + ([] `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t + + worker (ln@(GHC.L _l n) :: (GHC.Located GHC.Name)) + | GHC.nameUnique n == GHC.nameUnique name = [ln] + worker _ = [] + + workerBind (GHC.L l (GHC.VarPat n) :: (GHC.Located (GHC.Pat GHC.Name))) + | GHC.nameUnique n == GHC.nameUnique name = [(GHC.L l n)] + workerBind _ = [] + + workerExpr (GHC.L l (GHC.HsVar n) :: (GHC.Located (GHC.HsExpr GHC.Name))) + | GHC.nameUnique n == GHC.nameUnique name = [(GHC.L l n)] + workerExpr _ = [] + +-- --------------------------------------------------------------------- + +findNameInRdr :: (SYB.Data t) => NameMap -> GHC.Name -> t -> Bool +findNameInRdr nm pn t = + isJust $ SYB.something (Nothing `SYB.mkQ` worker) t + where + worker (ln :: GHC.Located GHC.RdrName) + | GHC.nameUnique pn == GHC.nameUnique (rdrName2NamePure nm ln) = Just True + worker _ = Nothing + +-- --------------------------------------------------------------------- + +-- | Return True if the identifier occurs in the given syntax phrase. +findPNT::(SYB.Data t) => GHC.Located GHC.Name -> t -> Bool +findPNT (GHC.L _ pn) = findPN pn + +-- | Return True if the identifier occurs in the given syntax phrase. +findPN::(SYB.Data t)=> GHC.Name -> t -> Bool +findPN pn + = isJust . SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) + where + worker (n::GHC.Name) + | GHC.nameUnique pn == GHC.nameUnique n = Just True + worker _ = Nothing + +-- | Return True if any of the specified PNames ocuur in the given syntax phrase. +findPNs::(SYB.Data t)=> [GHC.Name] -> t -> Bool +findPNs pns + = isJust . SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) + where + uns = map GHC.nameUnique pns + + worker (n::GHC.Name) + | elem (GHC.nameUnique n) uns = Just True + worker _ = Nothing + +-- --------------------------------------------------------------------- + +-- | Return True if any of the specified PNames ocuur in the given syntax phrase. +findNamesRdr :: (SYB.Data t) => NameMap -> [GHC.Name] -> t -> Bool +findNamesRdr nm pns t = + isJust $ SYB.something (inName) t + where + -- r = (SYB.everythingStaged SYB.Parser mappend mempty (inName) t) + + checker :: GHC.Located GHC.RdrName -> Maybe Bool + checker ln + | elem (GHC.nameUnique (rdrName2NamePure nm ln)) uns = Just True + checker _ = Nothing + + inName :: (SYB.Typeable a) => a -> Maybe Bool + inName = nameSybQuery checker + + uns = map GHC.nameUnique pns + + -- worker (ln :: GHC.Located GHC.RdrName) + -- | elem (GHC.nameUnique (rdrName2NamePure nm ln)) uns = Just True + -- worker _ = Nothing + +-- --------------------------------------------------------------------- + +-- | Return the type checked `GHC.Id` corresponding to the given +-- `GHC.Name` + +-- TODO: there has to be a simpler way, using the appropriate GHC internals +findIdForName :: GHC.Name -> RefactGhc (Maybe GHC.Id) +findIdForName n = do + tm <- getTypecheckedModule + let t = GHC.tm_typechecked_source tm + let r = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) t + worker (i::GHC.Id) + | (GHC.nameUnique n) == (GHC.varUnique i) = Just i + worker _ = Nothing + return r + +-- --------------------------------------------------------------------- + +getTypeForName :: GHC.Name -> RefactGhc (Maybe GHC.Type) +getTypeForName n = do + mId <- findIdForName n + case mId of + Nothing -> return Nothing + Just i -> return $ Just (GHC.varType i) + +-- --------------------------------------------------------------------- + +-- | Given the syntax phrase, find the largest-leftmost expression +-- contained in the region specified by the start and end position, if +-- found. +locToExp:: (SYB.Data t,SYB.Typeable n) => + SimpPos -- ^ The start position. + -> SimpPos -- ^ The end position. + -> t -- ^ The syntax phrase. + -> Maybe (GHC.Located (GHC.HsExpr n)) -- ^ The result. +locToExp beginPos endPos t = res + where + res = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` expr) t + + expr :: GHC.Located (GHC.HsExpr n) -> (Maybe (GHC.Located (GHC.HsExpr n))) + expr e + |inScope e = Just e + expr _ = Nothing + + inScope :: GHC.Located e -> Bool + inScope (GHC.L l _) = + let + (startLoc,endLoc) = case l of + (GHC.RealSrcSpan ss) -> + ((GHC.srcSpanStartLine ss,GHC.srcSpanStartCol ss), + (GHC.srcSpanEndLine ss,GHC.srcSpanEndCol ss)) + (GHC.UnhelpfulSpan _) -> ((0,0),(0,0)) + in + (startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && (endLoc<=endPos) + +-------------------------------------------------------------------------------- + + +ghcToPN :: GHC.RdrName -> PName +ghcToPN rdr = PN rdr + +lghcToPN :: GHC.Located GHC.RdrName -> PName +lghcToPN (GHC.L _ rdr) = PN rdr + + +-- | If an expression consists of only one identifier then return this +-- identifier in the GHC.Name format, otherwise return the default Name +expToName:: GHC.LHsExpr GHC.Name -> GHC.Name -- TODO: Use a Maybe, rather than defaultName +expToName (GHC.L _ (GHC.HsVar pnt)) = pnt +expToName (GHC.L _ (GHC.HsPar e)) = expToName e +expToName _ = defaultName + +-- | If an expression consists of only one identifier then return this +-- identifier in the GHC.Name format, otherwise return the default Name +expToNameRdr :: NameMap -> GHC.LHsExpr GHC.RdrName -> Maybe GHC.Name +expToNameRdr nm (GHC.L l (GHC.HsVar pnt)) = Just (rdrName2NamePure nm (GHC.L l pnt)) +expToNameRdr nm (GHC.L _ (GHC.HsPar e)) = expToNameRdr nm e +expToNameRdr _ _ = Nothing + +nameToString :: GHC.Name -> String +-- nameToString name = showGhc name +nameToString name = showGhcQual name + +-- | If a pattern consists of only one identifier then return this +-- identifier, otherwise return Nothing +patToNameRdr :: NameMap -> GHC.LPat GHC.RdrName -> Maybe GHC.Name +patToNameRdr nm (GHC.L l (GHC.VarPat n)) = Just (rdrName2NamePure nm (GHC.L l n)) +patToNameRdr _ _ = Nothing + +-- | If a pattern consists of only one identifier then return this +-- identifier, otherwise return Nothing +patToPNT :: GHC.LPat GHC.Name -> Maybe GHC.Name +patToPNT (GHC.L _ (GHC.VarPat n)) = Just n +patToPNT _ = Nothing + +-- | Compose a pattern from a pName. +pNtoPat :: name -> GHC.Pat name +pNtoPat pname = GHC.VarPat pname + +-- EOF diff --git a/src/Language/Haskell/Refact/Utils/Types.hs b/src/Language/Haskell/Refact/Utils/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/Types.hs @@ -0,0 +1,56 @@ +module Language.Haskell.Refact.Utils.Types + ( + ApplyRefacResult + , RefacResult(..) + , RefacSource(..) + -- * + , TreeId(..) + , mainTid + , TokenCache(..) + , SimpPos + , SimpSpan + , NameMap + + ) where + +import qualified GHC as GHC + +import Language.Haskell.GHC.ExactPrint + +import qualified Data.Map as Map + + +-- --------------------------------------------------------------------- +-- | The result of a refactoring is the file, a flag as to whether it +-- was modified, and the updated AST +type ApplyRefacResult = ((FilePath, RefacResult), (Anns,GHC.ParsedSource)) + +data RefacResult = RefacModified | RefacUnmodifed + deriving (Show,Ord,Eq) + + +data RefacSource = RSFile FilePath + | RSMod GHC.ModSummary + | RSAlreadyLoaded + +-- --------------------------------------------------------------------- + +data TreeId = TId !Int deriving (Eq,Ord,Show) + +-- |Identifies the tree carrying the main tokens, not any work in +-- progress or deleted ones +mainTid :: TreeId +mainTid = TId 0 + +data TokenCache a = TK + { tkCache :: !(Map.Map TreeId a) + , tkLastTreeId :: !TreeId + } deriving (Show) + +type SimpPos = (Int,Int) -- Line, column +type SimpSpan = (SimpPos,SimpPos) + +-- --------------------------------------------------------------------- + +type NameMap = Map.Map GHC.SrcSpan GHC.Name + diff --git a/src/Language/Haskell/Refact/Utils/Utils.hs b/src/Language/Haskell/Refact/Utils/Utils.hs --- a/src/Language/Haskell/Refact/Utils/Utils.hs +++ b/src/Language/Haskell/Refact/Utils/Utils.hs @@ -1,27 +1,27 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId module Language.Haskell.Refact.Utils.Utils ( -- * Managing the GHC / project environment - getModuleGhc + getTargetGhc , parseSourceFileGhc - , activateModule - , getModuleDetails -- * The bits that do the work , runRefacSession + , runRefactGhcCd , applyRefac , refactDone - , ApplyRefacResult - , RefacSource(..) - , update - , fileNameToModName + , Update(..) + -- , fileNameToModName , fileNameFromModSummary , getModuleName , clientModsAndFiles @@ -29,71 +29,37 @@ ) where +import Control.Exception import Control.Monad.State import Data.List -import Data.Maybe -import Language.Haskell.GhcMod -import Language.Haskell.Refact.Utils.GhcBugWorkArounds + +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Utils + +import qualified Language.Haskell.GhcMod as GM +import qualified Language.Haskell.GhcMod.Internal as GM + import Language.Haskell.Refact.Utils.GhcModuleGraph -import Language.Haskell.Refact.Utils.GhcUtils import Language.Haskell.Refact.Utils.GhcVersionSpecific -import Language.Haskell.Refact.Utils.LocUtils import Language.Haskell.Refact.Utils.Monad import Language.Haskell.Refact.Utils.MonadFunctions -import Language.Haskell.Refact.Utils.TypeSyn -import Language.Haskell.Refact.Utils.TypeUtils -import Language.Haskell.TokenUtils.DualTree -import Language.Haskell.TokenUtils.TokenUtils -import Language.Haskell.TokenUtils.Utils +import Language.Haskell.Refact.Utils.Types +import Language.Haskell.Refact.Utils.Variables import System.Directory import System.FilePath.Posix +import qualified Data.Generics as SYB import qualified Digraph as GHC -import qualified FastString as GHC -import qualified GHC +import qualified DynFlags as GHC +import qualified GHC as GHC import qualified Outputable as GHC -import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB --- import Debug.Trace - --- --------------------------------------------------------------------- - --- | From file name to module name. -fileNameToModName :: FilePath -> RefactGhc GHC.ModuleName -fileNameToModName fileName = do - mm <- getModuleMaybe fileName - case mm of - Nothing -> error $ "Can't find module name" - Just ms -> return $ GHC.moduleName $ GHC.ms_mod ms - --- --------------------------------------------------------------------- - -getModuleMaybe :: FilePath -> RefactGhc (Maybe GHC.ModSummary) -getModuleMaybe fileName = do - cfileName <- liftIO $ canonicalizePath fileName - -- logm $ "getModuleMaybe for (fileName,cfileName):" ++ show (fileName,cfileName) - - graphs <- gets rsGraph - currentTgt <- gets rsCurrentTarget - logm $ "getModuleMaybe " ++ show fileName ++ ":" ++ show (length graphs,currentTgt) - - let cgraph = concatMap (\(_,cg) -> cg) graphs - -- graph <- GHC.getModuleGraph - -- cgraph <- liftIO $ canonicalizeGraph graph - - -- logm $ "getModuleMaybe: [mfn]=" ++ show (map (\(mfn,_ms) -> mfn) cgraph) - - let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph - -- logm $ "getModuleMaybe: mm=" ++ show mm +import qualified Data.Map as Map +import qualified Data.Set as Set - case mm of - [] -> return Nothing - _ -> do - let (_mfn,ms) = (ghead "getModuleMaybe" mm) - -- activateModule (fromJust mfn,ms) - return $ Just ms +-- import Debug.Trace -- --------------------------------------------------------------------- @@ -106,145 +72,73 @@ -- --------------------------------------------------------------------- --- | Once the module graph has been loaded, load the given module into --- the RefactGhc monad --- TODO: relax the equality test, if the file is loaded via cabal it --- may have a full filesystem path. -getModuleGhc :: - FilePath -> RefactGhc () -getModuleGhc targetFile = do - -- TODO: consult cached store of multiple module graphs, one for - -- each main file. - mTarget <- identifyTargetModule targetFile - case mTarget of - Nothing -> return () - Just tm -> do - void $ activateModule tm - return () - - mm <- getModuleMaybe targetFile - case mm of - Just ms -> getModuleDetails ms - Nothing -> parseSourceFileGhc targetFile +getTargetGhc :: TargetModule -> RefactGhc () +getTargetGhc (GM.ModulePath _mn fp) = parseSourceFileGhc fp -- --------------------------------------------------------------------- -identifyTargetModule :: FilePath -> RefactGhc (Maybe TargetModule) -identifyTargetModule targetFile = do - currentDirectory <- liftIO getCurrentDirectory - target1 <- liftIO $ canonicalizePath targetFile - target2 <- liftIO $ canonicalizePath (combine currentDirectory targetFile) - -- logm $ "identifyTargetModule:(targetFile,target1,target2)=" ++ show (targetFile,target1,target2) - graphs <- gets rsModuleGraph - - -- logm $ "identifyTargetModule:graphs=" ++ show graphs - - let ff = catMaybes $ map (findInTarget target1 target2) graphs - -- logm $ "identifyTargetModule:ff=" ++ show ff - case ff of - [] -> return Nothing - ms -> return (Just (ghead ("identifyTargetModule:" ++ (show ms)) ms)) - -findInTarget :: FilePath -> FilePath -> ([FilePath],GHC.ModuleGraph) -> Maybe TargetModule -findInTarget f1 f2 (fps,graph) = r' - where - -- We also need to process the case where it is a main file for an exe. - re :: Maybe TargetModule - re = case fps of - [x] -> re' -- single target, could be an exe - where - re' = case filter isMainModSummary graph of - [] -> Nothing - ms -> if x == f1 || x == f2 then Just (fps,ghead "findInTarget" ms) - else Nothing - _ -> Nothing - isMainModSummary ms = (show $ GHC.ms_mod ms) == "Main" - - r = case filter (compModFiles f1 f2) graph of - [] -> Nothing - ms -> Just (fps,ghead "findInTarget.2" ms) - compModFiles :: FilePath-> FilePath -> GHC.ModSummary -> Bool - compModFiles fileName1 fileName2 ms = - case GHC.ml_hs_file $ GHC.ms_location ms of - Nothing -> False - Just fn -> fn == fileName1 || fn == fileName2 - - r' = listToMaybe $ catMaybes [r,re] +-- | Parse a single source file into a GHC session +parseSourceFileGhc :: FilePath -> RefactGhc () +parseSourceFileGhc targetFile = do + setTargetSession targetFile + graph <- GHC.getModuleGraph + cgraph <- canonicalizeGraph graph + cfileName <- liftIO $ canonicalizePath targetFile + let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph + case mm of + [(_,modSum)] -> loadFromModSummary modSum + _ -> error $ "HaRe:unexpected error parsing " ++ targetFile -- --------------------------------------------------------------------- --- | In the existing GHC session, put the requested TypeCheckedModule --- into the RefactGhc Monad, after ensuring that its originating --- target is the currently loaded one +setTargetSession :: FilePath -> RefactGhc () +setTargetSession targetFile = RefactGhc $ GM.runGmlT' [Left targetFile] setDynFlags (return ()) -activateModule :: TargetModule -> RefactGhc GHC.ModSummary -activateModule (target, modSum) = do - logm $ "activateModule:" ++ show (target,GHC.ms_mod modSum) - newModSum <- ensureTargetLoaded (target,modSum) - getModuleDetails newModSum - return newModSum +setDynFlags :: GHC.DynFlags -> GHC.Ghc GHC.DynFlags +setDynFlags df = return (GHC.gopt_set df GHC.Opt_KeepRawTokenStream) -- --------------------------------------------------------------------- -- | In the existing GHC session, put the requested TypeCheckedModule -- into the RefactGhc monad - --- TODO: rename this function, it is not clear in a refactoring what --- it does -getModuleDetails :: GHC.ModSummary -> RefactGhc () -getModuleDetails modSum = do - p <- GHC.parseModule modSum - t <- GHC.typecheckModule p - - -- GHC.setContext [GHC.IIModule (GHC.moduleName $ GHC.ms_mod modSum)] - setGhcContext modSum +loadFromModSummary :: GHC.ModSummary -> RefactGhc () +loadFromModSummary modSum = do + logm $ "loadFromModSummary:modSum=" ++ show modSum + p <- GHC.parseModule modSum + t <- GHC.typecheckModule p - -- Use the workaround to get the tokens, the existing one does - -- not return tokens for CPP processed files. - -- tokens <- GHC.getRichTokenStream (GHC.ms_mod modSum) - tokens <- getRichTokenStreamWA (GHC.ms_mod modSum) - mtm <- gets rsModule - case mtm of - Just tm -> if ((rsStreamModified tm == False) - && ((GHC.mkFastString $ fileNameFromModSummary modSum) == - (fileNameFromTok $ ghead "getModuleDetails" tokens))) - then return () - else if rsStreamModified tm == False - then putParsedModule t tokens - else error $ "getModuleDetails: trying to load a module without finishing with active one." + -- required for inscope queries. Is there a better way to do those? + setGhcContext modSum - Nothing -> putParsedModule t tokens + (mfp,_modSum) <- canonicalizeModSummary modSum + newTargetModule <- case mfp of + Nothing -> error $ "HaRe:no file path for module:" ++ showGhc modSum + Just fp -> return $ GM.ModulePath (GHC.moduleName $ GHC.ms_mod modSum) fp - return () + oldTargetModule <- gets rsCurrentTarget + let + putModule = do + putParsedModule t + settings <- get + put $ settings { rsCurrentTarget = Just newTargetModule } --- --------------------------------------------------------------------- + mtm <- gets rsModule + case mtm of + Just tm -> if ((rsStreamModified tm == RefacUnmodifed) + && oldTargetModule == Just newTargetModule) + then do + logm $ "loadFromModSummary:not calling putParsedModule for targetModule=" ++ show newTargetModule + return () + else if rsStreamModified tm == RefacUnmodifed + then putModule + else error $ "loadFromModSummary: trying to load a module without finishing with active one." --- | Parse a single source file into a GHC session -parseSourceFileGhc :: FilePath -> RefactGhc () -parseSourceFileGhc targetFile = do - {- - target <- GHC.guessTarget ("*" ++ targetFile) Nothing -- The * - -- is to force interpretation, for inscopes - GHC.setTargets [target] - void $ GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling ghc --make - -} - -- logm $ "parseSourceFileGhc:about to loadModuleGraphGhc for" ++ (show targetFile) - loadModuleGraphGhc (Just [targetFile]) - -- logm $ "parseSourceFileGhc:loadModuleGraphGhc done" + Nothing -> putModule - mm <- getModuleMaybe targetFile - case mm of - Nothing -> error $ "HaRe:unexpected error parsing " ++ targetFile - Just modSum -> getModuleDetails modSum + return () -- --------------------------------------------------------------------- --- | The result of a refactoring is the file, a flag as to whether it --- was modified, the updated token stream, and the updated AST --- type ApplyRefacResult = ((FilePath, Bool), ([Ppr],[PosToken], GHC.RenamedSource)) -type ApplyRefacResult = ((FilePath, Bool), ([Line PosToken],[PosToken], GHC.RenamedSource)) - - -- | Manage a whole refactor session. Initialise the monad, load the -- whole project if required, and then apply the individual -- refactorings, and write out the resulting files. @@ -254,27 +148,24 @@ -- runRefacSession :: RefactSettings - -> Cradle -- ^ Identifies the surrounding - -- project + -> GM.Options -- ^ ghc-mod options -> RefactGhc [ApplyRefacResult] -- ^ The computation doing the -- refactoring. Normally created -- via 'applyRefac' -> IO [FilePath] -runRefacSession settings cradle comp = do +runRefacSession settings opt comp = do let - initialState = RefSt - { rsSettings = settings - , rsUniqState = 1 - , rsFlags = RefFlags False - , rsStorage = StorageNone - , rsGraph = [] - , rsModuleGraph = [] + initialState = RefSt + { rsSettings = settings + , rsUniqState = 1 + , rsSrcSpanCol = 1 + , rsFlags = RefFlags False + , rsStorage = StorageNone , rsCurrentTarget = Nothing - , rsModule = Nothing + , rsModule = Nothing } - (refactoredMods,_s) <- runRefactGhc (initGhcSession cradle (rsetImportPaths settings) >> - comp) initialState + (refactoredMods,_s) <- runRefactGhcCd comp initialState opt let verbosity = rsetVerboseLevel (rsSettings initialState) writeRefactoredFiles verbosity refactoredMods @@ -282,10 +173,42 @@ -- --------------------------------------------------------------------- -data RefacSource = RSFile FilePath - | RSMod GHC.ModSummary - | RSAlreadyLoaded +runRefactGhcCd :: + RefactGhc a -> RefactState -> GM.Options -> IO (a, RefactState) +runRefactGhcCd comp initialState opt = do + let + runMain :: IO a -> IO a + runMain progMain = do + catches progMain [ + Handler $ \(GM.GMEWrongWorkingDirectory projDir _curDir) -> do + cdAndDo projDir progMain + ] + + fullComp = runRefactGhc comp initialState opt + + runMain fullComp + +-- --------------------------------------------------------------------- + +cdAndDo :: FilePath -> IO a -> IO a +cdAndDo path fn = do + old <- getCurrentDirectory + r <- GHC.gbracket (setCurrentDirectory path) (\_ -> setCurrentDirectory old) + $ const fn + return r + +-- --------------------------------------------------------------------- + +canonicalizeTargets :: Targets-> IO Targets +canonicalizeTargets tgts = do + cur <- getCurrentDirectory + let + canonicalizeTarget (Left path) = Left <$> canonicalizePath (cur path) + canonicalizeTarget (Right modname) = return $ Right modname + mapM canonicalizeTarget tgts + +-- --------------------------------------------------------------------- -- TODO: the module should be stored in the state, and returned if it -- has been modified in a prior refactoring, instead of being parsed -- afresh each time. @@ -303,9 +226,9 @@ -- restore the state. Fix this to store the modules in some kind of cache. fileName <- case source of - RSFile fname -> do getModuleGhc fname + RSFile fname -> do parseSourceFileGhc fname return fname - RSMod ms -> do getModuleGhc $ fileNameFromModSummary ms + RSMod ms -> do parseSourceFileGhc $ fileNameFromModSummary ms return $ fileNameFromModSummary ms RSAlreadyLoaded -> do mfn <- getRefactFileName case mfn of @@ -314,43 +237,47 @@ res <- refac -- Run the refactoring, updating the state as required - mod' <- getRefactRenamed - -- toks' <- fetchToksFinal - let toks' = [] - -- pprVal <- fetchPprFinal - linesVal <- fetchLinesFinal - m <- getRefactStreamModified + mod' <- getRefactParsed + anns <- fetchAnnsFinal + m <- getRefactStreamModified -- Clear the refactoring state clearParsedModule - return (((fileName,m),(linesVal,toks', mod')),res) + absFileName <- liftIO $ canonicalizePath fileName + return (((absFileName,m),(anns, mod')),res) -- --------------------------------------------------------------------- -- |Returns True if any of the results has its modified flag set refactDone :: [ApplyRefacResult] -> Bool -refactDone rs = any (\((_,d),_) -> d) rs +refactDone rs = any (\((_,d),_) -> d == RefacModified) rs -- --------------------------------------------------------------------- - modifiedFiles :: [ApplyRefacResult] -> [String] modifiedFiles refactResult = map (\((s,_),_) -> s) - $ filter (\((_,b),_) -> b) refactResult + $ filter (\((_,b),_) -> b == RefacModified) refactResult -- --------------------------------------------------------------------- - -fileNameFromModSummary :: GHC.ModSummary -> FilePath -fileNameFromModSummary modSummary = fileName +{- +getEnabledTargets :: RefactSettings -> ([FilePath],[FilePath],[FilePath],[FilePath]) -> ([FilePath],[FilePath]) +getEnabledTargets settings (libt,exet,testt,bencht) = (targetsLib,targetsExe) where - -- TODO: what if we are loading a compiled only client and do not - -- have the original source? - Just fileName = GHC.ml_hs_file (GHC.ms_location modSummary) + (libEnabled, exeEnabled, testEnabled, benchEnabled) = rsetEnabledTargets settings + targetsLib = on libEnabled libt + targetsExe = on exeEnabled exet + ++ on testEnabled testt + ++ on benchEnabled bencht + on flag xs = if flag then xs else [] +-} -- --------------------------------------------------------------------- + +-- ++AZ++ I think the intended function of this class has been superseded by +-- ghc-exactprint HasDecls. class (SYB.Data t, SYB.Data t1) => Update t t1 where -- | Update the occurrence of one syntax phrase in a given scope by @@ -360,56 +287,44 @@ -> t1 -- ^ The contex where the old syntax phrase occurs. -> RefactGhc t1 -- ^ The result. -instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update (GHC.Located (GHC.HsExpr n)) t where +instance (SYB.Data t, GHC.OutputableBndr n, GHC.DataId n) + => Update (GHC.Located (GHC.HsExpr n)) t where update oldExp newExp t - = everywhereMStaged SYB.Parser (SYB.mkM inExp) t + = SYB.everywhereMStaged SYB.Parser (SYB.mkM inExp) t where inExp (e::GHC.Located (GHC.HsExpr n)) | sameOccurrence e oldExp - = do - -- drawTokenTree "update Located HsExpr starting" -- ++AZ++ - _ <- updateToks oldExp newExp prettyprint False - -- drawTokenTree "update Located HsExpr done" -- ++AZ++ - - -- error "update: updated tokens" -- ++AZ++ debug - -- TODO: make sure to call syncAST - return newExp + = return newExp | otherwise = return e -instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update (GHC.LPat n) t where +instance (SYB.Data t, GHC.OutputableBndr n, GHC.DataId n) + => Update (GHC.LPat n) t where update oldPat newPat t - = everywhereMStaged SYB.Parser (SYB.mkM inPat) t + = SYB.everywhereMStaged SYB.Parser (SYB.mkM inPat) t where inPat (p::GHC.LPat n) | sameOccurrence p oldPat - = do - _ <- updateToks oldPat newPat prettyprint False - -- TODO: make sure to call syncAST - return newPat + = return newPat | otherwise = return p -instance (SYB.Data t, GHC.OutputableBndr n, SYB.Data n) => Update (GHC.LHsType n) t where +instance (SYB.Data t, GHC.OutputableBndr n, GHC.DataId n) + => Update (GHC.LHsType n) t where update oldTy newTy t - = everywhereMStaged SYB.Parser (SYB.mkM inTyp) t + = SYB.everywhereMStaged SYB.Parser (SYB.mkM inTyp) t where inTyp (t'::GHC.LHsType n) | sameOccurrence t' oldTy - = do - _ <- updateToks oldTy newTy prettyprint False - -- TODO: make sure to call syncAST - return newTy + = return newTy | otherwise = return t' -instance (SYB.Data t, GHC.OutputableBndr n1, GHC.OutputableBndr n2, SYB.Data n1, SYB.Data n2) => Update (GHC.LHsBindLR n1 n2) t where +instance (SYB.Data t, GHC.OutputableBndr n1, GHC.OutputableBndr n2, GHC.DataId n1, GHC.DataId n2) + => Update (GHC.LHsBindLR n1 n2) t where update oldBind newBind t - = everywhereMStaged SYB.Parser (SYB.mkM inBind) t + = SYB.everywhereMStaged SYB.Parser (SYB.mkM inBind) t where inBind (t'::GHC.LHsBindLR n1 n2) | sameOccurrence t' oldBind - = do - _ <- updateToks oldBind newBind prettyprint False - -- TODO: make sure to call syncAST - return newBind + = return newBind | otherwise = return t' @@ -419,7 +334,7 @@ writeRefactoredFiles :: VerboseLevel -> [ApplyRefacResult] -> IO () writeRefactoredFiles verbosity files - = do let filesModified = filter (\((_f,m),_) -> m == modified) files + = do let filesModified = filter (\((_f,m),_) -> m == RefacModified) files -- TODO: restore the history function -- ++AZ++ PFE0.addToHistory isSubRefactor (map (fst.fst) filesModified) @@ -427,75 +342,68 @@ -- mapM_ writeTestDataForFile files -- This should be removed for the release version. where - modifyFile ((fileName,_),(finalLines,ts,renamed)) = do - -- let source = concatMap (snd.snd) ts - - let ts' = bypassGHCBug7351 ts - -- let source = GHC.showRichTokenStream ts' - - -- let source = renderPpr ppr - let source = renderLines finalLines + modifyFile ((fileName,_),(ann,parsed)) = do - -- (Julien personnal remark) seq forces the evaluation of - -- its first argument and returns its second argument. It - -- is unclear for me why (length source) evaluation is - -- forced. + let source = exactPrint parsed ann let (baseFileName,ext) = splitExtension fileName seq (length source) (writeFile (baseFileName ++ ".refactored" ++ ext) source) when (verbosity == Debug) $ do - writeFile (fileName ++ ".tokens") (showToks ts') - writeFile (fileName ++ ".renamed_out") (showGhc renamed) - writeFile (fileName ++ ".AST_out") $ ((showGhc renamed) ++ + writeFile (fileName ++ ".parsed_out") (showGhc parsed) + writeFile (fileName ++ ".AST_out") ((showGhc parsed) ++ "\n\n----------------------\n\n" ++ - (SYB.showData SYB.Renamer 0 renamed)) - + -- (SYB.showData SYB.Parser 0 parsed) ++ + (showAnnData ann 0 parsed) ++ + "\n\n----------------------\n\n" ++ + (showGhc ann) ++ + "\n\n----------------------\n\n" +-- (showAnnData (organiseAnns ann) 0 parsed) + ) -- --------------------------------------------------------------------- -- | Return the client modules and file names. The client modules of -- module, say m, are those modules which directly or indirectly -- import module m. --- TODO: deal with an anonymous main module, by taking Maybe GHC.ModuleName -clientModsAndFiles - :: GHC.ModuleName -> RefactGhc [([FilePath],GHC.ModSummary)] +-- clientModsAndFiles :: GHC.ModuleName -> RefactGhc [TargetModule] +clientModsAndFiles :: GM.ModulePath -> RefactGhc [TargetModule] clientModsAndFiles m = do - modsum <- GHC.getModSummary m + mgs <- cabalModuleGraphs + -- logm $ "clientModsAndFiles:mgs=" ++ show mgs + -- mgs is [Map ModulePath (Set ModulePath)] + -- where eack key imports the corresponding set. + -- There are no cycles - -- ms' <- GHC.getModuleGraph - ms' <- gets rsModuleGraph - -- target <- gets rsCurrentTarget + -- We need the reverse of this, the transitive set of values where if the + -- ModulePath is in the set, then the key is of interest. - let getClients ms = clientMods - where - mg = getModulesAsGraph False ms Nothing - rg = GHC.transposeG mg - {- - modNode = gfromJust ("clientModsAndFiles:" ++ (showGhc (GHC.ms_mod modsum,target,mg))) - $ find (\(msum',_,_) -> mycomp msum' modsum) (GHC.verticesG rg) - clientMods = filter (\msum' -> not (mycomp msum' modsum)) - $ map summaryNodeSummary $ GHC.reachableG rg modNode - -} - maybeModNode = find (\(msum',_,_) -> mycomp msum' modsum) (GHC.verticesG rg) - clientMods = case maybeModNode of - Nothing -> [] - Just modNode -> - filter (\msum' -> not (mycomp msum' modsum)) - $ map summaryNodeSummary $ GHC.reachableG rg modNode + -- So + -- Flatten the module graph, reverse the dependencies, then rebuild it + let + flattenSwap (GM.GmModuleGraph mg) + = concatMap (\(k,vs) -> map (\v -> (v,Set.singleton k)) (Set.elems vs)) $ Map.toList mg + transposed = mgs' + where + kvs = concatMap flattenSwap mgs + mgs' = foldl' (\acc (k,v) -> Map.insertWith Set.union k v acc) Map.empty kvs - let clients = concatMap (\(f,mg) -> zip (repeat f) (getClients mg)) ms' - -- Need to strip out duplicates, based on the snd of the tuple - clients' = nubBy cc clients - cc (_,mg1) (_,mg2) - = if (show $ GHC.ms_mod mg1) == "Main" || (show $ GHC.ms_mod mg2) == "Main" - then False - else mycomp mg1 mg2 + -- transposed is a map from each module to those that import it. We need the + -- transitive closure of all the importers of the given module. + check acc k = + case Map.lookup k transposed of + Nothing -> (acc,[]) + Just s -> (Set.union acc s, Set.toList $ s Set.\\ acc) + go (acc,[]) = acc + go (acc,c:s) = go (acc',s') + where + (acc',q) = check acc c + s' = nub (q ++ s) - logm $ "clientModsAndFiles:clients=" ++ show clients - logm $ "clientModsAndFiles:clients'=" ++ show clients' - return clients' + r = go (Set.empty, [m]) + return $ Set.toList r + -- TODO : find decent name and place for this. mycomp :: GHC.ModSummary -> GHC.ModSummary -> Bool mycomp ms1 ms2 = (GHC.ms_mod ms1) == (GHC.ms_mod ms2) @@ -519,9 +427,3 @@ return serverMods --- --------------------------------------------------------------------- - -instance (Show GHC.ModuleName) where - show = GHC.moduleNameString - --- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/Refact/Utils/Variables.hs b/src/Language/Haskell/Refact/Utils/Variables.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Refact/Utils/Variables.hs @@ -0,0 +1,2558 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +-------------------------------------------------------------------------------- +-- Module : Variables + +-- | +-- + +-- --------------------------------------------------------------------- + +module Language.Haskell.Refact.Utils.Variables + ( + -- ** Variable analysis + isFieldName + , isClassName + , isInstanceName + -- , hsPNs + , isDeclaredIn,isDeclaredInRdr + , FreeNames(..),DeclaredNames(..) + , hsFreeAndDeclaredPNsOld + , hsFreeAndDeclaredRdr + , hsFreeAndDeclaredNameStrings + , hsFreeAndDeclaredPNs + , hsFreeAndDeclaredGhc + , getDeclaredTypes + , getDeclaredTypesRdr + , getFvs, getFreeVars, getDeclaredVars + , hsVisiblePNs, hsVisiblePNsRdr, hsVisibleNames, hsVisibleNamesRdr + , hsFDsFromInsideRdr, hsFDNamesFromInsideRdr + , hsFDsFromInside, hsFDNamesFromInside + , hsVisibleDs, hsVisibleDsRdr + , rdrName2Name, rdrName2NamePure + , eqRdrNamePure + , rdrName2Name' + + -- ** Identifiers, expressions, patterns and declarations + , FindEntity(..) + , sameOccurrence + {- ,definingDecls -}, definedPNs, definedPNsRdr,definedNamesRdr + , definingDeclsRdrNames,definingDeclsRdrNames',definingSigsRdrNames + , definingDeclsNames, definingDeclsNames', definingSigsNames + , definingTyClDeclsNames + , defines + , definesRdr,definesDeclRdr + , definesTypeSig,definesTypeSigRdr,definesSigDRdr + , definesP + , allNames + -- ,simplifyDecl + + , hsPNs, hsNamess, hsNamessRdr + , locToName, locToRdrName + ) where + +import Control.Monad.State +import Data.List +import Data.Maybe +import Data.Monoid + +import Language.Haskell.Refact.Utils.Binds +import Language.Haskell.Refact.Utils.GhcVersionSpecific +import Language.Haskell.Refact.Utils.LocUtils +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions +import Language.Haskell.Refact.Utils.TypeSyn +import Language.Haskell.Refact.Utils.Types + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Utils + + +-- Modules from GHC +import qualified Bag as GHC +import qualified GHC as GHC +import qualified Name as GHC +import qualified NameSet as GHC +import qualified Outputable as GHC +import qualified RdrName as GHC +import qualified UniqSet as GHC + +import qualified Data.Generics as SYB +import qualified GHC.SYB.Utils as SYB + +import qualified Data.Map as Map + +import Data.Generics.Strafunski.StrategyLib.StrategyLib hiding (liftIO,MonadPlus,mzero) + +-- --------------------------------------------------------------------- + +class (SYB.Data a, SYB.Typeable a) => FindEntity a where + + -- | Returns True is a syntax phrase, say a, is part of another + -- syntax phrase, say b. + -- NOTE: very important: only do a shallow check + findEntity:: (SYB.Data b) => a -> b -> Bool + +-- --------------------------------------------------------------------- + +instance FindEntity GHC.Name where + + findEntity n t = fromMaybe False res + where + res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t + + worker (name::GHC.Name) + | n == name = Just True + worker _ = Nothing + + +-- This instance does not make sense, it will only find the specific RdrName +-- where it was found, not any other instances of it. +instance FindEntity (GHC.Located GHC.RdrName) where + + findEntity ln t = + case SYB.something (nameSybQuery checkRdr) t of + Nothing -> False + _ -> True + where + checkRdr :: GHC.Located GHC.RdrName -> Maybe Bool + checkRdr n + | sameOccurrence n ln = Just True + | otherwise = Nothing +{- + findEntity n t = fromMaybe False res + where + res = SYB.something (Nothing `SYB.mkQ` worker) t + + worker (name :: GHC.Located GHC.RdrName) + | sameOccurrence n name = Just True + worker _ = Nothing +-} + +-- --------------------------------------------------------------------- +{- +-- This is not precise enough, RdrNames are ambiguous +instance FindEntity GHC.RdrName where + + findEntity n t = fromMaybe False res + where + res = SYB.something (Nothing `SYB.mkQ` worker) t + + worker (name::GHC.RdrName) + | n == name = Just True + worker _ = Nothing +-} +-- --------------------------------------------------------------------- + +-- TODO: should the location be matched too in this case? +instance FindEntity (GHC.Located GHC.Name) where + + findEntity n t = fromMaybe False res + where + res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t + + worker (name::GHC.Located GHC.Name) + | n == name = Just True + worker _ = Nothing + + +-- --------------------------------------------------------------------- + +instance FindEntity (GHC.LHsExpr GHC.RdrName) where + + findEntity e t = fromMaybe False res + where + res = SYB.something (Nothing `SYB.mkQ` worker) t + + worker (expr :: GHC.LHsExpr GHC.RdrName) + | sameOccurrence e expr = Just True + worker _ = Nothing + +-- TODO: remove this instance +instance FindEntity (GHC.LHsExpr GHC.Name) where + + findEntity e t = fromMaybe False res + where + res = SYB.something (Nothing `SYB.mkQ` worker) t + + worker (expr :: GHC.LHsExpr GHC.Name) + | sameOccurrence e expr = Just True + worker _ = Nothing + +-- --------------------------------------------------------------------- + +instance FindEntity (GHC.Located (GHC.HsBindLR GHC.Name GHC.Name)) where + findEntity e t = fromMaybe False res + where + res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t + + worker (expr::(GHC.Located (GHC.HsBindLR GHC.Name GHC.Name))) + | sameOccurrence e expr = Just True + worker _ = Nothing + +instance FindEntity (GHC.Located (GHC.HsDecl GHC.Name)) where + findEntity d t = fromMaybe False res + where + res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t + + worker (decl::(GHC.Located (GHC.HsDecl GHC.Name))) + | sameOccurrence d decl = Just True + worker _ = Nothing + +-- --------------------------------------------------------------------- + +-- TODO: AZ: pretty sure this can be simplified, depends if we need to +-- manage transformed stuff too though. + +-- | Return True if syntax phrases t1 and t2 refer to the same one. +sameOccurrence :: (GHC.Located t) -> (GHC.Located t) -> Bool +sameOccurrence (GHC.L l1 _) (GHC.L l2 _) + = l1 == l2 + + +-- --------------------------------------------------------------------- + +-- | For free variables +data FreeNames = FN { fn :: [GHC.Name] } + +-- | For declared variables +data DeclaredNames = DN { dn :: [GHC.Name] } + +instance Show FreeNames where + show (FN ls) = "FN " ++ showGhcQual ls + +instance Show DeclaredNames where + show (DN ls) = "DN " ++ showGhcQual ls + +instance Monoid FreeNames where + mempty = FN [] + mappend (FN a) (FN b) = FN (a `mappend` b) + +instance Monoid DeclaredNames where + mempty = DN [] + mappend (DN a) (DN b) = DN (a `mappend` b) + + +emptyFD :: (FreeNames,DeclaredNames) +emptyFD = (FN [], DN []) + +-- --------------------------------------------------------------------- +-- | True if the name is a field name +isFieldName :: GHC.Name -> Bool +isFieldName _n = error "undefined isFieldName" + +-- --------------------------------------------------------------------- +-- | True if the name is a field name +isClassName :: GHC.Name -> Bool +isClassName _n = error "undefined isClassName" + +-- --------------------------------------------------------------------- +-- | True if the name is a class instance +isInstanceName :: GHC.Name -> Bool +isInstanceName _n = error "undefined isInstanceName" + + +-- --------------------------------------------------------------------- +-- | Collect the identifiers (in PName format) in a given syntax phrase. + +hsPNs::(SYB.Data t)=> t -> [PName] +hsPNs t = (nub.ghead "hsPNs") res + where + res = SYB.everythingStaged SYB.Parser (++) [] ([] `SYB.mkQ` inPnt) t + + inPnt (pname :: GHC.RdrName) = return [(PN pname)] + +------------------------------------------------------------------------------- +-- ++AZ++ see if we can get away with one only.. +isDeclaredIn :: (HsValBinds t GHC.Name) => GHC.Name -> t -> Bool +isDeclaredIn name t = nonEmptyList $ definingDeclsNames [name] (hsBinds t) False True + +isDeclaredInRdr :: NameMap -> GHC.Name -> [GHC.LHsDecl GHC.RdrName] -> Bool +isDeclaredInRdr nm name decls = nonEmptyList $ definingDeclsRdrNames nm [name] decls False True + +-- --------------------------------------------------------------------- +-- | Collect the free and declared variables (in the GHC.Name 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. +-- Expects RenamedSource +hsFreeAndDeclaredRdr :: (SYB.Data t) => NameMap -> t -> (FreeNames,DeclaredNames) +hsFreeAndDeclaredRdr nm t = res + where + fd = hsFreeAndDeclaredRdr' nm t + (FN f,DN d) = fromMaybe mempty fd + res = (FN (f \\ d),DN d) + +hsFreeAndDeclaredRdr':: (SYB.Data t) => NameMap -> t -> Maybe (FreeNames,DeclaredNames) +hsFreeAndDeclaredRdr' nm t = do + (FN f,DN d) <- hsFreeAndDeclared' + let (f',d') = (nub f, nub d) + -- return (f' \\ d',d') + return (FN f',DN d') + -- hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp + + where + hsFreeAndDeclared' :: Maybe (FreeNames,DeclaredNames) + hsFreeAndDeclared' = applyTU (stop_tdTU (failTU + `adhocTU` expr + `adhocTU` pattern + `adhocTU` binds + `adhocTU` bindList + `adhocTU` match + `adhocTU` stmts + `adhocTU` rhs + `adhocTU` ltydecl + )) t + + -- expr -- + expr (GHC.L l (GHC.HsVar n)) + = return (FN [rdrName2NamePure nm (GHC.L l n)],DN []) + + expr (GHC.L _ (GHC.OpApp e1 (GHC.L l (GHC.HsVar n)) _ e2)) = do + efed <- hsFreeAndDeclaredRdr' nm [e1,e2] + fd <- addFree (rdrName2NamePure nm (GHC.L l n)) efed + return fd + + expr (GHC.L _ ((GHC.HsLam (GHC.MG matches _ _ _))) :: GHC.LHsExpr GHC.RdrName) = + hsFreeAndDeclaredRdr' nm matches + + expr (GHC.L _ ((GHC.HsLet decls e)) :: GHC.LHsExpr GHC.RdrName) = + do + (FN df,DN dd) <- hsFreeAndDeclaredRdr' nm decls + (FN ef,_) <- hsFreeAndDeclaredRdr' nm e + return (FN (df `union` (ef \\ dd)),DN []) + + expr (GHC.L _ (GHC.RecordCon ln _ e)) = do + fd <- (hsFreeAndDeclaredRdr' nm e) + addFree (rdrName2NamePure nm ln) fd --Need Testing + + expr (GHC.L _ (GHC.EAsPat ln e)) = do + fd <- (hsFreeAndDeclaredRdr' nm e) + addFree (rdrName2NamePure nm ln) fd + + expr _ = mzero + + + -- rhs -- + rhs ((GHC.GRHSs g ds) :: GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + = do (FN df,DN dd) <- hsFreeAndDeclaredRdr' nm g + (FN ef,DN ed) <- hsFreeAndDeclaredRdr' nm ds + return (FN $ df ++ ef, DN $ dd ++ ed) + + + -- pat -- + pattern (GHC.L _ (GHC.AsPat ln pat)) = do + let (f,DN d) = fromMaybe mempty $ hsFreeAndDeclaredRdr' nm pat + return (f,DN (rdrName2NamePure nm ln:d)) + + pattern (GHC.L l (GHC.VarPat n)) + = return (FN [],DN [rdrName2NamePure nm (GHC.L l n)]) + -- It seems all the GHC pattern match syntax elements end up + -- with GHC.VarPat + + pattern _ = mzero + -- pattern _ = return ([],[]) + + bindList (ds :: [GHC.LHsBind GHC.RdrName]) + =do (FN f,DN d) <- hsFreeAndDeclaredList ds + return (FN (f\\d),DN d) + -- bindList _ = mzero + + -- match and patBind, same type-- + binds ((GHC.FunBind ln _ (GHC.MG matches _ _ _) _ _fvs _) :: GHC.HsBind GHC.RdrName) + = do + (FN pf,_pd) <- hsFreeAndDeclaredRdr' nm matches + let n = rdrName2NamePure nm ln + return (FN (pf \\ [n]) ,DN [n]) + + -- patBind -- + binds (GHC.PatBind pat prhs _ _ds _) = + do + (FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pat + (FN rf,DN rd) <- hsFreeAndDeclaredRdr' nm prhs + return (FN $ pf `union` (rf \\ pd),DN $ pd ++ rd) + + binds _ = mzero + + match ((GHC.Match _fn pats _mtype mrhs) :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) + = do + (FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pats + (FN rf,DN rd) <- hsFreeAndDeclaredRdr' nm mrhs + return (FN (pf `union` (rf \\ (pd `union` rd))),DN []) + + -- stmts -- + stmts ((GHC.BindStmt pat expre _bindOp _failOp) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do + -- TODO ++AZ++ : Not sure it is meaningful to pull + -- anything out of bindOp/failOp + (FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pat + (FN ef,_ed) <- hsFreeAndDeclaredRdr' nm expre + let sf1 = [] + return (FN $ pf `union` ef `union` (sf1\\pd),DN []) -- pd) -- Check this + + stmts ((GHC.LetStmt binds') :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = + hsFreeAndDeclaredRdr' nm binds' + + stmts _ = mzero + + -- tycldecls ----------------- + + ltydecl :: GHC.LTyClDecl GHC.RdrName -> Maybe (FreeNames,DeclaredNames) + + ltydecl (GHC.L _ (GHC.FamDecl fd)) = hsFreeAndDeclaredRdr' nm fd + ltydecl (GHC.L _ (GHC.SynDecl ln _bndrs _rhs _fvs)) + = return (FN [],DN [rdrName2NamePure nm ln]) + ltydecl (GHC.L _ (GHC.DataDecl ln _bndrs defn _fvs)) = do + let dds = map (rdrName2NamePure nm) $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn + return (FN [],DN (rdrName2NamePure nm ln:dds)) + ltydecl (GHC.L _ (GHC.ClassDecl _ctx ln _tyvars + _fds _sigs meths ats atds _docs _fvs)) = do + (_,md) <- hsFreeAndDeclaredRdr' nm meths + (_,ad) <- hsFreeAndDeclaredRdr' nm ats + (_,atd) <- hsFreeAndDeclaredRdr' nm atds + return (FN [],DN [rdrName2NamePure nm ln] <> md <> ad <> atd) + + ------------------------------ + + addFree :: GHC.Name -> (FreeNames,DeclaredNames) + -> Maybe (FreeNames,DeclaredNames) + addFree free (FN fr,de) = return (FN $ [free] `union` fr, de) + + hsFreeAndDeclaredList :: (SYB.Data t) => [t] -> Maybe (FreeNames,DeclaredNames) + hsFreeAndDeclaredList l = do + fds <- mapM (hsFreeAndDeclaredRdr' nm) l + let + unionF (FN a) (FN b) = FN (a `union` b) + unionD (DN a) (DN b) = DN (a `union` b) + return (foldr unionF mempty (map fst fds), + foldr unionD mempty (map snd fds)) + + +-- --------------------------------------------------------------------- +-- | Collect the free and declared variables (in the GHC.Name 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. +-- Expects RenamedSource +hsFreeAndDeclaredPNsOld:: (SYB.Data t) => t -> ([GHC.Name],[GHC.Name]) +hsFreeAndDeclaredPNsOld t = res + where + fd = hsFreeAndDeclaredPNs' t + (f,d) = fromMaybe ([],[]) fd + res = (f \\ d, d) + +hsFreeAndDeclaredPNs':: (SYB.Data t) => t -> Maybe ([GHC.Name],[GHC.Name]) +hsFreeAndDeclaredPNs' t = do + (f,d) <- hsFreeAndDeclared' + let (f',d') = (nub f, nub d) + -- return (f' \\ d',d') + return (f',d') + -- hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp + + where + + hsFreeAndDeclared' = applyTU (stop_tdTU (failTU + `adhocTU` expr + `adhocTU` pattern + `adhocTU` binds + `adhocTU` bindList + `adhocTU` match + `adhocTU` stmts + `adhocTU` rhs + )) t + + -- TODO: ++AZ++ Note:After renaming, HsBindLR has field bind_fvs + -- containing locally bound free vars + + -- expr -- + expr (GHC.HsVar n) = return ([n],[]) + + expr (GHC.OpApp e1 (GHC.L _ (GHC.HsVar n)) _ e2) = do + efed <- hsFreeAndDeclaredPNs' [e1,e2] + fd <- addFree n efed + return fd + + expr ((GHC.HsLam (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.Name) = + hsFreeAndDeclaredPNs' matches + + expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.Name) = + do + (df,dd) <- hsFreeAndDeclaredPNs' decls + (ef,_) <- hsFreeAndDeclaredPNs' e + return ((df `union` (ef \\ dd)),[]) + + expr (GHC.RecordCon (GHC.L _ n) _ e) = do + fd <- (hsFreeAndDeclaredPNs' e) + addFree n fd --Need Testing + + expr (GHC.EAsPat (GHC.L _ n) e) = do + fd <- (hsFreeAndDeclaredPNs' e) + addFree n fd + + expr _ = mzero + + + -- rhs -- + rhs ((GHC.GRHSs g ds) :: GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name)) + = do (df,dd) <- hsFreeAndDeclaredPNs' g + (ef,ed) <- hsFreeAndDeclaredPNs' ds + return (df ++ ef, dd ++ ed) + + + -- pat -- + pattern (GHC.AsPat (GHC.L _ n) pat) = do + (f,d) <- hsFreeAndDeclaredPNs' pat + return (f,n:d) + + pattern (GHC.VarPat n) = return ([],[n]) + -- It seems all the GHC pattern match syntax elements end up + -- with GHC.VarPat + + pattern _ = mzero + -- pattern _ = return ([],[]) + + bindList (ds :: [GHC.LHsBind GHC.Name]) + =do (f,d) <- hsFreeAndDeclaredList ds + return (f\\d,d) + -- bindList _ = mzero + + -- match and patBind, same type-- + binds ((GHC.FunBind (GHC.L _ n) _ (GHC.MG matches _ _ _) _ _fvs _) :: GHC.HsBind GHC.Name) + = do + (pf,_pd) <- hsFreeAndDeclaredPNs' matches + + return (pf \\ [n] ,[n]) + + -- patBind -- + binds (GHC.PatBind pat prhs _ ds _) = + do + (pf,pd) <- hsFreeAndDeclaredPNs' pat + (rf,rd) <- hsFreeAndDeclaredPNs' prhs + return (pf `union` (rf \\pd),pd ++ GHC.uniqSetToList ds ++ rd) + + binds _ = mzero + + match ((GHC.Match _fn pats _mtype mrhs) :: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) + = do + (pf,pd) <- hsFreeAndDeclaredPNs' pats + (rf,rd) <- hsFreeAndDeclaredPNs' mrhs + return ((pf `union` (rf \\ (pd `union` rd))),[]) + + -- stmts -- + stmts ((GHC.BindStmt pat expre _bindOp _failOp) :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) = do + -- TODO ++AZ++ : Not sure it is meaningful to pull + -- anything out of bindOp/failOp + (pf,pd) <- hsFreeAndDeclaredPNs' pat + (ef,_ed) <- hsFreeAndDeclaredPNs' expre + let sf1 = [] + return (pf `union` ef `union` (sf1\\pd),[]) -- pd) -- Check this + + stmts ((GHC.LetStmt binds') :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) = + hsFreeAndDeclaredPNs' binds' + + stmts _ = mzero + + + addFree :: GHC.Name -> ([GHC.Name],[GHC.Name]) + -> Maybe ([GHC.Name],[GHC.Name]) + addFree free (fr,de) = return ([free] `union` fr, de) + + 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. +hsFreeAndDeclaredNameStrings::(SYB.Data t,GHC.Outputable t) + => t -> RefactGhc ([String],[String]) +hsFreeAndDeclaredNameStrings t = do + (f1,d1) <- hsFreeAndDeclaredPNs t + return ((nub.map showGhc) f1, (nub.map showGhc) d1) + + +-- hsFreeAndDeclaredPNs :: (SYB.Data t,GHC.Outputable t) => t -> RefactGhc ([GHC.Name],[GHC.Name]) +hsFreeAndDeclaredPNs :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name]) +hsFreeAndDeclaredPNs t = do + -- logm $ "hsFreeAndDeclaredPNs:t=" ++ (showGhc t) + (FN f,DN d) <- hsFreeAndDeclaredGhc t + return (f,d) + +-- --------------------------------------------------------------------- + +-- | Collect the free and declared variables (in the GHC.Name 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. +-- TODO: use GHC.NameSet instead of lists for FreeNames/DeclaredNames +-- NOTE: The GHC fvs fields only carry non-GHC values, as they are +-- used in the renaming process +-- hsFreeAndDeclaredGhc :: (SYB.Data t,GHC.Outputable t) +hsFreeAndDeclaredGhc :: (SYB.Data t) + => t -> RefactGhc (FreeNames,DeclaredNames) +hsFreeAndDeclaredGhc t = do + -- logm $ "hsFreeAndDeclaredGhc:t=" ++ showGhc t + -- logm $ "hsFreeAndDeclaredGhc:t=" ++ SYB.showData SYB.Renamer 0 t + (FN f,DN d) <- res + let f' = nub f + let d' = nub d + -- logm $ "hsFreeAndDeclaredGhc:res=" ++ showGhc (f',d') + return (FN (f' \\ d'), DN d') + + where + res = (const err + `SYB.extQ` renamed + `SYB.extQ` lhsbind + `SYB.extQ` hsbind + `SYB.extQ` lhsbinds + `SYB.extQ` lhsbindslrs + `SYB.extQ` lhsbindslr + `SYB.extQ` hslocalbinds + `SYB.extQ` hsvalbinds + `SYB.extQ` lpats + `SYB.extQ` lpat + `SYB.extQ` bndrs + `SYB.extQ` ltydecls + `SYB.extQ` ltydecl + -- `SYB.extQ` lfaminstdecls + -- `SYB.extQ` lfaminstdecl + `SYB.extQ` lsigs + `SYB.extQ` lsig + `SYB.extQ` lexprs + `SYB.extQ` lexpr + `SYB.extQ` expr + `SYB.extQ` name + `SYB.extQ` lstmts + `SYB.extQ` lstmt + `SYB.extQ` lhstype + `SYB.extQ` hstype + `SYB.extQ` grhs_s + `SYB.extQ` grhs + `SYB.extQ` grhsss + `SYB.extQ` grhss + `SYB.extQ` matchgroup + `SYB.extQ` lmatches + `SYB.extQ` lmatch + `SYB.extQ` hsrecordbinds + `SYB.extQ` hsrecordbind + ) t + + -- ----------------------- + + renamed :: GHC.RenamedSource -> RefactGhc (FreeNames,DeclaredNames) + renamed (g,_i,_e,_d) = do + (FN gf,DN gd) <- hsFreeAndDeclaredGhc $ GHC.hs_valds g + let tds = concatMap getDeclaredTypes $ concatMap GHC.group_tyclds (GHC.hs_tyclds g) + logm $ "hsFreeAndDeclaredGhc.renamed:(gf,gd,tds)=" ++ showGhc (gf,gd,tds) + -- return $ gfds <> (FN [],DN tds) + return $ (FN (gf \\ tds), DN (gd++tds)) + + -- ----------------------- + + -- lhsdecls :: [GHC.LHsDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) + -- lhsdecls ds = recurseList ds + + -- ----------------------- + + lhsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) + lhsbinds bs = do + (FN f,DN d) <- recurseList bs + let r = (FN (f \\ d),DN d) + -- logm $ "hsFreeAndDeclaredGhc.hsbinds:r=" ++ (show r) + return r + + lhsbind :: GHC.LHsBind GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + lhsbind (GHC.L _ b) = hsFreeAndDeclaredGhc b + + -- ----------------------- + + hsbind :: GHC.HsBind GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + hsbind b@(GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _) = do + -- logm $ "hsFreeAndDeclaredGhc.hsbind:b=" ++ (showGhc b) + let d = GHC.collectHsBindBinders b + -- let pats = concatMap (\(GHC.L _ (GHC.Match pat _ _)) -> pat) matches + (fp,_dp) <- hsFreeAndDeclaredGhc matches + -- logm $ "hsFreeAndDeclaredGhc.hsbind:(fp,_dp)=" ++ (show (fp,_dp)) + -- logm $ "hsFreeAndDeclaredGhc.hsbind:(d)=" ++ (showGhc (d)) + let r = (fp,DN []) <> (FN [],DN d) + -- logm $ "hsFreeAndDeclaredGhc.hsbind:r=" ++ (show (r)) + return $ r + hsbind b@(GHC.PatBind pa rhs _ _ _) = do + -- logm $ "hsFreeAndDeclaredGhc.hsbind.PatBind:b=" ++ (showGhc b) + let d = GHC.collectHsBindBinders b + (FN fr,DN _dr) <- hsFreeAndDeclaredGhc rhs + (fp,_) <- lpat pa + -- logm $ "hsFreeAndDeclaredGhc.hsbind.PatBind:f=" ++ (showGhc fr) + return $ (fp,DN []) <> (FN fr,DN d) + hsbind b = do + -- logm $ "hsFreeAndDeclaredGhc.hsbind:b=" ++ (showGhc b) + let d = GHC.collectHsBindBinders b + return (FN [],DN d) + + -- ----------------------- + + lhsbindslrs :: [GHC.LHsBindsLR GHC.Name GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) + lhsbindslrs bs = recurseList bs + + -- ----------------------- + + lhsbindslr :: GHC.LHsBindsLR GHC.Name GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + lhsbindslr bs = do + hsFreeAndDeclaredGhc $ GHC.bagToList bs + + hslocalbinds :: GHC.HsLocalBinds GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + hslocalbinds (GHC.HsValBinds binds) = hsFreeAndDeclaredGhc binds + hslocalbinds (GHC.HsIPBinds binds) = hsFreeAndDeclaredGhc binds + hslocalbinds GHC.EmptyLocalBinds = return emptyFD + + + hsvalbinds :: GHC.HsValBinds GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + hsvalbinds (GHC.ValBindsIn binds sigs) = do + bfds <- hsFreeAndDeclaredGhc binds + sfds <- hsFreeAndDeclaredGhc sigs + return $ bfds <> sfds + hsvalbinds (GHC.ValBindsOut binds sigs) = do + bfds <- hsFreeAndDeclaredGhc $ map snd binds + sfds <- hsFreeAndDeclaredGhc sigs + return $ bfds <> sfds + + -- ----------------------- + + lpats :: [GHC.LPat GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) + lpats xs = recurseList xs + + -- ----------------------- + + lpat :: GHC.LPat GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + lpat lp@(GHC.L _ p) = do + -- logm $ "hsFreeAndDeclaredGhc.lpat:" ++ (showGhc lp) + let + d = GHC.collectPatBinders lp + + -- logm $ "hsFreeAndDeclaredGhc.lpat p=" ++ (SYB.showData SYB.Renamer 0 p) + + (FN f,DN _dn) <- pat p + -- logm $ "hsFreeAndDeclaredGhc.lpat:(fn,dn)=" ++ (showGhc (fn,dn)) + return (FN f,DN d) + + pat :: GHC.Pat GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + pat (GHC.WildPat _) = return emptyFD + pat (GHC.VarPat n) = return (FN [],DN [n]) + pat (GHC.LazyPat (GHC.L _ p)) = pat p + pat (GHC.AsPat (GHC.L _ n) (GHC.L _ p)) = do + fd <- pat p + return $ (FN [], DN [n]) <> fd + pat (GHC.ParPat (GHC.L _ p)) = pat p + pat (GHC.BangPat (GHC.L _ p)) = pat p + pat (GHC.ListPat ps _ _) = do + fds <- mapM pat $ map GHC.unLoc ps + return $ mconcat fds + pat (GHC.TuplePat ps _ _) = do + fds <- mapM pat $ map GHC.unLoc ps + return $ mconcat fds + pat (GHC.PArrPat ps _) = do + fds <- mapM pat $ map GHC.unLoc ps + return $ mconcat fds + pat (GHC.ConPatIn (GHC.L _ n) det) = do + -- logm $ "hsFreeAndDeclaredGhc.pat.ConPatIn:details=" ++ (SYB.showData SYB.Renamer 0 det) + (FN f,DN _d) <- details det + return $ (FN [n],DN []) <> (FN [],DN f) + -- pat (GHC.ConPatOut ) + pat (GHC.ViewPat e (GHC.L _ p) _) = do + fde <- hsFreeAndDeclaredGhc e + fdp <- pat p + return $ fde <> fdp + -- pat (GHC.QuasiQuotePat _) + pat (GHC.LitPat _) = return emptyFD + pat (GHC.NPat _ _ _) = return emptyFD + pat (GHC.NPlusKPat (GHC.L _ n) _ _ _) = return (FN [],DN [n]) + pat _p@(GHC.SigPatIn (GHC.L _ p) b) = do + fdp <- pat p + (FN fb,DN _db) <- hsFreeAndDeclaredGhc b + return $ fdp <> (FN fb,DN []) + pat (GHC.SigPatOut (GHC.L _ p) _) = pat p + pat (GHC.CoPat _ p _) = pat p + + pat p = error $ "hsFreeAndDeclaredGhc.pat:unimplemented:" ++ (showGhc p) + + -- HsConDetails (LPat id) (HsRecFields id (LPat id)) + details :: GHC.HsConPatDetails GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + details (GHC.PrefixCon args) = do + -- logm $ "hsFreeAndDeclaredGhc.details:args=" ++ (showGhc args) + fds <- mapM pat $ map GHC.unLoc args + return $ mconcat fds + details (GHC.RecCon recf) = + recfields recf + details (GHC.InfixCon arg1 arg2) = do + fds <- mapM pat $ map GHC.unLoc [arg1,arg2] + return $ mconcat fds + + -- Note: this one applies to HsRecFields in LPats + recfields :: (GHC.HsRecFields GHC.Name (GHC.LPat GHC.Name)) -> RefactGhc (FreeNames,DeclaredNames) + recfields (GHC.HsRecFields fields _) = do + let args = map (\(GHC.L _ (GHC.HsRecField _ (GHC.L _ arg) _)) -> arg) fields + fds <- mapM pat args + return $ mconcat fds + + -- ----------------------- + + bndrs :: GHC.HsWithBndrs GHC.Name (GHC.LHsType GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) + bndrs (GHC.HsWB (GHC.L _ thing) _ _ _) = do + (_ft,DN dt) <- hsFreeAndDeclaredGhc thing + -- logm $ "hsFreeAndDeclaredGhc.bndrs (_ft,dt)=" ++ show (_ft,DN dt) + return (FN dt,DN []) + -- ----------------------- + + ltydecls :: [GHC.LTyClDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) + ltydecls ds = do + fds <- mapM hsFreeAndDeclaredGhc ds + return $ mconcat fds + + ltydecl :: GHC.LTyClDecl GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + -- ltydecl (GHC.L _ (GHC.ForeignType (GHC.L _ n) _)) = return (FN [],DN [n]) + + -- ltydecl (GHC.L _ (GHC.TyFamily _ (GHC.L _ n) _bndrs _)) = return (FN [],DN [n]) + ltydecl (GHC.L _ (GHC.FamDecl fd)) = hsFreeAndDeclaredGhc fd + ltydecl (GHC.L _ (GHC.SynDecl (GHC.L _ n) _bndrs _rhs fvs)) + = return (FN (GHC.nameSetElems fvs),DN [n]) + ltydecl (GHC.L _ (GHC.DataDecl (GHC.L _ n) _bndrs defn fvs)) = do + let dds = map GHC.unLoc $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn + logm $ "hsFreeAndDeclaredGhc.ltydecl:(n,dds)" ++ showGhc (n,dds) + return (FN (GHC.nameSetElems fvs),DN (n:dds)) + ltydecl (GHC.L _ (GHC.ClassDecl _ctx (GHC.L _ n) _tyvars + _fds _sigs meths ats atds _docs fvs)) = do + -- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.meths" + (_,md) <- hsFreeAndDeclaredGhc meths + -- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.ats" + (_,ad) <- hsFreeAndDeclaredGhc ats + -- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.atds" + (_,atd) <- hsFreeAndDeclaredGhc atds + -- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.done" + return (FN (GHC.nameSetElems fvs),DN [n] <> md <> ad <> atd) +{- +FamDecl -- type/data family T :: *->* + tcdFam :: FamilyDecl name + +SynDecl -- type declaration + tcdLName :: Located name + tcdTyVars :: LHsTyVarBndrs name + tcdRhs :: LHsType name + tcdFVs :: PostRn name NameSet + +DataDecl + tcdLName :: Located name + tcdTyVars :: LHsTyVarBndrs name + tcdDataDefn :: HsDataDefn name + tcdFVs :: PostRn name NameSet + +ClassDecl + tcdCtxt :: LHsContext name + tcdLName :: Located name + tcdTyVars :: LHsTyVarBndrs name + tcdFDs :: [Located (FunDep (Located name))] + tcdSigs :: [LSig name] + tcdMeths :: LHsBinds name + tcdATs :: [LFamilyDecl name] + tcdATDefs :: [LTyFamDefltEqn name] + tcdDocs :: [LDocDecl] + tcdFVs :: PostRn name NameSet + + +-} + + -- --------------------------------- +{- + lfaminstdecls :: [GHC.LFamInstDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) + lfaminstdecls ds = do + fds <- mapM hsFreeAndDeclaredGhc ds + return $ mconcat fds + + lfaminstdecl :: GHC.LFamInstDecl GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + lfaminstdecl _f@(GHC.L _ (GHC.FamInstDecl (GHC.L _ n) _pats _defn fvs)) = do + -- logm $ "hsFreeAndDeclaredGhc.lfaminstdecl:" ++ showGhc _f + return (FN (GHC.nameSetElems fvs), DN [n]) +-} + -- ----------------------- + + lsigs :: [GHC.LSig GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) + lsigs ss = do + fds <- mapM hsFreeAndDeclaredGhc ss + return $ mconcat fds + + -- ----------------------- + + lsig :: GHC.LSig GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + lsig (GHC.L _ (GHC.TypeSig ns typ _)) = do + tfds <- hsFreeAndDeclaredGhc typ + return $ (FN [],DN (map GHC.unLoc ns)) <> tfds + lsig (GHC.L _ (GHC.GenericSig n typ)) = do + tfds <- hsFreeAndDeclaredGhc typ + return $ (FN [],DN (map GHC.unLoc n)) <> tfds + lsig (GHC.L _ (GHC.IdSig _)) = return emptyFD + lsig (GHC.L _ (GHC.InlineSig _ _)) = return emptyFD + lsig (GHC.L _ (GHC.SpecSig n typ _)) = do + tfds <- hsFreeAndDeclaredGhc typ + return $ (FN [],DN [GHC.unLoc n]) <> tfds + lsig (GHC.L _ (GHC.SpecInstSig _ _)) = return emptyFD + lsig (GHC.L _ (GHC.FixSig _)) = return emptyFD + lsig (GHC.L _ (GHC.PatSynSig _ _ _ _ _)) = error "lsig: PatSynSig: toImplement" + lsig (GHC.L _ (GHC.MinimalSig _ _)) = error "lsig FixSig: toImplement" + + -- ----------------------- + + lexprs :: [GHC.LHsExpr GHC.Name] -> RefactGhc (FreeNames,DeclaredNames) + lexprs es = recurseList es + + -- ----------------------- + + lexpr :: GHC.LHsExpr GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + lexpr (GHC.L _ e) = hsFreeAndDeclaredGhc e + + -- ----------------------- + + expr :: GHC.HsExpr GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + expr ((GHC.HsVar n)) = return (FN [n],DN []) + + expr ((GHC.HsIPVar _)) = return emptyFD + + expr ((GHC.HsOverLit _)) = return emptyFD + + expr ((GHC.HsLit _)) = return emptyFD + + expr ((GHC.HsLam mg)) = hsFreeAndDeclaredGhc mg + + expr ((GHC.HsLamCase _ mg)) = hsFreeAndDeclaredGhc mg + + expr ((GHC.HsApp e1 e2)) = do + fde1 <- hsFreeAndDeclaredGhc e1 + fde2 <- hsFreeAndDeclaredGhc e2 + return $ fde1 <> fde2 + + expr ((GHC.OpApp e1 eop _fix e2)) = do + fde1 <- hsFreeAndDeclaredGhc e1 + fdeop <- hsFreeAndDeclaredGhc eop + fde2 <- hsFreeAndDeclaredGhc e2 + return $ fde1 <> fdeop <> fde2 + + expr ((GHC.NegApp e _)) = hsFreeAndDeclaredGhc e + + expr ((GHC.HsPar e)) = hsFreeAndDeclaredGhc e + + expr ((GHC.SectionL e1 e2)) = do + fde1 <- hsFreeAndDeclaredGhc e1 + fde2 <- hsFreeAndDeclaredGhc e2 + return $ fde1 <> fde2 + + expr ((GHC.SectionR e1 e2)) = do + fde1 <- hsFreeAndDeclaredGhc e1 + fde2 <- hsFreeAndDeclaredGhc e2 + return $ fde1 <> fde2 + + expr ((GHC.ExplicitTuple args _boxity)) = do + let argse = concatMap bb args + bb (GHC.L _ (GHC.Missing _)) = [] + bb (GHC.L _ (GHC.Present a)) = [a] + + fds <- mapM hsFreeAndDeclaredGhc argse + return $ mconcat fds + + expr ((GHC.HsCase e body)) = do + fdes <- hsFreeAndDeclaredGhc e + fdbs <- hsFreeAndDeclaredGhc body + return $ fdes <> fdbs + + expr ((GHC.HsIf _ms e1 e2 e3)) = do + fde1 <- hsFreeAndDeclaredGhc e1 + fde2 <- hsFreeAndDeclaredGhc e2 + fde3 <- hsFreeAndDeclaredGhc e3 + return $ fde1 <> fde2 <> fde3 + + expr ((GHC.HsMultiIf _typ rhs)) + = hsFreeAndDeclaredGhc rhs + + expr ((GHC.HsLet binds e)) = do + fdb <- hsFreeAndDeclaredGhc binds + fde <- hsFreeAndDeclaredGhc e + return $ fdb <> fde + + expr ((GHC.HsDo _ctx stmts _typ)) + = hsFreeAndDeclaredGhc stmts + + expr ((GHC.ExplicitList _ _ es)) + = hsFreeAndDeclaredGhc es + + expr ((GHC.ExplicitPArr _typ es)) + = hsFreeAndDeclaredGhc es + + expr ((GHC.RecordCon (GHC.L _ n) _typ binds)) = do + fdb <- hsFreeAndDeclaredGhc binds + return $ (FN [],DN [n]) <> fdb + + expr ((GHC.RecordUpd e1 binds _cons _typ1 _typ2)) = do + fde <- hsFreeAndDeclaredGhc e1 + fdb <- hsFreeAndDeclaredGhc binds + return $ fde <> fdb + + expr ((GHC.ExprWithTySig e _typ _)) + = hsFreeAndDeclaredGhc e + + expr ((GHC.ExprWithTySigOut e _typ)) + = hsFreeAndDeclaredGhc e + + expr ((GHC.ArithSeq _ _typ as)) = do + fds <- case as of + GHC.From e -> hsFreeAndDeclaredGhc e + GHC.FromThen e1 e2 -> recurseList [e1,e2] + GHC.FromTo e1 e2 -> recurseList [e1,e2] + GHC.FromThenTo e1 e2 e3 -> recurseList [e1,e2,e3] + return fds + + expr ((GHC.PArrSeq _typ as)) + = hsFreeAndDeclaredGhc as + + expr ((GHC.HsSCC _ _ e)) + = hsFreeAndDeclaredGhc e + + expr ((GHC.HsCoreAnn _ _ e)) + = hsFreeAndDeclaredGhc e + + expr ((GHC.HsBracket (GHC.ExpBr b))) + = hsFreeAndDeclaredGhc b + expr ((GHC.HsBracket (GHC.PatBr b))) + = hsFreeAndDeclaredGhc b + expr ((GHC.HsBracket (GHC.DecBrL b))) + = hsFreeAndDeclaredGhc b + expr ((GHC.HsBracket (GHC.DecBrG b))) + = hsFreeAndDeclaredGhc b + expr ((GHC.HsBracket (GHC.TypBr b))) + = hsFreeAndDeclaredGhc b + expr ((GHC.HsBracket (GHC.VarBr _ n))) + = return (FN [],DN [n]) + expr ((GHC.HsBracket (GHC.TExpBr _))) + = error "expr: GHC.HsBracket (GHC.TExpBr), to implement" + + expr ((GHC.HsRnBracketOut b _ps)) + = hsFreeAndDeclaredGhc b + + expr ((GHC.HsTcBracketOut b _ps)) + = hsFreeAndDeclaredGhc b + + expr ((GHC.HsSpliceE _ (GHC.HsSplice _ e))) + = hsFreeAndDeclaredGhc e + + expr ((GHC.HsQuasiQuoteE _q)) + = return emptyFD + + expr ((GHC.HsProc pa cmd)) = do + fdp <- hsFreeAndDeclaredGhc pa + fdc <- hsFreeAndDeclaredGhc cmd + return $ fdp <> fdc + + expr ((GHC.HsStatic e)) = hsFreeAndDeclaredGhc e + + expr ((GHC.HsArrApp e1 e2 _typ _atyp _)) = do + fd1 <- hsFreeAndDeclaredGhc e1 + fd2 <- hsFreeAndDeclaredGhc e2 + return $ fd1 <> fd2 + + expr ((GHC.HsArrForm e1 _fix cmds)) = do + fd1 <- hsFreeAndDeclaredGhc e1 + fdc <- hsFreeAndDeclaredGhc cmds + return $ fd1 <> fdc + + expr ((GHC.HsTick _ e)) + = hsFreeAndDeclaredGhc e + + expr ((GHC.HsBinTick _ _ e)) + = hsFreeAndDeclaredGhc e + + expr ((GHC.HsTickPragma _ _ e)) + = hsFreeAndDeclaredGhc e + + expr ((GHC.EWildPat)) = return emptyFD + + expr ((GHC.EAsPat (GHC.L _ n) e)) = do + fde <- hsFreeAndDeclaredGhc e + return $ (FN [],DN [n]) <> fde + + expr ((GHC.EViewPat e1 e2)) = do + fd1 <- hsFreeAndDeclaredGhc e1 + fd2 <- hsFreeAndDeclaredGhc e2 + return $ fd1 <> fd2 + + expr ((GHC.ELazyPat e)) + = hsFreeAndDeclaredGhc e + + expr ((GHC.HsType typ)) + = hsFreeAndDeclaredGhc typ + + expr ((GHC.HsWrap _wrap e)) + = hsFreeAndDeclaredGhc e + + expr ((GHC.HsUnboundVar _)) = return emptyFD + + -- ----------------------- + + name :: GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + name n = return (FN [],DN [n]) + + -- ----------------------- + lstmts :: [GHC.LStmt GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames) + lstmts ss = recurseList ss + + + lstmt :: GHC.LStmt GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) + lstmt (GHC.L _ (GHC.LastStmt e _)) = hsFreeAndDeclaredGhc e + lstmt (GHC.L _ (GHC.BindStmt pa e _ _)) = do + fdp <- hsFreeAndDeclaredGhc pa + fde <- hsFreeAndDeclaredGhc e + return (fdp <> fde) + lstmt (GHC.L _ (GHC.BodyStmt e _ _ _)) = hsFreeAndDeclaredGhc e + -- lstmt (GHC.L _ (GHC.ExprStmt e _ _ _)) = hsFreeAndDeclaredGhc e + + lstmt (GHC.L _ (GHC.LetStmt bs)) = hsFreeAndDeclaredGhc bs + lstmt (GHC.L _ (GHC.ParStmt ps _ _)) = hsFreeAndDeclaredGhc ps + lstmt (GHC.L _ (GHC.TransStmt _ stmts _ using mby _ _ _)) = do + fds <- hsFreeAndDeclaredGhc stmts + fdu <- hsFreeAndDeclaredGhc using + fdb <- case mby of + Nothing -> return emptyFD + Just e -> hsFreeAndDeclaredGhc e + return $ fds <> fdu <> fdb + lstmt (GHC.L _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _)) = hsFreeAndDeclaredGhc stmts + + -- ----------------------- + + lhstype :: GHC.LHsType GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + lhstype (GHC.L _ typ) = hstype typ + + -- ----------------------- + + hstype :: GHC.HsType GHC.Name -> RefactGhc (FreeNames,DeclaredNames) + hstype (GHC.HsForAllTy _ _ _ _ typ) = hsFreeAndDeclaredGhc typ + hstype (GHC.HsTyVar n) = return (FN [],DN [n]) + hstype (GHC.HsAppTy t1 t2) = recurseList [t1,t2] + hstype (GHC.HsFunTy t1 t2) = recurseList [t1,t2] + hstype (GHC.HsListTy typ) = hsFreeAndDeclaredGhc typ + hstype (GHC.HsPArrTy typ) = hsFreeAndDeclaredGhc typ + hstype (GHC.HsTupleTy _ typs) = recurseList typs + hstype (GHC.HsOpTy t1 _ t2) = recurseList [t1,t2] + hstype (GHC.HsParTy typ) = hsFreeAndDeclaredGhc typ + hstype (GHC.HsIParamTy _ typ) = hsFreeAndDeclaredGhc typ + hstype (GHC.HsEqTy t1 t2) = recurseList [t1,t2] + hstype (GHC.HsKindSig t1 t2) = recurseList [t1,t2] + hstype (GHC.HsQuasiQuoteTy _) = return emptyFD + hstype (GHC.HsSpliceTy _ _) = return (FN [],DN []) + hstype (GHC.HsDocTy _ typ) = hsFreeAndDeclaredGhc typ + hstype (GHC.HsBangTy _ typ) = hsFreeAndDeclaredGhc typ + hstype (GHC.HsRecTy cons) = recurseList cons + hstype (GHC.HsCoreTy _) = return emptyFD + hstype (GHC.HsExplicitListTy _ typs) = recurseList typs + hstype (GHC.HsExplicitTupleTy _ typs) = recurseList typs + hstype (GHC.HsTyLit _) = return emptyFD + hstype (GHC.HsWrapTy _ typ) = hsFreeAndDeclaredGhc typ + hstype (GHC.HsWildcardTy) = error "To implement: hstype, HsWildcardTy" + hstype (GHC.HsNamedWildcardTy _) = error "To implement: HsNamedWildcardTy" + + + + -- ----------------------- + + grhs_s :: [GHC.LGRHS GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames) + grhs_s gs = recurseList gs + + -- ----------------------- + + grhs :: GHC.LGRHS GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) + grhs (GHC.L _ (GHC.GRHS stmts e)) = do + fds <- hsFreeAndDeclaredGhc stmts + fde <- hsFreeAndDeclaredGhc e + return $ fds <> fde + + -- ----------------------- + + grhsss :: [GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames) + grhsss gs = recurseList gs + + -- ----------------------- + + grhss :: GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) + grhss (GHC.GRHSs g binds) = do + (fg,_dg) <- hsFreeAndDeclaredGhc g + fdb <- hsFreeAndDeclaredGhc binds + return $ (fg,DN[]) <> fdb + + -- ----------------------- + + matchgroup :: GHC.MatchGroup GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) + matchgroup (GHC.MG matches _ _ _) = recurseList matches + + -- ----------------------- + + lmatches :: [GHC.LMatch GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames) + lmatches ms = recurseList ms + + -- ----------------------- + + lmatch :: GHC.LMatch GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) + lmatch (GHC.L _ _m@(GHC.Match _fn pats _ rhs)) = do + (fp,DN dp) <- recurseList pats + (FN fr,DN dr) <- hsFreeAndDeclaredGhc rhs + let r = (fp,DN []) <> (FN (fr \\ (dr ++ dp)), DN []) + return $ r + + -- ----------------------- + + hsrecordbinds :: (GHC.HsRecordBinds GHC.Name) -> RefactGhc (FreeNames,DeclaredNames) + hsrecordbinds (GHC.HsRecFields fields _) = recurseList fields + + hsrecordbind :: (GHC.HsRecField GHC.Name (GHC.LHsExpr GHC.Name)) -> RefactGhc (FreeNames,DeclaredNames) + hsrecordbind (GHC.HsRecField (GHC.L _ n) arg _) = do + fda <- hsFreeAndDeclaredGhc arg + return $ (FN [n],DN []) <> fda + + -- ----------------------- + + err = do + logm $ "hsFreeAndDeclaredGhc:not matched:" + ++ show (annGetConstr t) ++ ":" + ++ (SYB.showData SYB.Renamer 0 t) + return emptyFD + + -- --------------------------------- + + recurseList xs = do + fds <- mapM hsFreeAndDeclaredGhc xs + return $ mconcat fds + + +-- --------------------------------------------------------------------- + +-- |Get the names of all types declared in the given declaration +-- getDeclaredTypesRdr :: GHC.LTyClDecl GHC.RdrName -> RefactGhc [GHC.Name] +getDeclaredTypesRdr :: GHC.LHsDecl GHC.RdrName -> RefactGhc [GHC.Name] +getDeclaredTypesRdr (GHC.L _ (GHC.TyClD decl)) = do + nm <- getRefactNameMap + case decl of + (GHC.FamDecl (GHC.FamilyDecl _ ln _ _)) -> return [rdrName2NamePure nm ln] + (GHC.SynDecl ln _ _ _) -> return [rdrName2NamePure nm ln] + (GHC.DataDecl ln _ defn _) -> do + let dds = concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn + let ddns = map (rdrName2NamePure nm) dds + return $ [rdrName2NamePure nm ln] ++ ddns + + (GHC.ClassDecl _ ln _vars _fds sigs meths ats _atdefs _ _fvs) -> do + -- msn <- getMsn meths + let msn = getDeclaredVarsRdr nm (map wrapDecl $ GHC.bagToList meths) + let fds = map (GHC.fdLName . GHC.unLoc) ats + fds' = map (rdrName2NamePure nm) fds + return $ nub $ [rdrName2NamePure nm ln] ++ ssn ++ msn ++ fds' -- ++ asn + where + getLSig :: GHC.LSig GHC.RdrName -> [GHC.Name] + getLSig (GHC.L _ (GHC.TypeSig ns _ _)) = map (rdrName2NamePure nm) ns + getLSig (GHC.L _ (GHC.GenericSig ns _)) = map (rdrName2NamePure nm) ns + getLSig (GHC.L _ (GHC.IdSig _n)) = [] + getLSig (GHC.L _ (GHC.InlineSig ln2 _)) = [rdrName2NamePure nm ln2] + getLSig (GHC.L _ (GHC.SpecSig ln2 _ _)) = [rdrName2NamePure nm ln2] + getLSig (GHC.L _ (GHC.SpecInstSig _ _)) = [] + getLSig (GHC.L _ (GHC.FixSig _)) = [] + getLSig (GHC.L _ (GHC.PatSynSig _ _ _ _ _)) = error "To implement: getLSig PatSynSig" + getLSig (GHC.L _ (GHC.MinimalSig _ _)) = error "To implement: getLSig PatSynSig" + + ssn = concatMap getLSig sigs + -- msn = getDeclaredVars $ hsBinds meths +getDeclaredTypesRdr _ = return [] + +-- |Get the names of all types declared in the given declaration +getDeclaredTypes :: GHC.LTyClDecl GHC.Name -> [GHC.Name] +getDeclaredTypes (GHC.L _ (GHC.FamDecl (GHC.FamilyDecl _ (GHC.L _ n) _ _))) = [n] +getDeclaredTypes (GHC.L _ (GHC.SynDecl (GHC.L _ n) _ _ _)) = [n] +getDeclaredTypes (GHC.L _ (GHC.DataDecl (GHC.L _ n) _ defn _)) = n:dds + where dds = map GHC.unLoc $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn +getDeclaredTypes (GHC.L _ (GHC.ClassDecl _ (GHC.L _ n) _vars _fds sigs meths _ats _atdefs _ _fvs)) + = nub $ [n] ++ ssn ++ msn -- ++ asn + where + getLSig :: GHC.LSig GHC.Name -> [GHC.Name] + getLSig (GHC.L _ (GHC.TypeSig ns _ _)) = map GHC.unLoc ns + getLSig (GHC.L _ (GHC.GenericSig ns _)) = map GHC.unLoc ns + getLSig (GHC.L _ (GHC.IdSig _n)) = [] + getLSig (GHC.L _ (GHC.InlineSig (GHC.L _ n2) _)) = [n2] + getLSig (GHC.L _ (GHC.SpecSig (GHC.L _ n2) _ _)) = [n2] + getLSig (GHC.L _ (GHC.SpecInstSig _ _)) = [] + getLSig (GHC.L _ (GHC.FixSig _)) = [] + getLSig (GHC.L _ (GHC.PatSynSig _ _ _ _ _)) = error "To implement: getLSig PatSynSig" + getLSig (GHC.L _ (GHC.MinimalSig _ _)) = error "To implement: getLSig PatSynSig" + + ssn = concatMap getLSig sigs + msn = getDeclaredVars $ hsBinds meths + +-- --------------------------------------------------------------------- + +-- | Return the list of identifiers (in PName format) defined by a +-- function\/pattern binding. +definedPNs :: GHC.LHsBind GHC.Name -> [GHC.Name] +definedPNs (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) = [pname] +definedPNs (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = (hsNamess p) +definedPNs (GHC.L _ (GHC.VarBind pname _rhs _)) = [pname] + +-- AbsBinds and ValBinds will never occur in ParsedSource +definedPNs _ = [] + +definedPNsRdr :: GHC.LHsDecl GHC.RdrName -> [GHC.Located GHC.RdrName] +definedPNsRdr (GHC.L _ (GHC.ValD (GHC.FunBind pname _ _ _ _ _))) = [pname] +definedPNsRdr (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) = (hsNamessRdr p) +-- VarBind will never occur in ParsedSource +-- TODO: what about GHC.AbsBinds? +definedPNsRdr _ = [] + +-- --------------------------------------------------------------------- + +definedNamesRdr :: NameMap -> GHC.LHsDecl GHC.RdrName -> [GHC.Name] +definedNamesRdr nameMap bind = map (rdrName2NamePure nameMap) (definedPNsRdr bind) + +-- --------------------------------------------------------------------- + +-- |Find those declarations(function\/pattern binding) which define +-- the specified GHC.Names. incTypeSig indicates whether the +-- corresponding type signature will be included. +definingDeclsRdrNames:: + NameMap + ->[GHC.Name] -- ^ The specified identifiers. + ->[GHC.LHsDecl GHC.RdrName] -- ^ A collection of declarations. + ->Bool -- ^ True means to include the type signature. + ->Bool -- ^ True means to look at the local declarations as well. + ->[GHC.LHsDecl GHC.RdrName] -- ^ The result. +definingDeclsRdrNames nameMap pns ds _incTypeSig recursive = concatMap defining ds +-- ++AZ++:TODO: now we are processing decls again, reinstate incTypeSig function + where + defining decl + = if recursive + then SYB.everythingStaged SYB.Parser (++) [] ([] `SYB.mkQ` definesDecl `SYB.extQ` definesBind) decl + else definesDecl decl + where + definesDecl :: (GHC.LHsDecl GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] + definesDecl decl'@(GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _ _))) + | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] + + definesDecl decl'@(GHC.L _l (GHC.ValD (GHC.PatBind _p _rhs _ty _fvs _))) + | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] + + definesDecl _ = [] + + definesBind :: (GHC.LHsBind GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] + definesBind (GHC.L l b) = definesDecl (GHC.L l (GHC.ValD b)) + +-- --------------------------------------------------------------------- + +-- |Find those declarations(function\/pattern binding) which define +-- the specified GHC.Names. incTypeSig indicates whether the corresponding type +-- signature will be included. +definingDeclsRdrNames' :: (SYB.Data t) + => NameMap + -> [GHC.Name] -- ^ The specified identifiers. + -> t -- ^ A collection of declarations. + -> [GHC.LHsDecl GHC.RdrName] -- ^ The result. +definingDeclsRdrNames' nameMap pns ds = defining ds + where + defining decl + = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines' `SYB.extQ` definesBind) decl + where + defines' :: (GHC.LHsDecl GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] + defines' decl'@(GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _ _))) + | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] + + defines' decl'@(GHC.L _l (GHC.ValD (GHC.PatBind _p _rhs _ty _fvs _))) + | any (\n -> definesDeclRdr nameMap n decl') pns = [decl'] + + defines' _ = [] + + definesBind :: (GHC.LHsBind GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName] + definesBind (GHC.L l b) = defines' (GHC.L l (GHC.ValD b)) + +-- --------------------------------------------------------------------- + +-- |Find those declarations(function\/pattern binding) which define +-- the specified GHC.Names. incTypeSig indicates whether the +-- corresponding type signature will be included. +definingDeclsNames:: + [GHC.Name] -- ^ The specified identifiers. + ->[GHC.LHsBind GHC.Name] -- ^ A collection of declarations. + ->Bool -- ^ True means to include the type signature. + ->Bool -- ^ True means to look at the local declarations as well. + ->[GHC.LHsBind GHC.Name] -- ^ The result. +definingDeclsNames pns ds _incTypeSig recursive = concatMap defining ds + where + defining decl + = if recursive + then SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl + else defines' decl + where + defines' :: (GHC.LHsBind GHC.Name) -> [GHC.LHsBind GHC.Name] + defines' decl'@(GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) + |isJust (find (==(pname)) pns) = [decl'] + + defines' decl'@(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) + |(hsNamess p) `intersect` pns /= [] = [decl'] + + defines' _ = [] + +-- |Find those declarations(function\/pattern binding) which define +-- the specified GHC.Names. incTypeSig indicates whether the +-- corresponding type signature will be included. +definingDeclsNames':: (SYB.Data t) + => [GHC.Name] -- ^ The specified identifiers. + -> t -- ^ A collection of declarations. + ->[GHC.LHsBind GHC.Name] -- ^ The result. +definingDeclsNames' pns t = defining t + where + defining decl + = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl + where + defines' :: (GHC.LHsBind GHC.Name) -> [GHC.LHsBind GHC.Name] + defines' decl'@(GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) + |isJust (find (==(pname)) pns) = [decl'] + + defines' decl'@(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) + |(hsNamess p) `intersect` pns /= [] = [decl'] + + defines' _ = [] + +-- --------------------------------------------------------------------- + +-- |Find those type signatures for the specified GHC.Names. +definingSigsNames :: (SYB.Data t) => + [GHC.Name] -- ^ The specified identifiers. + ->t -- ^ A collection of declarations. + ->[GHC.LSig GHC.Name] -- ^ The result. +definingSigsNames pns ds = def ds + where + def decl + = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inSig) decl + where + inSig :: (GHC.LSig GHC.Name) -> [GHC.LSig GHC.Name] + inSig (GHC.L l (GHC.TypeSig ns t p)) + | defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t p))] + inSig _ = [] + + defines' (p::[GHC.Located GHC.Name]) + = filter (\(GHC.L _ n) -> n `elem` pns) p + +-- --------------------------------------------------------------------- + +-- |Find those type signatures for the specified GHC.Names. +definingSigsRdrNames :: (SYB.Data t) => + NameMap + ->[GHC.Name] -- ^ The specified identifiers. + ->t -- ^ A collection of declarations. + ->[GHC.LSig GHC.RdrName] -- ^ The result. +definingSigsRdrNames nameMap pns ds = def ds + where + def decl + -- = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inSig) decl + = SYB.everything (++) ([] `SYB.mkQ` inSig `SYB.extQ` inSigDecl) decl + where + inSigDecl :: GHC.LHsDecl GHC.RdrName -> [GHC.LSig GHC.RdrName] + inSigDecl (GHC.L l (GHC.SigD s)) = inSig (GHC.L l s) + inSigDecl _ = [] + + inSig :: (GHC.LSig GHC.RdrName) -> [GHC.LSig GHC.RdrName] + inSig (GHC.L l (GHC.TypeSig ns t p)) + | defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t p))] + inSig _ = [] + + defines' :: [GHC.Located GHC.RdrName] -> [GHC.Located GHC.RdrName] + defines' p + -- = filter (\(GHC.L _ n) -> n `elem` pns) p + = let + isDefined :: GHC.Located GHC.RdrName -> [GHC.Located GHC.RdrName] + isDefined ln = if (rdrName2NamePure nameMap ln) `elem` pns + then [ln] + else [] + in concatMap isDefined p + +-- --------------------------------------------------------------------- + +-- |Find those declarations which define the specified GHC.Names. +definingTyClDeclsNames:: (SYB.Data t) + => [GHC.Name] -- ^ The specified identifiers. + -> t -- ^ A collection of declarations. + ->[GHC.LTyClDecl GHC.Name] -- ^ The result. +definingTyClDeclsNames pns t = defining t + where + defining decl + = SYB.everythingStaged SYB.Renamer (++) [] + ([] `SYB.mkQ` defines') decl + where + defines' :: (GHC.LTyClDecl GHC.Name) -> [GHC.LTyClDecl GHC.Name] + defines' decl'@(GHC.L _ (GHC.FamDecl (GHC.FamilyDecl _ (GHC.L _ pname) _ _))) + |isJust (find (==(pname)) pns) = [decl'] + | otherwise = [] + + defines' decl'@(GHC.L _ (GHC.SynDecl (GHC.L _ pname) _ _ _)) + |isJust (find (==(pname)) pns) = [decl'] + | otherwise = [] + + defines' decl'@(GHC.L _ (GHC.DataDecl (GHC.L _ pname) _ _ _)) + |isJust (find (==(pname)) pns) = [decl'] + | otherwise = [] + + defines' decl'@(GHC.L _ (GHC.ClassDecl _ (GHC.L _ pname) _ _ _ _ _ _ _ _)) + |isJust (find (==(pname)) pns) = [decl'] + | otherwise = [] + +-- --------------------------------------------------------------------- + +-- | Return True if the function\/pattern binding defines the +-- specified identifier. +defines:: GHC.Name -> GHC.LHsBind GHC.Name -> Bool +defines n (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) + = GHC.nameUnique pname == GHC.nameUnique n +defines n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) + = elem (GHC.nameUnique n) (map GHC.nameUnique $ hsNamess p) +defines _ _= False + +-- | Return True if the function\/pattern binding defines the +-- specified identifier. +definesRdr :: NameMap -> GHC.Name -> GHC.LHsBind GHC.RdrName -> Bool +definesRdr nameMap nin (GHC.L _ (GHC.FunBind (GHC.L ln _pname) _ _ _ _ _)) = + case Map.lookup ln nameMap of + Nothing -> False + Just n -> GHC.nameUnique n == GHC.nameUnique nin +definesRdr nameMap n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = + elem n (map (rdrName2NamePure nameMap) (hsNamessRdr p)) +definesRdr _ _ _= False + +-- |Unwraps a LHsDecl and calls definesRdr on the result if a HsBind +definesDeclRdr :: NameMap -> GHC.Name -> GHC.LHsDecl GHC.RdrName -> Bool +definesDeclRdr nameMap nin (GHC.L l (GHC.ValD d)) = definesRdr nameMap nin (GHC.L l d) +definesDeclRdr _ _ _ = False + + +definesP::PName -> HsDeclP ->Bool +definesP pn (GHC.L _ (GHC.ValD (GHC.FunBind (GHC.L _ pname) _ _ _ _ _))) + = PN pname == pn +definesP pn (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) + = elem pn (hsPNs p) +definesP _ _= False + +-- --------------------------------------------------------------------- + +-- | Return True if the declaration defines the type signature of the +-- specified identifier. +definesTypeSig :: GHC.Name -> GHC.LSig GHC.Name -> Bool +definesTypeSig pn (GHC.L _ (GHC.TypeSig names _typ _)) = elem (GHC.nameUnique pn) $ map (\(GHC.L _ n)->GHC.nameUnique n) names +definesTypeSig _ _ = False + +-- | Return True if the declaration defines the type signature of the +-- specified identifier. +definesTypeSigRdr :: NameMap -> GHC.Name -> GHC.Sig GHC.RdrName -> Bool +definesTypeSigRdr nameMap pn (GHC.TypeSig names _typ _) + = elem (GHC.nameUnique pn) (map (GHC.nameUnique . rdrName2NamePure nameMap) names) +-- definesTypeSigRdr _ _ _ = False +definesTypeSigRdr _ _ x = error $ "definesTypeSigRdr : got " ++ SYB.showData SYB.Parser 0 x + +-- |Unwraps a LHsDecl and calls definesRdr on the result if a Sig +definesSigDRdr :: NameMap -> GHC.Name -> GHC.LHsDecl GHC.RdrName -> Bool +definesSigDRdr nameMap nin (GHC.L _ (GHC.SigD d)) = definesTypeSigRdr nameMap nin d +definesSigDRdr _ _ _ = False + +-- --------------------------------------------------------------------- + +-- |Find all Located Names in the given Syntax phrase. +allNames::(SYB.Data t) + =>t -- ^ The syntax phrase + ->[GHC.Located GHC.Name] -- ^ The result +allNames t + = res + where + res = SYB.everythingStaged SYB.Parser (++) [] + ([] `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t + + worker (pnt :: (GHC.Located GHC.Name)) + = [pnt] + -- worker _ = [] + + workerBind (GHC.L l (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name))) + = [(GHC.L l name)] + workerBind _ = [] + + workerExpr ((GHC.L l (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name))) + = [(GHC.L l name)] + workerExpr _ = [] + + + +-- --------------------------------------------------------------------- + +-- |Get all the names in the given syntax element +hsNamess :: (SYB.Data t) => t -> [GHC.Name] +hsNamess t = nub $ concat res + where + res = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inName) t + + inName (pname :: GHC.Name) = return [pname] + +-- |Get all the names in the given syntax element +hsNamessRdr :: (SYB.Data t) => t -> [GHC.Located GHC.RdrName] +hsNamessRdr t = nub $ fromMaybe [] r + where + r = (SYB.everythingStaged SYB.Parser mappend mempty (inName) t) + + checker :: GHC.Located GHC.RdrName -> Maybe [GHC.Located GHC.RdrName] + checker x = Just [x] + + inName :: (SYB.Typeable a) => a -> Maybe [GHC.Located GHC.RdrName] + inName = nameSybQuery checker + +-- --------------------------------------------------------------------- + + +getDeclaredVarsRdr :: NameMap -> [GHC.LHsDecl GHC.RdrName] -> [GHC.Name] +getDeclaredVarsRdr nm bs = concatMap vars bs + where + vars :: (GHC.LHsDecl GHC.RdrName) -> [GHC.Name] + vars (GHC.L _ (GHC.ValD (GHC.FunBind ln _ _ _ _fvs _))) = [rdrName2NamePure nm ln] + vars (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) = (hsNamess p) + vars _ = [] + +getDeclaredVars :: [GHC.LHsBind GHC.Name] -> [GHC.Name] +getDeclaredVars bs = concatMap vars bs + where + vars :: (GHC.LHsBind GHC.Name) -> [GHC.Name] + vars (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _fvs _)) = [pname] + vars (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = (hsNamess p) + vars _ = [] + +-- --------------------------------------------------------------------- +-- |Experiment with GHC fvs stuff +getFvs :: [GHC.LHsBind GHC.Name] -> [([GHC.Name], GHC.NameSet)] +getFvs bs = concatMap binds bs + where + binds :: (GHC.LHsBind GHC.Name) -> [([GHC.Name],GHC.NameSet)] + binds (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ fvs _)) = [([pname], fvs)] + binds (GHC.L _ (GHC.PatBind p _rhs _ty fvs _)) = [((hsNamess p),fvs)] + binds _ = [] + +getFreeVars :: [GHC.LHsBind GHC.Name] -> [GHC.Name] +getFreeVars bs = concatMap binds bs + where + binds :: (GHC.LHsBind GHC.Name) -> [GHC.Name] + binds (GHC.L _ (GHC.FunBind (GHC.L _ _pname) _ _ _ fvs _)) = (GHC.nameSetElems fvs) + binds (GHC.L _ (GHC.PatBind _p _rhs _ty fvs _)) = (GHC.nameSetElems fvs) + binds _ = [] + +------------------------------------------------------------------------ + +-- | Given syntax phrases e and t, if e occurs in t, then return those +-- variables which are declared in t and accessible to e, otherwise +-- return []. +hsVisiblePNs :: (FindEntity e,HsValBinds t GHC.Name,GHC.Outputable e) + => e -> t -> RefactGhc [GHC.Name] +hsVisiblePNs e t = do + (DN d) <- hsVisibleDs e t + return d + +-------------------------------------------------------------------------------- +-- | Same as `hsVisiblePNs' except that the returned identifiers are +-- in String format. +hsVisibleNames:: (FindEntity t1,HsValBinds t2 GHC.Name,GHC.Outputable t1) + => t1 -> t2 -> RefactGhc [String] +hsVisibleNames e t = do + d <- hsVisiblePNs e t + return ((nub . map showGhc) d) + +-------------------------------------------------------------------------------- +-- | Same as `hsVisiblePNs' except that the returned identifiers are +-- in String format. +hsVisibleNamesRdr:: (FindEntity t1,SYB.Data t2,GHC.Outputable t1) + => t1 -> t2 -> RefactGhc [String] +hsVisibleNamesRdr e t = do + nm <- getRefactNameMap + d <- hsVisiblePNsRdr nm e t + return ((nub . map showGhc) d) + +------------------------------------------------------------------------ + +-- | Given syntax phrases e and t, if e occurs in t, then return those +-- variables which are declared in t and accessible to e, otherwise +-- return []. +hsVisiblePNsRdr :: (FindEntity e,SYB.Data t,GHC.Outputable e) + => NameMap -> e -> t -> RefactGhc [GHC.Name] +hsVisiblePNsRdr nm e t = do + (DN d) <- hsVisibleDsRdr nm e t + return d + +------------------------------------------------------------------------ + +-- | Given syntax phrases e and t, if e occurs in t, then return those +-- variables which are declared in t and accessible to e, otherwise +-- return []. +hsVisibleDsRdr :: (FindEntity e, GHC.Outputable e,SYB.Data t) + => NameMap -> e -> t -> RefactGhc DeclaredNames +hsVisibleDsRdr nm e t = do + -- logm $ "hsVisibleDsRdr:(e,t)=" ++ (SYB.showData SYB.Renamer 0 (e,t)) + (DN d) <- res + return (DN (nub d)) + where + -- TODO: this is effectively a recursive descent approach, where + -- each syntax element processor knows exactly what it needs + -- in terms of sub-elements. Hence as an optimisation, + -- consider calling the relevent element directly, instead + -- of looping back into the main function. + res = (const err -- (DN []) + `SYB.extQ` parsed + `SYB.extQ` valbinds + `SYB.extQ` lhsdecls + `SYB.extQ` lhsdecl + `SYB.extQ` lhsbindslr + `SYB.extQ` hsbinds + `SYB.extQ` hsbind + `SYB.extQ` hslocalbinds + `SYB.extQ` lmatch + `SYB.extQ` grhss + `SYB.extQ` lgrhs + `SYB.extQ` lexpr + `SYB.extQ` tyclgroups + `SYB.extQ` tyclgroup + `SYB.extQ` tycldeclss + `SYB.extQ` tycldecls + `SYB.extQ` tycldecl + `SYB.extQ` instdecls + `SYB.extQ` instdecl + `SYB.extQ` lhstype + `SYB.extQ` lsigs + `SYB.extQ` lsig + ) t + + -- err2 = error $ "hsVisibleDsRdr:err2:no match for:" ++ (SYB.showData SYB.Renamer 0 t) + + parsed :: GHC.ParsedSource -> RefactGhc DeclaredNames + parsed p + | findEntity e p = do + -- dfds <- mapM (hsVisibleDsRdr nm e) $ GHC.hsmodDecls $ GHC.unLoc p + logm $ "hsVisibleDsRdr parsedSource:decls starting" + dfds <- mapM (declFun ( hsVisibleDsRdr nm e) ) $ GHC.hsmodDecls $ GHC.unLoc p + logm $ "hsVisibleDsRdr parsedSource:decls done" + return $ mconcat dfds + parsed _ = return (DN []) + + valbinds :: (GHC.HsValBindsLR GHC.RdrName GHC.RdrName) -> RefactGhc DeclaredNames + valbinds vb@(GHC.ValBindsIn bindsBag sigs) + | findEntity e vb = do + fdsb <- mapM (hsVisibleDsRdr nm e) $ hsBinds bindsBag + fdss <- mapM (hsVisibleDsRdr nm e) sigs + return $ mconcat fdss <> mconcat fdsb + valbinds vb@(GHC.ValBindsOut _binds _sigs) + | findEntity e vb = do + logm $ "hsVisibleDsRdr valbinds:ValBindsOut:impossible for RdrName" + return (DN []) + + valbinds _ = do + logm $ "hsVisibleDsRdr nm.valbinds:not matched" + return (DN []) + + lhsdecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc DeclaredNames + lhsdecls ds + | findEntity e ds = do + dfds <- mapM (declFun ( hsVisibleDsRdr nm e) ) ds + return $ mconcat dfds + lhsdecls _ = return (DN []) + + lhsdecl :: GHC.LHsDecl GHC.RdrName -> RefactGhc DeclaredNames + lhsdecl (GHC.L l dd) = do + logm $ "hsVisibleDsRdr.lhsdecl" + case dd of + GHC.TyClD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.InstD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.DerivD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.ValD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.SigD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.DefD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.ForD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.WarningD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.AnnD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.RuleD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.VectD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.SpliceD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.DocD d -> hsVisibleDsRdr nm e (GHC.L l d) + GHC.RoleAnnotD d -> hsVisibleDsRdr nm e (GHC.L l d) +#if __GLASGOW_HASKELL__ < 711 + GHC.QuasiQuoteD d -> hsVisibleDsRdr nm e (GHC.L l d) +#endif + + lhsbindslr :: GHC.LHsBindsLR GHC.RdrName GHC.RdrName -> RefactGhc DeclaredNames + lhsbindslr bs = do + fds <- mapM (hsVisibleDsRdr nm e) $ GHC.bagToList bs + return $ mconcat fds + + hsbinds :: [GHC.LHsBind GHC.RdrName] -> RefactGhc DeclaredNames + hsbinds ds + | findEntity e ds = do + fds <- mapM (hsVisibleDsRdr nm e) ds + return $ mconcat fds + hsbinds _ = return (DN []) + + hsbind :: (GHC.LHsBind GHC.RdrName) -> RefactGhc DeclaredNames + hsbind ((GHC.L _ (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _))) + | findEntity e matches = do + fds <- mapM (hsVisibleDsRdr nm e) matches + logm $ "hsVisibleDsRdr.hsbind:fds=" ++ show fds + return $ mconcat fds + hsbind _ = do + logm $ "hsVisibleDsRdr.hsbind:miss" + return (DN []) + + hslocalbinds :: (GHC.HsLocalBinds GHC.RdrName) -> RefactGhc DeclaredNames + hslocalbinds (GHC.HsValBinds binds) + | findEntity e binds = hsVisibleDsRdr nm e binds + hslocalbinds (GHC.HsIPBinds binds) + | findEntity e binds = hsVisibleDsRdr nm e binds + hslocalbinds (GHC.EmptyLocalBinds) = return (DN []) + hslocalbinds _ = return (DN []) + + lmatch :: (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames + lmatch (GHC.L _ (GHC.Match _fn pats _mtyp rhs)) + | findEntity e pats = do + logm $ "hsVisibleDsRdr nm.lmatch:in pats=" + return (DN []) -- TODO: extend this + | findEntity e rhs = do + logm $ "hsVisibleDsRdr nm.lmatch:doing rhs" + let (pf,pd) = hsFreeAndDeclaredRdr nm pats + logm $ "hsVisibleDsRdr nm.lmatch:(pf,pd)=" ++ (show (pf,pd)) + ( rd) <- hsVisibleDsRdr nm e rhs + return (pd <> rd) + lmatch _ =return (DN []) + + grhss :: (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames + grhss (GHC.GRHSs guardedRhss lstmts) + | findEntity e guardedRhss = do + logm "hsVisibleDsRdr nm.grhss:about to do grhss" + fds <- mapM (hsVisibleDsRdr nm e) guardedRhss + logm "hsVisibleDsRdr nm.grhss:grhss done" + return $ mconcat fds + | findEntity e lstmts = do + logm "hsVisibleDsRdr nm.grhss:about to do lstmts" + hsVisibleDsRdr nm e lstmts + grhss _ = return (DN []) + + lgrhs :: GHC.LGRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc DeclaredNames + lgrhs (GHC.L _ (GHC.GRHS guards ex)) + | findEntity e guards = logm "hsVisibleDsRdr nm.lgrhs.guards" >> hsVisibleDsRdr nm e guards + | findEntity e ex = logm "hsVisibleDsRdr nm.lgrhs.ex" >> hsVisibleDsRdr nm e ex + lgrhs _ = return (DN []) + + + lexpr :: GHC.LHsExpr GHC.RdrName -> RefactGhc DeclaredNames + lexpr (GHC.L l (GHC.HsVar n)) + | findEntity e n = do + logm $ "hsVisibleDsRdr.lexpr.HsVar entity found" + return (DN [rdrName2NamePure nm (GHC.L l n)]) + lexpr (GHC.L _ (GHC.HsLet lbinds expr)) + | findEntity e lbinds || findEntity e expr = do + logm $ "hsVisibleDsRdr.lexpr.HsLet entity found" + let (_,lds) = hsFreeAndDeclaredRdr nm lbinds + let (_,eds) = hsFreeAndDeclaredRdr nm expr + return $ lds <> eds + + lexpr expr + | findEntity e expr = do + logm $ "hsVisibleDsRdr nm.lexpr.(e,expr):" ++ (showGhc (e,expr)) + let (FN efs,_) = hsFreeAndDeclaredRdr nm expr + let (FN _eefs,DN eeds) = hsFreeAndDeclaredRdr nm e + logm $ "hsVisibleDsRdr nm.lexpr done" + -- return (DN e1fs <> DN eofs <> DN e2fs) + return (DN (efs \\ eeds)) + + lexpr x = do + logm $ "hsVisibleDsRdr.lexpr:miss for:" ++ SYB.showData SYB.Parser 0 x + return (DN []) + + -- --------------------------------- + + tyclgroups :: [GHC.TyClGroup GHC.RdrName] -> RefactGhc DeclaredNames + tyclgroups tgrps + | findEntity e tgrps = do + fds <- mapM (hsVisibleDsRdr nm e) tgrps + return $ mconcat fds + tyclgroups _ = return (DN []) + + tyclgroup :: GHC.TyClGroup GHC.RdrName -> RefactGhc DeclaredNames + tyclgroup (GHC.TyClGroup tyclds _roles) + | findEntity e tyclds = do + fds <- mapM (hsVisibleDsRdr nm e) tyclds + return $ mconcat fds + tyclgroup _ = return (DN []) + + tycldeclss :: [[GHC.LTyClDecl GHC.RdrName]] -> RefactGhc DeclaredNames + tycldeclss tcds + | findEntity e tcds = do + fds <- mapM (hsVisibleDsRdr nm e) tcds + return $ mconcat fds + tycldeclss _ = return (DN []) + + tycldecls :: [GHC.LTyClDecl GHC.RdrName] -> RefactGhc DeclaredNames + tycldecls tcds + | findEntity e tcds = do + logm $ "hsVisibleDsRdr.tycldecls" + fds <- mapM (hsVisibleDsRdr nm e) tcds + logm $ "hsVisibleDsRdr.tycldecls done" + return $ mconcat fds + tycldecls _ = return (DN []) + + tycldecl :: GHC.LTyClDecl GHC.RdrName -> RefactGhc DeclaredNames + tycldecl tcd + | findEntity e tcd = do + logm $ "hsVisibleDsRdr.tycldecl" + let (_,ds) = hsFreeAndDeclaredRdr nm tcd + logm $ "hsVisibleDsRdr.tycldecl done" + return ds + tycldecl _ = return (DN []) + + -- --------------------------------- + + instdecls :: [GHC.LInstDecl GHC.RdrName] -> RefactGhc DeclaredNames + instdecls ds + | findEntity e ds = do + fds <- mapM (hsVisibleDsRdr nm e) ds + return $ mconcat fds + instdecls _ = return (DN []) + + instdecl :: GHC.LInstDecl GHC.RdrName -> RefactGhc DeclaredNames + instdecl (GHC.L _ (GHC.ClsInstD (GHC.ClsInstDecl polytyp binds sigs tyfaminsts dfaminsts _))) + | findEntity e polytyp = hsVisibleDsRdr nm e polytyp + | findEntity e binds = hsVisibleDsRdr nm e binds + | findEntity e sigs = hsVisibleDsRdr nm e sigs + | findEntity e tyfaminsts = hsVisibleDsRdr nm e tyfaminsts + | findEntity e dfaminsts = hsVisibleDsRdr nm e dfaminsts + | otherwise = return (DN []) + instdecl (GHC.L _ (GHC.DataFamInstD (GHC.DataFamInstDecl _ln pats defn _))) + | findEntity e pats = hsVisibleDsRdr nm e pats + | findEntity e defn = hsVisibleDsRdr nm e defn + | otherwise = return (DN []) + instdecl (GHC.L _ (GHC.TyFamInstD (GHC.TyFamInstDecl eqn _))) + | findEntity e eqn = hsVisibleDsRdr nm e eqn + | otherwise = return (DN []) + + lhstype :: GHC.LHsType GHC.RdrName -> RefactGhc DeclaredNames + lhstype tv@(GHC.L l (GHC.HsTyVar n)) + | findEntity e tv = return (DN [rdrName2NamePure nm (GHC.L l n)]) + | otherwise = return (DN []) + lhstype (GHC.L _ (GHC.HsForAllTy _ _ _bndrs _ctxt _typ)) + = return (DN []) + lhstype (GHC.L _ (GHC.HsFunTy{})) = return (DN []) + lhstype ty = do + logm $ "lshtype: TypeUtils 1588" ++ SYB.showData SYB.Renamer 0 ty + return (DN []) + + -- ----------------------- + + lsigs :: [GHC.LSig GHC.RdrName] -> RefactGhc DeclaredNames + lsigs ss = do + fds <- mapM (hsVisibleDsRdr nm e) ss + return $ mconcat fds + + -- ----------------------- + + lsig :: GHC.LSig GHC.RdrName -> RefactGhc DeclaredNames + lsig (GHC.L _ (GHC.TypeSig _ns typ _)) + | findEntity e typ = hsVisibleDsRdr nm e typ + lsig (GHC.L _ (GHC.GenericSig _n typ)) + | findEntity e typ = hsVisibleDsRdr nm e typ + lsig (GHC.L _ (GHC.IdSig _)) = return (DN []) + lsig (GHC.L _ (GHC.InlineSig _ _)) = return (DN []) + lsig (GHC.L _ (GHC.SpecSig _n typ _)) + | findEntity e typ = hsVisibleDsRdr nm e typ + lsig (GHC.L _ (GHC.SpecInstSig _ _)) = return (DN []) + + lsig _ = return (DN []) + + -- ----------------------- + + err = error $ "hsVisibleDsRdr nm:no match for:" ++ (SYB.showData SYB.Renamer 0 t) + + +------------------------------------------------------------------------ + +-- | Given syntax phrases e and t, if e occurs in t, then return those +-- variables which are declared in t and accessible to e, otherwise +-- return []. +hsVisibleDs :: (FindEntity e, GHC.Outputable e + ,SYB.Data t,HsValBinds t GHC.Name) + => e -> t -> RefactGhc DeclaredNames +hsVisibleDs e t = do + -- logm $ "hsVisibleDs:(e,t)=" ++ (SYB.showData SYB.Renamer 0 (e,t)) + (DN d) <- res + return (DN (nub d)) + where + -- TODO: this is effectively a recursive descent approach, where + -- each syntax element processor knows exactly what it needs + -- in terms of sub-elements. Hence as an optimisation, + -- consider calling the relevent element directly, instead + -- of looping back into the main function. + res = (const err -- (DN []) + `SYB.extQ` renamed + `SYB.extQ` valbinds + `SYB.extQ` lhsbindslr + `SYB.extQ` hsbinds + `SYB.extQ` hsbind + `SYB.extQ` hslocalbinds + `SYB.extQ` lmatch + `SYB.extQ` grhss + `SYB.extQ` lgrhs + `SYB.extQ` lexpr + `SYB.extQ` tyclgroups + `SYB.extQ` tyclgroup + `SYB.extQ` tycldeclss + `SYB.extQ` tycldecls + `SYB.extQ` tycldecl + `SYB.extQ` instdecls + `SYB.extQ` instdecl + `SYB.extQ` lhstype + `SYB.extQ` lsigs + `SYB.extQ` lsig + ) t + + renamed :: GHC.RenamedSource -> RefactGhc DeclaredNames + renamed (g,_i,_ex,_d) + | findEntity e g = do + dfds <- hsVisibleDs e $ GHC.hs_valds g + -- logm $ "hsVisibleDs.renamedSource:valds done" + tfds <- hsVisibleDs e $ GHC.hs_tyclds g + -- logm $ "hsVisibleDs.renamedSource:tyclds done" + ifds <- hsVisibleDs e $ GHC.hs_instds g + -- logm $ "hsVisibleDs.renamedSource:instds done" + return $ dfds <> tfds <> ifds + renamed _ = return (DN []) + + valbinds :: (GHC.HsValBindsLR GHC.Name GHC.Name) -> RefactGhc DeclaredNames + valbinds vb@(GHC.ValBindsIn bindsBag sigs) + | findEntity e vb = do + fdsb <- mapM (hsVisibleDs e) $ hsBinds bindsBag + fdss <- mapM (hsVisibleDs e) sigs + return $ mconcat fdss <> mconcat fdsb + valbinds vb@(GHC.ValBindsOut binds sigs) + | findEntity e vb = do + -- logm $ "hsVisibleDs.valbinds:ValBindsOut" + fdsb <- mapM (hsVisibleDs e) $ map snd binds + fdss <- mapM (hsVisibleDs e) sigs + return $ mconcat fdss <> mconcat fdsb + + valbinds _ = do + -- logm $ "hsVisibleDs.valbinds:not matched" + return (DN []) + + lhsbindslr :: GHC.LHsBindsLR GHC.Name GHC.Name -> RefactGhc DeclaredNames + lhsbindslr bs = do + fds <- mapM (hsVisibleDs e) $ GHC.bagToList bs + return $ mconcat fds + + hsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc DeclaredNames + hsbinds ds + | findEntity e ds = do + fds <- mapM (hsVisibleDs e) ds + return $ mconcat fds + hsbinds _ = return (DN []) + + hsbind :: (GHC.LHsBind GHC.Name) -> RefactGhc DeclaredNames + hsbind ((GHC.L _ (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _))) + | findEntity e matches = do + fds <- mapM (hsVisibleDs e) matches + -- logm $ "hsVisibleDs.hsbind:fds=" ++ show fds + return $ mconcat fds + hsbind _ = return (DN []) + + hslocalbinds :: (GHC.HsLocalBinds GHC.Name) -> RefactGhc DeclaredNames + hslocalbinds (GHC.HsValBinds binds) + | findEntity e binds = hsVisibleDs e binds + hslocalbinds (GHC.HsIPBinds binds) + | findEntity e binds = hsVisibleDs e binds + hslocalbinds (GHC.EmptyLocalBinds) = return (DN []) + hslocalbinds _ = return (DN []) + + lmatch :: (GHC.LMatch GHC.Name (GHC.LHsExpr GHC.Name)) -> RefactGhc DeclaredNames + lmatch (GHC.L _ (GHC.Match _fn pats _mtyp rhs)) + | findEntity e pats = do + -- logm $ "hsVisibleDs.lmatch:in pats=" + return (DN []) -- TODO: extend this + | findEntity e rhs = do + -- logm $ "hsVisibleDs.lmatch:doing rhs" + (_pf,pd) <- hsFreeAndDeclaredGhc pats + -- logm $ "hsVisibleDs.lmatch:(pf,pd)=" ++ (show (pf,pd)) + ( rd) <- hsVisibleDs e rhs + return (pd <> rd) + lmatch _ =return (DN []) + + grhss :: (GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name)) -> RefactGhc DeclaredNames + grhss (GHC.GRHSs guardedRhss lstmts) + | findEntity e guardedRhss = do + -- logm "hsVisibleDs.grhss:about to do grhss" + fds <- mapM (hsVisibleDs e) guardedRhss + -- logm "hsVisibleDs.grhss:grhss done" + return $ mconcat fds + | findEntity e lstmts = do + -- logm "hsVisibleDs.grhss:about to do lstmts" + hsVisibleDs e lstmts + grhss _ = return (DN []) + + lgrhs :: GHC.LGRHS GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc DeclaredNames + lgrhs (GHC.L _ (GHC.GRHS guards ex)) + | findEntity e guards = hsVisibleDs e guards + | findEntity e ex = hsVisibleDs e ex + lgrhs _ = return (DN []) + + + lexpr :: GHC.LHsExpr GHC.Name -> RefactGhc DeclaredNames + lexpr (GHC.L _ (GHC.HsVar n)) + | findEntity e n = return (DN [n]) + lexpr (GHC.L _ (GHC.HsLet lbinds expr)) + | findEntity e lbinds || findEntity e expr = do + (_,lds) <- hsFreeAndDeclaredGhc lbinds + (_,eds) <- hsFreeAndDeclaredGhc expr + return $ lds <> eds + + lexpr expr + | findEntity e expr = do + -- logm $ "hsVisibleDs.lexpr.(e,expr):" ++ (showGhc (e,expr)) + (FN efs,_) <- hsFreeAndDeclaredGhc expr + (FN _eefs,DN eeds) <- hsFreeAndDeclaredGhc e + -- logm $ "hsVisibleDs.lexpr done" + -- return (DN e1fs <> DN eofs <> DN e2fs) + return (DN (efs \\ eeds)) + + lexpr _ = return (DN []) + + -- --------------------------------- + + tyclgroups :: [GHC.TyClGroup GHC.Name] -> RefactGhc DeclaredNames + tyclgroups tgrps + | findEntity e tgrps = do + fds <- mapM (hsVisibleDs e) tgrps + return $ mconcat fds + tyclgroups _ = return (DN []) + + tyclgroup :: GHC.TyClGroup GHC.Name -> RefactGhc DeclaredNames + tyclgroup (GHC.TyClGroup tyclds _roles) + | findEntity e tyclds = do + fds <- mapM (hsVisibleDs e) tyclds + return $ mconcat fds + tyclgroup _ = return (DN []) + + tycldeclss :: [[GHC.LTyClDecl GHC.Name]] -> RefactGhc DeclaredNames + tycldeclss tcds + | findEntity e tcds = do + fds <- mapM (hsVisibleDs e) tcds + return $ mconcat fds + tycldeclss _ = return (DN []) + + tycldecls :: [GHC.LTyClDecl GHC.Name] -> RefactGhc DeclaredNames + tycldecls tcds + | findEntity e tcds = do + -- logm $ "hsVisibleDs.tycldecls" + fds <- mapM (hsVisibleDs e) tcds + return $ mconcat fds + tycldecls _ = return (DN []) + + tycldecl :: GHC.LTyClDecl GHC.Name -> RefactGhc DeclaredNames + tycldecl tcd + | findEntity e tcd = do + -- logm $ "hsVisibleDs.tycldecl" + (_,ds) <- hsFreeAndDeclaredGhc tcd + return ds + tycldecl _ = return (DN []) + + -- --------------------------------- + + instdecls :: [GHC.LInstDecl GHC.Name] -> RefactGhc DeclaredNames + instdecls ds + | findEntity e ds = do + fds <- mapM (hsVisibleDs e) ds + return $ mconcat fds + instdecls _ = return (DN []) + + instdecl :: GHC.LInstDecl GHC.Name -> RefactGhc DeclaredNames + instdecl (GHC.L _ (GHC.ClsInstD (GHC.ClsInstDecl polytyp binds sigs tyfaminsts dfaminsts _))) + | findEntity e polytyp = hsVisibleDs e polytyp + | findEntity e binds = hsVisibleDs e binds + | findEntity e sigs = hsVisibleDs e sigs + | findEntity e tyfaminsts = hsVisibleDs e tyfaminsts + | findEntity e dfaminsts = hsVisibleDs e dfaminsts + | otherwise = return (DN []) + instdecl (GHC.L _ (GHC.DataFamInstD (GHC.DataFamInstDecl _ln pats defn _))) + | findEntity e pats = hsVisibleDs e pats + | findEntity e defn = hsVisibleDs e defn + | otherwise = return (DN []) + instdecl (GHC.L _ (GHC.TyFamInstD (GHC.TyFamInstDecl eqn _))) + | findEntity e eqn = hsVisibleDs e eqn + | otherwise = return (DN []) + + lhstype :: GHC.LHsType GHC.Name -> RefactGhc DeclaredNames + lhstype tv@(GHC.L _ (GHC.HsTyVar n)) + | findEntity e tv = return (DN [n]) + | otherwise = return (DN []) + lhstype (GHC.L _ (GHC.HsForAllTy _ _ _bndrs _ctxt _typ)) + = return (DN []) + lhstype (GHC.L _ (GHC.HsFunTy{})) = return (DN []) + lhstype _ty = do + -- logm $ "lshtype: TypeUtils 1588" ++ SYB.showData SYB.Renamer 0 _ty + return (DN []) + + -- ----------------------- + + lsigs :: [GHC.LSig GHC.Name] -> RefactGhc DeclaredNames + lsigs ss = do + fds <- mapM (hsVisibleDs e) ss + return $ mconcat fds + + -- ----------------------- + + lsig :: GHC.LSig GHC.Name -> RefactGhc DeclaredNames + lsig (GHC.L _ (GHC.TypeSig _ns typ _)) + | findEntity e typ = hsVisibleDs e typ + lsig (GHC.L _ (GHC.GenericSig _n typ)) + | findEntity e typ = hsVisibleDs e typ + lsig (GHC.L _ (GHC.IdSig _)) = return (DN []) + lsig (GHC.L _ (GHC.InlineSig _ _)) = return (DN []) + lsig (GHC.L _ (GHC.SpecSig _n typ _)) + | findEntity e typ = hsVisibleDs e typ + lsig (GHC.L _ (GHC.SpecInstSig _ _)) = return (DN []) + + lsig _ = return (DN []) + + -- ----------------------- + + err = error $ "hsVisibleDs:no match for:" ++ (SYB.showData SYB.Renamer 0 t) + +-- --------------------------------------------------------------------- + +-- |`hsFDsFromInsideRdr` is different from `hsFreeAndDeclaredPNs` in +-- that: given an syntax phrase t, `hsFDsFromInsideRdr` 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. +-- NOTE: Expects to be given RenamedSource +hsFDsFromInsideRdr:: (SYB.Data t) + => NameMap -> t -> RefactGhc (FreeNames,DeclaredNames) +hsFDsFromInsideRdr nm t = do + r <- hsFDsFromInsideRdr' t + return r + where + hsFDsFromInsideRdr' :: (SYB.Data t) => t -> RefactGhc (FreeNames,DeclaredNames) + hsFDsFromInsideRdr' t1 = do + r1 <- applyTU (once_tdTU (failTU `adhocTU` parsed + `adhocTU` decl + `adhocTU` match + `adhocTU` expr + `adhocTU` stmts )) t1 + -- let (f',d') = fromMaybe ([],[]) r1 + let (FN f',DN d') = r1 + return (FN $ nub f', DN $ nub d') + + parsed :: GHC.ParsedSource -> RefactGhc (FreeNames,DeclaredNames) + parsed p + = return $ hsFreeAndDeclaredRdr nm p + + -- Match [LPat id] (Maybe (LHsType id)) (GRHSs id) + match :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (FreeNames,DeclaredNames) + match (GHC.Match _fn pats _type rhs) = do + let (FN pf, DN pd) = hsFreeAndDeclaredRdr nm pats + let (FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs + return (FN $ nub (pf `union` (rf \\ pd)), + DN $ nub (pd `union` rd)) + + -- ---------------------- + + decl :: GHC.HsBind GHC.RdrName -> RefactGhc (FreeNames,DeclaredNames) + decl (GHC.FunBind (GHC.L _ _) _ (GHC.MG matches _ _ _) _ _ _) = + do + fds <- mapM hsFDsFromInsideRdr' matches + -- error (show $ nameToString n) + return (FN $ nub (concat $ map (fn . fst) fds), DN $ nub (concat $ map (dn . snd) fds)) + + decl ((GHC.PatBind p rhs _ _ _) :: GHC.HsBind GHC.RdrName) = + do + let (FN pf, DN pd) = hsFreeAndDeclaredRdr nm p + let (FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs + return + (FN $ nub (pf `union` (rf \\ pd)), + DN $ nub (pd `union` rd)) + + decl ((GHC.VarBind p rhs _) :: GHC.HsBind GHC.RdrName) = + do + let (FN pf, DN pd) = hsFreeAndDeclaredRdr nm p + let (FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs + return + (FN $ nub (pf `union` (rf \\ pd)), + DN $ nub (pd `union` rd)) + + decl _ = return (FN [],DN []) + + -- ---------------------- + + expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.RdrName) = + do + let (FN df,DN dd) = hsFreeAndDeclaredRdr nm decls + let (FN ef,_) = hsFreeAndDeclaredRdr nm e + return (FN $ nub (df `union` (ef \\ dd)), DN $ nub dd) + + expr ((GHC.HsLam (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.RdrName) = + return $ hsFreeAndDeclaredRdr nm matches + + expr ((GHC.HsCase e (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.RdrName) = + do + let (FN ef,_) = hsFreeAndDeclaredRdr nm e + let (FN df,DN dd) = hsFreeAndDeclaredRdr nm matches + return (FN $ nub (df `union` (ef \\ dd)), DN $ nub dd) + + expr _ = mzero + + stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = + do + let (FN pf,DN pd) = hsFreeAndDeclaredRdr nm pat + let (FN ef,DN _ed) = hsFreeAndDeclaredRdr nm e1 + let (FN df,DN dd) = hsFreeAndDeclaredRdr nm [e2,e3] + return + (FN $ nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), DN $ nub (pd `union` dd)) + + stmts ((GHC.LetStmt binds) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = + return $ hsFreeAndDeclaredRdr nm binds + + stmts _ = mzero + + +-- --------------------------------------------------------------------- + +-- |`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. +-- NOTE: Expects to be given RenamedSource +hsFDsFromInside:: (SYB.Data t) => t-> RefactGhc ([GHC.Name],[GHC.Name]) +hsFDsFromInside t = do + r <- hsFDsFromInside' t + return r + where + hsFDsFromInside' :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name]) + hsFDsFromInside' t1 = do + r1 <- applyTU (once_tdTU (failTU `adhocTU` renamed + `adhocTU` decl + `adhocTU` match + `adhocTU` expr + `adhocTU` stmts )) t1 + -- let (f',d') = fromMaybe ([],[]) r1 + let (f',d') = r1 + return (nub f', nub d') + + renamed :: GHC.RenamedSource -> RefactGhc ([GHC.Name],[GHC.Name]) + renamed ((grp,_,_,_)::GHC.RenamedSource) + = hsFreeAndDeclaredPNs $ GHC.hs_valds grp + + -- Match [LPat id] (Maybe (LHsType id)) (GRHSs id) + match :: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc ([GHC.Name],[GHC.Name]) + match ((GHC.Match _fn pats _type rhs):: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) = do + (pf, pd) <- hsFreeAndDeclaredPNs pats + (rf, rd) <- hsFreeAndDeclaredPNs rhs + return (nub (pf `union` (rf \\ pd)), + nub (pd `union` rd)) + + -- ---------------------- + + decl :: GHC.HsBind GHC.Name -> RefactGhc ([GHC.Name],[GHC.Name]) + decl ((GHC.FunBind (GHC.L _ _) _ (GHC.MG matches _ _ _) _ _ _) :: GHC.HsBind GHC.Name) = + do + fds <- mapM hsFDsFromInside' matches + -- error (show $ nameToString n) + return (nub (concatMap fst fds), nub (concatMap snd fds)) + + decl ((GHC.PatBind p rhs _ _ _) :: GHC.HsBind GHC.Name) = + do + (pf, pd) <- hsFreeAndDeclaredPNs p + (rf, rd) <- hsFreeAndDeclaredPNs rhs + return + (nub (pf `union` (rf \\ pd)), + nub (pd `union` rd)) + + decl ((GHC.VarBind p rhs _) :: GHC.HsBind GHC.Name) = + do + (pf, pd) <- hsFreeAndDeclaredPNs p + (rf, rd) <- hsFreeAndDeclaredPNs rhs + return + (nub (pf `union` (rf \\ pd)), + nub (pd `union` rd)) + + decl _ = return ([],[]) + + -- ---------------------- + + expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.Name) = + do + (df,dd) <- hsFreeAndDeclaredPNs decls + (ef,_) <- hsFreeAndDeclaredPNs e + return (nub (df `union` (ef \\ dd)), nub dd) + + expr ((GHC.HsLam (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.Name) = + hsFreeAndDeclaredPNs matches + + expr ((GHC.HsCase e (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.Name) = + do + (ef,_) <- hsFreeAndDeclaredPNs e + (df,dd) <- hsFreeAndDeclaredPNs matches + return (nub (df `union` (ef \\ dd)), nub dd) + + -- expr _ = return ([],[]) + expr _ = mzero + + stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) = + do + (pf,pd) <- hsFreeAndDeclaredPNs pat + (ef,_ed) <- hsFreeAndDeclaredPNs e1 + (df,dd) <- hsFreeAndDeclaredPNs [e2,e3] + return + (nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), nub (pd `union` dd)) + + stmts ((GHC.LetStmt binds) :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) = + hsFreeAndDeclaredPNs binds + + -- stmts _ = return ([],[]) + stmts _ = mzero + + + +-- | The same as `hsFDsFromInside` except that the returned variables +-- are in the String format +hsFDNamesFromInside::(SYB.Data t) => t -> RefactGhc ([String],[String]) +hsFDNamesFromInside t = do + (f,d) <- hsFDsFromInside t + return + ((nub.map showGhc) f, (nub.map showGhc) d) + +-- | The same as `hsFDsFromInside` except that the returned variables +-- are in the String format +hsFDNamesFromInsideRdr ::(SYB.Data t) => t -> RefactGhc ([String],[String]) +hsFDNamesFromInsideRdr t = do + nm <- getRefactNameMap + (FN f,DN d) <- hsFDsFromInsideRdr nm t + return + ((nub.map showGhc) f, (nub.map showGhc) d) + +-- --------------------------------------------------------------------- + +rdrName2Name' :: GHC.Located GHC.RdrName -> RefactGhc GHC.Name +rdrName2Name' (GHC.L l rdr) = do + renamed <- getRefactRenamed + let mn = locToName (getGhcLoc l) renamed + return (GHC.unLoc $ gfromJust ("rdrName2Name':failed for:" ++ showGhc (GHC.L l rdr)) mn) + +-- --------------------------------------------------------------------- + +rdrName2Name :: GHC.Located GHC.RdrName -> RefactGhc GHC.Name +rdrName2Name ln = do + nameMap <- getRefactNameMap + return (rdrName2NamePure nameMap ln) + +rdrName2NamePure :: NameMap -> GHC.Located GHC.RdrName -> GHC.Name +rdrName2NamePure _nameMap (GHC.L _ (GHC.Exact n)) = n +rdrName2NamePure nameMap (GHC.L lrn _) = + fromMaybe (error $ "rdrName2NamePure: no name found for" ++ showGhc lrn) + -- fromMaybe (error $ "rdrName2NamePure: no name found for (lrn,e,nameMap)=" ++ showGhc (lrn,e,nameMap)) + (Map.lookup lrn nameMap) + +eqRdrNamePure :: NameMap -> GHC.Located GHC.RdrName -> GHC.Name -> Bool +eqRdrNamePure nameMap rn n + = GHC.nameUnique (rdrName2NamePure nameMap rn) == GHC.nameUnique n + +-- --------------------------------------------------------------------- + +-- |Find the identifier(in GHC.Name format) whose start position is +-- (row,col) in the file specified by the fileName, and returns +-- `Nothing` if such an identifier does not exist. +locToName::(SYB.Data t) + =>SimpPos -- ^ The row and column number + ->t -- ^ The syntax phrase + -> Maybe (GHC.Located GHC.Name) -- ^ The result +locToName (row,col) t = locToName' (row,col) t + +-- |Find the identifier(in GHC.RdrName format) whose start position is +-- (row,col) in the file specified by the fileName, and returns +-- `Nothing` if such an identifier does not exist. +locToRdrName::(SYB.Data t) + =>SimpPos -- ^ The row and column number + ->t -- ^ The syntax phrase + -> Maybe (GHC.Located GHC.RdrName) -- ^ The result +locToRdrName (row,col) t = locToName' (row,col) t + + +-- |Worker for both locToName and locToRdrName. +-- NOTE: provides for FunBind MatchGroups where only the first name is +-- retained in the AST + +locToName':: forall a t.(SYB.Data t, SYB.Data a, Eq a) + =>SimpPos -- ^ The row and column number + ->t -- ^ The syntax phrase + -> Maybe (GHC.Located a) -- ^ The result +locToName' (row,col) t = res1 + where + res1 :: Maybe (GHC.Located a) + res1 = SYB.something (nameSybQuery checker) t + + checker pnt = + if inScope pnt + then Just pnt + else Nothing + + -- ++AZ++:TODO: Is inScope actually required? + inScope :: GHC.Located e -> Bool + inScope (GHC.L l _) = + case l of + (GHC.UnhelpfulSpan _) -> False + (GHC.RealSrcSpan ss) -> + -- (GHC.srcSpanFile ss == fileName) && + (GHC.srcSpanStartLine ss <= row) && + (GHC.srcSpanEndLine ss >= row) && + (col >= (GHC.srcSpanStartCol ss)) && + (col <= (GHC.srcSpanEndCol ss)) + +-- --------------------------------------------------------------------- +{- +nameSybQuery :: (SYB.Typeable a, SYB.Typeable t) + => (GHC.Located a -> Maybe r) -> t -> Maybe r +nameSybQuery checker = q + where + q = Nothing `SYB.mkQ` worker + `SYB.extQ` workerBind + `SYB.extQ` workerExpr + `SYB.extQ` workerLIE + `SYB.extQ` workerHsTyVarBndr + `SYB.extQ` workerLHsType + + worker (pnt :: (GHC.Located a)) + = checker pnt + + -- workerBind (GHC.L l (GHC.VarPat name) :: (GHC.Located (GHC.Pat a))) + workerBind (GHC.L l (GHC.VarPat name)) + = checker (GHC.L l name) + workerBind _ = Nothing + + -- workerExpr ((GHC.L l (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr a))) + workerExpr ((GHC.L l (GHC.HsVar name))) + = checker (GHC.L l name) + workerExpr _ = Nothing + + workerLIE ((GHC.L _l (GHC.IEVar (GHC.L ln name))) :: (GHC.LIE a)) + -- workerLIE ((GHC.L _l (GHC.IEVar (GHC.L ln name)))) + = checker (GHC.L ln name) + workerLIE _ = Nothing + + -- workerHsTyVarBndr ((GHC.L l (GHC.UserTyVar name)):: (GHC.LHsTyVarBndr a)) + workerHsTyVarBndr ((GHC.L l (GHC.UserTyVar name))) + = checker (GHC.L l name) + workerHsTyVarBndr _ = Nothing + + workerLHsType ((GHC.L l (GHC.HsTyVar name))) + = checker (GHC.L l name) + workerLHsType _ = Nothing +-} diff --git a/src/MainHaRe.hs b/src/MainHaRe.hs --- a/src/MainHaRe.hs +++ b/src/MainHaRe.hs @@ -7,7 +7,6 @@ import Control.Exception import Data.List -import Data.Maybe import Data.Typeable import Data.Version import Language.Haskell.GhcMod @@ -41,9 +40,10 @@ ---------------------------------------------------------------- argspec :: [OptDescr (RefactSettings -> RefactSettings)] -argspec = [ Option "m" ["mainfile"] - (ReqArg (\mf opts -> opts { rsetMainFile = Just [mf] }) "FILE") - "Main file name if not specified in cabal file" +argspec = [ + -- Option "m" ["mainfile"] + -- (ReqArg (\mf opts -> opts { rsetMainFile = Just [mf] }) "FILE") + -- "Main file name if not specified in cabal file" -- , Option "l" ["tolisp"] -- (NoArg (\opts -> opts { outputStyle = LispStyle })) @@ -51,21 +51,21 @@ -- , Option "h" ["hlintOpt"] -- (ReqArg (\h opts -> opts { hlintOpts = h : hlintOpts opts }) "hlintOpt") -- "hlint options" - , Option "g" ["ghcOpt"] - (ReqArg (\g opts -> opts { rsetGhcOpts = g : rsetGhcOpts opts }) "ghcOpt") - "GHC options" + -- , Option "g" ["ghcOpt"] + -- (ReqArg (\g opts -> opts { rsetGhcOpts = g : rsetGhcOpts opts }) "ghcOpt") + -- "GHC options" -- , Option "o" ["operators"] -- (NoArg (\opts -> opts { operators = True })) -- "print operators, too" -- , Option "d" ["detailed"] -- (NoArg (\opts -> opts { detailed = True })) -- "print detailed info" - , Option "v" ["verbose"] + Option "v" ["verbose"] (NoArg (\opts -> opts { rsetVerboseLevel = Debug })) "debug logging on" - , Option "b" ["boundary"] - (ReqArg (\s opts -> opts { rsetLineSeparator = LineSeparator s }) "sep") - "specify line separator (default is Nul string)" + -- , Option "b" ["boundary"] + -- (ReqArg (\s opts -> opts { rsetLineSeparator = LineSeparator s }) "sep") + -- "specify line separator (default is Nul string)" ] parseArgs :: [OptDescr (RefactSettings -> RefactSettings)] -> [String] -> (RefactSettings, [String]) @@ -87,49 +87,44 @@ main :: IO () main = flip catches handlers $ do --- #if __GLASGOW_HASKELL__ >= 611 hSetEncoding stdout utf8 --- #endif - -- currentDirectory <- getCurrentDirectory args <- getArgs let (opt,cmdArg) = parseArgs argspec args - cradle <- findCradle - -- case (cradleCabalDir cradle) of - -- Nothing -> return () - -- Just dir -> setCurrentDirectory dir - -- hPutStrLn stderr $ "cabal file=" ++ show (cradleCabalFile cradle) -- ++AZ++ debug let cmdArg0 = cmdArg !. 0 cmdArg1 = cmdArg !. 1 cmdArg2 = cmdArg !. 2 cmdArg3 = cmdArg !. 3 cmdArg4 = cmdArg !. 4 cmdArg5 = cmdArg !. 5 + -- putStrLn $ "cmdArg0=" ++ cmdArg0 res <- case cmdArg0 of - -- demote wants FilePath -> SimpPos - "demote" -> runFunc cradle $ demote opt cradle cmdArg1 (parseSimpPos cmdArg2 cmdArg3) + "demote" -> runFunc $ demote opt defaultOptions cmdArg1 (parseSimpPos cmdArg2 cmdArg3) -- dupdef wants FilePath -> String -> SimpPos - "dupdef" -> runFunc cradle $ duplicateDef opt cradle cmdArg1 cmdArg2 (parseSimpPos cmdArg3 cmdArg4) + "dupdef" -> runFunc $ duplicateDef opt defaultOptions cmdArg1 cmdArg2 (parseSimpPos cmdArg3 cmdArg4) -- iftocase wants FilePath -> SimpPos -> SimpPos - "iftocase" -> runFunc cradle $ ifToCase opt cradle cmdArg1 (parseSimpPos cmdArg2 cmdArg3) (parseSimpPos cmdArg4 cmdArg5) + "iftocase" -> runFunc $ ifToCase opt defaultOptions cmdArg1 (parseSimpPos cmdArg2 cmdArg3) (parseSimpPos cmdArg4 cmdArg5) -- liftOneLevel wants FilePath -> SimpPos - "liftOneLevel" -> runFunc cradle $ liftOneLevel opt cradle cmdArg1 (parseSimpPos cmdArg2 cmdArg3) + "liftOneLevel" -> runFunc $ liftOneLevel opt defaultOptions cmdArg1 (parseSimpPos cmdArg2 cmdArg3) -- liftToTopLevel wants FilePath -> SimpPos - "liftToTopLevel" -> runFunc cradle $ liftToTopLevel opt cradle cmdArg1 (parseSimpPos cmdArg2 cmdArg3) + "liftToTopLevel" -> runFunc $ liftToTopLevel opt defaultOptions cmdArg1 (parseSimpPos cmdArg2 cmdArg3) -- rename wants FilePath -> String -> SimpPos - "rename" -> runFunc cradle $ rename opt cradle cmdArg1 cmdArg2 (parseSimpPos cmdArg3 cmdArg4) + "rename" -> runFunc $ rename opt defaultOptions cmdArg1 cmdArg2 (parseSimpPos cmdArg3 cmdArg4) - "show" -> putStrLn (show (opt,cradle)) + -- roundtrip wants FilePath + "roundtrip" -> runFunc $ roundTrip opt defaultOptions cmdArg1 + "show" -> putStrLn (show (opt)) + cmd -> throw (NoSuchCommand cmd) - -- setCurrentDirectory currentDirectory - putStr (show res) + -- putStr (show res) -- putStr $ "(ok " ++ showLisp mfs ++ ")" + return () where handlers = [Handler handler1, Handler handler2] @@ -149,13 +144,6 @@ printUsage printUsage = hPutStrLn stderr $ '\n' : usageInfo usage argspec -{- - withFile cmd file = do - exist <- doesFileExist file - if exist - then cmd file - else throw (FileNotExist file) --} xs !. idx | length xs <= idx = throw SafeList | otherwise = xs !! idx @@ -163,11 +151,11 @@ ---------------------------------------------------------------- -runFunc :: Cradle -> IO [String] -> IO () -runFunc cradle f = do +runFunc :: IO [String] -> IO () +runFunc f = do r <- catchException f let ret = case r of - Left s -> "(error " ++ (show s) ++ "[" ++ (show $ cradleCabalFile cradle) ++ "])" + Left s -> "(error " ++ (show s) ++ ")" Right mfs -> "(ok " ++ showLisp mfs ++ ")" putStrLn ret @@ -185,7 +173,6 @@ ---------------------------------------------------------------- parseSimpPos :: String -> String -> SimpPos --- parseSimpPos str1 str2 = case (parse rowCol "" (T.pack (str1 ++ " " ++ str2))) of parseSimpPos str1 str2 = case (parse rowCol "" ((str1 ++ " " ++ str2))) of Left err -> throw (CmdArg [(show err)]) Right val -> val @@ -199,12 +186,6 @@ type P = Parsec String () -{- -instance (Monad m) => Stream String m Char where - -- uncons = return . T.uncons - uncons [] = return Nothing - uncons s = return $ Just (head s,tail s) --} number :: String -> P Integer number expectedStr = do { ds <- many1 digit; return (read ds) } expectedStr diff --git a/test/CaseSpec.hs b/test/CaseSpec.hs new file mode 100644 --- /dev/null +++ b/test/CaseSpec.hs @@ -0,0 +1,104 @@ +module CaseSpec (main, spec) where + +import Test.Hspec + +import Language.Haskell.Refact.Refactoring.Case + +import TestUtils + +import System.Directory + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + describe "ifToCase" $ do + it "converts an if expression to a case expression BSimple" $ do + r <- ct $ ifToCase defaultTestSettings testOptions "Case/BSimple.hs" (4,7) (4,43) + -- r <- ct $ ifToCase logTestSettings testOptions "Case/BSimple.hs" (4,7) (4,43) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Case/BSimple.hs"] + diff <- compareFiles "./test/testdata/Case/BSimple.refactored.hs" + "./test/testdata/Case/BSimpleExpected.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "converts an if expression to a case expression Foo" $ do + r <- ct $ ifToCase defaultTestSettings testOptions "Case/Foo.hs" (4,1) (9,1) + -- r <- ct $ ifToCase logTestSettings testOptions "Case/Foo.hs" (4,1) (9,1) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Case/Foo.hs"] + diff <- compareFiles "./test/testdata/Case/Foo.refactored.hs" + "./test/testdata/Case/Foo.hs.expected" + diff `shouldBe` [] + + -- --------------------------------- + + it "converts an if expression to a case expression B" $ do + r <- ct $ ifToCase defaultTestSettings testOptions "Case/B.hs" (4,7) (4,43) + -- r <- ct $ ifToCase logTestSettings testOptions "Case/B.hs" (4,7) (4,43) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Case/B.hs"] + diff <- compareFiles "./test/testdata/Case/B.refactored.hs" + "./test/testdata/Case/B.hs.expected" + diff `shouldBe` [] + + -- --------------------------------- + + it "converts an if expression with comments to a case expression 1 C" $ do + + r <- ct $ ifToCase defaultTestSettings testOptions "Case/C.hs" (5,7) (10,1) + -- ct $ ifToCase logTestSettings testOptions "Case/C.hs" (5,7) (10,1) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Case/C.hs"] + diff <- compareFiles "./test/testdata/Case/C.refactored.hs" + "./test/testdata/Case/C.hs.expected" + diff `shouldBe` [] + + -- --------------------------------- + + it "converts an if expression with comments to a case expression 2 D" $ do + r <- ct $ ifToCase defaultTestSettings testOptions "Case/D.hs" (5,7) (12,1) + -- ct $ ifToCase logTestSettings testOptions "Case/D.hs" (5,7) (12,1) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Case/D.hs"] + diff <- compareFiles "./test/testdata/Case/D.refactored.hs" + "./test/testdata/Case/D.hs.expected" + diff `shouldBe` [] + + -- --------------------------------- + + it "converts in complex sub level expression 2 E" $ do + r <- ct $ ifToCase defaultTestSettings testOptions "Case/E.hs" (7,8) (13,20) + -- ct $ ifToCase logTestSettings testOptions "Case/E.hs" (7,8) (13,20) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Case/E.hs"] + diff <- compareFiles "./test/testdata/Case/E.refactored.hs" + "./test/testdata/Case/E.hs.expected" + diff `shouldBe` [] + + -- --------------------------------- + + it "converts in complex sub level expression F" $ do + r <- ct $ ifToCase defaultTestSettings testOptions "Case/F.hs" (4,7) (8,20) + -- ct $ ifToCase logTestSettings testOptions "Case/F.hs" (4,7) (8,20) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Case/F.hs"] + diff <- compareFiles "./test/testdata/Case/F.refactored.hs" + "./test/testdata/Case/F.hs.expected" + diff `shouldBe` [] + + -- --------------------------------- + + it "complains if an if-then-else is not selected" $ do + res <- catchException(ct $ ifToCase defaultTestSettings testOptions "Case/C.hs" (4,7) (9,1)) + -- ifToCase logTestSettings testOptions "./test/testdata/Case/C.hs" (4,7) (9,1) + (show res) `shouldBe` "Just \"You haven't selected an if-then-else expression!\"" + +-- --------------------------------------------------------------------- +-- Helper functions + + diff --git a/test/DupDefSpec.hs b/test/DupDefSpec.hs new file mode 100644 --- /dev/null +++ b/test/DupDefSpec.hs @@ -0,0 +1,130 @@ +module DupDefSpec (main, spec) where + +import Test.Hspec + +import Language.Haskell.Refact.Refactoring.DupDef +import System.Directory + +import TestUtils + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + + describe "doDuplicateDef" $ do + it "checks for a clash of the new name" $ do + res <- catchException (ct $ duplicateDef defaultTestSettings testOptions "DupDef/Dd1.hs" "c" (4,1)) + -- res <- catchException (ct $ duplicateDef logTestSettings testOptions "DupDef/Dd1.hs" "c" (4,1)) + (show res) `shouldBe` "Just \"The new name'c' will cause name clash/capture or ambiguity problem after duplicating, please select another name!\"" + + -- --------------------------------- + + it "checks for no definition selected" $ do + -- res <- catchException (ct $ doDuplicateDef ["DupDef/Dd1.hs","c","5","1"]) + res <- catchException (ct $ duplicateDef defaultTestSettings testOptions "DupDef/Dd1.hs" "c" (5,1)) + (show res) `shouldBe` "Just \"Invalid cursor position!\"" + + -- --------------------------------- + + it "checks for invalid new name" $ do + -- res <- catchException (ct $ doDuplicateDef ["DupDef/Dd1.hs","$c","5","1"]) + res <- catchException (ct $ duplicateDef defaultTestSettings testOptions "DupDef/Dd1.hs" "$c" (5,1)) + (show res) `shouldBe` "Just \"Invalid new function name:$c!\"" + + -- --------------------------------- + + it "notifies if no definition selected" $ do + res <- catchException (ct $ duplicateDef defaultTestSettings testOptions "DupDef/Dd1.hs" "ccc" (14,13)) + -- res <- catchException (ct $ duplicateDef logTestSettings testOptions "DupDef/Dd1.hs" "ccc" (14,13)) + (show res) `shouldBe` "Just \"The selected identifier is not a function/simple pattern name, or is not defined in this module \"" + + -- --------------------------------- + + it "duplicates a definition at the top level" $ do + res <- ct $ duplicateDef defaultTestSettings testOptions "DupDef/Dd1.hs" "tl2" (4,1) + -- res <- ct $ duplicateDef logTestSettings testOptions "DupDef/Dd1.hs" "tl2" (4,1) + res' <- ct $ mapM makeRelativeToCurrentDirectory res + (show res') `shouldBe` "[\"DupDef/Dd1.hs\"]" + diff <- compareFiles "./test/testdata/DupDef/Dd1.refactored.hs" + "./test/testdata/DupDef/Dd1.hs.expected" + diff `shouldBe` [] + + -- --------------------------------- + + it "duplicates a definition in a match" $ do + res <- ct $ duplicateDef defaultTestSettings testOptions "DupDef/Dd1.hs" "nn" (23,5) + -- res <- ct $ duplicateDef logTestSettings testOptions "DupDef/Dd1.hs" "nn" (23,5) + res' <- ct $ mapM makeRelativeToCurrentDirectory res + (show res') `shouldBe` "[\"DupDef/Dd1.hs\"]" + diff <- compareFiles "./test/testdata/DupDef/Dd1.refactored.hs" + "./test/testdata/DupDef/Dd1.hs.expected.nn" + diff `shouldBe` [] + + -- --------------------------------- + + it "duplicates a definition in a pattern match" $ do + res <- ct $ duplicateDef defaultTestSettings testOptions "DupDef/Dd1.hs" "gg" (17,5) + -- res <- ct $ duplicateDef logTestSettings testOptions "DupDef/Dd1.hs" "gg" (17,5) + res' <- ct $ mapM makeRelativeToCurrentDirectory res + (show res') `shouldBe` "[\"DupDef/Dd1.hs\"]" + diff <- compareFiles "./test/testdata/DupDef/Dd1.refactored.hs" + "./test/testdata/DupDef/Dd1.hs.expected.gg" + diff `shouldBe` [] + + -- --------------------------------- + + it "duplicates a definition in a let expression" $ do + res <- ct $ duplicateDef defaultTestSettings testOptions "DupDef/Dd1.hs" "lll" (27,5) + -- res <- ct $ duplicateDef logTestSettings testOptions "DupDef/Dd1.hs" "lll" (27,5) + res' <- ct $ mapM makeRelativeToCurrentDirectory res + (show res') `shouldBe` "[\"DupDef/Dd1.hs\"]" + diff <- compareFiles "./test/testdata/DupDef/Dd1.refactored.hs" + "./test/testdata/DupDef/Dd1.hs.expected.ll" + diff `shouldBe` [] + + -- --------------------------------- + + it "duplicates a definition in a let statement" $ do + res <- ct $ duplicateDef defaultTestSettings testOptions "DupDef/Dd1.hs" "sss" (31,7) + -- res <- ct $ duplicateDef logTestSettings testOptions "DupDef/Dd1.hs" "sss" (31,7) + res' <- ct $ mapM makeRelativeToCurrentDirectory res + (show res') `shouldBe` "[\"DupDef/Dd1.hs\"]" + diff <- compareFiles "./test/testdata/DupDef/Dd1.refactored.hs" + "./test/testdata/DupDef/Dd1.hs.expected.dd" + diff `shouldBe` [] + + -- --------------------------------- + + it "hides the new definition if it will cause problems in client mods" $ do + res <- ct $ duplicateDef defaultTestSettings testOptions "DupDef/Dd1.hs" "mm" (21,1) + -- res <- ct $ duplicateDef logTestSettings testOptions "DupDef/Dd1.hs" "mm" (21,1) + r' <- ct $ mapM makeRelativeToCurrentDirectory res + (show r') `shouldBe` "[\"DupDef/Dd1.hs\",\"DupDef/Dd2.hs\",\"DupDef/Dd3.hs\"]" + diff <- compareFiles "./test/testdata/DupDef/Dd1.refactored.hs" + "./test/testdata/DupDef/Dd1.hs.expected.mm" + diff `shouldBe` [] + diff2 <- compareFiles "./test/testdata/DupDef/Dd2.refactored.hs" + "./test/testdata/DupDef/Dd2.hs.expected" + diff2 `shouldBe` [] + diff3 <- compareFiles "./test/testdata/DupDef/Dd3.refactored.hs" + "./test/testdata/DupDef/Dd3.hs.expected" + diff3 `shouldBe` [] + + -- --------------------------------- + + it "duplicates a definition and formats properly" $ do + res <- ct $ duplicateDef defaultTestSettings testOptions "Case/B.hs" "joe" (9,1) + -- res <- ct $ duplicateDef logTestSettings testOptions "Case/B.hs" "joe" (9,1) + res' <- ct $ mapM makeRelativeToCurrentDirectory res + (show res') `shouldBe` "[\"Case/B.hs\"]" + diff <- compareFiles "./test/testdata/Case/B.refactored.hs" + "./test/testdata/Case/B.hs.expected.dd" + diff `shouldBe` [] + +-- --------------------------------------------------------------------- + diff --git a/test/GhcUtilsSpec.hs b/test/GhcUtilsSpec.hs new file mode 100644 --- /dev/null +++ b/test/GhcUtilsSpec.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module GhcUtilsSpec (main, spec) where + +import Test.Hspec + +import TestUtils + +import qualified GHC as GHC + +import qualified Data.Generics as SYB +import qualified GHC.SYB.Utils as SYB + +import Language.Haskell.GHC.ExactPrint.Utils + +import Language.Haskell.Refact.Utils.Binds +import Language.Haskell.Refact.Utils.GhcUtils +import Language.Haskell.Refact.Utils.GhcVersionSpecific +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions +import Language.Haskell.Refact.Utils.TypeUtils +import Language.Haskell.Refact.Utils.Variables + +-- import TestUtils + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + + describe "onelayerStaged" $ do + it "only descends one layer into a structure" $ do + let s' = (2,[3,4],5) :: (Int,[Int],Int) + let + worker' (i::Int) = [i] + + let g = onelayerStaged SYB.Renamer [] ([] `SYB.mkQ` worker') s' + let g1 = SYB.gmapQ ([] `SYB.mkQ` worker') s' + let g2 = SYB.gmapQl (++) [] ([] `SYB.mkQ` worker') s' + + (show g) `shouldBe` "[[2],[],[5]]" + (show g1) `shouldBe` "[[2],[],[5]]" + (show g2) `shouldBe` "[2,5]" + + -- --------------------------------- + + it "Finds a GHC.Name at top level only" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + renamed <- getRefactRenamed + + let mn = locToName (4,1) renamed + let (Just (ln@(GHC.L _ n))) = mn + + let mx = locToName (4,10) renamed + let (Just (lx@(GHC.L _ x))) = mx + + let declsr = hsBinds renamed + duplicatedDecls = definingDeclsNames [n] declsr True False + + res = findEntity ln duplicatedDecls + res2 = findEntity n duplicatedDecls + + resx = findEntity lx duplicatedDecls + resx2 = findEntity x duplicatedDecls + + + worker (nn::GHC.Name) = [showGhc nn] + g = onelayerStaged SYB.Renamer ["-1"] (["-10"] `SYB.mkQ` worker) duplicatedDecls + + worker2 ((GHC.L _ (GHC.FunBind (GHC.L _ n') _ _ _ _ _))::GHC.Located (GHC.HsBind GHC.Name)) + | n == n' = ["found"] + worker2 _ = [] + g2 = onelayerStaged SYB.Renamer ["-1"] (["-10"] `SYB.mkQ` worker2) duplicatedDecls + + return (res,res2,resx,resx2,duplicatedDecls,g,g2,ln,lx) + ((r,r2,rx,rx2,d,gg,gg2,_l,_x),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (SYB.showData SYB.Renamer 0 d) `shouldBe` "" + + (showGhcQual d) `shouldBe` "[DupDef.Dd1.toplevel x = DupDef.Dd1.c GHC.Num.* x]" + (showGhcQual _l) `shouldBe` "DupDef.Dd1.toplevel" + (showGhc _x) `shouldBe` "x" + (show gg) `shouldBe` "[[\"-10\"],[\"-10\"]]" + (show gg2) `shouldBe` "[[\"found\"],[\"-10\"]]" + r `shouldBe` True + r2 `shouldBe` True + rx `shouldBe` False + rx2 `shouldBe` True + +-- --------------------------------------------------------------------- diff --git a/test/LocUtilsSpec.hs b/test/LocUtilsSpec.hs new file mode 100644 --- /dev/null +++ b/test/LocUtilsSpec.hs @@ -0,0 +1,62 @@ +module LocUtilsSpec (main, spec) where + +import Test.Hspec + +import TestUtils + +import Language.Haskell.GHC.ExactPrint + +import Language.Haskell.Refact.Utils.GhcVersionSpecific +import Language.Haskell.Refact.Utils.LocUtils +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions + +-- --------------------------------------------------------------------- + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + + -- ------------------------------------------------------------------- + + describe "getSrcSpan" $ do + it "Finds the top SrcSpan" $ do + t <- parsedFileDd1Ghc + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + let ss = getSrcSpan decls + return (decls,ss) + ((d,ss'),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual d) `shouldBe` "[toplevel :: Integer -> Integer, toplevel x = c * x,\n c, d :: Integer, c = 7, d = 9, tup :: (Int, Int), h :: Int,\n t :: Int,\n tup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15,\n data D = A | B String | C,\n ff y\n = y + zz\n where\n zz = 1,\n l z = let ll = 34 in ll + z,\n dd q\n = do { let ss = 5;\n return (ss + q) }]" + (showGhcQual ss') `shouldBe` "Just DupDef/Dd1.hs:3:1-30" + + -- ------------------------------- + + it "Finds the SrcSpan for a top level decl" $ do + t <- parsedFileDemoteGhc + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + let decl = head $ drop 2 decls + ss = getSrcSpan decl + return (decl,ss) + ((d,ss'),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual d) `shouldBe` "c = 7" + (showGhcQual ss') `shouldBe` "Just MoveDef/Demote.hs:7:1-5" + +-- --------------------------------------------------------------------- + +parsedFileDd1Ghc :: IO ParseResult +parsedFileDd1Ghc = ct $ parsedFileGhc "./DupDef/Dd1.hs" + +-- ----------- + +parsedFileDemoteGhc :: IO ParseResult +parsedFileDemoteGhc = ct $ parsedFileGhc "./MoveDef/Demote.hs" + +-- EOF diff --git a/test/MonadFunctionsSpec.hs b/test/MonadFunctionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/MonadFunctionsSpec.hs @@ -0,0 +1,35 @@ +module MonadFunctionsSpec (main, spec) where + +import Test.Hspec + +-- import TestUtils + +-- import qualified GHC as GHC + +-- import Language.Haskell.GHC.ExactPrint.Utils +-- import Language.Haskell.GHC.ExactPrint.Types + +-- import Language.Haskell.Refact.Utils.Binds +-- import Language.Haskell.Refact.Utils.GhcVersionSpecific +-- import Language.Haskell.Refact.Utils.Monad +-- import Language.Haskell.Refact.Utils.MonadFunctions +-- import Language.Haskell.Refact.Utils.TypeSyn +-- import Language.Haskell.Refact.Utils.TypeUtils + +-- import Language.Haskell.TokenUtils.DualTree + + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + describe "need tests" $ do + it "for these functions" $ do + pendingWith "need to write these" + + -- --------------------------------- + +-- --------------------------------------------------------------------- + diff --git a/test/MoveDefSpec.hs b/test/MoveDefSpec.hs new file mode 100644 --- /dev/null +++ b/test/MoveDefSpec.hs @@ -0,0 +1,821 @@ +module MoveDefSpec (main, spec) where + +import Test.Hspec + +import Language.Haskell.Refact.Refactoring.MoveDef +import System.Directory + +import TestUtils + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + + -- ------------------------------------------------------------------- + + describe "liftToTopLevel" $ do + it "cannot lift a top level declaration" $ do + -- res <- catchException (liftToTopLevel logTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (4,1)) + res <- catchException (ct $ liftToTopLevel defaultTestSettings testOptions "./MoveDef/Md1.hs" (4,1)) + (show res) `shouldBe` "Just \"\\nThe identifier is not a local function/pattern name!\"" + + -- --------------------------------- + + it "checks for name clashes" $ do + -- res <- catchException (doLiftToTopLevel ["./test/testdata/MoveDef/Md1.hs","17","5"]) + res <- catchException (liftToTopLevel defaultTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (17,5)) + (show res) `shouldBe` "Just \"The identifier(s): (ff, test/testdata/MoveDef/Md1.hs:17:5) will cause name clash/capture or ambiguity occurrence problem after lifting, please do renaming first!\"" + + {- + it "checks for invalid new name" $ do + res <- catchException (doDuplicateDef ["./test/testdata/DupDef/Dd1.hs","$c","5","1"]) + (show res) `shouldBe` "Just \"Invalid new function name:$c!\"" + + it "notifies if no definition selected" $ do + res <- catchException (doDuplicateDef ["./test/testdata/DupDef/Dd1.hs","ccc","14","13"]) + (show res) `shouldBe` "Just \"The selected identifier is not a function/simple pattern name, or is not defined in this module \"" + -} + + -- --------------------------------- + + it "lifts a definition to the top level" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (24,5) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (24,5) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/MoveDef/Md1.hs\"]" + diff <- compareFiles "./test/testdata/MoveDef/Md1.hs.expected" + "./test/testdata/MoveDef/Md1.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "liftToTopLevel D1 C1 A1 8 6" $ do + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/D1.hs" (8,6) + -- r <- ct $ liftToTopLevel logTestSettings testOptions "./LiftToToplevel/D1.hs" (8,6) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"LiftToToplevel/D1.hs\",\"LiftToToplevel/C1.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/D1.hs.expected" + "./test/testdata/LiftToToplevel/D1.refactored.hs" + diff `shouldBe` [] + + diff2 <- compareFiles "./test/testdata/LiftToToplevel/C1.hs.expected" + "./test/testdata/LiftToToplevel/C1.refactored.hs" + diff2 `shouldBe` [] + + a1Refactored <- doesFileExist "./test/testdata/LiftToToplevel/A1.refactored.hs" + a1Refactored `shouldBe` False + + + -- --------------------------------- + + it "liftToTopLevel D2 C2 A2 8 6" $ do + r <- ct $ liftToTopLevel defaultTestSettings testOptions "./LiftToToplevel/D2.hs" (8,6) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"LiftToToplevel/D2.hs\",\"LiftToToplevel/C2.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/D2.hs.expected" + "./test/testdata/LiftToToplevel/D2.refactored.hs" + diff `shouldBe` [] + + diff2 <- compareFiles "./test/testdata/LiftToToplevel/C2.hs.expected" + "./test/testdata/LiftToToplevel/C2.refactored.hs" + diff2 `shouldBe` [] + + a1Refactored <- doesFileExist "./test/testdata/LiftToToplevel/A2.refactored.hs" + a1Refactored `shouldBe` False + + + -- --------------------------------- + + it "liftToTopLevel D3 C3 A3 8 6" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/D3.hs" (8,6) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/D3.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/D3.hs.expected" + "./test/testdata/LiftToToplevel/D3.refactored.hs" + diff `shouldBe` [] + + c3Refactored <- doesFileExist "./test/testdata/LiftToToplevel/C3.refactored.hs" + c3Refactored `shouldBe` False + + a3Refactored <- doesFileExist "./test/testdata/LiftToToplevel/A3.refactored.hs" + a3Refactored `shouldBe` False + + + -- --------------------------------- + + it "liftToTopLevel WhereIn1 12 18" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn1.hs" (12,18) + -- r <- liftToTopLevel logTestSettings testOptions Nothing "./test/testdata/LiftToToplevel/WhereIn1.hs" (12,18) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/WhereIn1.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/WhereIn1.hs.expected" + "./test/testdata/LiftToToplevel/WhereIn1.refactored.hs" + diff `shouldBe` [] + + + -- --------------------------------- + + it "liftToTopLevel WhereIn6 13 29" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn6.hs" (13,29) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn6.hs" (13,29) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/WhereIn6.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/WhereIn6.hs.expected" + "./test/testdata/LiftToToplevel/WhereIn6.refactored.hs" + diff `shouldBe` [] + + + -- --------------------------------- + + it "liftToTopLevel WhereIn7 12 14" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn7.hs" (12,14) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn7.hs" (12,14) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/WhereIn7.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/WhereIn7.hs.expected" + "./test/testdata/LiftToToplevel/WhereIn7.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "liftToTopLevel LetIn1 11 22" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn1.hs" (11,22) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn1.hs" (11,22) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/LetIn1.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/LetIn1.hs.expected" + "./test/testdata/LiftToToplevel/LetIn1.refactored.hs" + diff `shouldBe` [] + + + -- --------------------------------- + + it "liftToTopLevel LetIn2 10 22" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn2.hs" (10,22) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn2.hs" (10,22) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/LetIn2.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/LetIn2.hs.expected" + "./test/testdata/LiftToToplevel/LetIn2.refactored.hs" + diff `shouldBe` [] + + + -- --------------------------------- + + it "liftToTopLevel LetIn3 10 27" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn3.hs" (10,27) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/LetIn3.hs" (10,27) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/LetIn3.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/LetIn3.hs.expected" + "./test/testdata/LiftToToplevel/LetIn3.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "liftToTopLevel PatBindIn1 18 7" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/PatBindIn1.hs" (18,7) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/PatBindIn1.hs" (18,7) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/PatBindIn1.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/PatBindIn1.hs.expected" + "./test/testdata/LiftToToplevel/PatBindIn1.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "liftToTopLevel PatBindIn3 11 15" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/PatBindIn3.hs" (11,15) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/PatBindIn3.hs" (11,15) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/PatBindIn3.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/PatBindIn3.hs.expected" + "./test/testdata/LiftToToplevel/PatBindIn3.refactored.hs" + diff `shouldBe` [] + + + -- --------------------------------- + + it "liftToTopLevel CaseIn1 10 28" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/CaseIn1.hs" (10,28) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/CaseIn1.hs" (10,28) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/CaseIn1.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/CaseIn1.hs.expected" + "./test/testdata/LiftToToplevel/CaseIn1.refactored.hs" + diff `shouldBe` [] + + + -- --------------------------------- + + it "liftToTopLevel PatBindIn2 17 7 fails" $ do +{- + res <- catchException (doLiftToTopLevel ["./test/testdata/LiftToToplevel/PatBindIn2.hs","17","7"]) + -- liftToTopLevel logTestSettings Nothing "./test/testdata/LiftToToplevel/PatBindIn2.hs" (17,7) + + (show res) `shouldBe` "Just \"\\nThe identifier is not a local function/pattern name!\"" +-} + pending -- Not clear that this was covered in the original, will + -- come back to it + + -- --------------------------------- + + it "liftToTopLevel WhereIn2 11 18 fails" $ do + -- res <- catchException (doLiftToTopLevel ["./test/testdata/LiftToToplevel/WhereIn2.hs","11","18"]) + res <- catchException (liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/WhereIn2.hs" (11,18)) + -- liftToTopLevel logTestSettings testOptions Nothing "./test/testdata/LiftToToplevel/WhereIn2.hs" (11,18) + + (show res) `shouldBe` "Just \"The identifier(s): (sq, test/testdata/LiftToToplevel/WhereIn2.hs:11:18) will cause name clash/capture or ambiguity occurrence problem after lifting, please do renaming first!\"" + + + +{- original tests +positive=[(["D1.hs","C1.hs","A1.hs"],["8","6"]), + (["D2.hs","C2.hs","A2.hs"],["8","6"]), + (["D3.hs","C3.hs","A3.hs"],["8","6"]), + (["WhereIn1.hs"],["12","18"]), + (["WhereIn6.hs"],["13","29"]), + (["WhereIn7.hs"],["12","14"]), + (["LetIn1.hs"],["11","22"]), + (["LetIn2.hs"],["10","22"]), + (["LetIn3.hs"],["10","27"]), + (["PatBindIn1.hs"],["18","7"]), + (["PatBindIn3.hs"],["11","15"]), + (["CaseIn1.hs"],["10","28"])], +negative=[(["PatBindIn2.hs"],["17","7"]), + (["WhereIn2.hs"],["11","18"]) + ] + +-} + + -- --------------------------------- + + it "liftToTopLevel Zmapq" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Zmapq.hs" (6,3) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Zmapq.hs" (6,3) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/Zmapq.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/Zmapq.expected.hs" + "./test/testdata/LiftToToplevel/Zmapq.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "liftToTopLevel LiftInLambda 10 5" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/LiftInLambda.hs" (10,5) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/LiftInLambda.hs" (10,5) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/LiftInLambda.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/LiftInLambda.expected.hs" + "./test/testdata/LiftToToplevel/LiftInLambda.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "liftToTopLevel NoWhere" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/NoWhere.hs" (14,12) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/NoWhere.hs" (14,12) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/NoWhere.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/NoWhere.expected.hs" + "./test/testdata/LiftToToplevel/NoWhere.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "liftToTopLevel Signature" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature.hs" (9,5) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature.hs" (9,5) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/Signature.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/Signature.expected.hs" + "./test/testdata/LiftToToplevel/Signature.refactored.hs" + diff `shouldBe` [] + + + -- --------------------------------- + + it "liftToTopLevel Signature2" $ do + -- should throw exception for forall in signature + res <- catchException (liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2.hs" (16,5)) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2.hs" (16,5) + (show res) `shouldBe` "Just \"\\nNew type signature may fail type checking: :: (forall t. Num t => t -> t -> t) -> Int -> \\n\"" + + {- + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2.hs" (16,5) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2.hs" (16,5) + (show r) `shouldBe` "[\"./test/testdata/LiftToToplevel/Signature2.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/Signature2.expected.hs" + "./test/testdata/LiftToToplevel/Signature2.refactored.hs" + diff `shouldBe` [] + -} + + + -- --------------------------------- + + it "liftToTopLevel Signature2r" $ do + -- should throw exception for forall in signature + r <- catchException (liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2r.hs" (12,5)) + -- r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2r.hs" (12,5) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature2r.hs" (12,5) + (show r) `shouldBe` "Just \"\\nNew type signature may fail type checking: :: (forall t. Num t => t -> t -> t) -> Int -> \\n\"" + {- + (show r) `shouldBe` "[\"./test/testdata/LiftToToplevel/Signature2r.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/Signature2r.expected.hs" + "./test/testdata/LiftToToplevel/Signature2r.refactored.hs" + diff `shouldBe` [] + -} + + -- --------------------------------- + + it "liftToTopLevel Signature3" $ do + r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature3.hs" (9,5) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature3.hs" (9,5) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftToToplevel/Signature3.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/Signature3.expected.hs" + "./test/testdata/LiftToToplevel/Signature3.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "liftToTopLevel Signature4" $ do + -- should throw exception for forall in signature + r <- catchException $ liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature4.hs" (9,5) + -- r <- liftToTopLevel defaultTestSettings testOptions "./test/testdata/LiftToToplevel/Signature4.hs" (9,5) + -- r <- liftToTopLevel logTestSettings testOptions "./test/testdata/LiftToToplevel/Signature4.hs" (9,5) + (show r) `shouldBe` "Just \"\\nNew type signature may fail type checking: :: (forall t. (Integral t, Num t) => t -> t -> Int) -> t -> \\n\"" + {- + (show r) `shouldBe` "[\"./test/testdata/LiftToToplevel/Signature4.hs\"]" + diff <- compareFiles "./test/testdata/LiftToToplevel/Signature4.expected.hs" + "./test/testdata/LiftToToplevel/Signature4.refactored.hs" + diff `shouldBe` [] + -} + + -- ------------------------------------------------------------------- + + describe "LiftOneLevel" $ do + + it "liftOneLevel.liftToMod D1 C1 A1 8 6" $ do + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/D1.hs" (8,6) + -- r <- ct $ liftOneLevel logTestSettings testOptions "./LiftOneLevel/D1.hs" (8,6) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"LiftOneLevel/D1.hs\",\"LiftOneLevel/C1.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/D1.hs.expected" + "./test/testdata/LiftOneLevel/D1.refactored.hs" + diff `shouldBe` [] + + diff2 <- compareFiles "./test/testdata/LiftOneLevel/C1.hs.expected" + "./test/testdata/LiftOneLevel/C1.refactored.hs" + diff2 `shouldBe` [] + + a1Refactored <- doesFileExist "./test/testdata/LiftOneLevel/A1.refactored.hs" + a1Refactored `shouldBe` False + + -- --------------------------------- + + it "LiftOneLevel.liftToMod D2 C2 A2 8 6" $ do + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/D2.hs" (8,6) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"LiftOneLevel/D2.hs\",\"LiftOneLevel/C2.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/D2.hs.expected" + "./test/testdata/LiftOneLevel/D2.refactored.hs" + diff `shouldBe` [] + + diff2 <- compareFiles "./test/testdata/LiftOneLevel/C2.hs.expected" + "./test/testdata/LiftOneLevel/C2.refactored.hs" + diff2 `shouldBe` [] + + a2Refactored <- doesFileExist "./test/testdata/LiftOneLevel/A2.refactored.hs" + a2Refactored `shouldBe` False + + -- --------------------------------- + + it "LiftOneLevel.liftToMod D3 C3 A3 8 6" $ do + r <- ct $ liftOneLevel defaultTestSettings testOptions "./LiftOneLevel/D3.hs" (8,6) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"LiftOneLevel/D3.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/D3.hs.expected" + "./test/testdata/LiftOneLevel/D3.refactored.hs" + diff `shouldBe` [] + + c3Refactored <- doesFileExist "./test/testdata/LiftOneLevel/C3.refactored.hs" + c3Refactored `shouldBe` False + + a3Refactored <- doesFileExist "./test/testdata/LiftOneLevel/A3.refactored.hs" + a3Refactored `shouldBe` False + + -- --------------------------------- + + it "LiftOneLevel WhereIn1 12 18" $ do + r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn1.hs" (12,18) + -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn1.hs" (12,18) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/WhereIn1.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/WhereIn1.hs.expected" + "./test/testdata/LiftOneLevel/WhereIn1.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "LiftOneLevel WhereIn6 13 29" $ do + r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn6.hs" (13,29) + -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn6.hs" (13,29) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/WhereIn6.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/WhereIn6.hs.expected" + "./test/testdata/LiftOneLevel/WhereIn6.refactored.hs" + diff `shouldBe` [] + + + -- --------------------------------- + + it "liftOneLevel WhereIn7 12 14" $ do + r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn7.hs" (12,14) + -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn7.hs" (12,14) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/WhereIn7.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/WhereIn7.hs.expected" + "./test/testdata/LiftOneLevel/WhereIn7.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "LiftOneLevel WhereIn8 8 11" $ do + r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn8.hs" (8,11) + -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn8.hs" (8,11) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/WhereIn8.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/WhereIn8.hs.expected" + "./test/testdata/LiftOneLevel/WhereIn8.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "LiftOneLevel LetIn1 11 22" $ do + r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn1.hs" (11,22) + -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn1.hs" (11,22) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/LetIn1.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/LetIn1.hs.expected" + "./test/testdata/LiftOneLevel/LetIn1.refactored.hs" + diff `shouldBe` [] + + + -- --------------------------------- + + it "LiftOneLevel LetIn2 11 22" $ do + r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn2.hs" (11,22) + -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn2.hs" (11,22) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/LetIn2.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/LetIn2.hs.expected" + "./test/testdata/LiftOneLevel/LetIn2.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "LiftOneLevel LetIn3 10 27" $ do + r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn3.hs" (10,27) + -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/LetIn3.hs" (10,27) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/LetIn3.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/LetIn3.hs.expected" + "./test/testdata/LiftOneLevel/LetIn3.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "LiftOneLevel PatBindIn3 11 15" $ do + r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/PatBindIn3.hs" (11,15) + -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/PatBindIn3.hs" (11,15) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/PatBindIn3.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/PatBindIn3.hs.expected" + "./test/testdata/LiftOneLevel/PatBindIn3.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "liftOneLevel CaseIn1 10 28" $ do + r <- liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/CaseIn1.hs" (10,28) + -- r <- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/CaseIn1.hs" (10,28) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/LiftOneLevel/CaseIn1.hs\"]" + diff <- compareFiles "./test/testdata/LiftOneLevel/CaseIn1.hs.expected" + "./test/testdata/LiftOneLevel/CaseIn1.refactored.hs" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "fails PatBindIn2 17 7" $ do + {- + res <- catchException (liftOneLevel defaultTestSettings testOptions Nothing "./test/testdata/LiftOneLevel/PatBindIn2.hs" (17,7)) + -- liftOneLevel logTestSettings testOptions Nothing "./test/testdata/LiftOneLevel/PatBindIn2.hs" (17,7) + (show res) `shouldBe` "Just \"Lifting this definition failed. This might be because that the definition to be lifted is defined in a class/instance declaration.\"" + -} + pending -- Not clear that this was covered in the original, will + -- come back to it + + -- ----------------------------------------------------------------- + + it "fails WhereIn2 8 18" $ do + res <- catchException (liftOneLevel defaultTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn2.hs" (8,18)) + -- liftOneLevel logTestSettings testOptions "./test/testdata/LiftOneLevel/WhereIn2.hs" (8,18) + (show res) `shouldBe` "Just \"The identifier(s): (sq, test/testdata/LiftOneLevel/WhereIn2.hs:8:18) will cause name clash/capture or ambiguity occurrence problem after lifting, please do renaming first!\"" + + +-- TODO: check that other declarations in a list that make use of the +-- one being lifted also have params changed. +{- original tests +TestCases{refactorCmd="liftOneLevel", +positive=[(["D1.hs","C1.hs","A1.hs"],["8","6"]), + (["D2.hs","C2.hs","A2.hs"],["8","6"]), + (["D3.hs","C3.hs","A3.hs"],["8","6"]), + (["WhereIn1.hs"],["12","18"]), + (["WhereIn6.hs"],["15","29"]), + (["WhereIn7.hs"],["12","14"]), + (["WhereIn8.hs"],["8","11"]), + (["LetIn1.hs"],["11","22"]), + (["LetIn2.hs"],["10","22"]), + (["LetIn3.hs"],["10","27"]), + (["PatBindIn3.hs"],["11","15"]), + (["CaseIn1.hs"],["10","28"])], +negative=[(["PatBindIn2.hs"],["17","7"]), + (["WhereIn2.hs"],["8","18"])] +} + + +-} + + -- ------------------------------------------------------------------- + + describe "demote" $ do + + it "notifies if no definition selected" $ do + -- res <- catchException (doDemote ["./test/testdata/MoveDef/Md1.hs","14","13"]) + res <- catchException (demote defaultTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (14,13)) + (show res) `shouldBe` "Just \"\\nInvalid cursor position!\"" + + it "will not demote if nowhere to go" $ do + res <- catchException (demote defaultTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (8,1)) + -- res <- demote logTestSettings testOptions "./test/testdata/MoveDef/Md1.hs" (8,1) + (show res) `shouldBe` "Just \"\\n Nowhere to demote this function!\\n\"" + + -- ----------------------------------------------------------------- + + it "demotes a definition from the top level 1" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/MoveDef/Demote.hs" (7,1) + -- r <- demote logTestSettings testOptions "./test/testdata/MoveDef/Demote.hs" (7,1) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/MoveDef/Demote.hs\"]" + diff <- compareFiles "./test/testdata/MoveDef/Demote.refactored.hs" + "./test/testdata/MoveDef/Demote.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "demotes a definition from the top level D1" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/D1.hs" (9,1) + -- r <- demote logTestSettings testOptions "./test/testdata/Demote/D1.hs" (9,1) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/D1.hs\"]" + diff <- compareFiles "./test/testdata/Demote/D1.refactored.hs" + "./test/testdata/Demote/D1.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "demotes WhereIn1 12 1" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn1.hs" (12,1) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn1.hs\"]" + diff <- compareFiles "./test/testdata/Demote/WhereIn1.refactored.hs" + "./test/testdata/Demote/WhereIn1.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "demotes WhereIn3 14 1" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn3.hs" (14,1) + -- r <- demote logTestSettings testOptions "./test/testdata/Demote/WhereIn3.hs" (14,1) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn3.hs\"]" + diff <- compareFiles "./test/testdata/Demote/WhereIn3.refactored.hs" + "./test/testdata/Demote/WhereIn3.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "demotes WhereIn4 14 1" $ do + -- r <- doDemote ["./test/testdata/Demote/WhereIn4.hs","14","1"] + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn4.hs" (14,1) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn4.hs\"]" + diff <- compareFiles "./test/testdata/Demote/WhereIn4.refactored.hs" + "./test/testdata/Demote/WhereIn4.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "demotes WhereIn5 14 1" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn5.hs" (14,1) + -- r <- demote logTestSettings testOptions "./test/testdata/Demote/WhereIn5.hs" (14,1) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn5.hs\"]" + diff <- compareFiles "./test/testdata/Demote/WhereIn5.refactored.hs" + "./test/testdata/Demote/WhereIn5.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "demotes WhereIn6 13 1" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn6.hs" (13,1) + -- r <- demote logTestSettings testOptions "./test/testdata/Demote/WhereIn6.hs" (13,1) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn6.hs\"]" + diff <- compareFiles "./test/testdata/Demote/WhereIn6.refactored.hs" + "./test/testdata/Demote/WhereIn6.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "demotes WhereIn7 13 1" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn7.hs" (13,1) + -- r <- demote logTestSettings testOptions "./test/testdata/Demote/WhereIn7.hs" (13,1) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/WhereIn7.hs\"]" + diff <- compareFiles "./test/testdata/Demote/WhereIn7.refactored.hs" + "./test/testdata/Demote/WhereIn7.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "demotes CaseIn1 16 1" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/CaseIn1.hs" (16,1) + -- r <- demote logTestSettings testOptions "./test/testdata/Demote/CaseIn1.hs" (16,1) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/CaseIn1.hs\"]" + diff <- compareFiles "./test/testdata/Demote/CaseIn1.refactored.hs" + "./test/testdata/Demote/CaseIn1.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "demotes LetIn1 12 22" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/LetIn1.hs" (12,22) + -- r <- demote logTestSettings testOptions "./test/testdata/Demote/LetIn1.hs" (12,22) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/LetIn1.hs\"]" + diff <- compareFiles "./test/testdata/Demote/LetIn1.refactored.hs" + "./test/testdata/Demote/LetIn1.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "demotes PatBindIn1 19 1" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/PatBindIn1.hs" (19,1) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/PatBindIn1.hs\"]" + diff <- compareFiles "./test/testdata/Demote/PatBindIn1.refactored.hs" + "./test/testdata/Demote/PatBindIn1.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "demotes D2 5 1 when not imported by other module" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/D2.hs" (5,1) + -- r <- demote logTestSettings testOptions "./test/testdata/Demote/D2.hs" (5,1) + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/D2.hs\"]" + diff <- compareFiles "./test/testdata/Demote/D2.refactored.hs" + "./test/testdata/Demote/D2.hs.expected" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "fails WhereIn2 14 1" $ do + -- res <- catchException (doDemote ["./test/testdata/Demote/WhereIn2.hs","14","1"]) + res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn2.hs" (14,1)) + -- demote (Just logSettings) testOptions Nothing "./test/testdata/Demote/WhereIn2.hs" (14,1) + (show res) `shouldBe` "Just \"\\n Nowhere to demote this function!\\n\"" + + -- ----------------------------------------------------------------- + + it "fails LetIn2 11 22" $ do + -- res <- catchException (doDemote ["./test/testdata/Demote/LetIn2.hs","11","22"]) + res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/LetIn2.hs" (11,22)) + (show res) `shouldBe` "Just \"This function can not be demoted as it is used in current level!\\n\"" + + -- ----------------------------------------------------------------- + + it "fails PatBindIn4 18 1" $ do + -- res <- catchException (doDemote ["./test/testdata/Demote/PatBindIn4.hs","18","1"]) + res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/PatBindIn4.hs" (18,1)) + -- (show res) `shouldBe` "Just \"\\n Nowhere to demote this function!\\n\"" + (show res) `shouldBe` "Just \"\\nThis function/pattern binding is used by more than one friend bindings\\n\"" + + -- ----------------------------------------------------------------- + + it "fails WhereIn8 16 1" $ do + -- res <- catchException (doDemote ["./test/testdata/Demote/WhereIn8.hs","16","1"]) + res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/WhereIn8.hs" (16,1)) + (show res) `shouldBe` "Just \"\\n Nowhere to demote this function!\\n\"" + + -- ----------------------------------------------------------------- + + it "fails D2 5 1" $ do + res <- catchException (ct $ demote defaultTestSettings testOptions "./Demote/D2.hs" (5,1)) + -- res <- catchException (ct $ demote logTestSettings testOptions "./Demote/D2.hs" (5,1)) + (show res) `shouldBe` "Just \"This definition can not be demoted, as it is used in the client module 'Demote.A2'!\"" + + -- ----------------------------------------------------------------- + + it "fails for re-export in client module" $ do + pending + + -- ----------------------------------------------------------------- + + it "fails D3 5 1" $ do + -- res <- catchException (doDemote ["./test/testdata/Demote/D3.hs","5","1"]) + res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/D3.hs" (5,1)) + (show res) `shouldBe` "Just \"This definition can not be demoted, as it is explicitly exported by the current module!\"" + + + +{- Original test cases. These files are now in testdata/Demote + +TestCases{refactorCmd="demote", +positive=[(["D1.hs","C1.hs","A1.hs"],["9","1"]), x + (["WhereIn1.hs"],["12","1"]), x + (["WhereIn3.hs"],["14","1"]), x + (["WhereIn4.hs"],["14","1"]), x + (["WhereIn5.hs"],["14","1"]), x + (["WhereIn6.hs"],["13","1"]), x + (["WhereIn7.hs"],["13","1"]), x + (["CaseIn1.hs"],["16","1"]), x + (["LetIn1.hs"],["12","22"]), x + (["PatBindIn1.hs"],["19","1"])], x +negative=[(["WhereIn2.hs"],["14","1"]), x + (["LetIn2.hs"],["11","22"]), x + (["PatBindIn4.hs"],["18","1"]), x + (["WhereIn8.hs"],["16","1"]), x + (["D2.hs","C2.hs","A2.hs"],["5","1"]), x + (["D3.hs"],["5","1"])] x +} +-} + + -- ----------------------------------------------------------------- + + it "fails MultiLeg.hs" $ do + res <- catchException (demote defaultTestSettings testOptions "./test/testdata/Demote/MultiLeg.hs" (14,1)) + -- demote logTestSettings testOptions "./test/testdata/Demote/MultiLeg.hs" (14,1) + (show res) `shouldBe` "Just \"\\nThis function/pattern binding is used by more than one friend bindings\\n\"" + + + -- ----------------------------------------------------------------- + + it "passes MultiLeg2.hs" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/MultiLeg2.hs" (14,1) + -- demote logTestSettings testOptions "./test/testdata/Demote/MultiLeg2.hs" (14,1) + + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/MultiLeg2.hs\"]" + diff <- compareFiles "./test/testdata/Demote/MultiLeg2.refactored.hs" + "./test/testdata/Demote/MultiLeg2.hs.expected" + diff `shouldBe` [] + + + -- ----------------------------------------------------------------- + + it "passes UsedAtLevel.hs" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/UsedAtLevel.hs" (19,12) + -- demote logTestSettings testOptions "./test/testdata/Demote/UsedAtLevel.hs" (19,12) + + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/UsedAtLevel.hs\"]" + diff <- compareFiles "./test/testdata/Demote/UsedAtLevel.refactored.hs" + "./test/testdata/Demote/UsedAtLevel.expected.hs" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "passes UsedAtLevel.hs2" $ do + r <- demote defaultTestSettings testOptions "./test/testdata/Demote/UsedAtLevel2.hs" (23,12) + -- demote logTestSettings testOptions "./test/testdata/Demote/UsedAtLevel2.hs" (23,12) + + r' <- mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"test/testdata/Demote/UsedAtLevel2.hs\"]" + diff <- compareFiles "./test/testdata/Demote/UsedAtLevel2.refactored.hs" + "./test/testdata/Demote/UsedAtLevel2.expected.hs" + diff `shouldBe` [] + + +-- --------------------------------------------------------------------- +-- Helper functions + diff --git a/test/RenamingSpec.hs b/test/RenamingSpec.hs new file mode 100644 --- /dev/null +++ b/test/RenamingSpec.hs @@ -0,0 +1,602 @@ +module RenamingSpec (main, spec) where + +import Test.Hspec + +import Language.Haskell.Refact.Refactoring.Renaming + +import TestUtils + +import System.Directory + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + + describe "Renaming" $ do + it "renames in D1 B1 C1 A1 6 6" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/D1.hs" "AnotherTree" (6,6) + -- r <- ct $ rename logTestSettings testOptions "./Renaming/D1.hs" "AnotherTree" (6,6) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "Renaming/D1.hs" + , "Renaming/A1.hs" + , "Renaming/B1.hs" + , "Renaming/C1.hs" + ] + + diffD <- ct $ compareFiles "./Renaming/D1.hs.expected" + "./Renaming/D1.refactored.hs" + diffD `shouldBe` [] + + diffC <- ct $ compareFiles "./Renaming/C1.hs.expected" + "./Renaming/C1.refactored.hs" + diffC `shouldBe` [] + + diffB <- ct $ compareFiles "./Renaming/B1.hs.expected" + "./Renaming/B1.refactored.hs" + diffB `shouldBe` [] + + diffA <- ct $ compareFiles "./Renaming/A1.hs.expected" + "./Renaming/A1.refactored.hs" + diffA `shouldBe` [] + + -- --------------------------------- + + it "renames in D2 B2 C2 A2 6 24" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/D2.hs" "SubTree" (6,24) + -- r <- ct $ rename logTestSettings testOptions "./Renaming/D2.hs" "SubTree" (6,24) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "Renaming/D2.hs" + , "Renaming/A2.hs" + , "Renaming/B2.hs" + , "Renaming/C2.hs" + ] + + diffD <- ct $ compareFiles "./Renaming/D2.hs.expected" + "./Renaming/D2.refactored.hs" + diffD `shouldBe` [] + + diffC <- ct $ compareFiles "./Renaming/C2.hs.expected" + "./Renaming/C2.refactored.hs" + diffC `shouldBe` [] + + diffB <- ct $ compareFiles "./Renaming/B2.hs.expected" + "./Renaming/B2.refactored.hs" + diffB `shouldBe` [] + + -- diffA <- ct $ compareFiles "./Renaming/A2.hs.expected" + -- "./Renaming/A2.refactored.hs" + -- diffA `shouldBe` [] + + -- --------------------------------- + + it "renames in D3 B3 C3 A3 12 7" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/D3.hs" "Same" (12,7) + -- r <- ct $ rename logTestSettings testOptions "./Renaming/D3.hs" "Same" (12,7) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "Renaming/D3.hs" + , "Renaming/A3.hs" + , "Renaming/B3.hs" + , "Renaming/C3.hs" + ] + + diffD <- ct $ compareFiles "./Renaming/D3.hs.expected" + "./Renaming/D3.refactored.hs" + diffD `shouldBe` [] + + diffC <- ct $ compareFiles "./Renaming/C3.hs.expected" + "./Renaming/C3.refactored.hs" + diffC `shouldBe` [] + + diffB <- ct $ compareFiles "./Renaming/B3.hs.expected" + "./Renaming/B3.refactored.hs" + diffB `shouldBe` [] + + -- diffA <- ct $ compareFiles "./Renaming/A3.hs.expected" + -- "./Renaming/A3.refactored.hs" + -- diffA `shouldBe` [] + + -- --------------------------------- + + it "renames in D4 B4 C4 A4 13 4" $ do + -- (["D4.hs","B4.hs","C4.hs","A4.hs"],["isSameOrNot","13","4"]), + r <- ct $ rename defaultTestSettings testOptions "./Renaming/D4.hs" "isSameOrNot" (13,4) + -- r <- ct $ rename logTestSettings testOptions "./Renaming/D4.hs" "isSameOrNot" (13,4) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "Renaming/D4.hs" + , "Renaming/A4.hs" + , "Renaming/B4.hs" + , "Renaming/C4.hs" + ] + + diffD <- ct $ compareFiles "./Renaming/D4.hs.expected" + "./Renaming/D4.refactored.hs" + diffD `shouldBe` [] + + diffC <- ct $ compareFiles "./Renaming/C4.hs.expected" + "./Renaming/C4.refactored.hs" + diffC `shouldBe` [] + + diffB <- ct $ compareFiles "./Renaming/B4.hs.expected" + "./Renaming/B4.refactored.hs" + diffB `shouldBe` [] + + diffA <- ct $ compareFiles "./Renaming/A4.hs.expected" + "./Renaming/A4.refactored.hs" + diffA `shouldBe` [] + + -- --------------------------------- + + it "renames in D5 B5 C5 A5 24 1" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/D5.hs" "sum" (24,1) + -- r <- ct $ rename logTestSettings testOptions "./Renaming/D5.hs" "sum" (24,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "Renaming/D5.hs" + , "Renaming/A5.hs" + , "Renaming/B5.hs" + , "Renaming/C5.hs" + ] + + diffD <- ct $ compareFiles "./Renaming/D5.hs.expected" + "./Renaming/D5.refactored.hs" + diffD `shouldBe` [] + + diffC <- ct $ compareFiles "./Renaming/C5.hs.expected" + "./Renaming/C5.refactored.hs" + diffC `shouldBe` [] + + diffB <- ct $ compareFiles "./Renaming/B5.hs.expected" + "./Renaming/B5.refactored.hs" + diffB `shouldBe` [] + + diffA <- ct $ compareFiles "./Renaming/A5.hs.expected" + "./Renaming/A5.refactored.hs" + diffA `shouldBe` [] + + -- --------------------------------- + + it "renames in D7 C7 10 1" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/D7.hs" "myFringe" (10,1) + -- r <- ct $ rename logTestSettings testOptions "./Renaming/D7.hs" "myFringe" (10,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` [ "Renaming/D7.hs" + , "Renaming/C7.hs" + ] + + diffD <- ct $ compareFiles "./Renaming/D7.hs.expected" + "./Renaming/D7.refactored.hs" + diffD `shouldBe` [] + + diffC <- ct $ compareFiles "./Renaming/C7.hs.expected" + "./Renaming/C7.refactored.hs" + diffC `shouldBe` [] + + + -- --------------------------------- + + it "renames in Field1 5 18" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/Field1.hs" "pointx1" (5,18) + -- r <- ct $ rename logTestSettings testOptions "./Renaming/Field1.hs" "pointx1" (5,18) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/Field1.hs" + ] + diff <- ct $ compareFiles "./Renaming/Field1.hs.expected" + "./Renaming/Field1.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in Field3 9 1" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/Field3.hs" "abs" (9,1) + -- r <- ct $ rename logTestSettings testOptions "./Renaming/Field3.hs" "abs" (9,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/Field3.hs" + ] + diff <- ct $ compareFiles "./Renaming/Field3.hs.expected" + "./Renaming/Field3.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in Field4 5 23" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/Field4.hs" "value2" (5,23) + -- ct $ rename logTestSettings Nothing "./Renaming/Field4.hs" "value2" (5,23) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/Field4.hs" + ] + diff <- ct $ compareFiles "./Renaming/Field4.hs.expected" + "./Renaming/Field4.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in IdIn1 11 1" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/IdIn1.hs" "x1" (11,1) + -- ct $ rename logTestSettings testOptions "./Renaming/IdIn1.hs" "x1" (11,1) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/IdIn1.hs" + ] + diff <- ct $ compareFiles "./Renaming/IdIn1.hs.expected" + "./Renaming/IdIn1.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in IdIn2 15 7" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/IdIn2.hs" "x1" (15,7) + -- r <- ct $ rename logTestSettings testOptions "./Renaming/IdIn2.hs" "x1" (15,7) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/IdIn2.hs" + ] + diff <- ct $ compareFiles "./Renaming/IdIn2.hs.expected" + "./Renaming/IdIn2.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in ClassIn1 7 7" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/ClassIn1.hs" "MyReversable" (7,7) + -- ct $ rename logTestSettings testOptions Nothing "./Renaming/ClassIn1.hs" "MyReversable" (7,7) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/ClassIn1.hs" + ] + diff <- ct $ compareFiles "./Renaming/ClassIn1.hs.expected" + "./Renaming/ClassIn1.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in ClassIn2 8 3" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/ClassIn2.hs" "reversable" (8,3) + -- ct $ rename logTestSettings testOptions Nothing "./Renaming/ClassIn2.hs" "reversable" (8,3) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/ClassIn2.hs" + ] + diff <- ct $ compareFiles "./Renaming/ClassIn2.hs.expected" + "./Renaming/ClassIn2.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in ConstructorIn1 8 6" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/ConstructorIn1.hs" "MyBTree" (8,6) + -- ct $ rename logTestSettings testOptions "./Renaming/ConstructorIn1.hs" "MyBTree" (8,6) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/ConstructorIn1.hs" + ] + diff <- ct $ compareFiles "./Renaming/ConstructorIn1.hs.expected" + "./Renaming/ConstructorIn1.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in ConstructorIn2 8 6" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/ConstructorIn2.hs" "Tree" (8,24) + -- ct $ rename logTestSettings testOptions Nothing "./Renaming/ConstructorIn2.hs" "Tree" (8,24) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/ConstructorIn2.hs" + ] + diff <- ct $ compareFiles "./Renaming/ConstructorIn2.hs.expected" + "./Renaming/ConstructorIn2.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in ConstructorIn3 9 12" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/ConstructorIn3.hs" "b" (9,13) + -- ct $ rename logTestSettings testOptions Nothing "./Renaming/ConstructorIn3.hs" "b" (9,13) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/ConstructorIn3.hs" + ] + diff <- ct $ compareFiles "./Renaming/ConstructorIn3.hs.expected" + "./Renaming/ConstructorIn3.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in LayoutIn1 7 17" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/LayoutIn1.hs" "square" (7,17) + -- ct $ rename logTestSettings testOptions "./Renaming/LayoutIn1.hs" "square" (7,17) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/LayoutIn1.hs" + ] + diff <- ct $ compareFiles "./Renaming/LayoutIn1.hs.expected" + "./Renaming/LayoutIn1.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in LayoutIn2 8 7" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/LayoutIn2.hs" "ls" (8,7) + -- ct $ rename logTestSettings testOptions Nothing "./Renaming/LayoutIn2.hs" "ls" (8,7) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/LayoutIn2.hs" + ] + diff <- ct $ compareFiles "./Renaming/LayoutIn2.hs.expected" + "./Renaming/LayoutIn2.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in LayoutIn3 7 13" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/LayoutIn3.hs" "anotherX" (7,13) + -- ct $ rename logTestSettings testOptions "./Renaming/LayoutIn3.hs" "anotherX" (7,13) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/LayoutIn3.hs" + ] + diff <- ct $ compareFiles "./Renaming/LayoutIn3.hs.expected" + "./Renaming/LayoutIn3.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in LayoutIn4 7 8" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/LayoutIn4.hs" "io" (7,8) + -- ct $ rename logTestSettings testOptions "./Renaming/LayoutIn4.hs" "io" (7,8) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/LayoutIn4.hs" + ] + diff <- ct $ compareFiles "./Renaming/LayoutIn4.hs.expected" + "./Renaming/LayoutIn4.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + -- Negative tests + -- --------------------------------- + + it "naming clash at top level IdIn3" $ do + -- rename logTestSettings testOptions Nothing "./Renaming/IdIn3.hs" "foo" (10,1) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/IdIn3.hs" "foo" (10,1)) + (show res) `shouldBe` "Just \"Name 'foo' already existed\\n\"" + + -- --------------------------------- + + it "upper case name for fn fails IdIn4" $ do + -- rename logTestSettings testOptions Nothing "./Renaming/IdIn4.hs" "Foo" (12,1) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/IdIn4.hs" "Foo" (12,1)) + (show res) `shouldBe` "Just \"The new name should be an identifier!\"" + + -- --------------------------------- + + it "naming clash IdIn5" $ do + -- rename logTestSettings testOptions "./Renaming/IdIn5.hs" "y" (10,1) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/IdIn5.hs" "y" (10,1)) + (show res) `shouldBe` "Just \"Name 'y' already existed, or rename 'IdIn5.x' to 'y' will change the program's semantics!\\n\"" + + -- --------------------------------- + + it "must rename in home module ClassIn3" $ do + -- rename logTestSettings testOptions Nothing "./Renaming/ClassIn3.hs" "Eq1" (16,10) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/ClassIn3.hs" "Eq1" (16,10)) + (show res) `shouldBe` "Just \"This identifier is defined in module GHC.Classes, please do renaming in that module!\"" + + -- --------------------------------- + + it "will not rename existing name Field2" $ do + -- rename logTestSettings testOptions Nothing "./Renaming/Field2.hs" "absPoint" (5,18) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/Field2.hs" "absPoint" (5,18)) + (show res) `shouldBe` "Just \"Name 'absPoint' already existed\\n\"" + + -- --------------------------------- + + it "must qualify clashes Qualifier" $ do + -- rename logTestSettings testOptions "./Renaming/Qualifier.hs" "sum" (13,1) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/Qualifier.hs" "sum" (13,1)) + (show res) `shouldBe` "Just \"The new name will cause ambiguous occurrence problem, please select another new name or qualify the use of ' sum' before renaming!\\n\"" + + -- --------------------------------- + + it "cannot rename main Main" $ do + -- rename logTestSettings testOptions Nothing "./Renaming/Main.hs" "main1" (11,1) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/Main.hs" "main1" (11,1)) + (show res) `shouldBe` "Just \"The 'main' function defined in a 'Main' module should not be renamed!\"" + + -- --------------------------------- + + it "cannot rename main Main2" $ do + -- res <- catchException (ct $ rename logTestSettings testOptions "./Renaming/Main2.hs" "main1" (4,1)) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/Main2.hs" "main1" (4,1)) + (show res) `shouldBe` "Just \"The 'main' function defined in a 'Main' module should not be renamed!\"" + + -- --------------------------------- + + it "rename with default main Main2" $ do + -- ct $ rename logTestSettings testOptions Nothing "./Renaming/Main2.hs" "baz" (6,1) + r <- ct $ rename defaultTestSettings testOptions "./Renaming/Main2.hs" "baz" (6,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/Main2.hs" + ] + diff <- ct $ compareFiles "./Renaming/Main2.hs.expected" + "./Renaming/Main2.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "rename in a do statement" $ do + -- ct $ rename logTestSettings testOptions "./Layout/Do1.hs" "g2" (10,3) + r <- ct $ rename defaultTestSettings testOptions "./Layout/Do1.hs" "g2" (10,3) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Layout/Do1.hs" + ] + diff <- ct $ compareFiles "./Layout/Do1.hs.expected" + "./Layout/Do1.refactored.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "renames in QualServer QualClient" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/QualServer.hs" "foo1" (11,1) + -- r <- ct $ rename logTestSettings testOptions "./Renaming/QualServer.hs" "foo1" (11,1) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` ["Renaming/QualServer.hs", + "Renaming/QualClient.hs" + ] + + diffD <- ct $ compareFiles "./Renaming/QualServer.expected.hs" + "./Renaming/QualServer.refactored.hs" + diffD `shouldBe` [] + + diffC <- ct $ compareFiles "./Renaming/QualClient.expected.hs" + "./Renaming/QualClient.refactored.hs" + diffC `shouldBe` [] + + -- --------------------------------- + + it "renames in lib and in main 1" $ do + let ct4 = cdAndDo "./test/testdata/cabal/cabal4" + r <- ct4 $ rename defaultTestSettings testOptions "./src/Foo/Bar.hs" "baz1" (3,1) + -- r <- cdAndDo "./test/testdata/cabal/cabal4" $ rename logTestSettings testOptions "./src/Foo/Bar.hs" "baz1" (3,1) + + r' <- ct4 $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` ["src/Foo/Bar.hs", + "src/main4.hs" + ] + + diffD <- ct4 $ compareFiles "./src/Foo/Bar.expected.hs" + "./src/Foo/Bar.refactored.hs" + diffD `shouldBe` [] + + diffC <- ct4 $ compareFiles "./src/main4.expected.hs" + "./src/main4.refactored.hs" + diffC `shouldBe` [] + + -- --------------------------------- + + it "renames in lib and in main 2" $ do + let ctf = cdAndDo "./test/testdata/cabal/foo" + r <- ctf $ rename defaultTestSettings testOptions "./src/Foo/Bar.hs" "bar1" (3,1) + -- r <- cdAndDo "./test/testdata/cabal/foo" $ rename logTestSettings testOptions "./src/Foo/Bar.hs" "bar1" (3,1) + + r' <- ctf $ mapM makeRelativeToCurrentDirectory r + + r' `shouldBe` ["src/Foo/Bar.hs", + "src/Main.hs" + ] + + diffD <- ctf $ compareFiles "./src/Foo/Bar.expected.hs" + "./src/Foo/Bar.refactored.hs" + diffD `shouldBe` [] + + diffC <- ctf $ compareFiles "./src/Main.expected.hs" + "./src/Main.refactored.hs" + diffC `shouldBe` [] + + -- --------------------------------- + +{- + it "rename gives noRebindableInfo MoveDef" $ do + -- ct $ rename logTestSettings testOptions "./src/Language/Haskell/Refact/MoveDef.hs" "t2" (1105,20) + r <- ct $ rename defaultTestSettings (testOptions { cradleCabalDir = Just ".", cradleCabalFile = Just "HaRe.cabal"}) "./src/Language/Haskell/Refact/MoveDef.hs" "t2" (1105,20) + + r `shouldBe` [ "Renaming/Main2.hs" + ] + diff <- ct $ compareFiles "./Renaming/Main2.hs.expected" + "./Renaming/Main2.refactored.hs" + diff `shouldBe` [] +-} + + -- --------------------------------- + + it "ConflictExports" $ do + -- rename (logTestSettingsMainfile "./Renaming/ConflictExport.hs") testOptions "./Renaming/ConflictExport.hs" "fringe" (7,1) + res <- catchException (ct $ rename defaultTestSettings testOptions "./Renaming/ConflictExport.hs" "fringe" (7,1)) + -- res <- catchException (ct $ rename (testSettingsMainfile "./Renaming/ConflictExport.hs") testOptions "./Renaming/ConflictExport.hs" "fringe" (7,1)) + (show res) `shouldBe` "Just \"The new name will cause conflicting exports, please select another new name!\"" + +{- +TestCases{refactorCmd="rename", +positive=[ + (["D1.hs","B1.hs","C1.hs","A1.hs"],["AnotherTree", "6", "6"]), + (["D2.hs","B2.hs","C2.hs","A2.hs"],["SubTree" , "6", "24"]), + (["D3.hs","B3.hs","C3.hs","A3.hs"],["Same","12","7"]), + (["D4.hs","B4.hs","C4.hs","A4.hs"],["isSameOrNot","13","4"]), + (["D5.hs","B5.hs","C5.hs","A5.hs"],["sum","24","1"]), + (["D7.hs","C7.hs"],["myFringe","10","1"]), + (["Field1.hs"],["pointx1","5","18"]), + (["Field3.hs"],["abs", "9","1"]), + (["Field4.hs"],["value2","5","23"]), + (["IdIn1.hs"],["x1","11","1"]), + (["IdIn2.hs"],["x1","15","7"]), + (["ClassIn1.hs"],["MyReversable","7","7"]), + (["ClassIn2.hs"],["reversable","8","3"]), + (["ConstructorIn1.hs"],["MyBTree","8","6"]), + (["ConstructorIn2.hs"],["Tree","8","24"]), + (["ConstructorIn3.hs"],["b","9","12"]), + (["LayoutIn1.hs"],["square","7","17"]), + (["LayoutIn2.hs"],["ls","8","7"]), + (["LayoutIn3.hs"],["anotherX","7","13"]), + (["LayoutIn4.hs"],["io","7","8"])], +negative=[(["IdIn3.hs"],["foo","10","1"]), + (["IdIn4.hs"],["Foo","12","1"]), + (["IdIn5.hs"],["y","10","1"]), + (["ClassIn3.hs"],["Eq1","16","10"]), + (["Field2.hs"], ["absPoint", "5", "18"]), + (["Qualifier.hs"],["sum","13","1"]), + (["Main.hs"],["main1", "11","1"]), + (["ConflictExport.hs","D6.hs"],["fringe","7","1"])] +} +-} + + -- --------------------------------- + + it "rename preserving layout Utils.hs" $ do + -- ct $ rename logTestSettings testOptions "./Renaming/Utils.hs" "parsed1" (5,11) + r <- ct $ rename defaultTestSettings testOptions "./Renaming/Utils.hs" "parsed1" (5,11) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` [ "Renaming/Utils.hs" + ] + diff <- ct $ compareFiles "./Renaming/Utils.expected.hs" + "./Renaming/Utils.refactored.hs" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "passes RenameInExportedType.hs 1" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/RenameInExportedType.hs" "NewType" (6,6) + -- ct $ rename logTestSettings testOptions "./Renaming/RenameInExportedType.hs" "NewType" (6,6) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"Renaming/RenameInExportedType.hs\"]" + diff <- ct $ compareFiles "./Renaming/RenameInExportedType.refactored.hs" + "./Renaming/RenameInExportedType.expected.hs" + diff `shouldBe` [] + + -- ----------------------------------------------------------------- + + it "passes RenameInExportedType2.hs" $ do + r <- ct $ rename defaultTestSettings testOptions "./Renaming/RenameInExportedType2.hs" "NewType" (6,24) + -- ct $ rename logTestSettings testOptions "./Renaming/RenameInExportedType2.hs" "NewType" (6,24) + + r' <- ct $ mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"Renaming/RenameInExportedType2.hs\"]" + diff <- ct $ compareFiles "./Renaming/RenameInExportedType2.refactored.hs" + "./Renaming/RenameInExportedType2.expected.hs" + diff `shouldBe` [] + + + +-- --------------------------------------------------------------------- +-- Helper functions diff --git a/test/RoundTripSpec.hs b/test/RoundTripSpec.hs new file mode 100644 --- /dev/null +++ b/test/RoundTripSpec.hs @@ -0,0 +1,62 @@ +module RoundTripSpec (main, spec) where + +import Test.Hspec + +import Language.Haskell.Refact.Refactoring.RoundTrip + +import TestUtils + +import System.Directory + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + describe "roundtrip" $ do + it "roundtrips B" $ do + r <- ct $ roundTrip defaultTestSettings testOptions "Case/BSimpleExpected.hs" + -- r <- ct $ roundTrip logTestSettings testOptions "Case/BSimpleExpected.hs" + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Case/BSimpleExpected.hs"] + diff <- compareFiles "./test/testdata/Case/BSimpleExpected.refactored.hs" + "./test/testdata/Case/BSimpleExpected.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "roundtrips FooExpected" $ do + r <- ct $ roundTrip defaultTestSettings testOptions "Case/FooExpected.hs" + -- r <- ct $ roundTrip logTestSettings testOptions "Case/FooExpected.hs" + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Case/FooExpected.hs"] + diff <- compareFiles "./test/testdata/Case/FooExpected.refactored.hs" + "./test/testdata/Case/FooExpected.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "roundtrips FExpected" $ do + r <- ct $ roundTrip defaultTestSettings testOptions "Case/FExpected.hs" + -- r <- ct $ roundTrip logTestSettings testOptions "Case/FExpected.hs" + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Case/FExpected.hs"] + diff <- compareFiles "./test/testdata/Case/FExpected.refactored.hs" + "./test/testdata/Case/FExpected.hs" + diff `shouldBe` [] + + -- --------------------------------- + + it "roundtrips CExpected" $ do + r <- ct $ roundTrip defaultTestSettings testOptions "Case/CExpected.hs" + -- r <- ct $ roundTrip logTestSettings testOptions "Case/CExpected.hs" + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Case/CExpected.hs"] + diff <- compareFiles "./test/testdata/Case/CExpected.refactored.hs" + "./test/testdata/Case/CExpected.hs" + diff `shouldBe` [] + +-- --------------------------------------------------------------------- diff --git a/test/SimpleSpec.hs b/test/SimpleSpec.hs new file mode 100644 --- /dev/null +++ b/test/SimpleSpec.hs @@ -0,0 +1,25 @@ +module SimpleSpec (main, spec) where + +import Test.Hspec + +import Language.Haskell.Refact.Refactoring.Simple + +import TestUtils + +import System.Directory + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + describe "removeBrackets" $ do + it "Removes redundent brackets around a simple expression A.hs" $ do + r <- ct $ removeBracket defaultTestSettings testOptions "Simple/A.hs" (4,7) (4,11) + -- r <- ct $ removeBracket logTestSettings testOptions "Simple/A.hs" (4,7) (4,11) + r' <- ct $ mapM makeRelativeToCurrentDirectory r + r' `shouldBe` ["Simple/A.hs"] + diff <- compareFiles "./test/testdata/Simple/A.refactored.hs" + "./test/testdata/Simple/A.hs.expected" + diff `shouldBe` [] diff --git a/test/SwapArgsSpec.hs b/test/SwapArgsSpec.hs new file mode 100644 --- /dev/null +++ b/test/SwapArgsSpec.hs @@ -0,0 +1,47 @@ +module SwapArgsSpec (main, spec) where + +import Test.Hspec + +-- import qualified GHC as GHC +-- import qualified GhcMonad as GHC +-- import qualified RdrName as GHC +-- import qualified SrcLoc as GHC + +import Language.Haskell.Refact.Refactoring.SwapArgs + +import TestUtils + +import System.Directory + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + -- setLogger + hspec spec + +spec :: Spec +spec = do + + describe "swapArgs" $ do + it "checks for that an identifier is selected" $ do + res <- catchException (swapArgs defaultTestSettings testOptions ["./test/testdata/SwapArgs/B.hs","4","1"]) + -- let res = "foo" + (show res) `shouldBe` "Just \"Incorrect identifier selected!\"" + + + it "swaps arguments for a definition at the top level" $ do + r <- ct $ swapArgs defaultTestSettings testOptions ["./SwapArgs/B.hs","9","1"] + -- r <- ct $ swapArgs logTestSettings testOptions ["./SwapArgs/B.hs","9","1"] + r' <- ct $ mapM makeRelativeToCurrentDirectory r + (show r') `shouldBe` "[\"SwapArgs/B.hs\"]" + pendingWith "need to complete this" + -- diff <- compareFiles "./test/testdata/SwapArgs/B.refactored.hs" + -- "./test/testdata/SwapArgs/B.hs.expected" + -- diff `shouldBe` [] + + + +-- --------------------------------------------------------------------- +-- Helper functions + diff --git a/test/TestUtils.hs b/test/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils.hs @@ -0,0 +1,394 @@ +module TestUtils + ( compareFiles + , compareStrings + , parsedFileGhc + , parsedFileGhcCd + , parseSourceFileTest + , runLogTestGhc + , runTestGhc + , runRefactGhcState + , runRefactGhcStateLog + , initialState + , initialLogOnState + , showAnnDataFromState + , showAnnDataItemFromState + , showAnnsFromState + , exactPrintFromState + , sourceFromState + , annsFromState + , defaultTestSettings + , logTestSettings + , testOptions + , catchException + , mkTokenCache + , hex + , unspace + , mkTestGhcName + , setLogger + , cdAndDo + , ct + , pwd + , cd + , parseToAnnotated + , parseDeclToAnnotated + , ss2span + , PosToken + ) where + + +import qualified FastString as GHC +import qualified GHC as GHC +import qualified Name as GHC +-- import qualified Outputable as GHC +import qualified Unique as GHC + +import Control.Monad.State +import Data.Algorithm.Diff +import Data.Data +import Exception +import Language.Haskell.GHC.ExactPrint +import Language.Haskell.GHC.ExactPrint.Annotate +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils +import qualified Language.Haskell.GhcMod as GM +import qualified Language.Haskell.GhcMod.Types as GM +import Language.Haskell.Refact.Utils.GhcBugWorkArounds +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions +import Language.Haskell.Refact.Utils.Types +import Language.Haskell.Refact.Utils.Utils +import Numeric +import System.Directory +import System.Log.Handler.Simple +import System.Log.Logger + +import qualified Data.Map as Map +-- import Control.Monad.IO.Class + +-- --------------------------------------------------------------------- + +type PosToken = (GHC.Located GHC.Token, String) + +pwd :: IO FilePath +pwd = getCurrentDirectory + +cd :: FilePath -> IO () +cd = setCurrentDirectory + +-- --------------------------------------------------------------------- + +hex :: Int -> String +hex v = "0x" ++ showHex v "" + +-- --------------------------------------------------------------------- + +compareFiles :: FilePath -> FilePath -> IO [Diff [String]] +compareFiles fileA fileB = do + astr <- readFile fileA + bstr <- readFile fileB + -- return $ filter (\c -> not( isBoth c)) $ getGroupedDiff (lines astr) (lines bstr) + return $ compareStrings astr bstr + +compareStrings :: String -> String -> [Diff [String]] +compareStrings astr bstr = filter (\c -> not( isBoth c)) $ getGroupedDiff (lines astr) (lines bstr) + where + isBoth (Both _ _) = True + isBoth _ = False + +-- --------------------------------------------------------------------- + +parsedFileGhc :: String -> IO ParseResult +parsedFileGhc fileName = do + let + comp = do + -- logm $ "parsedFileGhc:fileName" ++ show fileName + res <- parseSourceFileTest fileName + -- logm $ "parsedFileGhc:done" + return res + (parseResult,_s) <- runRefactGhcStateLog comp Normal + -- (parseResult,_s) <- runRefactGhcStateLog comp fileName Debug + return parseResult + +-- --------------------------------------------------------------------- + +parsedFileGhcCd :: FilePath -> FilePath -> IO ParseResult +parsedFileGhcCd path fileName = do + old <- getCurrentDirectory + let + comp = do + res <- parseSourceFileTest fileName + return res + newDir = setCurrentDirectory path + oldDir _ = setCurrentDirectory old + (parseResult,_s) <- GHC.gbracket newDir oldDir $ \_ -> runRefactGhcState comp + return parseResult + +-- --------------------------------------------------------------------- + +ct :: IO a -> IO a +ct = cdAndDo "./test/testdata/" + +cdAndDo :: FilePath -> IO a -> IO a +cdAndDo path fn = do + old <- getCurrentDirectory + r <- GHC.gbracket (setCurrentDirectory path) (\_ -> setCurrentDirectory old) + $ \_ -> fn + return r + +-- --------------------------------------------------------------------- + +parseSourceFileTest :: FilePath -> RefactGhc ParseResult +parseSourceFileTest fileName = do + parseSourceFileGhc fileName -- Load the file first + getTypecheckedModule + +-- --------------------------------------------------------------------- + +initialState :: RefactState +initialState = RefSt + { rsSettings = defaultTestSettings + , rsUniqState = 1 + , rsSrcSpanCol = 1 + , rsFlags = RefFlags False + , rsStorage = StorageNone + , rsCurrentTarget = Nothing + , rsModule = Nothing + } + +-- --------------------------------------------------------------------- + +initialLogOnState :: RefactState +initialLogOnState = RefSt + { rsSettings = logTestSettings + , rsUniqState = 1 + , rsSrcSpanCol = 1 + , rsFlags = RefFlags False + , rsStorage = StorageNone + , rsCurrentTarget = Nothing + , rsModule = Nothing + } + +-- --------------------------------------------------------------------- + +mkTokenCache :: a -> TokenCache a +mkTokenCache forest = TK (Map.fromList [((TId 0),forest)]) (TId 0) + +-- --------------------------------------------------------------------- + +runTestInternal :: RefactGhc a -> RefactState -> GM.Options + -> IO (a, RefactState) +runTestInternal comp st opts = + runRefactGhc comp st opts + +-- --------------------------------------------------------------------- + +runLogTestGhc :: RefactGhc a -> IO (a, RefactState) +runLogTestGhc comp = + runTestInternal comp initialLogOnState testOptions + +-- --------------------------------------------------------------------- + +runTestGhc :: RefactGhc a -> IO (a, RefactState) +runTestGhc comp = do + runTestInternal comp initialState testOptions + +-- --------------------------------------------------------------------- + +runRefactGhcState :: RefactGhc t -> IO (t, RefactState) +runRefactGhcState comp = runRefactGhcStateLog comp Normal + +-- --------------------------------------------------------------------- + +runRefactGhcStateLog :: RefactGhc t -> VerboseLevel -> IO (t, RefactState) +runRefactGhcStateLog comp logOn = do + let + initState = RefSt + { rsSettings = defaultTestSettings { rsetVerboseLevel = logOn } + , rsUniqState = 1 + , rsSrcSpanCol = 1 + , rsFlags = RefFlags False + , rsStorage = StorageNone + , rsCurrentTarget = Nothing + , rsModule = Nothing + } + -- putStrLn $ "runRefactGhcStateLog:initState=" ++ show initState + -- putStrLn $ "runRefactGhcStateLog:testOptions=" ++ show testOptions + runTestInternal comp initState testOptions + +-- --------------------------------------------------------------------- + +testOptions :: GM.Options +-- testOptions = GM.defaultOptions { GM.ooptLogLevel = GM.GmError } +testOptions = GM.defaultOptions { + GM.optOutput = GM.OutputOpts { + GM.ooptLogLevel = GM.GmError + -- GM.ooptLogLevel = GM.GmVomit + , GM.ooptStyle = GM.PlainStyle + , GM.ooptLineSeparator = GM.LineSeparator "\0" + , GM.ooptLinePrefix = Nothing + } + + } + +-- --------------------------------------------------------------------- + +defaultTestSettings :: RefactSettings +defaultTestSettings = defaultSettings { rsetVerboseLevel = Normal } + +logTestSettings :: RefactSettings +logTestSettings = defaultSettings { rsetVerboseLevel = Debug } + +-- --------------------------------------------------------------------- + +catchException :: (IO t) -> IO (Maybe String) +catchException f = do + res <- handle handler (f >> return Nothing) + return res + where + handler:: SomeException -> IO (Maybe String) + handler e = return (Just (show e)) + +-- --------------------------------------------------------------------- + +showAnnDataFromState :: RefactState -> String +showAnnDataFromState st = + case rsModule st of + Just tm -> r + where + anns = tkCache (rsTokenCache tm) Map.! mainTid + parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module + $ rsTypecheckedMod tm + r = showAnnData anns 0 parsed + Nothing -> [] + +-- --------------------------------------------------------------------- + +showAnnDataItemFromState :: (Data a) => RefactState -> a -> String +showAnnDataItemFromState st t = + case rsModule st of + Just tm -> r + where + anns = tkCache (rsTokenCache tm) Map.! mainTid + r = showAnnData anns 0 t + Nothing -> [] + +-- --------------------------------------------------------------------- + +showAnnsFromState :: RefactState -> String +showAnnsFromState st = + case rsModule st of + Just tm -> r + where + anns = tkCache (rsTokenCache tm) Map.! mainTid + r = showGhc anns + Nothing -> [] + +-- --------------------------------------------------------------------- + +exactPrintFromState :: (Annotate a) => RefactState -> GHC.Located a -> String +exactPrintFromState st ast = + case rsModule st of + Just tm -> r + where + -- anns = tkCache (rsTokenCache tm) Map.! mainTid + anns = case Map.lookup mainTid (tkCache (rsTokenCache tm)) of + Just a -> a + Nothing -> error $ "exactPrintFromState:mainTid not found" + r = exactPrint ast anns + Nothing -> [] + +-- --------------------------------------------------------------------- + +sourceFromState :: RefactState -> String +sourceFromState st = + case rsModule st of + Just tm -> r + where + anns = tkCache (rsTokenCache tm) Map.! mainTid + parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module + $ rsTypecheckedMod tm + r = exactPrint parsed anns + Nothing -> [] + +-- --------------------------------------------------------------------- + +annsFromState :: RefactState -> Anns +annsFromState st = + case rsModule st of + Just tm -> tkCache (rsTokenCache tm) Map.! mainTid + Nothing -> error $ "annsFromState: no rsModule" + +-- --------------------------------------------------------------------- + +setLogger :: IO () +setLogger = do + {- + h <- fileHandler "debug.log" DEBUG >>= \lh -> return $ + setFormatter lh (simpleLogFormatter "[$time : $loggername : $prio] $msg") + updateGlobalLogger "MyApp.BuggyComponent" (addHandler h) + -} + + -- s <- streamHandler stdout DEBUG + h <- fileHandler "debug.log" DEBUG + updateGlobalLogger rootLoggerName (setHandlers [h]) + +-- --------------------------------------------------------------------- + +-- |Convert any sequence of more than one space to a single space +unspace :: String -> String +unspace str = go [] str + where + go acc [] = acc + go acc [x] = acc ++ [x] + go acc (' ':' ':xs) = go acc (' ':xs) + go acc (x:xs) = go (acc++[x]) xs + +-- --------------------------------------------------------------------- + +mkTestGhcName :: Int -> Maybe GHC.Module -> String -> GHC.Name +mkTestGhcName u maybeMod name = n + where + un = GHC.mkUnique 'H' (u+1) -- H for HaRe :) + n = case maybeMod of + Nothing -> GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc name) + Just modu -> GHC.mkExternalName un modu (GHC.mkVarOcc name) nullSrcSpan + +nullSrcSpan :: GHC.SrcSpan +nullSrcSpan = GHC.UnhelpfulSpan $ GHC.mkFastString "HaRe nullSrcSpan" + +-- --------------------------------------------------------------------- + +parseToAnnotated :: (Show a, Annotate ast) + => GHC.DynFlags + -> FilePath + -> (GHC.DynFlags -> FilePath -> String -> Either a (Anns, GHC.Located ast)) + -> String + -> (GHC.Located ast, Anns) +parseToAnnotated df fp parser src = (ast,anns) + where + (anns, ast) = case (parser df fp src) of + Right xs -> xs + Left err -> error (show err) + +-- --------------------------------------------------------------------- + +parseDeclToAnnotated :: + GHC.DynFlags + -> FilePath + -- -> (GHC.DynFlags -> FilePath -> String -> Either a (Anns, GHC.Located ast)) + -> String + -> (GHC.LHsDecl GHC.RdrName, Anns) +parseDeclToAnnotated df fp src = (ast,anns) + where + (anns, ast) = case (parseDecl df fp src) of + Right xs -> xs + Left err -> error (show err) + +-- --------------------------------------------------------------------- + +ss2span :: GHC.SrcSpan -> (Pos,Pos) +ss2span ss = (ss2pos ss,ss2posEnd ss) + +-- --------------------------------------------------------------------- +-- EOF diff --git a/test/TypeUtilsSpec.hs b/test/TypeUtilsSpec.hs new file mode 100644 --- /dev/null +++ b/test/TypeUtilsSpec.hs @@ -0,0 +1,3807 @@ +module TypeUtilsSpec (main, spec) where + +import Test.Hspec + +import TestUtils + +import qualified GHC.SYB.Utils as SYB + +import qualified GHC as GHC +import qualified GhcMonad as GHC +import qualified Name as GHC +import qualified RdrName as GHC +import qualified Module as GHC + +import Data.Maybe + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Parsers +import Language.Haskell.GHC.ExactPrint + +import Language.Haskell.Refact.Utils.Binds +import Language.Haskell.Refact.Utils.GhcVersionSpecific +import Language.Haskell.Refact.Utils.LocUtils +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions +import Language.Haskell.Refact.Utils.TypeUtils +import Language.Haskell.Refact.Utils.Utils +import Language.Haskell.Refact.Utils.Variables + +import qualified Data.Map as Map +import Data.List + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + + -- ------------------------------------------------------------------- + + describe "findAllNameOccurences" $ do + it "finds all occurrences of the given name in a syntax phrase" $ do + t <- ct $ parsedFileGhc "./TypeUtils/S.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just ((GHC.L _l n)) = locToName (4,5) renamed + (showGhcQual n) `shouldBe` "x" + + let res = findAllNameOccurences n renamed + (showGhcQual res) `shouldBe` "[x, x]" + -- NOTE: does not get the x's in line 8 + (showGhcQual $ map startEndLocGhc res) `shouldBe` "[((4, 5), (4, 6)), ((4, 17), (4, 18))]" + + -- ------------------------------------------------------------------- + + describe "locToName" $ do + it "returns a GHC.Name for a given source location, if it falls anywhere in an identifier #1" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (res@(GHC.L l n)) = locToName (7,3) renamed + showGhcQual l `shouldBe` "TypeUtils/B.hs:7:1-3" + getLocatedStart res `shouldBe` (7,1) + showGhcQual n `shouldBe` "TypeUtils.B.foo" + + -- --------------------------------- + + it "returns a GHC.Name for a given source location, if it falls anywhere in an identifier #2" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (res@(GHC.L l n)) = locToName (25,8) renamed + showGhcQual n `shouldBe` "TypeUtils.B.bob" + showGhcQual l `shouldBe` "TypeUtils/B.hs:25:7-9" + getLocatedStart res `shouldBe` (25,7) + + -- --------------------------------- + + it "returns Nothing for a given source location, if it does not fall in an identifier" $ do + t <- ct $ parsedFileGhc "TypeUtils/B.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let res = locToName (7,7) renamed + (showGhcQual res) `shouldBe` "Nothing" + + -- --------------------------------- + + it "gets a short name too" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (res@(GHC.L l n)) = locToName (14,1) renamed + showGhcQual n `shouldBe` "Demote.WhereIn2.sq" + showGhcQual l `shouldBe` "Demote/WhereIn2.hs:14:1-2" + getLocatedStart res `shouldBe` (14,1) + + -- --------------------------------- + + it "gets a type variable name" $ do + t <- ct $ parsedFileGhc "./Renaming/ConstructorIn3.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (res@(GHC.L l n)) = locToName (9,12) renamed + showGhcQual n `shouldBe` "a" + -- Note: loc does not line up due to multiple matches in FunBind + showGhcQual l `shouldBe` "Renaming/ConstructorIn3.hs:9:12" + getLocatedStart res `shouldBe` (9,12) + + -- --------------------------------- + + it "gets an instance class name" $ do + t <- ct $ parsedFileGhc "./Renaming/ClassIn3.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let Just (res@(GHC.L l n)) = locToName (16,10) renamed + showGhcQual n `shouldBe` "GHC.Classes.Eq" + showGhcQual l `shouldBe` "Renaming/ClassIn3.hs:16:10-11" + getLocatedStart res `shouldBe` (16,10) + + -- ------------------------------------------------------------------- + + describe "locToRdrName" $ do + it "returns a GHC.RdrName for a given source location, if it falls anywhere in an identifier" $ do + t <- ct $ parsedFileGhc "./Renaming/D5.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (res@(GHC.L l n)) = locToRdrName (20,1) parsed + (show $ ss2span l) `shouldBe` "((20,1),(20,11))" + getLocatedStart res `shouldBe` (20,1) + showGhcQual n `shouldBe` "sumSquares" + + it "returns a GHC.RdrName for a source location, in a MatchGroup" $ do + t <- ct $ parsedFileGhc "./LocToName.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (res@(GHC.L l n)) = locToRdrName (24,2) parsed + showGhcQual n `shouldBe` "sumSquares" + getLocatedStart res `shouldBe` (24,1) + showGhcQual l `shouldBe` "LocToName.hs:24:1-10" + + -- ------------------------------------------------------------------- + + describe "allNames" $ do + it "lists all Names" $ do + t <- ct $ parsedFileGhc "./TypeUtils/S.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let res = allNames renamed + let res' = map (\(GHC.L l n) -> (showGhcQual $ GHC.nameUnique n,showGhcQual (l, GHC.getSrcSpan n, n))) res + + let res'' = foldl' (\m (k,a) -> Map.insertWith (++) k a m) Map.empty res' + + (sort $ Map.elems res'') `shouldBe` + ["(TypeUtils/S.hs:10:12, TypeUtils/S.hs:10:8, n)(TypeUtils/S.hs:10:8, TypeUtils/S.hs:10:8, n)" + ,"(TypeUtils/S.hs:10:14, , GHC.Num.+)" + ,"(TypeUtils/S.hs:10:5-6, TypeUtils/S.hs:10:5-6, zz)(TypeUtils/S.hs:10:5-6, TypeUtils/S.hs:10:5-6, zz)(TypeUtils/S.hs:8:13-14, TypeUtils/S.hs:10:5-6, zz)" + ,"(TypeUtils/S.hs:4:1-3, TypeUtils/S.hs:4:1-3, TypeUtils.S.foo)(TypeUtils/S.hs:4:1-3, TypeUtils/S.hs:4:1-3, TypeUtils.S.foo)" + ,"(TypeUtils/S.hs:4:13-15, , GHC.Real.odd)" + ,"(TypeUtils/S.hs:4:17, TypeUtils/S.hs:4:5, x)(TypeUtils/S.hs:4:5, TypeUtils/S.hs:4:5, x)" + ,"(TypeUtils/S.hs:6:10, TypeUtils/S.hs:6:10, TypeUtils.S.A)" + ,"(TypeUtils/S.hs:6:14, TypeUtils/S.hs:6:14-21, TypeUtils.S.B)" + ,"(TypeUtils/S.hs:6:25, TypeUtils/S.hs:6:25, TypeUtils.S.C)" + ,"(TypeUtils/S.hs:6:6, TypeUtils/S.hs:6:1-25, TypeUtils.S.D)" + ,"(TypeUtils/S.hs:8:1-7, TypeUtils/S.hs:8:1-7, TypeUtils.S.subdecl)(TypeUtils/S.hs:8:1-7, TypeUtils/S.hs:8:1-7, TypeUtils.S.subdecl)" + ,"(TypeUtils/S.hs:8:16, TypeUtils/S.hs:8:9, x)(TypeUtils/S.hs:8:9, TypeUtils/S.hs:8:9, x)" + ] + + -- ------------------------------------------------------------------- + + describe "getName" $ do + it "gets a qualified Name at the top level" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let Just n = getName "TypeUtils.B.foo'" renamed + (showGhcQual n) `shouldBe` "TypeUtils.B.foo'" + (showGhcQual $ GHC.getSrcSpan n) `shouldBe` "TypeUtils/B.hs:14:1-4" + + it "gets any instance of an unqualified Name" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let Just n = getName "foo" renamed + (showGhcQual n) `shouldBe` "foo" + (showGhcQual $ GHC.getSrcSpan n) `shouldBe` "TypeUtils/B.hs:9:15-17" + + it "returns Nothing if the Name is not found" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let res = getName "baz" renamed + (showGhcQual res) `shouldBe` "Nothing" + + -- ------------------------------------------------------------------- + + describe "definingDeclsRdrNames" $ do + it "returns [] if not found" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = fromJust $ GHC.tm_renamed_source t + let nameMap = initRdrNameMap t + let Just ((GHC.L _ n)) = locToName (16,6) renamed + let decls = GHC.hsmodDecls $ GHC.unLoc parsed + let res = definingDeclsRdrNames nameMap [n] decls False False + showGhcQual res `shouldBe` "[]" + + -- --------------------------------- + + it "finds declarations at the top level" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nameMap = initRdrNameMap t + + let Just (GHC.L _ n) = locToName (3,3) renamed + let decls = GHC.hsmodDecls $ GHC.unLoc parsed + let res = definingDeclsRdrNames nameMap [n] decls False False + showGhcQual res `shouldBe` "[toplevel x = c * x]" + + -- --------------------------------- + + it "finds declarations not at the top level 1" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/WhereIn6.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nameMap = initRdrNameMap t + + let Just (GHC.L _ n) = locToName (13,29) renamed + let decls = GHC.hsmodDecls $ GHC.unLoc parsed + let res = definingDeclsRdrNames nameMap [n] decls False True + showGhcQual n `shouldBe` "pow" + showGhcQual res `shouldBe` "[pow = 2]" + + -- --------------------------------- + + it "finds declarations not at the top level 2" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/LetIn1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nameMap = initRdrNameMap t + + let Just (GHC.L _ n) = locToName (11,22) renamed + let decls = GHC.hsmodDecls $ GHC.unLoc parsed + let res = definingDeclsRdrNames nameMap [n] decls False True + showGhcQual n `shouldBe` "sq" + showGhcQual res `shouldBe` "[sq 0 = 0\n sq z = z ^ pow]" + + -- --------------------------------- + + it "finds in a patbind" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nameMap = initRdrNameMap t + + let Just (GHC.L _ n) = locToName (14,1) renamed + let decls = GHC.hsmodDecls $ GHC.unLoc parsed + let res = definingDeclsRdrNames nameMap [n] decls False False + showGhcQual res `shouldBe` "[tup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15]" + + -- --------------------------------- + + it "finds recursively in sub-binds" $ do + {- + modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let res = definingDecls [(PN (mkRdrName "zz"))] ds False True + showGhcQual res `shouldBe` "[zz n = n + 1]" -- TODO: Currently fails, will come back to it + -} + pending -- "Currently fails, will come back to it" + + -- --------------------------------- + + it "only finds recursively in sub-binds if asked" $ do + {- + modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let res = definingDecls [(PN (mkRdrName "zz"))] ds False False + showGhcQual res `shouldBe` "[]" + -} + pending -- "Convert to definingDeclsNames" + + -- ------------------------------------------------------------------- + + describe "definingDeclsNames" $ do + it "returns [] if not found" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just ((GHC.L _ n)) = locToName (16,6) renamed + let res = definingDeclsNames [n] (hsBinds renamed) False False + showGhcQual res `shouldBe` "[]" + + it "finds declarations at the top level" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n) = locToName (3,3) renamed + let res = definingDeclsNames [n] (hsBinds renamed) False False + showGhcQual res `shouldBe` "[DupDef.Dd1.toplevel x = DupDef.Dd1.c GHC.Num.* x]" + + + it "finds in a patbind" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n) = locToName (14,1) renamed + let res = definingDeclsNames [n] (hsBinds renamed) False False + showGhcQual res `shouldBe` "[DupDef.Dd1.tup@(DupDef.Dd1.h, DupDef.Dd1.t)\n = GHC.List.head GHC.Base.$ GHC.List.zip [1 .. 10] [3 .. ff]\n where\n ff :: GHC.Types.Int\n ff = 15]" + + + it "finds recursively in sub-binds" $ do + {- + modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let res = definingDecls [(PN (mkRdrName "zz"))] ds False True + showGhcQual res `shouldBe` "[zz n = n + 1]" -- TODO: Currently fails, will come back to it + -} + pending -- "Currently fails, will come back to it" + + it "only finds recursively in sub-binds if asked" $ do + {- + modInfo@((_, _, mod@(GHC.L l (GHC.HsModule name exps imps ds _ _))), toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let res = definingDecls [(PN (mkRdrName "zz"))] ds False False + showGhcQual res `shouldBe` "[]" + -} + pending -- "Convert to definingDeclsNames" + + -- ------------------------------------------------------------------- + + describe "definingSigsRdrNames" $ do + it "returns [] if not found" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nameMap = initRdrNameMap t + + let Just ((GHC.L _ n)) = locToName (21,1) renamed + showGhcQual n `shouldBe` "DupDef.Dd1.ff" + let res = definingSigsRdrNames nameMap [n] parsed + showGhcQual res `shouldBe` "[]" + + -- --------------------------------- + + it "finds signatures at the top level" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nameMap = initRdrNameMap t + + let Just ((GHC.L _ n)) = locToName (4,1) renamed + showGhcQual n `shouldBe` "DupDef.Dd1.toplevel" + let res = definingSigsRdrNames nameMap [n] parsed + showGhcQual res `shouldBe` "[toplevel :: Integer -> Integer]" + + -- --------------------------------- + + it "returns only the single signature where there are others too" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nameMap = initRdrNameMap t + + let Just ((GHC.L _ n)) = locToName (7,1) renamed + showGhcQual n `shouldBe` "DupDef.Dd1.c" + let res = definingSigsRdrNames nameMap [n] parsed + showGhcQual res `shouldBe` "[c :: Integer]" + + -- --------------------------------- + + it "finds signatures at lower levels" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nameMap = initRdrNameMap t + + let Just ((GHC.L _ n)) = locToName (16,5) renamed + showGhcQual n `shouldBe` "ff" + let res = definingSigsRdrNames nameMap [n] parsed + showGhcQual res `shouldBe` "[ff :: Int]" + + -- --------------------------------- + + it "finds multiple signatures 1" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nameMap = initRdrNameMap t + + let Just ((GHC.L _ n1)) = locToName (21,1) renamed + showGhcQual n1 `shouldBe` "DupDef.Dd1.ff" + + let Just ((GHC.L _ n2)) = locToName (16,5) renamed + showGhcQual n2 `shouldBe` "ff" + + let Just ((GHC.L _ n3)) = locToName (4,1) renamed + showGhcQual n3 `shouldBe` "DupDef.Dd1.toplevel" + + let res = definingSigsRdrNames nameMap [n1,n2,n3] parsed + showGhcQual res `shouldBe` "[toplevel :: Integer -> Integer, ff :: Int]" + + -- --------------------------------- + + it "finds multiple signatures 2" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let nameMap = initRdrNameMap t + + let Just ((GHC.L _ n1)) = locToName (14,1) renamed + showGhcQual n1 `shouldBe` "DupDef.Dd1.tup" + + let Just ((GHC.L _ n2)) = locToName (14,6) renamed + showGhcQual n2 `shouldBe` "DupDef.Dd1.h" + + let Just ((GHC.L _ n3)) = locToName (14,8) renamed + showGhcQual n3 `shouldBe` "DupDef.Dd1.t" + + let res = definingSigsRdrNames nameMap [n1,n2,n3] parsed + showGhcQual res `shouldBe` "[tup :: (Int, Int), h :: Int, t :: Int]" + + -- ------------------------------------------------------------------- + + describe "definingSigsNames" $ do + it "returns [] if not found" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just ((GHC.L _ n)) = locToName (21,1) renamed + showGhcQual n `shouldBe` "DupDef.Dd1.ff" + let res = definingSigsNames [n] renamed + showGhcQual res `shouldBe` "[]" + + it "finds signatures at the top level" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just ((GHC.L _ n)) = locToName (4,1) renamed + showGhcQual n `shouldBe` "DupDef.Dd1.toplevel" + let res = definingSigsNames [n] renamed + showGhcQual res `shouldBe` "[DupDef.Dd1.toplevel ::\n GHC.Integer.Type.Integer -> GHC.Integer.Type.Integer]" + + it "returns only the single signature where there are others too" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just ((GHC.L _ n)) = locToName (7,1) renamed + showGhcQual n `shouldBe` "DupDef.Dd1.c" + let res = definingSigsNames [n] renamed + showGhcQual res `shouldBe` "[DupDef.Dd1.c :: GHC.Integer.Type.Integer]" + + it "finds signatures at lower levels" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just ((GHC.L _ n)) = locToName (16,5) renamed + showGhcQual n `shouldBe` "ff" + let res = definingSigsNames [n] renamed + showGhcQual res `shouldBe` "[ff :: GHC.Types.Int]" + + it "finds multiple signatures" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just ((GHC.L _ n1)) = locToName (21,1) renamed + showGhcQual n1 `shouldBe` "DupDef.Dd1.ff" + + let Just ((GHC.L _ n2)) = locToName (16,5) renamed + showGhcQual n2 `shouldBe` "ff" + + let Just ((GHC.L _ n3)) = locToName (4,1) renamed + showGhcQual n3 `shouldBe` "DupDef.Dd1.toplevel" + + let res = definingSigsNames [n1,n2,n3] renamed + showGhcQual res `shouldBe` "[ff :: GHC.Types.Int,\n DupDef.Dd1.toplevel ::\n GHC.Integer.Type.Integer -> GHC.Integer.Type.Integer]" + + + -- ------------------------------------------------------------------- + + describe "definingTyClDeclsNames" $ do + it "returns [] if not found" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just ((GHC.L _ n)) = locToName (10,29) renamed + let res = definingTyClDeclsNames [n] renamed + showGhcQual res `shouldBe` "[]" + + -- --------------------------------- + + it "finds foreign type declarations" $ do + pending + + -- --------------------------------- + + it "finds family declarations" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n) = locToName (7,14) renamed + let res = definingTyClDeclsNames [n] renamed + showGhcQual res `shouldBe` "[data family TypeUtils.TyClDEcls.XList a]" + + -- --------------------------------- + + it "finds data declarations" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n) = locToName (12,6) renamed + let res = definingTyClDeclsNames [n] renamed + (unspace $ showGhcQual res) `shouldBe` "[data TypeUtils.TyClDEcls.Foo\n = TypeUtils.TyClDEcls.Foo GHC.Types.Int]" + + -- --------------------------------- + + it "finds type declarations" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n) = locToName (14,6) renamed + let res = definingTyClDeclsNames [n] renamed + showGhcQual res `shouldBe` "[type TypeUtils.TyClDEcls.Foo2 = GHC.Base.String]" + + -- --------------------------------- + + it "finds class declarations" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n) = locToName (16,7) renamed + let res = definingTyClDeclsNames [n] renamed + showGhcQual res `shouldBe` "[class TypeUtils.TyClDEcls.Bar a where\n TypeUtils.TyClDEcls.bar :: a -> GHC.Types.Bool]" + + -- --------------------------------- + + it "finds multiple declarations" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TyClDecls.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n1) = locToName (14,6) renamed + let Just (GHC.L _ n2) = locToName (16,7) renamed + let res = definingTyClDeclsNames [n1,n2] renamed + showGhcQual res `shouldBe` + "[type TypeUtils.TyClDEcls.Foo2 = GHC.Base.String,\n"++ + " class TypeUtils.TyClDEcls.Bar a where\n"++ + " TypeUtils.TyClDEcls.bar :: a -> GHC.Types.Bool]" + + + -- ------------------------------------------------------------------- + + describe "isFunBindR" $ do + it "Returns False if not a function definition" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just tup = getName "DupDef.Dd1.tup" renamed + let [decl] = definingDeclsNames [tup] (hsBinds renamed) False False + isFunBindR decl `shouldBe` False + + it "Returns True if a function definition" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let (GHC.L _l (GHC.HsModule _name _exps _imps _ds _ _)) = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just toplevel = getName "DupDef.Dd1.toplevel" renamed + let [decl] = definingDeclsNames [toplevel] (hsBinds renamed) False False + isFunBindR decl `shouldBe` True + + -- ------------------------------------------------------------------- + + describe "isFunOrPatName" $ do + it "Return True if a PName is a function/pattern name defined in t" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just tup = getName "DupDef.Dd1.tup" renamed + isFunOrPatName tup renamed `shouldBe` True + + it "Return False if a PName is a function/pattern name defined in t" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + t2 <- ct $ parsedFileGhc "./DupDef/Dd2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let renamed2 = fromJust $ GHC.tm_renamed_source t2 + + let Just tup = getName "DupDef.Dd1.tup" renamed + isFunOrPatName tup renamed2 `shouldBe` False + + + -- ------------------------------------------------------------------- + + describe "hsFreeAndDeclaredXXXX" $ do + + it "finds declared in type class definitions" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareTypes.hs" + + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + tdss <- mapM getDeclaredTypesRdr decls + let tds = nub $ concat tdss + return (tds) + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (res)) `shouldBe` + "[(FreeAndDeclared.DeclareTypes.XList, (8, 1)),\n"++ + " (FreeAndDeclared.DeclareTypes.X, (19, 1)),\n"++ + " (FreeAndDeclared.DeclareTypes.Y, (19, 10)),\n"++ + " (FreeAndDeclared.DeclareTypes.Z, (19, 22)),\n"++ + " (FreeAndDeclared.DeclareTypes.W, (19, 26)),\n"++ + " (FreeAndDeclared.DeclareTypes.Foo, (21, 1)),\n"++ + " (FreeAndDeclared.DeclareTypes.Bar, (23, 1)),\n"++ + " (FreeAndDeclared.DeclareTypes.doBar, (27, 3)),\n"++ + " (FreeAndDeclared.DeclareTypes.BarVar, (24, 3)),\n"++ + " (FreeAndDeclared.DeclareTypes.BarData, (25, 3))]" + + -- --------------------------------- + + it "finds declared HsVar" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let + comp = do + parsed <- getRefactParsed + nm <- getRefactNameMap + let rr = hsFreeAndDeclaredRdr nm parsed + let r = hsFreeAndDeclaredPNsOld renamed + rg <- hsFreeAndDeclaredPNs renamed + return (r,rg,rr) + -- ((res,resg,rrr),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + ((res,resg,(FN fr,DN dr)),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + -- (showGhcQual _fff) `shouldBe` "" + + -- --------------------- + -- Free Vars - renamed + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` + "[(Data.Generics.Text.gshow, (-1, -1)),\n "++ + "(System.IO.getChar, (-1, -1)), "++ + "(System.IO.putStrLn, (-1, -1)),\n "++ + "(GHC.Base.return, (-1, -1)), "++ + "(GHC.Base.$, (-1, -1)),\n "++ + "(GHC.List.head, (-1, -1)), "++ + "(GHC.List.zip, (-1, -1)),\n "++ + "(GHC.Num.fromInteger, (-1, -1)), "++ + "(GHC.Num.*, (-1, -1))]" + + -- Declared Vars - renamed + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` + "[(FreeAndDeclared.Declare.ff, (36, 1)),\n "++ + "(FreeAndDeclared.Declare.mkT, (34, 1)),\n "++ + "(FreeAndDeclared.Declare.main, (30, 1)),\n "++ + "(FreeAndDeclared.Declare.unF, (27, 1)),\n "++ + "(FreeAndDeclared.Declare.unD, (21, 1)),\n "++ + "(FreeAndDeclared.Declare.tup, (16, 1)),\n "++ -- ++AZ++ addition + "(FreeAndDeclared.Declare.h, (16, 6)),\n "++ + "(FreeAndDeclared.Declare.t, (16, 8)),\n "++ + "(FreeAndDeclared.Declare.d, (10, 1)),\n "++ + "(FreeAndDeclared.Declare.c, (9, 1)),\n "++ + "(FreeAndDeclared.Declare.toplevel, (6, 1))]" + + -- --------------------- + -- Free Vars - parsed + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) fr) `shouldBe` + "[(GHC.Num.*, (-1, -1)), "++ + "(GHC.Base.$, (-1, -1)),\n "++ + "(GHC.List.head, (-1, -1)), "++ + "(GHC.List.zip, (-1, -1)),\n "++ + "(System.IO.getChar, (-1, -1)), "++ + "(System.IO.putStrLn, (-1, -1)),\n "++ + "(Data.Generics.Text.gshow, (-1, -1))]" + + -- Declared Vars - parsed + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) dr) `shouldBe` + "[(FreeAndDeclared.Declare.toplevel, (6, 1)),\n "++ + "(FreeAndDeclared.Declare.c, (9, 1)),\n "++ + "(FreeAndDeclared.Declare.d, (10, 1)),\n "++ + "(FreeAndDeclared.Declare.tup, (16, 1)),\n "++ + "(FreeAndDeclared.Declare.h, (16, 6)),\n "++ + "(FreeAndDeclared.Declare.t, (16, 8)),\n "++ + "(FreeAndDeclared.Declare.unD, (21, 1)),\n "++ + "(FreeAndDeclared.Declare.unF, (27, 1)),\n "++ + "(FreeAndDeclared.Declare.main, (30, 1)),\n "++ + "(FreeAndDeclared.Declare.mkT, (34, 1)),\n "++ + "(FreeAndDeclared.Declare.ff, (36, 1))]" + + -- --------------------- + -- GHC version + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` + "[(Data.Generics.Text.gshow, (-1, -1)),\n "++ + "(System.IO.getChar, (-1, -1)), "++ + "(System.IO.putStrLn, (-1, -1)),\n "++ + "(GHC.List.head, (-1, -1)), "++ + "(GHC.Base.$, (-1, -1)),\n "++ + "(GHC.List.zip, (-1, -1)), "++ + "(GHC.Num.*, (-1, -1))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` + "[(FreeAndDeclared.Declare.ff, (36, 1)),\n "++ + "(FreeAndDeclared.Declare.mkT, (34, 1)),\n "++ + "(FreeAndDeclared.Declare.main, (30, 1)),\n "++ + "(FreeAndDeclared.Declare.unF, (27, 1)),\n "++ + "(FreeAndDeclared.Declare.unD, (21, 1)),\n "++ + "(FreeAndDeclared.Declare.tup, (16, 1)),\n "++ -- ++AZ++ not found by old + "(FreeAndDeclared.Declare.h, (16, 6)),\n "++ + "(FreeAndDeclared.Declare.t, (16, 8)),\n "++ + "(FreeAndDeclared.Declare.d, (10, 1)),\n "++ + "(FreeAndDeclared.Declare.c, (9, 1)),\n "++ + "(FreeAndDeclared.Declare.toplevel, (6, 1)),\n "++ + "(GHC.Types.Int, (-1, -1)), (GHC.Integer.Type.Integer, (-1, -1)),\n "++ + "(FreeAndDeclared.Declare.D, (18, 1)),\n "++ + "(FreeAndDeclared.Declare.A, (18, 10)),\n "++ + "(FreeAndDeclared.Declare.B, (18, 14)),\n "++ + "(FreeAndDeclared.Declare.C, (18, 25)),\n "++ + "(FreeAndDeclared.Declare.F, (25, 1)),\n "++ + "(FreeAndDeclared.Declare.G, (25, 10)),\n "++ + "(FreeAndDeclared.Declare.:|, (25, 14))]" + + -- --------------------------------- + + it "finds free and declared in a single bind PrefixCon" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let + comp = do + let b = head $ drop 4 $ hsBinds renamed + rg <- hsFreeAndDeclaredPNs [b] + return (b,rg) + ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + + (showGhcQual bb) `shouldBe` "FreeAndDeclared.Declare.unD (FreeAndDeclared.Declare.B y) = y" + -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" + + -- GHC version + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` + "[(FreeAndDeclared.Declare.B, (18, 14))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` + "[(FreeAndDeclared.Declare.unD, (21, 1))]" + + -- --------------------------------- + + it "finds free and declared in a single bind InfixCon" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let + comp = do + let b = head $ drop 3 $ hsBinds renamed + rg <- hsFreeAndDeclaredPNs [b] + return (b,rg) + ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual bb) `shouldBe` "FreeAndDeclared.Declare.unF (a FreeAndDeclared.Declare.:| b)\n = (a, b)" + -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" + + -- GHC version + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` + "[(FreeAndDeclared.Declare.:|, (25, 14))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` + "[(FreeAndDeclared.Declare.unF, (27, 1))]" + + -- --------------------------------- + + it "finds free and declared in a single bind RecCon" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareRec.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let + comp = do + let b = head $ drop 0 $ hsBinds renamed + rg <- hsFreeAndDeclaredPNs [b] + return (b,rg) + ((bb,resg),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + + (showGhcQual bb) `shouldBe` "FreeAndDeclared.DeclareRec.unR2\n (FreeAndDeclared.DeclareRec.RCon {FreeAndDeclared.DeclareRec.r1 = a})\n = a" + -- (SYB.showData SYB.Renamer 0 bb) `shouldBe` "" + + -- GHC version + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst resg)) `shouldBe` + "[(FreeAndDeclared.DeclareRec.RCon, (3, 10))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd resg)) `shouldBe` + "[(FreeAndDeclared.DeclareRec.unR2, (7, 1))]" + + -- ----------------------------------------------------------------- + + it "hsFreeAndDeclaredPNs simplest" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareS.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let + comp = do + r <- hsFreeAndDeclaredPNs renamed + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` "[]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` "[(FreeAndDeclared.DeclareS.c, (6, 1))]" + + -- ----------------------------------------------------------------- + + it "finds free and declared in a single bind #2" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just tup = getName "DupDef.Dd1.ff" renamed + let [decl] = definingDeclsNames [tup] (hsBinds renamed) False False + + let + comp = do + r <- hsFreeAndDeclaredPNs [decl] + return (r,decl) + ((res,d),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual d) `shouldBe` "DupDef.Dd1.ff y\n = y GHC.Num.+ zz\n where\n zz = 1" + -- (SYB.showData SYB.Renamer 0 d) `shouldBe` "" + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` + "[(GHC.Num.+, (-1, -1))]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` + "[(DupDef.Dd1.ff, (21, 1))]" + + -- ----------------------------------------------------------------- + + it "finds free and declared at the top level 1" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/WhereIn1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let + comp = do + r <- hsFreeAndDeclaredPNs $ hsBinds renamed + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` + "[(LiftToToplevel.WhereIn1.anotherFun, (15, 1)),\n "++ + "(LiftToToplevel.WhereIn1.sumSquares, (9, 1))]" + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` + "[(GHC.Real.^, (-1, -1)), (GHC.Num.+, (-1, -1))]" + + -- ----------------------------------------------------------------- + + it "finds free and declared at the top level 2" $ do + t <- ct $ parsedFileGhc "./Renaming/IdIn3.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let + comp = do + r <- hsFreeAndDeclaredPNs renamed + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` + "[(IdIn3.bar, (14, 1))"++ + ", (IdIn3.x, (10, 1))"++ + ", (IdIn3.foo, (12, 1)),\n "++ + "(IdIn3.main, (18, 1))]" + + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` + "[(GHC.Num.+, (-1, -1))]" + + -- ----------------------------------------------------------------- + + it "finds free and declared in a GRHSs" $ do + t <- ct $ parsedFileGhc "./LiftOneLevel/LetIn2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just tup = getName "LiftOneLevel.LetIn2.sumSquares" renamed + let [decl] = definingDeclsNames [tup] (hsBinds renamed) False False + + let (GHC.L _ (GHC.FunBind _ _ (GHC.MG [match] _ _ _) _ _ _)) = decl + let (GHC.L _ (GHC.Match _ _pat _ grhss)) = match + + let + comp = do + r <- hsFreeAndDeclaredPNs grhss + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` + "[]" + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` + "[(GHC.Real.^, (-1, -1)), (x, (10, 12)), (GHC.Num.+, (-1, -1)),\n (y, (10, 14))]" + + -- ----------------------------------------------------------------- + + it "finds free and declared in a single bind" $ do + pending -- "fix the prior test" + + -- --------------------------------------------------------------------- + + + describe "hsFDsFromInsideRdr" $ do + it "does something useful" $ do + pending -- "Complete this" + + describe "hsFDsFromInside" $ do + it "does something useful" $ do + pending -- "Complete this" + + describe "hsFDNamesFromInside" $ do + it "does something useful" $ do + pending -- "Complete this" + + -- --------------------------------------------------------------------- + + describe "hsVisibleNames" $ do + it "does something useful" $ do + pending -- "Complete this" + + -- --------------------------------------------------------------------- + + describe "hsVisiblePNs" $ do + + -- --------------------------------- + + it "returns [] if e does not occur in t" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just tl1 = locToExp (4,13) (4,40) renamed :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) + let Just tup = getName "DupDef.Dd1.tup" renamed + let + comp = do + r <- hsVisiblePNs tup tl1 + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual $ res) `shouldBe` "[]" + + -- ----------------------------------------------------------------- + + it "returns visible vars if e does occur in t #1" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just tl1 = locToExp (28,4) (28,12) renamed :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) + (showGhcQual tl1) `shouldBe` "ll GHC.Num.+ z" + + let Just tup = getName "DupDef.Dd1.l" renamed + let [decl] = definingDeclsNames [tup] (hsBinds renamed) False False + (showGhcQual decl) `shouldBe` "DupDef.Dd1.l z = let ll = 34 in ll GHC.Num.+ z" + + let + comp = do + r <- hsVisiblePNs tl1 decl + return (r) + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual res ) `shouldBe` "[z, ll]" + -- (showGhcQual res2 ) `shouldBe` "[z, ll]" + + -- ----------------------------------------------------------------- + + it "returns visible vars if e does occur in t #2" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just tl1 = locToExp (28,4) (28,12) renamed :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) + (showGhcQual tl1) `shouldBe` "ll GHC.Num.+ z" + + let Just rhs = locToExp (26,1) (28,12) renamed :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) + (showGhcQual rhs) `shouldBe` "let ll = 34 in ll GHC.Num.+ z" + + let + comp = do + r <- hsVisiblePNs tl1 rhs + return r + ((res),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual res) `shouldBe` "[ll]" + + -- ----------------------------------------------------------------- + +{- + it "returns visible vars if e does occur in t #3" $ do + (t,toks) <- ct $ parsedFileGhc "./TypeUtils/VisiblePNs.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let + comp = do + renamed <- getRefactRenamed + let Just tl1 = locToName (41,11) renamed -- :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) + r <- hsVisiblePNs tl1 renamed + -- let r = hsVisiblePNsGhc tl1 renamed + let fvs = map (\b -> (showGhcQual b,getFreeVars [b])) (hsBinds renamed) + let dvs = getDeclaredVars $ hsBinds renamed + return (tl1,r,fvs,dvs) + -- ((tl,res,_f,d),_s) <- runRefactGhc comp $ initialState { rsModule = initRefactModule t } + ((tl,res,_f,d),_s) <- runRefactGhc comp $ initialLogOnState { rsModule = initRefactModule t } + + (showGhcQual tl) `shouldBe` "modu" + -- (showGhcQual f) `shouldBe` "" + (showGhcQual d) `shouldBe` + "[TypeUtils.VisiblePNs.parsedFileGhc,\n"++ + " TypeUtils.VisiblePNs.parsedFileBGhc,\n"++ + " TypeUtils.VisiblePNs.runRefactGhcState,"++ + " TypeUtils.VisiblePNs.zz,\n"++ + " TypeUtils.VisiblePNs.yy,"++ + " TypeUtils.VisiblePNs.xx,\n"++ + " TypeUtils.VisiblePNs.ww,"++ + " TypeUtils.VisiblePNs.spec,\n"++ + " TypeUtils.VisiblePNs.main]" + (showGhcQual res) `shouldBe` + "[TypeUtils.VisiblePNs.parsedFileGhc,\n"++ + " TypeUtils.VisiblePNs.parsedFileBGhc,\n"++ + " TypeUtils.VisiblePNs.runRefactGhcState,"++ + " TypeUtils.VisiblePNs.zz,\n"++ + " TypeUtils.VisiblePNs.yy,"++ + " TypeUtils.VisiblePNs.xx,\n"++ + " TypeUtils.VisiblePNs.ww,"++ + " TypeUtils.VisiblePNs.spec,\n"++ + " TypeUtils.VisiblePNs.main,"++ + " modu,"++ + " t,"++ + " _toks,"++ + " expr]" +-} + + -- --------------------------------------------------------------------- + + describe "hsVisibleDsRdr" $ do + it "Rdr:finds function arguments visible in RHS 1" $ do + t <- ct $ parsedFileGhc "./Visible/Simple.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just e = locToExp (5,11) (5,19) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) + (showGhcQual e) `shouldBe` "a + b" + + let Just n = getName "Visible.Simple.params" renamed + + let + comp = do + nameMap <- getRefactNameMap + declsp <- liftT $ hsDecls parsed + let [decl] = definingDeclsRdrNames nameMap [n] declsp False False + fds' <- hsVisibleDsRdr nameMap e decl + return (fds') + -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show fds) `shouldBe` "DN [a, b, GHC.Num.+]" + + -- ----------------------------------- + + it "Rdr:finds function arguments visible in RHS 2" $ do + t <- ct $ parsedFileGhc "./Visible/Simple.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let Just e = locToExp (9,15) (9,17) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) + (showGhcQual e) `shouldBe` "x" + + let Just n = getName "Visible.Simple.param2" renamed + + let + comp = do + nameMap <- getRefactNameMap + declsp <- liftT $ hsDecls parsed + let [decl] = definingDeclsRdrNames nameMap [n] declsp False False + fds' <- hsVisibleDsRdr nameMap e decl + return (fds') + -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show fds) `shouldBe` "DN [x]" + + + -- ----------------------------------- + + it "Rdr:finds visible vars inside a function" $ do + t <- ct $ parsedFileGhc "./Renaming/IdIn5.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just rhsr = locToExp (14,6) (15,14) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) + let Just rhs = locToExp (14,6) (15,14) parsed :: (Maybe (GHC.LHsExpr GHC.RdrName)) + (showGhcQual rhs) `shouldBe` "x + y + z" + + -- let Just er = getName "IdIn5.x" renamed + let Just e = locToRdrName (14,7) parsed + (showGhcQual e) `shouldBe` "x" + (SYB.showData SYB.Parser 0 e) `shouldBe` "\n(L {Renaming/IdIn5.hs:14:7} \n (Unqual {OccName: x}))" + + let + comp = do + nameMap <- getRefactNameMap + fds' <- hsVisibleDsRdr nameMap e rhs + ffds <- hsFreeAndDeclaredGhc rhsr + return (fds',ffds) + -- ((fds,_fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show _fds) `shouldBe` "(FN [IdIn5.x, GHC.Num.+, y, z],DN [])" + (show fds) `shouldBe` "DN [GHC.Num.+, IdIn5.x, y, z]" + + -- ----------------------------------- + + it "Rdr:finds visible vars inside a data declaration" $ do + t <- ct $ parsedFileGhc "./Renaming/D1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just ln = locToRdrName (6, 6) parsed + (showGhcQual ln) `shouldBe` "Tree" + (SYB.showData SYB.Parser 0 ln) `shouldBe` "\n(L {Renaming/D1.hs:6:6-9} \n (Unqual {OccName: Tree}))" + + let + comp = do + nameMap <- getRefactNameMap + fds' <- hsVisibleDsRdr nameMap ln parsed + ffds <- hsFreeAndDeclaredGhc renamed + return (fds',ffds) + ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((fds,_fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (show _fds) `shouldBe` "(FN [:, GHC.Num.+, GHC.Real.^, [], GHC.Base.++],"++ + "DN [Renaming.D1.sumSquares, Renaming.D1.fringe, Renaming.D1.Tree, a,\n"++ + " Renaming.D1.Leaf, Renaming.D1.Branch, Renaming.D1.SameOrNot,\n"++ + " Renaming.D1.isSame, Renaming.D1.isNotSame])" + (show fds) `shouldBe` "DN [Renaming.D1.Tree, Renaming.D1.Leaf, Renaming.D1.Branch]" + + + -- --------------------------------------------------------------------- + + describe "hsVisibleDs" $ do + it "finds function arguments visible in RHS 1" $ do + t <- ct $ parsedFileGhc "./Visible/Simple.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let Just e = locToExp (5,11) (5,19) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) + (showGhcQual e) `shouldBe` "a GHC.Num.+ b" + + let Just n = getName "Visible.Simple.params" renamed + let [decl] = definingDeclsNames [n] (hsBinds renamed) False False + + let binds = hsValBinds [decl] + + let + comp = do + fds' <- hsVisibleDs e $ head $ hsBinds binds + return (fds') + -- ((fds),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show fds) `shouldBe` "DN [a, b, GHC.Num.+]" + + -- ----------------------------------- + + it "finds function arguments visible in RHS 2" $ do + t <- ct $ parsedFileGhc "./Visible/Simple.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just e = locToExp (9,15) (9,17) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) + (showGhcQual e) `shouldBe` "x" + + let Just n = getName "Visible.Simple.param2" renamed + let [decl] = definingDeclsNames [n] (hsBinds renamed) False False + + let binds = hsValBinds [decl] + + let + comp = do + fds' <- hsVisibleDs e $ head $ hsBinds binds + return (fds') + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show fds) `shouldBe` "DN [x]" + + + -- ----------------------------------- + + it "finds visible vars inside a function" $ do + t <- ct $ parsedFileGhc "./Renaming/IdIn5.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just rhs = locToExp (14,6) (15,14) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) + (showGhcQual rhs) `shouldBe` "IdIn5.x GHC.Num.+ y GHC.Num.+ z" + + let Just e = getName "IdIn5.x" renamed + + let + comp = do + fds' <- hsVisibleDs e rhs + ffds <- hsFreeAndDeclaredGhc rhs + return (fds',ffds) + ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show _fds) `shouldBe` "(FN [IdIn5.x, GHC.Num.+, y, z],DN [])" + (show fds) `shouldBe` "DN [GHC.Num.+, y, z]" + + -- ----------------------------------- + + it "finds visible vars inside a data declaration" $ do + t <- ct $ parsedFileGhc "./Renaming/D1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n) = locToName (6, 6) renamed + (showGhcQual n) `shouldBe` "Renaming.D1.Tree" + + let + comp = do + fds' <- hsVisibleDs n renamed + ffds <- hsFreeAndDeclaredGhc renamed + return (fds',ffds) + ((fds,_fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show _fds) `shouldBe` "(FN [:, GHC.Num.+, GHC.Real.^, [], GHC.Base.++],"++ + "DN [Renaming.D1.sumSquares, Renaming.D1.fringe, Renaming.D1.Tree, a,\n "++ + "Renaming.D1.Leaf, Renaming.D1.Branch, Renaming.D1.SameOrNot,\n "++ + "Renaming.D1.isSame, Renaming.D1.isNotSame])" + (show fds) `shouldBe` "DN [Renaming.D1.Tree, Renaming.D1.Leaf, Renaming.D1.Branch]" + + + -- --------------------------------------------------------------------- + + describe "hsFreeAndDeclaredGhc" $ do + it "finds function arguments visible in RHS fd" $ do + t <- ct $ parsedFileGhc "./Visible/Simple.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let Just e = locToExp (5,11) (5,19) renamed :: (Maybe (GHC.Located (GHC.HsExpr GHC.Name))) + (showGhcQual e) `shouldBe` "a GHC.Num.+ b" + + let Just n = getName "Visible.Simple.params" renamed + let [decl] = definingDeclsNames [n] (hsBinds renamed) False False + + let binds = hsValBinds [decl] + + let + comp = do + fds' <- hsFreeAndDeclaredGhc $ head $ hsBinds binds + return (fds') + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show fds) `shouldBe` "(FN [GHC.Num.+],DN [Visible.Simple.params])" + + -- ----------------------------------- + + it "finds function arguments and free vars visible in RHS" $ do + t <- ct $ parsedFileGhc "./Visible/Simple.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just e = locToExp (9,15) (9,17) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) + (showGhcQual e) `shouldBe` "x" + + let Just n = getName "Visible.Simple.param2" renamed + let [decl] = definingDeclsNames [n] (hsBinds renamed) False False + + let binds = hsValBinds [decl] + let (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = head $ hsBinds binds + let [(GHC.L _ (GHC.Match _ pats _ _))] = matches + let lpat = head pats + + let + comp = do + fds' <- hsFreeAndDeclaredGhc $ lpat + return (fds') + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show fds) `shouldBe` "(FN [Visible.Simple.B],DN [x])" + + -- ----------------------------------- + + it "finds imported functions used in the rhs" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just n = getName "FreeAndDeclared.Declare.tup" renamed + let decls = definingDeclsNames [n] (hsBinds renamed) False False + + let + comp = do + fds' <- hsFreeAndDeclaredGhc $ decls + return (fds') + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show fds) `shouldBe` + "(FN [GHC.List.head, GHC.Base.$, GHC.List.zip],"++ + "DN [FreeAndDeclared.Declare.tup, FreeAndDeclared.Declare.h,\n "++ + "FreeAndDeclared.Declare.t])" + + -- ----------------------------------- + + it "finds free vars in HsWithBndrs" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Binders.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just n = getName "FreeAndDeclared.Binders.findNewPName" renamed + let [decl] = definingDeclsNames [n] (hsBinds renamed) False False + let (GHC.L _ (GHC.FunBind _ _ (GHC.MG [match] _ _ _) _ _ _)) = decl + let (GHC.L _ (GHC.Match _ _pats _rhs binds)) = match + + let + comp = do + fds' <- hsFreeAndDeclaredGhc $ binds + return (fds') + ((fds),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show fds) `shouldBe` + "(FN [FreeAndDeclared.Binders.gfromJust,"++ + " FreeAndDeclared.Binders.Name,\n"++ + " FreeAndDeclared.Binders.occNameString,"++ + " GHC.Base.$,\n"++ + " FreeAndDeclared.Binders.getOccName,"++ + " GHC.Classes.==,"++ + " name,\n"++ + " GHC.Base.Just,"++ + " GHC.Base.Nothing,\n"++ + " FreeAndDeclared.Binders.somethingStaged,\n"++ + " FreeAndDeclared.Binders.Renamer,"++ + " renamed],"++ + "DN [worker, res])" + + -- ----------------------------------- + + it "finds free vars in TH files" $ do + t <- ct $ parsedFileGhc "./TH/Main.hs" + let + comp = do + parseSourceFileGhc "./TH/Main.hs" + parsed <- getRefactParsed + nm <- getRefactNameMap + let fds' = hsFreeAndDeclaredRdr nm parsed + return (fds') + ((fds),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show fds) `shouldBe` + "(FN [System.IO.putStrLn, pr],"++ + "DN [TH.Main.main, TH.Main.baz, TH.Main.sillyString])" + + -- --------------------------------------------- + + describe "getParsedForRenamedLPat" $ do + it "gets the ParsedSource version of a RenamedSource LPat" $ do + t <- ct $ parsedFileGhc "./Visible/Simple.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just e = locToExp (9,15) (9,17) renamed :: (Maybe (GHC.LHsExpr GHC.Name)) + (showGhcQual e) `shouldBe` "x" + + let Just n = getName "Visible.Simple.param2" renamed + let [decl] = definingDeclsNames [n] (hsBinds renamed) False False + + let binds = hsValBinds [decl] + let (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = head $ hsBinds binds + let [(GHC.L _ (GHC.Match _ pats _ _))] = matches + let pat@(GHC.L lp _) = head pats + + let pat' = getParsedForRenamedLPat parsed pat + + let (GHC.L lp' _) = pat' + lp `shouldBe` lp' + + (SYB.showData SYB.Renamer 0 pat') `shouldBe` + "\n"++ + "(L {Visible/Simple.hs:9:8-12} \n"++ + " (ParPat \n"++ + " (L {Visible/Simple.hs:9:9-11} \n"++ + " (ConPatIn \n"++ + " (L {Visible/Simple.hs:9:9} \n"++ + " (Unqual {OccName: B})) \n"++ + " (PrefixCon \n"++ + " [\n"++ + " (L {Visible/Simple.hs:9:11} \n"++ + " (VarPat \n"++ + " (Unqual {OccName: x})))])))))" + + (SYB.showData SYB.Renamer 0 pat) `shouldBe` + "\n"++ + "(L {Visible/Simple.hs:9:8-12} \n"++ + " (ParPat \n"++ + " (L {Visible/Simple.hs:9:9-11} \n"++ + " (ConPatIn \n"++ + " (L {Visible/Simple.hs:9:9} {Name: B}) \n"++ + " (PrefixCon \n"++ + " [\n"++ + " (L {Visible/Simple.hs:9:11} \n"++ + " (VarPat {Name: x}))])))))" + + + -- --------------------------------------------- + + describe "isLocalPN" $ do + it "returns True if the name is local to the module" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let Just (GHC.L _ n) = locToName (17, 5) renamed + (showGhcQual n) `shouldBe` "ff" + isLocalPN n `shouldBe` True + + it "returns False if the name is not local to the module" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let Just (GHC.L _ n) = locToName (21, 1) renamed + (showGhcQual n) `shouldBe` "DupDef.Dd1.ff" + isLocalPN n `shouldBe` False + + -- --------------------------------------------- + + describe "isTopLevelPN" $ do + it "returns False if the name is not defined at the top level of the module" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + renamed <- getRefactRenamed + let Just (GHC.L _ n) = locToName (17, 5) renamed + topLevel <- isTopLevelPN n + return (n,topLevel) + ((nf,tl),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual nf) `shouldBe` "ff" + tl `shouldBe` False + + it "returns True if the name is defined at the top level of the module" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + renamed <- getRefactRenamed + let Just (GHC.L _ n) = locToName (21, 1) renamed + topLevel <- isTopLevelPN n + return (n,topLevel) + + ((nf,tl),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual nf) `shouldBe` "DupDef.Dd1.ff" + tl `shouldBe` True + + -- --------------------------------------------- + + describe "definedPNs" $ do + it "gets the PNs defined in a declaration" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ pn) = locToName (3, 1) renamed + (showGhcQual pn) `shouldBe` "DupDef.Dd1.toplevel" + + let origDecls = hsBinds renamed + let demotedDecls'= definingDeclsNames [pn] origDecls True False + let declaredPns = nub $ concatMap definedPNs demotedDecls' + + (showGhcQual declaredPns) `shouldBe` "[DupDef.Dd1.toplevel]" + + -- --------------------------------- + + it "gets the PNs defined in an as-match" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ pn) = locToName (14, 1) renamed + (showGhcQual pn) `shouldBe` "DupDef.Dd1.tup" + + let origDecls = hsBinds renamed + let demotedDecls'= definingDeclsNames [pn] origDecls True False + let declaredPns = nub $ concatMap definedPNs demotedDecls' + + (showGhcQual declaredPns) `shouldBe` "[DupDef.Dd1.tup, DupDef.Dd1.h, DupDef.Dd1.t]" + + + -- --------------------------------------------- + + describe "inScopeInfo" $ do + it "returns 4 element tuples for in scope names" $ do + pending -- "is this still needed?" + {- + ((inscopes, _renamed, _parsed), _toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let info = inScopeInfo inscopes + (show $ head info) `shouldBe` "foo" + -- (show $ info) `shouldBe` "foo" + -} + + -- --------------------------------------------- + + describe "isInScopeAndUnqualified" $ do + it "True if the identifier is in scope and unqualified" $ do + pending -- "needed?" + {- + ((inscopes, _renamed, _parsed), _toks) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let info = inScopeInfo inscopes + (show $ head info) `shouldBe` "foo" + -} +-- inScopeInfo for c is +-- (\"DupDef.Dd1.c\",VarName,DupDef.Dd1,Nothing) + + -- --------------------------------------------- + + describe "isInScopeAndUnqualifiedGhc" $ do + it "True if the identifier is in scope and unqualified" $ do + let + comp = do + parseSourceFileGhc "./DupDef/Dd1.hs" + ctx <- GHC.getContext + res1 <- isInScopeAndUnqualifiedGhc "c" Nothing + res2 <- isInScopeAndUnqualifiedGhc "DupDef.Dd1.c" Nothing + res3 <- isInScopeAndUnqualifiedGhc "nonexistent" Nothing + return (res1,res2,res3,ctx) + ((r1,r2,r3,_c),_s) <- ct $ runRefactGhc comp (initialState { rsModule = Nothing }) testOptions + r1 `shouldBe` True + r2 `shouldBe` True + r3 `shouldBe` False + + -- --------------------------------- + + it "requires qualification on name clash with an import" $ do + t <- ct $ parsedFileGhc "./ScopeAndQual.hs" + let + comp = do + parseSourceFileGhc "./ScopeAndQual.hs" + putParsedModule t + renamed <- getRefactRenamed + + logm $ "renamed=" ++ (SYB.showData SYB.Renamer 0 renamed) -- ++AZ++ + + ctx <- GHC.getContext + + let Just sumSquares = locToName (13,15) renamed + ssUnqual <- isQualifiedPN $ GHC.unLoc sumSquares + names <- GHC.parseName "sum" + names2 <- GHC.parseName "mySumSq" + res1 <- isInScopeAndUnqualifiedGhc "sum" Nothing + res2 <- isInScopeAndUnqualifiedGhc "L.sum" Nothing + return (res1,res2,names,names2,sumSquares,ssUnqual,ctx) + ((r1,r2,ns,ns2,ss,ssu,_c),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (prettyprint ss) `shouldBe` "sumSquares" + (showGhcQual ss) `shouldBe` "ScopeAndQual.sumSquares" + (show $ ssu) `shouldBe` "False" + (showGhcQual ns) `shouldBe` "[ScopeAndQual.sum]" + (showGhcQual ns2) `shouldBe` "[ScopeAndQual.mySumSq]" + "1" ++ (show r1) `shouldBe` "1True" + "2" ++ (show r2) `shouldBe` "2True" + + -- --------------------------------------------- + + describe "mkNewGhcName" $ do + it "Creates a new GHC.Name" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + renamed <- getRefactRenamed + let Just (GHC.L _ topLevel) = locToName (3,1) renamed + + name1 <- mkNewGhcName Nothing "foo" + name2 <- mkNewGhcName Nothing "bar" + name3 <- mkNewGhcName (Just (GHC.nameModule topLevel)) "baz" + + return (name1,name2,name3) + ((n1,n2,n3),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + GHC.getOccString n1 `shouldBe` "foo" + showGhcQual n1 `shouldBe` "foo" + GHC.getOccString n2 `shouldBe` "bar" + showGhcQual n2 `shouldBe` "bar" + (showGhcQual $ GHC.nameModule n3) `shouldBe` "main@main:DupDef.Dd1" + (SYB.showData SYB.Renamer 0 n3) `shouldBe` "{Name: baz}" + GHC.getOccString n3 `shouldBe` "baz" + showGhcQual n3 `shouldBe` "DupDef.Dd1.baz" + (showGhcQual $ GHC.nameUnique n1) `shouldBe` "H2" + (showGhcQual $ GHC.nameUnique n2) `shouldBe` "H3" + (showGhcQual $ GHC.nameUnique n3) `shouldBe` "H4" + + -- --------------------------------------------- + + describe "prettyprint" $ do + it "Prints a GHC.Name ready for parsing into tokens" $ do + -- (_t, _toks, _tgt) <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + name1 <- mkNewGhcName Nothing "foo" + name2 <- mkNewGhcName Nothing "bar" + return (name1,name2) + ((n1,n2),_s) <- ct $ runRefactGhcState comp + GHC.getOccString n1 `shouldBe` "foo" + showGhcQual n1 `shouldBe` "foo" + GHC.getOccString n2 `shouldBe` "bar" + showGhcQual n2 `shouldBe` "bar" + showGhcQual n1 `shouldBe` "foo" + + -- --------------------------------------------- + + describe "duplicateDecl" $ do + it "duplicates a bind only" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n) = locToName (3, 1) renamed + let + comp = do + parsed <- getRefactParsed + declsp <- liftT $ hsDecls parsed + newName2 <- mkNewGhcName Nothing "bar2" + newBindings <- duplicateDecl declsp n newName2 + parsed' <- liftT $ replaceDecls parsed newBindings + putRefactParsed parsed' emptyAnns + + return newBindings + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual n) `shouldBe` "DupDef.Dd1.toplevel" + (sourceFromState s) `shouldBe` "module DupDef.Dd1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nbar2 :: Integer -> Integer\nbar2 x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\n" + + -- --------------------------------------------- + + it "duplicates a bind with a signature, and an offset" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just np = locToName (14, 1) renamed + (showGhcQual np) `shouldBe` "DupDef.Dd1.tup" + + let Just ln@(GHC.L _l n) = locToName (17, 6) renamed + (showGhcQual n) `shouldBe` "ff" + let + comp = do + newName2 <- mkNewGhcName Nothing "gg" + nm <- getRefactNameMap + + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + + (front,[parent],back) <- divideDecls decls ln + + (parent',Just (funBinding,declsToDup,declsp')) <- modifyValD (GHC.getLoc parent) parent $ \_m declsp -> do + let + declsToDup = definingDeclsRdrNames nm [n] declsp True True + funBinding = filter isFunOrPatBindP declsToDup --get the fun binding. + + declsp' <- duplicateDecl declsp n newName2 + + return (declsp',Just (funBinding,declsToDup,declsp')) + + parsed' <- liftT $ replaceDecls parsed (front ++ [parent'] ++ back) + putRefactParsed parsed' emptyAnns + + return (funBinding,declsToDup,declsp') + + ((fb,dd,newb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((fb,dd,newb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "ff" + (showGhcQual dd) `shouldBe` "[ff = 15]" + (showGhcQual fb) `shouldBe` "[ff = 15]" + (show $ getStartEndLoc fb) `shouldBe` "((17,5),(17,12))" + (sourceFromState s) `shouldBe` "module DupDef.Dd1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\n gg :: Int\n gg = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\n" + (showGhcQual newb) `shouldBe` "[ff :: Int, ff = 15, gg :: Int, gg = 15]" + (showGhcQual fb) `shouldBe` "[ff = 15]" + + + -- --------------------------------------------- + + describe "addParamsToDecl" $ do + it "adds parameters to a declaration" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _ n) = locToName (3, 1) renamed + let + comp = do + declsp <- liftT $ hsDecls parsed + let newName2 = mkRdrName "bar2" + declsp' <- addParamsToDecls declsp n [newName2] + parsed' <- liftT $ replaceDecls parsed declsp' + putRefactParsed parsed' emptyAnns + + return declsp' + (nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1.toplevel" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel bar2 x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (showGhcQual $ head $ tail nb) `shouldBe` "toplevel bar2 x = c * x" + + -- --------------------------------- + + it "adds parameters to a declaration with multiple matches" $ do + t <- ct $ parsedFileGhc "./AddParams1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _ n) = locToName (3, 1) renamed + let + comp = do + declsp <- liftT $ hsDecls parsed + let newName = mkRdrName "pow" + declsp' <- addParamsToDecls declsp n [newName] + parsed' <- liftT $ replaceDecls parsed declsp' + putRefactParsed parsed' emptyAnns + return declsp' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "AddParams1.sq" + (sourceFromState s) `shouldBe` "module AddParams1 where\n\nsq pow 0 = 0\nsq pow z = z^2\n\nfoo = 3\n\n" + + -- --------------------------------- + + it "adds parameters to a declaration with no existing ones" $ do + t <- ct $ parsedFileGhc "./AddParams1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _ n) = locToName (6, 1) renamed + let + comp = do + declsp <- liftT $ hsDecls parsed + let newName1 = mkRdrName "baz" + let newName2 = mkRdrName "bar" + declsp' <- addParamsToDecls declsp n [newName1,newName2] + parsed' <- liftT $ replaceDecls parsed declsp' + putRefactParsed parsed' emptyAnns + + return declsp' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "AddParams1.foo" + (sourceFromState s) `shouldBe` "module AddParams1 where\n\nsq 0 = 0\nsq z = z^2\n\nfoo baz bar = 3\n\n" + + -- --------------------------------------------- + + describe "addActualParamsToRhs" $ do + it "adds a parameter to the rhs of a declaration" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/D1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n) = locToName (6, 21) renamed + let + comp = do + parsed <- getRefactParsed + declsp <- liftT $ hsDecls parsed + let decl = head declsp + let newName2 = mkRdrName "bar2" + newBinding <- addActualParamsToRhs n [newName2] decl + + return (newBinding,decl) + ((nb,decl'),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((nb,decl'),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual decl') `shouldBe` "sumSquares (x : xs)\n = sq x + sumSquares xs\n where\n sq x = x ^ pow\n pow = 2\nsumSquares [] = 0" + (showGhcQual n) `shouldBe` "sq" + (showGhcQual nb) `shouldBe` "sumSquares (x : xs)\n = (sq bar2) x + sumSquares xs\n where\n sq x = x ^ pow\n pow = 2\nsumSquares [] = 0" + (exactPrintFromState s nb) `shouldBe` "\n\n{-lift 'sq' to top level. This refactoring\n affects module 'D1' and 'C1' -}\n\nsumSquares (x:xs) = (sq bar2) x + sumSquares xs\n where\n sq x = x ^ pow\n pow =2\n\nsumSquares [] = 0" + + -- -------------------- + + it "adds parameters to a complex rhs of a declaration" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/WhereIn7.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n) = locToName (10, 17) renamed + let + comp = do + parsed <- getRefactParsed + declsp <- liftT $ hsDecls parsed + let decl = head declsp + + let newName1 = mkRdrName "x1" + let newName2 = mkRdrName "y1" + let newName3 = mkRdrName "z1" + newBinding <- addActualParamsToRhs n [newName1,newName2,newName3] decl + + return (newBinding,decl) + ((nb,decl'),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual decl') `shouldBe` "fun x y z\n = inc addthree\n where\n inc a = a + 1\n addthree = x + y + z" + (showGhcQual n) `shouldBe` "addthree" + (showGhcQual nb) `shouldBe` "fun x y z\n = inc (addthree x1 y1 z1)\n where\n inc a = a + 1\n addthree = x + y + z" + (exactPrintFromState s nb) `shouldBe` "\n\n--A definition can be lifted from a where or let to the top level binding group.\n--Lifting a definition widens the scope of the definition.\n\n--In this example, lift 'addthree' defined in 'fun'.\n--This example aims to test adding parenthese.\n\n\nfun x y z =inc (addthree x1 y1 z1)\n where inc a =a +1\n addthree=x+y+z" + + + -- --------------------------------------------- + + describe "rmDecl" $ do + it "removes a top level declaration, leaving type signature 1" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1a.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let Just (GHC.L _ n) = locToName (6, 1) renamed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + + return parsed' + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1a.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1a where\n\ndata D = A | B String | C\n\nff :: Int -> Int\n\nl = 1\n\n" + + -- --------------------------------- + + it "removes a top level declaration, leaving type signature 2b" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1b.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let Just (GHC.L _ n) = locToName (6, 1) renamed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + return parsed' + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1b.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1b where\n\ndata D = A | C\n\nff :: Int -> Int\n\nl z =\n let\n ll = 34\n in ll + z\n\n" + + -- --------------------------------- + + it "removes a top level declaration, leaving type signature 2" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let Just (GHC.L _ n) = locToName (22, 1) renamed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + logDataWithAnns "parsed'" parsed' + return parsed' + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + + -- --------------------------------- + + it "removes a top level declaration, and type signature" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _ n) = locToName (22, 1) renamed + let + comp = do + (newDecls,_removedDecl,_removedSig) <- rmDecl n True parsed + putRefactParsed newDecls emptyAnns + return newDecls + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + + -- ----------------------------------- + + it "removes the last local decl in a let/in clause" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/LetIn1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _ n) = locToName (11, 22) renamed + let + comp = do + parsed <- getRefactParsed + (parsed',_removedDecl,_removedSig) <- rmDecl n True parsed + + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "sq" + -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" + (sourceFromState s) `shouldBe` "module LiftToToplevel.LetIn1 where\n\n--A definition can be lifted from a where or let to the top level binding group.\n--Lifting a definition widens the scope of the definition.\n\n--In this example, lift 'sq' in 'sumSquares'\n--This example aims to test lifting a definition from a let clause to top level,\n--and the elimination of the keywords 'let' and 'in'\n\nsumSquares x y = sq x + sq y\n where pow=2\n\nanotherFun 0 y = sq y\n where sq x = x^2\n" + + -- ----------------------------------- + + it "removes the last local decl in a where clause" $ do + t <- ct $ parsedFileGhc "./RmDecl3.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _ n) = locToName (6, 5) renamed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n True parsed + + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "zz" + (sourceFromState s) `shouldBe` "module RmDecl3 where\n\n-- Remove last declaration from a where clause, where should disappear too\nff y = y + zz\n\n-- EOF\n" + + -- ----------------------------------- + + it "removes the first local decl in a where clause" $ do + t <- ct $ parsedFileGhc "./RmDecl4.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let Just (GHC.L _ n) = locToName (7, 5) renamed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n True parsed + + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "zz" + (sourceFromState s) `shouldBe` "{-# LANGUAGE FlexibleContexts #-}\nmodule RmDecl4 where\n\n-- Remove first declaration from a where clause, rest should still be indented\nff y = y + zz ++ xx\n where\n xx = 2\n\n-- EOF\n" + + -- ----------------------------------- + + it "removes the non last local decl in a let/in clause 1" $ do + t <- ct $ parsedFileGhc "./Demote/LetIn1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + -- (SYB.showData SYB.Renamer 0 renamed) `shouldBe` "" + + let Just (GHC.L _ n) = locToName (12, 22) renamed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "pow" + (sourceFromState s) `shouldBe` "module Demote.LetIn1 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the local 'pow' to 'sq'\n--This example also aims to test the demoting a local declaration in 'let'.\n\nsumSquares x y = let sq 0=0\n sq z=z^pow\n in sq x + sq y\n\n\nanotherFun 0 y = sq y\n where sq x = x^2\n\n " + + -- ----------------------------------- + + it "removes the non last local decl in a let/in clause 2" $ do + t <- ct $ parsedFileGhc "./Demote/LetIn2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _ n) = locToName (10, 22) renamed + let + comp = do + (parsed',_removedDecl,_removedSig) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "sq" + (sourceFromState s) `shouldBe` "module Demote.LetIn2 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the local 'pow' will fail.\n\nsumSquares x y = let pow=2\n in sq x + sq y +pow\n\n\nanotherFun 0 y = sq y\n where sq x = x^2\n\n " + + -- ----------------------------------------------------------------- + + it "removes a decl with a trailing comment" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn3.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let Just (GHC.L _ n) = locToName (14, 1) renamed + let + comp = do + (parsed',_removedDecl,_removedSig1) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual n) `shouldBe` "Demote.WhereIn3.sq" + (sourceFromState s) `shouldBe` "module Demote.WhereIn3 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there are multi matches), the parameters are not folded after demoting.\n\nsumSquares x y = sq p x + sq p y\n where p=2 {-There is a comment-}\n\nsq :: Int -> Int -> Int\n\n{- foo bar -}\nanotherFun 0 y = sq y\n where sq x = x^2\n" + + + -- ----------------------------------------------------------------- + + it "removes a sub decl liftOneLevel D1" $ do + t <- ct $ parsedFileGhc "./LiftOneLevel/D1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let Just (GHC.L _ n) = locToName (8, 6) renamed + let + comp = do + (parsed',_removedDecl,_removedSig1) <- rmDecl n False parsed + putRefactParsed parsed' emptyAnns + + return parsed' + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual n) `shouldBe` "sq" + (sourceFromState s) `shouldBe` "module LiftOneLevel.D1 where\n\n{-lift 'sq' to top level. This refactoring\naffects module 'D1' and 'C1' -}\n\nsumSquares (x:xs) = sq x + sumSquares xs\n where\n pow =2\n\nsumSquares [] = 0\n\nmain = sumSquares [1..4]\n" + + + -- --------------------------------------------- + + describe "rmTypeSig" $ do + it "removes a type signature from the top level 1" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let Just (GHC.L _ n) = locToName (22, 1) renamed + let + comp = do + (renamed',sigRemoved) <- rmTypeSig n parsed + putRefactParsed renamed' emptyAnns + return (renamed',sigRemoved) + ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((_nb,os),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (showGhcQual os) `shouldBe` "Just ff :: Int -> Int" + + -- ----------------------------------------------------------------- + + it "removes a type signature from the top level, after decl removed" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn3.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let Just (GHC.L _ n) = locToName (14, 1) renamed + let + comp = do + (parsed',_removedDecl,_removedSig1) <- rmDecl n False parsed + (parsed2,_removedSig2) <- rmTypeSig n parsed' + putRefactParsed parsed2 emptyAnns + + return parsed2 + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual n) `shouldBe` "Demote.WhereIn3.sq" + (sourceFromState s) `shouldBe` "module Demote.WhereIn3 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there are multi matches), the parameters are not folded after demoting.\n\nsumSquares x y = sq p x + sq p y\n where p=2 {-There is a comment-}\n\n{- foo bar -}\nanotherFun 0 y = sq y\n where sq x = x^2\n" + + + -- ----------------------------------------------------------------- + + it "removes a type signature from non-top level" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let Just (GHC.L _ n) = locToName (16, 5) renamed + let + comp = do + (renamed',_removedSig) <- rmTypeSig n parsed + putRefactParsed renamed' emptyAnns + return renamed' + -- (_nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (_nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "ff" + -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + + -- ----------------------------------------------------------------- + + it "removes a type signature within multi signatures 1" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TypeSigs.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let Just (GHC.L _ b) = locToName (12, 1) renamed + let + comp = do + (renamed',removedSig) <- rmTypeSig b parsed + putRefactParsed renamed' emptyAnns + return (renamed',removedSig) + ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (exactPrintFromState s (fromJust os)) `shouldBe` "\n\nb::Int->Integer->Char" + (showGhcQual b) `shouldBe` "TypeSigs.b" + (sourceFromState s) `shouldBe` "module TypeSigs where\n\nsq,anotherFun :: Int -> Int\nsq 0 = 0\nsq z = z^2\n\nanotherFun x = x^2\n\na,c::Int->Integer->Char\n\na x y = undefined\nb x y = undefined\nc x y = undefined\n\n" + + -- ----------------------------------------------------------------- + + it "removes a type signature within multi signatures 2" $ do + t <- ct $ parsedFileGhc "./TypeUtils/TypeSigs.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let Just (GHC.L _ n) = locToName (4, 1) renamed + let + comp = do + (renamed',removedSig) <- rmTypeSig n parsed + putRefactParsed renamed' emptyAnns + return (renamed',removedSig) + -- ((_nb,os),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- putStrLn $ "anntree\n" ++ showAnnDataFromState s + (exactPrintFromState s (fromJust os)) `shouldBe` "\n\nsq :: Int -> Int" + (showGhcQual n) `shouldBe` "TypeSigs.sq" + (sourceFromState s) `shouldBe` "module TypeSigs where\n\nanotherFun :: Int -> Int\nsq 0 = 0\nsq z = z^2\n\nanotherFun x = x^2\n\na,b,c::Int->Integer->Char\n\na x y = undefined\nb x y = undefined\nc x y = undefined\n\n" + (showGhcQual os) `shouldBe` "Just sq :: Int -> Int" + + -- ----------------------------------------------------------------- + + it "removes a type signature within multi signatures 3" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn7.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let Just (GHC.L _ n) = locToName (12, 1) renamed + let + comp = do + (parsed',removedSig) <- rmTypeSig n parsed + putRefactParsed parsed' emptyAnns + return (parsed',removedSig) + -- ((_nb,os),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + ((_nb,os),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual n) `shouldBe` "WhereIn7.sq" + (exactPrintFromState s (fromJust os)) `shouldBe` "\n\nsq :: Int -> Int" + (sourceFromState s) `shouldBe` "module WhereIn7 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--This example also aims to test the split of type signature.\n\nsumSquares x y = sq x + sq y\n\nanotherFun :: Int -> Int\nsq 0 = 0\nsq z = z^pow\n where pow=2\n\nanotherFun x = x^2\n " + (showGhcQual os) `shouldBe` "Just sq :: Int -> Int" + + -- ----------------------------------------------------------------- +{- + it "removes a type signature for a pattern in a bind" $ do + t <- ct $ parsedFileGhc "./LiftToToplevel/PatBindIn1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let Just (GHC.L _ n) = locToName (GHC.mkFastString "./test/testdata/LiftToToplevel/PatBindIn1.hs") (18, 7) renamed + let + comp = do + (renamed',removedSig) <- rmTypeSig n renamed + let (Just (GHC.L ss _)) = removedSig + oldSigToks <- getToksForSpan ss + return (renamed',removedSig,oldSigToks) + -- ((nb,os,ot),s) <- runRefactGhc comp $ initialState { rsModule = initRefactModule t } + ((nb,os,ot),s) <- runRefactGhc comp $ initialLogOnState { rsModule = initRefactModule t } + (showGhcQual n) `shouldBe` "tup" + -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" + (sourceFromState s) `shouldBe` "module LiftToToplevel.PatBindIn1 where\n\n --A definition can be lifted from a where or let into the surrounding binding group.\n --Lifting a definition widens the scope of the definition.\n\n --In this example, lift 'tup' defined in 'foo'\n --This example aims to test renaming and the lifting of type signatures.\n\n main :: Int\n main = foo 3\n\n foo :: Int -> Int\n foo x = h + t + (snd tup)\n where\n \n \n\n tup@(h,t) = head $ zip [1..10] [3..15]\n " + (showGhcQual nb) `shouldBe` "" + (showGhcQual os) `shouldBe` "" + (GHC.showRichTokenStream ot) `shouldBe` "" +-} + -- --------------------------------------------- + + describe "addDecl" $ do + it "adds a top level declaration without a type signature, in default pos" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let + comp = do + parsed <- getRefactParsed + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "a" "nn = n2") + -- let declAnns' = setPrecedingLines declAnns newDecl 2 + parsed' <- addDecl parsed Nothing ([decl],Just declAnns) + putRefactParsed parsed' emptyAnns + return parsed' + (nb,s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (nb,s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\nnn = n2\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\nnn = n2\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" + + -- ------------------------------------------- + + it "adds a top level declaration with a type signature 1" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let + comp = do + parsed <- getRefactParsed + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = 2") + (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") + parsed' <- addDecl parsed Nothing ([sig,decl],Just $ mergeAnns sigAnns declAnns) + putRefactParsed parsed' emptyAnns + return (sig,parsed') + ((_hs,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\nnn :: Int\nnn = 2\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\nnn :: Int\nnn = 2\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" + + -- ------------------------------------------- + + it "adds a top level declaration after a specified one" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let + comp = do + parsed <- getRefactParsed + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "a" "nn = nn2") + renamed <- getRefactRenamed + let Just (GHC.L _l n) = locToName (21, 1) renamed + parsed' <- addDecl parsed (Just n) ([decl],Just declAnns) + putRefactParsed parsed' emptyAnns + return (n,parsed') + ((n,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((n,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual n) `shouldBe` "MoveDef.Md1.ff" + (sourceFromState s) `shouldBe` "module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nnn = nn2\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nnn = nn2\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" + + + -- ------------------------------------------- + + it "adds a top level declaration with a type signature after a specified one" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let + comp = do + renamed <- getRefactRenamed + let Just (GHC.L _l n) = locToName (21, 1) renamed + parsed <- getRefactParsed + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") + parsed' <- addDecl parsed (Just n) ([sig,decl],Just $ mergeAnns sigAnns declAnns) + putRefactParsed parsed' emptyAnns + return (n,parsed') + ((nn,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual nn) `shouldBe` "MoveDef.Md1.ff" + (sourceFromState s) `shouldBe`"module MoveDef.Md1 where\n\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff :: Int -> Int\nff y = y + zz\n where\n zz = 1\n\nnn :: Int\nnn = nn2\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\nzz1 a = 1 + toplevel a\n\n-- General Comment\n-- |haddock comment\ntlFunc :: Integer -> Integer\ntlFunc x = c * x\n-- Comment at end\n\n\n" + (unspace $ showGhcQual nb) `shouldBe` unspace "module MoveDef.Md1 where\ntoplevel :: Integer -> Integer\ntoplevel x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff :: Int -> Int\nff y\n = y + zz\n where\n zz = 1\nnn :: Int\nnn = nn2\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }\nzz1 a = 1 + toplevel a\ntlFunc :: Integer -> Integer\ntlFunc x = c * x" + + + -- ------------------------------------------- + + it "adds a local declaration without a type signature 1" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + + let + comp = do + parsed <- getRefactParsed + renamed <- getRefactRenamed + nameMap <- getRefactNameMap + + let Just (GHC.L _ tl) = locToName (4, 1) renamed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + + newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) + + logm $ "test:addDecl done" + + return (tlDecl,newDecl) + -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual tl) `shouldBe` "toplevel x = c * x" + (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x\n where\n nn = nn2" + (showGhcQual nb) `shouldBe` "toplevel x\n = c * x\n where\n nn = nn2" + + -- ------------------------------------------- + + it "adds a local declaration with a type signature 1" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md1.hs" + let + comp = do + parsed <- getRefactParsed + renamed <- getRefactRenamed + nameMap <- getRefactNameMap + + let Just (GHC.L _ tl) = locToName (4, 1) renamed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") + + newDecl <- addDecl tlDecl Nothing ([sig,decl],Just $ mergeAnns sigAnns declAnns) + + return (tlDecl,newDecl) + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual tl) `shouldBe` "toplevel x = c * x" + -- putStrLn (showAnnDataItemFromState s nb) + (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x\n where\n nn :: Int\n nn = nn2" + (showGhcQual nb) `shouldBe` "toplevel x\n = c * x\n where\n nn = nn2\n nn :: Int" + -- ------------------------------------------- + + it "adds a local declaration with a where clause" $ do + t <- ct $ parsedFileGhc "./MoveDef/Demote.hs" + let + comp = do + + parsed <- getRefactParsed + renamed <- getRefactRenamed + nameMap <- getRefactNameMap + + let Just (GHC.L _ tl) = locToName (4, 1) renamed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + + newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) + + return (tlDecl,newDecl) + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual tl) `shouldBe` "toplevel x = c * x" + (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x\n where\n nn = nn2" + (showGhcQual nb) `shouldBe` "toplevel x\n = c * x\n where\n nn = nn2" + + -- ------------------------------------------- + + it "adds a local declaration to an existing one" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md2.hs" + let + comp = do + + parsed <- getRefactParsed + renamed <- getRefactRenamed + nameMap <- getRefactNameMap + + let Just (GHC.L _ tl) = locToName (4, 1) renamed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + + newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) + + return (tlDecl,newDecl) + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual tl) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3" + (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x * b\n where\n nn = nn2\n\n b = 3" + (showGhcQual nb) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3\n nn = nn2" + + -- ------------------------------------------- + + it "adds a local declaration with a type signature to an existing one" $ do + t <- ct $ parsedFileGhc "./MoveDef/Md2.hs" + let + comp = do + + parsed <- getRefactParsed + renamed <- getRefactRenamed + nameMap <- getRefactNameMap + + let Just (GHC.L _ tl) = locToName (4, 1) renamed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + (sig, sigAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "sig" "nn :: Int") + + newDecl <- addDecl tlDecl Nothing ([sig,decl],Just $ mergeAnns sigAnns declAnns) + + return (tlDecl,newDecl) + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual tl) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3" + (exactPrintFromState s nb) `shouldBe` "\ntoplevel x = c * x * b\n where\n nn :: Int\n nn = nn2\n\n b = 3" + (showGhcQual nb) `shouldBe` "toplevel x\n = c * x * b\n where\n b = 3\n nn = nn2\n nn :: Int" + + -- ------------------------------------------- + + it "adds a local decl with type signature to an existing one, with a comment" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn3.hs" + let + comp = do + parsed <- getRefactParsed + renamed <- getRefactRenamed + nameMap <- getRefactNameMap + + let Just (GHC.L _ tl) = locToName (10, 1) renamed + decls <- liftT (hsDecls parsed) + let [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False + + let Just (GHC.L _ sq) = locToName (14, 1) renamed + let Just (GHC.L _ af) = locToName (18, 1) renamed + + let [sqSig] = definingSigsRdrNames nameMap [sq] parsed + [sqDecl] = definingDeclsRdrNames nameMap [sq] decls False False + [afDecl] = definingDeclsRdrNames nameMap [af] decls False False + + let sqSigDecl = wrapSig sqSig + liftT (balanceComments tlDecl sqSigDecl) + liftT (balanceComments sqDecl afDecl) + + newDecl <- addDecl tlDecl Nothing ([sqSigDecl,sqDecl],Nothing) + + return (sqSig,sqDecl,tlDecl,afDecl,newDecl) + -- ((sigs,_sd,tl,aa,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + ((sigs,_sd,tl,aa,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual sigs) `shouldBe` "sq :: Int -> Int -> Int" + (showGhcQual tl) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2" + (showGhcQual aa) `shouldBe` "anotherFun 0 y\n = sq y\n where\n sq x = x ^ 2" + (exactPrintFromState s nb) `shouldBe` "\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there are multi matches), the parameters are not folded after demoting.\n\nsumSquares x y = sq p x + sq p y\n where sq :: Int -> Int -> Int\n sq pow 0 = 0\n sq pow z = z^pow --there is a comment\n\n p=2 {-There is a comment-}" + (showGhcQual nb) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2\n sq :: Int -> Int -> Int\n sq pow 0 = 0\n sq pow z = z ^ pow" + + -- ------------------------------------------- + + it "does not add a local decl to a FunBind with multiple matches" $ do + t <- ct $ parsedFileGhc "./MoveDef/MultiFunBind1.hs" + let + comp = do + parsed <- getRefactParsed + renamed <- getRefactRenamed + nameMap <- getRefactNameMap + + let Just (GHC.L _ tl) = locToName (3, 1) renamed + decls <- liftT (hsDecls parsed) + let -- decls = hsBinds parsed + [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False + + let Just (GHC.L _ y) = locToName (6, 1) renamed + + let [yDecl] = definingDeclsRdrNames nameMap [y] decls False False + + newDecl <- addDecl tlDecl Nothing ([yDecl],Nothing) + + return (yDecl,tlDecl,newDecl) + r <- catchException $ runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + r `shouldBe` Just "addDecl:Cannot add a local decl to a FunBind with multiple matches" + + -- ------------------------------------------- + + it "adds a local declaration to a PatBind" $ do + t <- ct $ parsedFileGhc "./MoveDef/PatBind1.hs" + let + comp = do + + parsed <- getRefactParsed + renamed <- getRefactRenamed + nameMap <- getRefactNameMap + + let Just (GHC.L _ tl) = locToName (3, 1) renamed + decls <- liftT (hsDecls parsed) + let + [tlDecl] = definingDeclsRdrNames nameMap [tl] decls True False + + (decl,declAnns) <- GHC.liftIO $ withDynFlags (\df -> parseDeclToAnnotated df "decl" "nn = nn2") + + newDecl <- addDecl tlDecl Nothing ([decl],Just declAnns) + + return (tlDecl,newDecl) + ((tl,nb),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((tl,nb),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual tl) `shouldBe` "tup@(h, t) = (x, 1)" + (exactPrintFromState s nb) `shouldBe` "\n\ntup@(h,t) = (x,1)\n where\n nn = nn2" + (showGhcQual nb) `shouldBe` "tup@(h, t)\n = (x, 1)\n where\n nn = nn2" + + -- --------------------------------------------- + + describe "renamePN" $ do + it "replaces a Name with another, updating tokens 1" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parsed <- getRefactParsed + renamed <- getRefactRenamed + let Just (GHC.L _l n') = locToName (3, 1) renamed + newName <- mkNewGhcName Nothing "bar2" + new <- renamePN' n' newName False parsed + putRefactParsed new emptyAnns + return (new,newName,n') + let + + ((nb,nn,n),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual (n,nn)) `shouldBe` "(DupDef.Dd1.toplevel, bar2)" + (sourceFromState s) `shouldBe` "module DupDef.Dd1 where\n\nbar2 :: Integer -> Integer\nbar2 x = c * x\n\nc,d :: Integer\nc = 7\nd = 9\n\n-- Pattern bind\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h,t) = head $ zip [1..10] [3..ff]\n where\n ff :: Int\n ff = 15\n\ndata D = A | B String | C\n\nff y = y + zz\n where\n zz = 1\n\nl z =\n let\n ll = 34\n in ll + z\n\ndd q = do\n let ss = 5\n return (ss + q)\n\n" + (showGhcQual nb) `shouldBe` "module DupDef.Dd1 where\nbar2 :: Integer -> Integer\nbar2 x = c * x\nc, d :: Integer\nc = 7\nd = 9\ntup :: (Int, Int)\nh :: Int\nt :: Int\ntup@(h, t)\n = head $ zip [1 .. 10] [3 .. ff]\n where\n ff :: Int\n ff = 15\ndata D = A | B String | C\nff y\n = y + zz\n where\n zz = 1\nl z = let ll = 34 in ll + z\ndd q\n = do { let ss = 5;\n return (ss + q) }" + + -- ----------------------------------------------------------------- + + it "replaces a Name with another, updating tokens 2" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn4.hs" + + let + comp = do + renamed <- getRefactRenamed + parsed <- getRefactParsed + declsr <- liftT $ hsDecls parsed + let decl = head $ drop 0 declsr + let Just (GHC.L _l n') = locToName (11, 21) renamed + newName <- mkNewGhcName Nothing "p_1" + new <- renamePN' n' newName False decl + parsed' <- liftT $ replaceDecls parsed (new:tail declsr) + putRefactParsed parsed' emptyAnns + return (new,newName,decl,n') + let + ((nb,nn,d,n),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual d) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2" + (showGhcQual (n,nn)) `shouldBe` "(p, p_1)" + (sourceFromState s) `shouldBe` "module Demote.WhereIn4 where\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there is single matches), if possible,\n--the parameters will be folded after demoting and type sigature will be removed.\n\nsumSquares x y = sq p_1 x + sq p_1 y\n where p_1=2 {-There is a comment-}\n\nsq::Int->Int->Int\nsq pow z = z^pow --there is a comment\n\nanotherFun 0 y = sq y\n where sq x = x^2\n\n" + (showGhcQual nb) `shouldBe` "sumSquares x y\n = sq p_1 x + sq p_1 y\n where\n p_1 = 2" + + + -- --------------------------------- + + it "replaces a Name with another in limited scope, updating tokens 1" $ do + t <- ct $ parsedFileGhc "./TokenTest.hs" + + let renamed = fromJust $ GHC.tm_renamed_source t + let Just (GHC.L _ n) = locToName (19, 1) renamed + (showGhcQual n) `shouldBe` "TokenTest.foo" + + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + newName <- mkNewGhcName Nothing "bar2" + new <- renamePN' n newName False (head $ drop 3 decls) + parsed' <- liftT $ replaceDecls parsed (take 3 decls ++ [new] ++ drop 4 decls) + putRefactParsed parsed' emptyAnns + return (new,newName) + let + + ((nb,nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((nb,nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual (n,nn)) `shouldBe` "(TokenTest.foo, bar2)" + (sourceFromState s) `shouldBe` "module TokenTest where\n\n-- Test new style token manager\n\nbob a b = x\n where x = 3\n\nbib a b = x\n where\n x = 3\n\n\nbab a b =\n let bar = 3\n in b + bar -- ^trailing comment\n\n\n-- leading comment\nbar2 x y =\n do c <- getChar\n return c\n\n\n\n\n" + (showGhcQual nb) `shouldBe` "bar2 x y\n = do { c <- getChar;\n return c }" + -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" + + -- --------------------------------- + + it "replace a Name with another in limited scope, updating tokens 2" $ do + t <- ct $ parsedFileGhc "./TokenTest.hs" + + let renamed = fromJust $ GHC.tm_renamed_source t + let Just (GHC.L _ n) = locToName (19, 1) renamed + (showGhcQual n) `shouldBe` "TokenTest.foo" + + let + comp = do + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + let decl = head $ drop 3 decls + newName <- mkNewGhcName Nothing "bar2" + new <- renamePN' n newName False decl + + parsed' <- liftT $ replaceDecls parsed (take 3 decls ++ [new] ++ drop 4 decls) + putRefactParsed parsed' emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "TokenTest.foo" + (sourceFromState s) `shouldBe` "module TokenTest where\n\n-- Test new style token manager\n\nbob a b = x\n where x = 3\n\nbib a b = x\n where\n x = 3\n\n\nbab a b =\n let bar = 3\n in b + bar -- ^trailing comment\n\n\n-- leading comment\nbar2 x y =\n do c <- getChar\n return c\n\n\n\n\n" + (showGhcQual nb) `shouldBe` "bar2 x y\n = do { c <- getChar;\n return c }" + -- (showToks $ take 20 $ toksFromState s) `shouldBe` "" + + ------------------------------------ + + it "replaces a name in a data declaration too" $ do + t <- ct $ parsedFileGhc "./Renaming/Field1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (5, 19) renamed + let + comp = do + newName <- mkNewGhcName Nothing "pointx1" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + let + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "Field1.pointx" + (sourceFromState s) `shouldBe` "module Field1 where\n\n--Rename field name 'pointx' to 'pointx1'\n\ndata Point = Pt {pointx1, pointy :: Float}\n\nabsPoint :: Point -> Float\nabsPoint p = sqrt (pointx1 p * pointx1 p +\n pointy p * pointy p)\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module Field1 where\ndata Point = Pt {pointx1, pointy :: Float}\nabsPoint :: Point -> Float\nabsPoint p = sqrt (pointx1 p * pointx1 p + pointy p * pointy p)" + + + ------------------------------------ + + it "replaces a name in a type signature too" $ do + t <- ct $ parsedFileGhc "./Renaming/Field1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (5, 6) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + newName <- mkNewGhcName Nothing "NewPoint" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + let + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((nb,nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual n) `shouldBe` "Field1.Point" + (sourceFromState s) `shouldBe` "module Field1 where\n\n--Rename field name 'pointx' to 'pointx1'\n\ndata NewPoint = Pt {pointx, pointy :: Float}\n\nabsPoint :: NewPoint -> Float\nabsPoint p = sqrt (pointx p * pointx p +\n pointy p * pointy p)\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module Field1 where\ndata NewPoint = Pt {pointx, pointy :: Float}\nabsPoint :: NewPoint -> Float\nabsPoint p = sqrt (pointx p * pointx p + pointy p * pointy p)" + + ------------------------------------ + + it "replace a name in a FunBind with multiple patterns" $ do + t <- ct $ parsedFileGhc "./LocToName.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (20, 1) renamed + let + comp = do + newName <- mkNewGhcName Nothing "newPoint" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + let + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual n) `shouldBe` "LocToName.sumSquares" + (sourceFromState s) `shouldBe` "module LocToName where\n\n{-\n\n\n\n\n\n\n\n\n-}\n\n\n\n\n\n\n\nnewPoint (x:xs) = x ^2 + newPoint xs\n -- where sq x = x ^pow \n -- pow = 2\n\nnewPoint [] = 0\n" + (unspace $ showGhcQual nb) `shouldBe` "module LocToName where\nnewPoint (x : xs) = x ^ 2 + newPoint xs\nnewPoint [] = 0" + + ------------------------------------ + + it "replaces a qualified name in a FunBind with multiple patterns" $ do + t <- ct $ parsedFileGhc "./LocToName.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") + + let Just (GHC.L _l n) = locToName (20, 1) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + newName <- mkNewGhcName (Just modu) "newPoint" + new <- renamePN' n newName True parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((nb,_nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual n) `shouldBe` "LocToName.sumSquares" + (unspace $ showGhcQual nb) `shouldBe` "module LocToName where\nLocToName.newPoint (x : xs) = x ^ 2 + LocToName.newPoint xs\nLocToName.newPoint [] = 0" + (sourceFromState s) `shouldBe` "module LocToName where\n\n{-\n\n\n\n\n\n\n\n\n-}\n\n\n\n\n\n\n\nnewPoint (x:xs) = x ^2 + LocToName.newPoint xs\n -- where sq x = x ^pow \n -- pow = 2\n\nnewPoint [] = 0\n" + + + ------------------------------------ + + it "replaces a parameter name in a FunBind" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _ n) = locToName (8, 7) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "ls" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- (showGhcQual $ sourceTreeFromState s) `shouldBe` "" + (sourceFromState s) `shouldBe` "module LayoutIn2 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'list' to 'ls'.\n\nsilly :: [Int] -> Int\nsilly ls = case ls of (1:xs) -> 1\n--There is a comment\n (2:xs)\n | x < 10 -> 4 where x = last xs\n otherwise -> 12\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn2 where\nsilly :: [Int] -> Int\nsilly ls\n = case ls of {\n (1 : xs) -> 1\n (2 : xs)\n | x < 10 -> 4\n where\n x = last xs\n otherwise -> 12 }" + + + ------------------------------------ + + it "does not qualify a name in an import hiding clause" $ do + t <- ct $ parsedFileGhc "./ScopeAndQual.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") + + let Just (GHC.L _l n) = locToName (4, 24) renamed + let + comp = do + newName <- mkNewGhcName (Just modu) "mySum" + new <- renamePN' n newName True parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((nb,_nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "Data.Foldable.sum" + (sourceFromState s) `shouldBe` "module ScopeAndQual where\n\nimport qualified Data.List as L\nimport Prelude hiding (mySum)\n\nmain :: IO ()\nmain = putStrLn (show $ L.mySum [1,2,3])\n\nsum a b = a + b\n\nsumSquares xs = L.mySum $ map (\\x -> x*x) xs\n\nmySumSq = sumSquares\n" + (unspace $ showGhcQual nb) `shouldBe` "module ScopeAndQual where\nimport qualified Data.List as L\nimport Prelude hiding ( mySum )\nmain :: IO ()\nmain = putStrLn (show $ L.mySum [1, 2, 3])\nsum a b = a + b\nsumSquares xs = L.mySum $ map (\\ x -> x * x) xs\nmySumSq = sumSquares" + + + ------------------------------------ + + it "does not qualify the subject of a type signature" $ do + t <- ct $ parsedFileGhc "./Renaming/C7.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let modu = GHC.mkModule (GHC.stringToPackageKey "mypackage-1.0") (GHC.mkModuleName "LocToName") + + let Just (GHC.L _l n) = locToName (5, 1) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + newName <- mkNewGhcName (Just modu) "myNewFringe" + + new <- renamePN' n newName True parsed + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((nb,_nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "Renaming.C7.myFringe" + (sourceFromState s) `shouldBe` "module Renaming.C7(LocToName.myNewFringe) where\n\nimport Renaming.D7\n\nmyNewFringe:: Tree a -> [a]\nmyNewFringe (Leaf x ) = [x]\nmyNewFringe (Branch left right) = LocToName.myNewFringe left ++ fringe right\n\n\n\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module Renaming.C7 (\n LocToName.myNewFringe\n ) where\nimport Renaming.D7\nmyNewFringe :: Tree a -> [a]\nLocToName.myNewFringe (Leaf x) = [x]\nLocToName.myNewFringe (Branch left right)\n = LocToName.myNewFringe left ++ fringe right" + + ------------------------------------ + + it "realigns toks in a case for a shorter name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (8, 7) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "ls" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "list" + (sourceFromState s) `shouldBe` "module LayoutIn2 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'list' to 'ls'.\n\nsilly :: [Int] -> Int\nsilly ls = case ls of (1:xs) -> 1\n--There is a comment\n (2:xs)\n | x < 10 -> 4 where x = last xs\n otherwise -> 12\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn2 where\nsilly :: [Int] -> Int\nsilly ls\n = case ls of {\n (1 : xs) -> 1\n (2 : xs)\n | x < 10 -> 4\n where\n x = last xs\n otherwise -> 12 }" + + + + ------------------------------------ + + it "realigns toks in a case for a longer name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (8, 7) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "listlonger" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "list" + (sourceFromState s) `shouldBe` "module LayoutIn2 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'list' to 'ls'.\n\nsilly :: [Int] -> Int\nsilly listlonger = case listlonger of (1:xs) -> 1\n --There is a comment\n (2:xs)\n | x < 10 -> 4 where x = last xs\n otherwise -> 12\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn2 where\nsilly :: [Int] -> Int\nsilly listlonger\n = case listlonger of {\n (1 : xs) -> 1\n (2 : xs)\n | x < 10 -> 4\n where\n x = last xs\n otherwise -> 12 }" + + + ------------------------------------ + + it "realigns toks in a do for a shorter name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn4.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (7, 8) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "io" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "ioFun" + (sourceFromState s) `shouldBe` "module LayoutIn4 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'ioFun' to 'io'\n\nmain = io \"hello\" where io s= do let k = reverse s\n--There is a comment\n s <- getLine\n let q = (k ++ s)\n putStr q\n putStr \"foo\"\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn4 where\nmain\n = io \"hello\"\n where\n io s\n = do { let k = reverse s;\n s <- getLine;\n let q = (k ++ s);\n putStr q;\n putStr \"foo\" }" + + + ------------------------------------ + + it "realigns toks in a do for a longer name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn4.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (7, 8) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "ioFunLong" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "ioFun" + (sourceFromState s) `shouldBe` "module LayoutIn4 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'ioFun' to 'io'\n\nmain = ioFunLong \"hello\" where ioFunLong s= do let k = reverse s\n --There is a comment\n s <- getLine\n let q = (k ++ s)\n putStr q\n putStr \"foo\"\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn4 where\nmain\n = ioFunLong \"hello\"\n where\n ioFunLong s\n = do { let k = reverse s;\n s <- getLine;\n let q = (k ++ s);\n putStr q;\n putStr \"foo\" }" + + ------------------------------------ + + it "realigns toks in a where for a shorter name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (7, 17) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "q" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "sq" + (sourceFromState s) `shouldBe` "module LayoutIn1 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'sq' to 'square'.\n\nsumSquares x y= q x + q y where q x= x^pow\n--There is a comment.\n pow=2\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn1 where\nsumSquares x y\n = q x + q y\n where\n q x = x ^ pow\n pow = 2" + + + ------------------------------------ + + it "realigns toks in a where for a longer name" $ do + t <- ct $ parsedFileGhc "./Renaming/LayoutIn1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (7, 17) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "square" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "sq" + (sourceFromState s) `shouldBe` "module LayoutIn1 where\n\n--Layout rule applies after 'where','let','do' and 'of'\n\n--In this Example: rename 'sq' to 'square'.\n\nsumSquares x y= square x + square y where square x= x^pow\n --There is a comment.\n pow=2\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutIn1 where\nsumSquares x y\n = square x + square y\n where\n square x = x ^ pow\n pow = 2" + + ------------------------------------ + + it "realigns toks in a let/in for a shorter name" $ do + t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (6, 6) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "x" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "xxx" + (sourceFromState s) `shouldBe` "module LayoutLet1 where\n\n-- Simple let expression, rename xxx to something longer or shorter\n-- and the let/in layout should adjust accordingly\n\nfoo x = let a = 1\n b = 2\n in x + a + b\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutLet1 where\nfoo x\n = let\n a = 1\n b = 2\n in x + a + b" + + ------------------------------------ + + it "realigns toks in a let/in for a longer name 1" $ do + t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (6, 6) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "xxxlong" + -- new <- renamePN n newName False renamed + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,_nn),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((nb,nn),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "xxx" + (sourceFromState s) `shouldBe` "module LayoutLet1 where\n\n-- Simple let expression, rename xxx to something longer or shorter\n-- and the let/in layout should adjust accordingly\n\nfoo xxxlong = let a = 1\n b = 2\n in xxxlong + a + b\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutLet1 where\nfoo xxxlong\n = let\n a = 1\n b = 2\n in xxxlong + a + b" + + + ------------------------------------ + + it "realigns toks in a let/in for a longer name 2" $ do + t <- ct $ parsedFileGhc "./TypeUtils/LayoutLet2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (7, 6) renamed + let + comp = do + logm $ "renamed:" ++ (SYB.showData SYB.Renamer 0 renamed) + + newName <- mkNewGhcName Nothing "xxxlong" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + + return (new,newName) + + ((nb,nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((nb,nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual (n,nn)) `shouldBe` "(xxx, xxxlong)" + (sourceFromState s) `shouldBe` "module LayoutLet2 where\n\n-- Simple let expression, rename xxx to something longer or shorter\n-- and the let/in layout should adjust accordingly\n-- In this case the tokens for xxx + a + b should also shift out\n\nfoo xxxlong = let a = 1\n b = 2 in xxxlong + a + b\n\n" + (unspace $ showGhcQual nb) `shouldBe` "module LayoutLet2 where\nfoo xxxlong\n = let\n a = 1\n b = 2\n in xxxlong + a + b" + + + ------------------------------------ + + it "renames an exported data type" $ do + t <- ct $ parsedFileGhc "./Renaming/RenameInExportedType2.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let Just (GHC.L _l n) = locToName (6, 24) renamed + let + comp = do + logm $ "parsed:" ++ (SYB.showData SYB.Parser 0 parsed) + + newName <- mkNewGhcName Nothing "NewType" + new <- renamePN' n newName False parsed + + putRefactParsed new emptyAnns + logm $ "parsed:after" ++ (SYB.showData SYB.Parser 0 new) + + return (new,newName) + + ((_nb,nn),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((_nb,nn),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual (n,nn)) `shouldBe` "(Renaming.RenameInExportedType.NT, NewType)" + (sourceFromState s) `shouldBe` "module Renaming.RenameInExportedType\n (\n MyType (NewType)\n ) where\n\ndata MyType = MT Int | NewType\n\n\n" + + + -- --------------------------------------------- + + describe "qualifyToplevelName" $ do + it "qualifies a name at the top level" $ do + t <- ct $ parsedFileGhc "./Renaming/C7.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let Just (GHC.L _l n) = locToName (7, 1) renamed + let + comp = do + qualifyToplevelName n + + return () + let + + (_,s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (showGhcQual n) `shouldBe` "Renaming.C7.myFringe" + (sourceFromState s) `shouldBe` "module Renaming.C7(Renaming.C7.myFringe) where\n\nimport Renaming.D7\n\nmyFringe:: Tree a -> [a]\nmyFringe (Leaf x ) = [x]\nmyFringe (Branch left right) = Renaming.C7.myFringe left ++ fringe right\n\n\n\n\n" + + + + -- --------------------------------------------- + + describe "findEntity" $ do + it "returns true if a (Located) Name is part of a HsBind 1" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parentr <- getRefactRenamed + + let mn = locToName (4,1) parentr + let (Just (ln@(GHC.L _ n))) = mn + + let declsr = hsBinds parentr + duplicatedDecls = definingDeclsNames [n] declsr True False + + res = findEntity ln duplicatedDecls + res2 = findEntity n duplicatedDecls + -- res = findEntity' ln duplicatedDecls + + return (res,res2,duplicatedDecls,ln) + ((r,r2,d,_l),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual d) `shouldBe` "[DupDef.Dd1.toplevel x = DupDef.Dd1.c GHC.Num.* x]" + (showGhcQual _l) `shouldBe` "DupDef.Dd1.toplevel" + ("1" ++ show r) `shouldBe` "1True" + ("2" ++ show r2) `shouldBe` "2True" + + -- --------------------------------- + + it "returns true if a (Located) Name is part of a HsBind 2" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parentr <- getRefactRenamed + + let mn = locToName (31,7) parentr + let (Just (ln@(GHC.L _ n))) = mn + + let mnd = locToName (30,1) parentr + let (Just ((GHC.L _ nd))) = mnd + + let declsr = hsBinds parentr + duplicatedDecls = definingDeclsNames [nd] declsr True False + + res = findEntity ln duplicatedDecls + res2 = findEntity n duplicatedDecls + + return (res,res2,duplicatedDecls,ln) + ((r,r2,d,_l),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual d) `shouldBe` "[DupDef.Dd1.dd q\n = do { let ss = 5;\n"++ + " GHC.Base.return (ss GHC.Num.+ q) }]" + (showGhcQual _l) `shouldBe` "ss" + ("1" ++ show r) `shouldBe` "1True" + ("2" ++ show r2) `shouldBe` "2True" + + + -- ----------------------------------------------------------------- + + it "returns false if a syntax phrase is not part of another" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + parentr <- getRefactRenamed + + let mn = locToName (4,1) parentr + let (Just (ln@(GHC.L _ n))) = mn + + let mltup = locToName (11,1) parentr + let (Just ((GHC.L _ tup))) = mltup + + let declsr = hsBinds parentr + duplicatedDecls = definingDeclsNames [n] declsr True False + + res = findEntity tup duplicatedDecls + -- res = findEntity' ln duplicatedDecls + + return (res,duplicatedDecls,ln) + ((r,d,_l),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual d) `shouldBe` "[DupDef.Dd1.toplevel x = DupDef.Dd1.c GHC.Num.* x]" + ("1" ++ show r) `shouldBe` "1False" + + -- ----------------------------------------------------------------- + + it "Finds an entity in [HsBind Name]" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (MatchGroup matches _)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (HsLet decls _)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (HsLet _ e1)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (HsLet decls _)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (PatBind pat rhs _ _ _)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (Match _ _ rhs)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (LetStmt binds)" $ do + pending -- "write this test" + + -- ----------------------------------------------------------------- + + it "Finds an entity in (BindStmt _ rhs _ _)" $ do + pending -- "write this test" + + + -- --------------------------------------------- + + describe "modIsExported" $ do + it "Returns True if the module is explicitly exported" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = fromJust $ GHC.tm_renamed_source t + let (Just (modName,_)) = getModuleName parsed + + (modIsExported modName renamed) `shouldBe` True + + it "Returns True if the module is exported by default" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare1.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = fromJust $ GHC.tm_renamed_source t + let (Just (modName,_)) = getModuleName parsed + + (modIsExported modName renamed) `shouldBe` True + + it "Returns False if the module is explicitly not exported" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare2.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + let renamed = fromJust $ GHC.tm_renamed_source t + let (Just (modName,_)) = getModuleName parsed + + (modIsExported modName renamed) `shouldBe` False + + -- --------------------------------------------- + + describe "isExported" $ do + it "returns True if a GHC.Name is exported" $ do + t <- ct $ parsedFileGhc "./Renaming/B1.hs" + + let + comp = do + renamed <- getRefactRenamed + + let mn1 = locToName (11,1) renamed + let (Just (GHC.L _ myFringe)) = mn1 + + let mn2 = locToName (15,1) renamed + let (Just (GHC.L _ sumSquares)) = mn2 + + exMyFring <- isExported myFringe + exSumSquares <- isExported sumSquares + + return (myFringe,exMyFring,sumSquares,exSumSquares) + ((mf,emf,ss,ess),_s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t}) testOptions + + (showGhcQual mf) `shouldBe` "Renaming.B1.myFringe" + emf `shouldBe` True + (showGhcQual ss) `shouldBe` "Renaming.B1.sumSquares" + ess `shouldBe` False + + -- --------------------------------------------- + + describe "addHiding" $ do + it "add a hiding entry to the imports with no existing hiding" $ do + t1 <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + clearParsedModule + t2 <- parseSourceFileTest "./DupDef/Dd2.hs" + let renamed1 = fromJust $ GHC.tm_renamed_source t1 + let renamed2 = fromJust $ GHC.tm_renamed_source t2 + + let parsed1 = GHC.pm_parsed_source $ GHC.tm_parsed_module t1 + let parsed2 = GHC.pm_parsed_source $ GHC.tm_parsed_module t2 + + let mn = locToName (4,1) renamed1 + let (Just (GHC.L _ _n)) = mn + + let Just (modName,_) = getModuleName parsed1 + let + n1 = mkRdrName "n1" + n2 = mkRdrName "n2" + res <- addHiding modName parsed2 [n1,n2] + putRefactParsed res emptyAnns + + return (res,renamed2) + ((_r,_r2),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t1}) testOptions + -- ((_r,_r2),s) <- ct $ runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t1}) testOptions + + (sourceFromState s) `shouldBe` "module DupDef.Dd2 where\n\nimport DupDef.Dd1 hiding (n1,n2)\n\n\nf2 x = ff (x+1)\n\nmm = 5\n\n\n" + + ------------------------------------ + + it "adds a hiding entry to the imports with an existing hiding" $ do + t1 <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + + clearParsedModule + t2 <- parseSourceFileTest "./DupDef/Dd3.hs" + let renamed1 = fromJust $ GHC.tm_renamed_source t1 + let renamed2 = fromJust $ GHC.tm_renamed_source t2 + + let parsed1 = GHC.pm_parsed_source $ GHC.tm_parsed_module t1 + let parsed2 = GHC.pm_parsed_source $ GHC.tm_parsed_module t2 + + let mn = locToName (4,1) renamed1 + let (Just (GHC.L _ _n)) = mn + + let Just (modName,_) = getModuleName parsed1 + let + n1 = mkRdrName "n1" + n2 = mkRdrName "n2" + res <- addHiding modName parsed2 [n1,n2] + + return (res,renamed2) + ((_r,_r2),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t1}) testOptions + (sourceFromState s) `shouldBe` "module DupDef.Dd3 where\n\nimport DupDef.Dd1 hiding (dd,n1,n2)\n\n\nf2 x = ff (x+1)\n\nmm = 5\n\n\n" + + -- --------------------------------------------- + + describe "equivalentNameInNewMod" $ do + it "finds equivalent name for normal import" $ do + let + ctc = cdAndDo "./test/testdata/cabal/foo" + let + comp = do + parseSourceFileGhc "./src/Foo/Bar.hs" + renamed <- getRefactRenamed + let Just ((GHC.L _l old)) = locToName (3,1) renamed + parseSourceFileGhc "./src/Main.hs" + [equiv] <- equivalentNameInNewMod old + return (old,equiv) + + ((o,e),_s) <- ctc $ runRefactGhc comp initialState testOptions + (showGhcQual (o,e)) `shouldBe` "(Foo.Bar.bar, Foo.Bar.bar)" + -- (showGhcQual (GHC.nameUnique o,GHC.nameUnique e)) `shouldBe` "" + (GHC.nameUnique o == GHC.nameUnique e) `shouldBe` False + + -- --------------------------------- + + it "finds equivalent name for qualified import" $ do + let + ctc = cdAndDo "./test/testdata/cabal/cabal4" + let + comp = do + parseSourceFileGhc "./src/Foo/Bar.hs" + renamed <- getRefactRenamed + let Just ((GHC.L _l old)) = locToName (3,1) renamed + parseSourceFileGhc "./src/main4.hs" + [equiv] <- equivalentNameInNewMod old + + parsed <- getRefactParsed + let Just ((GHC.L _l new)) = locToRdrName (11,12) parsed + return (old,equiv,new) + + ((o,e,n),_s) <- ctc $ runRefactGhc comp initialState testOptions + (showGhcQual (o,e,n)) `shouldBe` "(Foo.Bar.baz, Foo.Bar.baz, B.baz)" + -- (showGhcQual (GHC.nameUnique o,GHC.nameUnique e)) `shouldBe` "" + (GHC.nameUnique o == GHC.nameUnique e) `shouldBe` False + + -- --------------------------------------------- + + describe "usedWithoutQualR" $ do + it "Returns True if the identifier is used unqualified" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + renamed <- getRefactRenamed + parsed <- getRefactParsed + + let Just n@(GHC.L _ name) = locToName (14,21) renamed + let res = usedWithoutQualR name parsed + return (res,n,name) + + ((r,n1,n2),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (GHC.getOccString n2) `shouldBe` "zip" + (showGhcQual n1) `shouldBe` "GHC.List.zip" + r `shouldBe` True + + -- --------------------------------- + + it "Returns False if the identifier is used qualified" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/Declare.hs" + let + comp = do + renamed <- getRefactRenamed + parsed <- getRefactParsed + + let Just n@(GHC.L _ name) = locToName (36,12) renamed + let Just (GHC.L _ namep) = locToRdrName (36,12) parsed + let res = usedWithoutQualR name parsed + return (res,namep,name,n) + ((r,np,n1,n2),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (myShow np) `shouldBe` "Qual:G:gshow" + (myShow $ GHC.getRdrName n1) `shouldBe` "Exact:Data.Generics.Text.gshow" + (showGhcQual $ GHC.getRdrName n1) `shouldBe` "Data.Generics.Text.gshow" + (showGhcQual n2) `shouldBe` "Data.Generics.Text.gshow" + r `shouldBe` False + + -- --------------------------------------------- + + describe "isExplicitlyExported" $ do + it "Returns True if the identifier is explicitly exported" $ do + pending -- "write this " + + it "Returns False if the identifier is not explicitly exported" $ do + pending -- "write this " + + -- --------------------------------------------- + + describe "causeNameClashInExports" $ do + it "Returns True if there is a clash" $ do + + t <- ct $ parsedFileGhc "./Renaming/ConflictExport.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module t + + -- Is this the right module? + let Just (modName,_) = getModuleName parsed + + let Just (GHC.L _ myFringe) = locToName (9,1) renamed + (showGhcQual myFringe) `shouldBe` "Renaming.ConflictExport.myFringe" + + -- old name is myFringe + -- new name is "Renaming.ConflictExport.fringe" + let newName = mkTestGhcName 1 (Just modu) "fringe" + + (showGhcQual modu) `shouldBe` "main@main:Renaming.ConflictExport" + (showGhcQual newName) `shouldBe` "Renaming.ConflictExport.fringe" + + (showGhcQual $ GHC.localiseName newName) `shouldBe` "fringe" + + let res = causeNameClashInExports myFringe newName modName renamed + res `shouldBe` True + + it "Returns False if there is no clash" $ do + t <- ct $ parsedFileGhc "./Renaming/ConflictExport.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module t + + -- Is this the right module? + let Just (modName,_) = getModuleName parsed + + let Just (GHC.L _ myFringe) = locToName (9,1) renamed + (showGhcQual myFringe) `shouldBe` "Renaming.ConflictExport.myFringe" + + -- old name is myFringe + -- new name is "Renaming.ConflictExport.fringe" + let newName = mkTestGhcName 1 (Just modu) "fringeOk" + + (showGhcQual modu) `shouldBe` "main@main:Renaming.ConflictExport" + (showGhcQual newName) `shouldBe` "Renaming.ConflictExport.fringeOk" + + (showGhcQual $ GHC.localiseName newName) `shouldBe` "fringeOk" + + let res = causeNameClashInExports myFringe newName modName renamed + res `shouldBe` False + + -- --------------------------------------- + + describe "rmQualifier" $ do + it "removes the qualifiers from a list of identifiers in a given syntax phrase" $ do + let + comp = do + parseSourceFileGhc "./TypeUtils/Qualified.hs" + renamed <- getRefactRenamed + parsed <- getRefactParsed + decls <- liftT $ hsDecls parsed + nm <- getRefactNameMap + + let Just (GHC.L _ foo) = locToName (5, 1) renamed + let Just (GHC.L _ baz) = locToName (5, 27) renamed + + let [fooDecl] = definingDeclsRdrNames nm [foo] decls False False + + res <- rmQualifier [baz] fooDecl + return (res,fooDecl,baz) + + ((r,d,n1),_s) <- ct $ runRefactGhc comp initialState testOptions + (showGhcQual n1) `shouldBe` "TypeUtils.C.baz" + (showGhcQual d) `shouldBe` "main = return TypeUtils.C.baz" + (showGhcQual r) `shouldBe` "main = return baz" + + it "Removes the qualifiers and updates the tokens" $ do + pending -- "Is this needed?" + + -- --------------------------------------- + + describe "usedByRhs" $ do + it "returns True if a given identifier is used in the RHS of a syntax element" $ do + t <- ct $ parsedFileGhc "./MoveDef/Demote.hs" + let + comp = do + renamed <- getRefactRenamed + parsed <- getRefactParsed + declsp <- liftT $ hsDecls parsed + nm <- getRefactNameMap + + let Just (GHC.L _ tl) = locToName (4,1) renamed + let Just (GHC.L _ name) = locToName (7,1) renamed + let decls = definingDeclsRdrNames nm [tl] declsp False False + decls' <- rmQualifier [name] decls + + let res = usedByRhsRdr nm decls' [name] + + return (res,decls,tl,name) + + ((r,d,n1,n2),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (showGhcQual n1) `shouldBe` "MoveDef.Demote.toplevel" + (showGhcQual n2) `shouldBe` "MoveDef.Demote.c" + (showGhcQual d) `shouldBe` "[toplevel x = c * x]" + r `shouldBe` True + + -- --------------------------------------- + + describe "autoRenameLocalVar" $ do + it "renames an identifier if it is used and updates tokens" $ do + t <- ct $ parsedFileGhc "./Demote/WhereIn4.hs" + let + comp = do + renamed <- getRefactRenamed + parsed <- getRefactParsed + nm <- getRefactNameMap + tlDecls <- liftT $ hsDecls parsed + + let Just (GHC.L _ tl) = locToName (11,1) renamed + let Just (GHC.L _ name) = locToName (11,21) renamed + let [decls] = definingDeclsRdrNames nm [tl] tlDecls False True + decls' <- autoRenameLocalVar name decls + + return (decls',decls,tl,name) + + ((r,d,n1,n2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((r,d,n1,n2),s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + (showGhcQual n1) `shouldBe` "Demote.WhereIn4.sumSquares" + (showGhcQual n2) `shouldBe` "p" + (showGhcQual d) `shouldBe` "sumSquares x y\n = sq p x + sq p y\n where\n p = 2" + (showGhcQual r) `shouldBe` "sumSquares x y\n = sq p_1 x + sq p_1 y\n where\n p_1 = 2" + (exactPrintFromState s r) `shouldBe` "\n\n--A definition can be demoted to the local 'where' binding of a friend declaration,\n--if it is only used by this friend declaration.\n\n--Demoting a definition narrows down the scope of the definition.\n--In this example, demote the top level 'sq' to 'sumSquares'\n--In this case (there is single matches), if possible,\n--the parameters will be folded after demoting and type sigature will be removed.\n\nsumSquares x y = sq p_1 x + sq p_1 y\n where p_1=2" + + -- --------------------------------------- + + describe "mkNewName" $ do + it "Makes a new name that does not clash with existing ones" $ do + (mkNewName "f" ["f"] 0) `shouldBe` "f_1" + (mkNewName "f" ["g"] 0) `shouldBe` "f" + (mkNewName "f" ["g","f_1","f"] 0) `shouldBe` "f_2" + + -- --------------------------------------- + + describe "addImportDecl" $ do + it "adds an import entry to a module with already existing, non conflicting imports and other declarations" $ do + t <- ct $ parsedFileGhc "./DupDef/Dd1.hs" + let + comp = do + clearParsedModule + parseSourceFileGhc "./DupDef/Dd2.hs" + renamed2 <- getRefactRenamed + parsed2 <- getRefactParsed + + let listModName = GHC.mkModuleName "Data.List" + res <- addImportDecl parsed2 listModName Nothing False False False Nothing False [] + putRefactParsed res emptyAnns + + return (res,renamed2) + ((_r,_r2),s) <- ct $ runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (sourceFromState s) `shouldBe` "module DupDef.Dd2 where\n\nimport DupDef.Dd1\nimport Data.List\n\n\nf2 x = ff (x+1)\n\nmm = 5\n\n\n" + + -- --------------------------------- + + it "adds an import entry to a module with some declaration, but no explicit imports." $ do + t <- ct $ parsedFileGhc "./TypeUtils/Simplest.hs" + let + comp = do + + let renamed1 = fromJust $ GHC.tm_renamed_source t + parsed <- getRefactParsed + + let listModName = GHC.mkModuleName "Data.List" + res <- addImportDecl parsed listModName Nothing False False False Nothing False [] + putRefactParsed res emptyAnns + + return (res,renamed1) + ((_r,_r2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (sourceFromState s) `shouldBe` "module Simplest where\nimport Data.List\n\n\nsimple x = x\n" + + -- --------------------------------- + + it "adds an import entry to a module with explicit imports, but no declarations." $ do + t <- ct $ parsedFileGhc "./TypeUtils/JustImports.hs" + let + comp = do + let renamed1 = fromJust $ GHC.tm_renamed_source t + parsed <- getRefactParsed + + let listModName = GHC.mkModuleName "Data.List" + res <- addImportDecl parsed listModName Nothing False False False Nothing False [] + putRefactParsed res emptyAnns + + return (res,renamed1) + ((_r,_r2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (sourceFromState s) `shouldBe` "module JustImports where\n\nimport Data.Maybe\nimport Data.List\n" + + -- --------------------------------- + + it "adds an import entry to a module with no declarations and no explicit imports" $ do + t <- ct $ parsedFileGhc "./TypeUtils/Empty.hs" + let + comp = do + renamed1 <- getRefactRenamed + parsed <- getRefactParsed + + let listModName = GHC.mkModuleName "Data.List" + res <- addImportDecl parsed listModName Nothing False False False Nothing False [] + putRefactParsed res emptyAnns + + return (res,renamed1) + ((_r,_r2),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (sourceFromState s) `shouldBe` "module Empty where\nimport Data.List\n\n" + + + -- --------------------------------------- + + describe "addItemsToImport" $ do + it "adds an item to an import entry with no items" $ do + t <- ct $ parsedFileGhc "./TypeUtils/JustImports.hs" + let + comp = do + parsed <- getRefactParsed + + let modName = GHC.mkModuleName "Data.Maybe" + -- itemName <- mkNewGhcName Nothing "fromJust" + let itemName = mkRdrName "fromJust" + + res <- addItemsToImport modName parsed [itemName] + putRefactParsed res emptyAnns + + return (res) + ((_r),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + -- This is the correct behavior. If the import doesn't have an import list, creating + -- one for an item effectively reduces the imported interface. + (sourceFromState s) `shouldBe` "module JustImports where\n\nimport Data.Maybe\n" + +-- Not sure if this should be a test +{- it "Try adding more than one item to an existing import entry with no items, using separate calls." $ do + let + comp = do + (t1,_toks1) <- parseSourceFileTest "./TypeUtils/JustImports.hs" + -- clearParsedModule + let renamed1 = fromJust $ GHC.tm_renamed_source t1 + + let modName = GHC.mkModuleName "Data.Maybe" + itemName <- mkNewGhcName Nothing "fromJust" + + res <- addItemsToImport modName renamed1 [itemName] --listModName Nothing False False False Nothing False [] + + itemName2 <- mkNewGhcName Nothing "isJust" + + res2 <- addItemsToImport modName res [itemName2] + toks <- fetchToks + + return (res2,toks,renamed,_toks1) + ((_r,t,r2,tk2),s) <- ct $ runRefactGhcState comp + (GHC.showRichTokenStream t) `shouldBe` "module JustImports where\n\n import Data.Maybe (fromJust,isJust)\n " +-} + + -- --------------------------------- + + it "adds an item to an import entry with existing items" $ do + t <- ct $ parsedFileGhc "./TypeUtils/SelectivelyImports.hs" + let + comp = do + parsed <-getRefactParsed + + let modName = GHC.mkModuleName "Data.Maybe" + let itemName = mkRdrName "isJust" + + res <- addItemsToImport modName parsed [itemName] + putRefactParsed res emptyAnns + return (res) + ((_r),s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + (sourceFromState s) `shouldBe` "module SelectivelyImports where\n\nimport Data.Maybe (fromJust,isJust)\n\n__ = id\n" + +{- -- test after properly inserting conditional identifier + it "Add an item to an import entry with existing items, passing existing conditional identifier." $ do + let + comp = do + (t1,_toks1) <- parseSourceFileTest "./TypeUtils/SelectivelyImports.hs" + -- clearParsedModule + let renamed1 = fromJust $ GHC.tm_renamed_source t1 + + let modName = GHC.mkModuleName "Data.Maybe" + itemName <- mkNewGhcName Nothing "isJust" + conditionalId <- mkNewGhcName Nothing "fromJust" + + res <- addItemsToImport modName renamed1 [itemName] (Just conditionalId) + toks <- fetchToks + + return (res,toks,renamed1,_toks1) + ((_r,t,r2,tk2),s) <- ct $ runRefactGhcState comp + (GHC.showRichTokenStream t) `shouldBe` "module SelectivelyImports where\n\n import Data.Maybe (fromJust,isJust)\n\n __ = id\n " + + it "Add an item to an import entry with existing items, passing missing conditional identifier" $ do + let + comp = do + (t1,_toks1) <- parseSourceFileTest "./TypeUtils/SelectivelyImports.hs" + -- clearParsedModule + let renamed1 = fromJust $ GHC.tm_renamed_source t1 + + let modName = GHC.mkModuleName "Data.Maybe" + itemName <- mkNewGhcName Nothing "isJust" + + res <- addItemsToImport modName renamed1 [itemName] (Just itemName) + toks <- fetchToks + + return (res,toks,renamed1,_toks1) + ((_r,t,r2,tk2),s) <- ct $ runRefactGhcState comp + (GHC.showRichTokenStream t) `shouldBe` "module SelectivelyImports where\n\n import Data.Maybe (fromJust)\n\n __ = id\n " +-} + + -- --------------------------------------- + + describe "hsValBinds" $ do + it "returns ValBinds for RenamedSource" $ do + t <- ct $ parsedFileGhc "./LiftOneLevel/D1.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let vb = hsValBinds renamed + (showGhcQual vb) `shouldBe` "LiftOneLevel.D1.sumSquares (x : xs)\n = sq x GHC.Num.+ LiftOneLevel.D1.sumSquares xs\n where\n sq x = x GHC.Real.^ pow\n pow = 2\nLiftOneLevel.D1.sumSquares [] = 0\nLiftOneLevel.D1.main = LiftOneLevel.D1.sumSquares [1 .. 4]" + + -- --------------------------------- + + it "returns ValBinds for (HsGroup Name)" $ do + t <- ct $ parsedFileGhc "./LiftOneLevel/D1.hs" + let (g,_,_,_) = fromJust $ GHC.tm_renamed_source t + let vb = hsValBinds g + (showGhcQual vb) `shouldBe` "LiftOneLevel.D1.sumSquares (x : xs)\n = sq x GHC.Num.+ LiftOneLevel.D1.sumSquares xs\n where\n sq x = x GHC.Real.^ pow\n pow = 2\nLiftOneLevel.D1.sumSquares [] = 0\nLiftOneLevel.D1.main = LiftOneLevel.D1.sumSquares [1 .. 4]" + + -- --------------------------------------- + + describe "stripLeadingSpaces" $ do + it "Strips the longest common space prefix from a list of Strings" $ do + (stripLeadingSpaces []) `shouldBe` [] + (stripLeadingSpaces ["a"," b"," c"]) `shouldBe` ["a"," b"," c"] + (stripLeadingSpaces [" a"," b"," c"]) `shouldBe` ["a","b"," c"] + + -- --------------------------------------- + + describe "unspace" $ do + it "Reduces all sequences of more than one space to a single one" $ do + (unspace []) `shouldBe` [] + (unspace "a") `shouldBe` "a" + (unspace "a bc") `shouldBe` "a bc" + (unspace "a bc") `shouldBe` "a bc" + (unspace "ab c") `shouldBe` "ab c" + (unspace " ab c") `shouldBe` " ab c" + (unspace "abc ") `shouldBe` "abc " + + -- --------------------------------------- + + describe "isFieldName" $ do + it "returns True if a Name is a field name" $ do + t <- ct $ parsedFileGhc "./Renaming/Field3.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let Just (GHC.L _ nf) = locToName (10,21) renamed + let Just (GHC.L _ n) = locToName (10,1) renamed + + (showGhcQual n) `shouldBe` "Field3.absPoint" + (showGhcQual nf) `shouldBe` "Field3.pointx" + + -- --------------------------------------- + + describe "name predicates" $ do + it "classifies names" $ do + t <- ct $ parsedFileGhc "./Cons.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let Just (GHC.L _ n1) = locToName (3,6) renamed + let Just (GHC.L _ n2) = locToName (3,12) renamed + let Just (GHC.L _ n3) = locToName (3,16) renamed + let Just (GHC.L _ n4) = locToName (5,1) renamed + let Just (GHC.L _ n5) = locToName (8,5) renamed + + (showGhcQual n1) `shouldBe` "Main.Foo" + "11" ++ (show $ GHC.isTyVarName n1) `shouldBe` "11False" + "12" ++ (show $ GHC.isTyConName n1) `shouldBe` "12True" + "13" ++ (show $ GHC.isDataConName n1) `shouldBe` "13False" + "14" ++ (show $ GHC.isValName n1) `shouldBe` "14False" + "15" ++ (show $ GHC.isVarName n1) `shouldBe` "15False" + + (showGhcQual n2) `shouldBe` "Main.Ff" + "21" ++ (show $ GHC.isTyVarName n2) `shouldBe` "21False" + "22" ++ (show $ GHC.isTyConName n2) `shouldBe` "22False" + "23" ++ (show $ GHC.isDataConName n2) `shouldBe` "23True" + "24" ++ (show $ GHC.isValName n2) `shouldBe` "24True" + "25" ++ (show $ GHC.isVarName n2) `shouldBe` "25False" + + (showGhcQual n3) `shouldBe` "Main.fooA" -- field name + "31" ++ (show $ GHC.isTyVarName n3) `shouldBe` "31False" + "32" ++ (show $ GHC.isTyConName n3) `shouldBe` "32False" + "33" ++ (show $ GHC.isDataConName n3) `shouldBe` "33False" + "34" ++ (show $ GHC.isValName n3) `shouldBe` "34True" + "35" ++ (show $ GHC.isVarName n3) `shouldBe` "35True" + + (showGhcQual n4) `shouldBe` "Main.xx" + "41" ++ (show $ GHC.isTyVarName n4) `shouldBe` "41False" + "42" ++ (show $ GHC.isTyConName n4) `shouldBe` "42False" + "43" ++ (show $ GHC.isDataConName n4) `shouldBe` "43False" + "44" ++ (show $ GHC.isValName n4) `shouldBe` "44True" + "45" ++ (show $ GHC.isVarName n4) `shouldBe` "45True" + + (showGhcQual n5) `shouldBe` "GHC.Classes.==" + "51" ++ (show $ GHC.isTyVarName n5) `shouldBe` "51False" + "52" ++ (show $ GHC.isTyConName n5) `shouldBe` "52False" + "53" ++ (show $ GHC.isDataConName n5) `shouldBe` "53False" + "54" ++ (show $ GHC.isValName n5) `shouldBe` "54True" + "55" ++ (show $ GHC.isVarName n5) `shouldBe` "55True" + + -- --------------------------------------------------------------------- + + describe "rdrName2Name" $ do + + it "finds a Name for a top-level RdrName" $ do + t <- ct $ parsedFileGhc "./TokenTest.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let + comp = do + let (Just rdr) = locToRdrName (5,1) parsed + (Just name) = locToName (5,1) renamed + nname <- rdrName2Name rdr + return (rdr,name,nname) + ((r,n,nn),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((r,n,nn),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual (r,n,nn)) `shouldBe` "(bob, TokenTest.bob, TokenTest.bob)" + + -- --------------------------------- + + it "finds a Name for a local RdrName" $ do + t <- ct $ parsedFileGhc "./TokenTest.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let + comp = do + let (Just rdr) = locToRdrName (14,7) parsed + (Just name) = locToName (14,7) renamed + nname <- rdrName2Name rdr + return (rdr,name,nname) + ((r,n,nn),_s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + -- ((r,n,nn),_s) <- runRefactGhc comp (initialLogOnState { rsModule = initRefactModule t }) testOptions + + (showGhcQual (r,n,nn)) `shouldBe` "(bar, bar, bar)" + + -- --------------------------------------- + +myShow :: GHC.RdrName -> String +myShow n = case n of + GHC.Unqual on -> ("Unqual:" ++ (showGhcQual on)) + GHC.Qual ms on -> ("Qual:" ++ (showGhcQual ms) ++ ":" ++ (showGhcQual on)) + GHC.Orig ms on -> ("Orig:" ++ (showGhcQual ms) ++ ":" ++ (showGhcQual on)) + GHC.Exact en -> ("Exact:" ++ (showGhcQual en)) + +-- --------------------------------------------------------------------- +-- EOF diff --git a/test/UtilsSpec.hs b/test/UtilsSpec.hs new file mode 100644 --- /dev/null +++ b/test/UtilsSpec.hs @@ -0,0 +1,564 @@ +{-# LANGUAGE CPP #-} +module UtilsSpec (main, spec) where + +import Test.Hspec + +import TestUtils + +import qualified GHC as GHC +import qualified HscTypes as GHC + +import Control.Exception +import Control.Monad.State +import Data.List +import Data.Maybe + +import qualified Language.Haskell.GhcMod.Internal as GM (mpModule) + +import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.Refact.Refactoring.Renaming +import Language.Haskell.Refact.Utils.GhcVersionSpecific +import Language.Haskell.Refact.Utils.LocUtils +import Language.Haskell.Refact.Utils.Monad +import Language.Haskell.Refact.Utils.MonadFunctions +import Language.Haskell.Refact.Utils.TypeUtils +import Language.Haskell.Refact.Utils.Utils +import Language.Haskell.Refact.Utils.Variables + +import System.Directory + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + + describe "locToExp on ParsedSource" $ do + it "p:finds the largest leftmost expression contained in a given region #1" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let (Just expr) = locToExp (7,7) (7,43) parsed :: Maybe (GHC.Located (GHC.HsExpr GHC.RdrName)) + getLocatedStart expr `shouldBe` (7,9) + getLocatedEnd expr `shouldBe` (7,42) + + it "p:finds the largest leftmost expression contained in a given region #2" $ do + -- ((_, _, mod), toks) <- parsedFileBGhc + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let modu = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let (Just expr) = locToExp (7,7) (7,41) modu :: Maybe (GHC.Located (GHC.HsExpr GHC.RdrName)) + getLocatedStart expr `shouldBe` (7,12) + getLocatedEnd expr `shouldBe` (7,19) + + it "finds the largest leftmost expression in RenamedSource" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let (Just expr) = locToExp (7,7) (7,41) renamed :: Maybe (GHC.Located (GHC.HsExpr GHC.Name)) + getLocatedStart expr `shouldBe` (7,12) + getLocatedEnd expr `shouldBe` (7,19) + + describe "locToExp on RenamedSource" $ do + it "r:finds the largest leftmost expression contained in a given region #1" $ do + -- ((_, Just renamed, _), toks) <- parsedFileBGhc + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + + let (Just expr) = locToExp (7,7) (7,43) renamed :: Maybe (GHC.Located (GHC.HsExpr GHC.Name)) + getLocatedStart expr `shouldBe` (7,9) + getLocatedEnd expr `shouldBe` (7,42) + + -- ------------------------------------------------------------------- + + describe "loading a file" $ do + it "loads a file having the LANGUAGE CPP pragma" $ do + t <- ct $ parsedFileGhc "./BCpp.hs" + + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + (showGhc parsed) `shouldBe` "module BCpp where\nbob :: Int -> Int -> Int\nbob x y = x + y" + + -- ----------------------------------- + + it "loads a series of files based on cabal1" $ do + + currentDir <- getCurrentDirectory + setCurrentDirectory "./test/testdata/cabal/cabal1" + + let settings = defaultSettings { rsetEnabledTargets = (True,True,False,False) + -- , rsetVerboseLevel = Debug + } + + r <- rename settings testOptions "./src/Foo/Bar.hs" "baz1" (3, 1) + -- r <- rename logTestSettings cradle "./src/Foo/Bar.hs" "baz1" (3, 1) + r' <- mapM makeRelativeToCurrentDirectory r + setCurrentDirectory currentDir + + (show r') `shouldBe` "[\"src/Foo/Bar.hs\"," + ++"\"src/main.hs\"]" + + + -- ----------------------------------- + + it "loads a series of files based on cabal2, which has 2 exe" $ do + + currentDir <- getCurrentDirectory + setCurrentDirectory "./test/testdata/cabal/cabal2" + + let settings = defaultSettings { rsetEnabledTargets = (True,True,True,True) + -- , rsetVerboseLevel = Debug + } + + let handler = [Handler handler1] + handler1 :: GHC.SourceError -> IO [String] + handler1 e = do + setCurrentDirectory currentDir + return [show e] + + r <- catches (rename settings testOptions "./src/Foo/Bar.hs" "baz1" (3, 1)) handler + r' <- mapM makeRelativeToCurrentDirectory r + setCurrentDirectory currentDir + + + (show r') `shouldBe` "[\"src/Foo/Bar.hs\","++ + "\"src/main1.hs\","++ + "\"src/main2.hs\"]" + + -- ----------------------------------- + + it "loads a series of files based on cabal3, which has a lib and an exe" $ do + + currentDir <- getCurrentDirectory + setCurrentDirectory "./test/testdata/cabal/cabal3" + + let settings = defaultSettings { rsetEnabledTargets = (True,True,True,True) + -- , rsetVerboseLevel = Debug + } + + let handler = [Handler handler1] + handler1 :: GHC.SourceError -> IO [String] + handler1 e = do + setCurrentDirectory currentDir + return [show e] + + r <- catches (rename settings testOptions "./src/main1.hs" "baz1" (7, 1)) handler + r' <- mapM makeRelativeToCurrentDirectory r + setCurrentDirectory currentDir + + + (show r') `shouldBe` "[\"src/main1.hs\"]" + + -- ----------------------------------- + + it "loads a series of files based on cabal4, with different dependencies" $ do + + currentDir <- getCurrentDirectory + setCurrentDirectory "./test/testdata/cabal/cabal4" + + let settings = defaultSettings { rsetEnabledTargets = (True,True,True,True) + -- , rsetVerboseLevel = Debug + } + + let handler = [Handler handler1] + handler1 :: GHC.SourceError -> IO [String] + handler1 e = do + setCurrentDirectory currentDir + return [show e] + + r <- catches (rename settings testOptions "./src/Foo/Bar.hs" "baz1" (3, 1)) handler + -- r <- catches (rename settings testOptions "./src/main4.hs" "baz1" (3, 1)) handler + r' <- mapM makeRelativeToCurrentDirectory r + setCurrentDirectory currentDir + + + (show r') `shouldBe` "[\"src/Foo/Bar.hs\",\"src/main4.hs\"]" + + -- ----------------------------------- +{- TODO: this test fails on travis, due to missing hspec-discover + it "renames in HaRe Utils 1" $ do + + currentDir <- getCurrentDirectory + -- currentDir `shouldBe` "/home/alanz/mysrc/github/alanz/HaRe" + setCurrentDirectory "./" + -- d <- getCurrentDirectory + -- d `shouldBe` "/home/alanz/mysrc/github/alanz/HaRe" + cradle <- findCradle + -- (show cradle) `shouldBe` "" + -- (cradleCurrentDir cradle) `shouldBe` "/home/alanz/mysrc/github/alanz/HaRe" + + let settings = defaultSettings { rsetEnabledTargets = (True,True,True,True) + -- , rsetVerboseLevel = Debug + } + + let handler = [Handler handler1] + handler1 :: GHC.SourceError -> IO [String] + handler1 e = do + setCurrentDirectory currentDir + return [show e] + + r <- catches (rename settings cradle "./src/Language/Haskell/Refact/Utils.hs" "clientModsAndFiles1" (473, 6)) handler + setCurrentDirectory currentDir + + r' <- mapM makeRelativeToCurrentDirectory r + + (show r') `shouldBe` + "[\"./src/Language/Haskell/Refact/Utils.hs\","++ + "\"./src/Language/Haskell/Refact/Renaming.hs\","++ + "\"./src/Language/Haskell/Refact/MoveDef.hs\","++ + "\"./src/Language/Haskell/Refact/DupDef.hs\","++ + "\"./src/Language/Haskell/Refact/Renaming.hs\","++ + "\"./src/Language/Haskell/Refact/MoveDef.hs\","++ + "\"./src/Language/Haskell/Refact/DupDef.hs\","++ + "\"test/UtilsSpec.hs\","++ + "\"./src/Language/Haskell/Refact/Renaming.hs\","++ + "\"./src/Language/Haskell/Refact/MoveDef.hs\","++ + "\"./src/Language/Haskell/Refact/DupDef.hs\"]" +-} + + -- ----------------------------------- +{- + it "renames in HaRe Utils 2" $ do + + currentDir <- getCurrentDirectory + -- currentDir `shouldBe` "/home/alanz/mysrc/github/alanz/HaRe" + setCurrentDirectory "./" + -- d <- getCurrentDirectory + -- d `shouldBe` "/home/alanz/mysrc/github/alanz/HaRe" + cradle <- findCradle + -- (show cradle) `shouldBe` "" + -- (cradleCurrentDir cradle) `shouldBe` "/home/alanz/mysrc/github/alanz/HaRe" + + let settings = defaultSettings { rsetEnabledTargets = (True,True,True,True) + , rsetVerboseLevel = Debug + } + + let handler = [Handler handler1] + handler1 :: GHC.SourceError -> IO [String] + handler1 e = do + setCurrentDirectory currentDir + return [show e] + + r <- catches (rename settings cradle "./test/UtilsSpec.hs" "parsed" (41, 10)) handler + setCurrentDirectory currentDir + + r' <- mapM makeRelativeToCurrentDirectory r + + (show r') `shouldBe` + "[\"./src/Language/Haskell/Refact/Utils.hs\","++ + "\"./src/Language/Haskell/Refact/Renaming.hs\","++ + "\"./src/Language/Haskell/Refact/MoveDef.hs\","++ + "\"./src/Language/Haskell/Refact/DupDef.hs\","++ + "\"./src/Language/Haskell/Refact/Renaming.hs\","++ + "\"./src/Language/Haskell/Refact/MoveDef.hs\","++ + "\"./src/Language/Haskell/Refact/DupDef.hs\","++ + "\"test/UtilsSpec.hs\","++ + "\"./src/Language/Haskell/Refact/Renaming.hs\","++ + "\"./src/Language/Haskell/Refact/MoveDef.hs\","++ + "\"./src/Language/Haskell/Refact/DupDef.hs\"]" +-} + -- ----------------------------------- +{- + -- This test does not work properly on Travis, missing hspec-discover + it "renames in HaRe Utils 3" $ do + + currentDir <- getCurrentDirectory + -- currentDir `shouldBe` "/home/alanz/mysrc/github/alanz/HaRe" + setCurrentDirectory "./" + -- d <- getCurrentDirectory + -- d `shouldBe` "/home/alanz/mysrc/github/alanz/HaRe" + cradle <- findCradle + -- (show cradle) `shouldBe` "" + -- (cradleCurrentDir cradle) `shouldBe` "/home/alanz/mysrc/github/alanz/HaRe" + + let settings = defaultSettings { rsetEnabledTargets = (True,True,True,True) + -- , rsetVerboseLevel = Debug + } + + let handler = [Handler handler1] + handler1 :: GHC.SourceError -> IO [String] + handler1 e = do + setCurrentDirectory currentDir + return [show e] + + r <- catches (rename settings cradle "./test/UtilsSpec.hs" "parsed" (41, 11)) handler + setCurrentDirectory currentDir + + r' <- mapM makeRelativeToCurrentDirectory r + + (show r') `shouldBe` + "[\"test/UtilsSpec.hs\"]" +-} + -- ------------------------------------------------------------------- + + describe "sameOccurrence" $ do + it "checks that a given syntax element is the same occurrence as another" $ do + pending -- "write this test" + + -- ------------------------------------------------------------------- + + describe "isVarId" $ do + it "returns True if a string is a lexically valid variable name" $ do + isVarId "foo" `shouldBe` True + + it "returns False if a string is not lexically valid variable name" $ do + isVarId "Foo" `shouldBe` False + + + -- ------------------------------------------------------------------- + + describe "getModuleName" $ do + it "returns a string for the module name if there is one" $ do + t <- ct $ parsedFileGhc "./TypeUtils/B.hs" + let modu = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let (Just (_modname,modNameStr)) = getModuleName modu + modNameStr `shouldBe` "TypeUtils.B" + + it "returns Nothing for the module name otherwise" $ do + t <- ct $ parsedFileGhc "./NoMod.hs" + let modu = GHC.pm_parsed_source $ GHC.tm_parsed_module t + getModuleName modu `shouldBe` Nothing + + -- ------------------------------------------------------------------- + + describe "modIsExported" $ do + it "needs a test or two" $ do + pending -- "write this test" + + -- ------------------------------------------------------------------- + + describe "clientModsAndFiles" $ do + it "can only be called in a live RefactGhc session" $ do + pending -- "write this test" + + ------------------------------------ + + it "gets modules which directly or indirectly import a module #1" $ do + -- TODO: harvest this commonality + let + comp = do + parseSourceFileGhc "./S1.hs" + tm <- getRefactTargetModule + g <- clientModsAndFiles tm + return g + (mg,_s) <- ct $ runRefactGhc comp initialState testOptions + -- (mg,_s) <- ct $ runRefactGhc comp initialLogOnState testOptions + showGhc (map GM.mpModule mg) `shouldBe` "[Main, M3, M2]" + + ------------------------------------ + + it "gets modules which directly or indirectly import a module #2" $ do + let + comp = do + parseSourceFileGhc "./M3.hs" + tm <- getRefactTargetModule + g <- clientModsAndFiles tm + return g + (mg,_s) <- ct $ runRefactGhc comp initialState testOptions + showGhc (map GM.mpModule mg) `shouldBe` "[Main]" + + ------------------------------------ + + it "gets modules which import a module in different cabal targets" $ do + currentDir <- getCurrentDirectory + setCurrentDirectory "./test/testdata/cabal/cabal2" + + let + comp = do + parseSourceFileGhc "./src/Foo/Bar.hs" -- Load the file first + tm <- getRefactTargetModule + g <- clientModsAndFiles tm + return g + (mg,_s) <- runRefactGhc comp initialState testOptions + showGhc (map GM.mpModule mg) `shouldBe` "[Main, Main]" + + setCurrentDirectory currentDir + + -- ------------------------------------------------------------------- + + describe "serverModsAndFiles" $ do + it "can only be called in a live RefactGhc session" $ do + pending -- "write this test" + + it "gets modules which are directly or indirectly imported by a module #1" $ do + let + comp = do + parseSourceFileGhc "./M.hs" -- Load the file first + g <- serverModsAndFiles $ GHC.mkModuleName "S1" + return g + (mg,_s) <- ct $ runRefactGhc comp initialState testOptions + -- (mg,_s) <- ct $ runRefactGhc comp initialLogOnState testOptions + showGhc (map GHC.ms_mod mg) `shouldBe` "[]" + + it "gets modules which are directly or indirectly imported by a module #2" $ do + let + comp = do + parseSourceFileGhc "./M3.hs" -- Load the file first + g <- serverModsAndFiles $ GHC.mkModuleName "M3" + return g + (mg,_s) <- ct $ runRefactGhc comp initialState testOptions + showGhc (map GHC.ms_mod mg) `shouldBe` "[M2, S1]" + + + -- ------------------------------------------------------------------- +{- + describe "getCurrentModuleGraph" $ do + it "gets the module graph for the currently loaded modules" $ do + let + comp = do + (_p,_toks) <- parseFileBGhc -- Load the file first + g <- getCurrentModuleGraph + return g + (mg,_s) <- runRefactGhcState comp + map (\m -> GHC.moduleNameString $ GHC.ms_mod_name m) mg `shouldBe` (["TypeUtils.B","TypeUtils.C"]) + map (\m -> show $ GHC.ml_hs_file $ GHC.ms_location m) mg `shouldBe` (["Just \"./test/testdata/TypeUtils/B.hs\"" + ,"Just \"./test/testdata/TypeUtils/C.hs\""]) + + + it "gets the updated graph, after a refactor" $ do + pending -- "write this test" +-} + -- ------------------------------------------------------------------- +{- + describe "sortCurrentModuleGraph" $ do + it "needs a test or two" $ do + let + comp = do + (_p,_toks) <- parseFileBGhc -- Load the file first + g <- sortCurrentModuleGraph + return g + (mg,_s) <- runRefactGhcState comp + (showGhc $ map (\m -> GHC.ms_mod m) (GHC.flattenSCCs mg)) `shouldBe` "[main:TypeUtils.C, main:TypeUtils.B]" +-} + -- ------------------------------------------------------------------- + + describe "parseSourceFileGhc" $ do + it "retrieves a module from an existing module graph #1" $ do + let + comp = do + parseSourceFileGhc "./S1.hs" + pr <- getTypecheckedModule + tm <- getRefactTargetModule + g <- clientModsAndFiles tm + + return (pr,g) + + ( (t, mg), _s) <- ct $ runRefactGhc comp initialState testOptions + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + (show $ getModuleName parsed) `shouldBe` "Just (ModuleName \"S1\",\"S1\")" + showGhc (map GM.mpModule mg) `shouldBe` "[Main, M3, M2]" + + -- --------------------------------- + + it "loads the module and dependents if no existing module graph" $ do + let + comp = do + parseSourceFileGhc "./S1.hs" + pr <- getTypecheckedModule + tm <- getRefactTargetModule + g <- clientModsAndFiles tm + + return (pr,g) + ((t, mg ), _s) <- ct $ runRefactGhc comp initialState testOptions + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + + (show $ getModuleName parsed) `shouldBe` "Just (ModuleName \"S1\",\"S1\")" + showGhc (map GM.mpModule mg) `shouldBe` "[Main, M3, M2]" + + -- --------------------------------- + + it "retrieves a module from an existing module graph #2" $ do + let + comp = do + parseSourceFileGhc "./DupDef/Dd1.hs" + pr <- getTypecheckedModule + tm <- getRefactTargetModule + g <- clientModsAndFiles tm + + return (pr,g) + ((t, mg), _s) <- ct $ runRefactGhc comp initialState testOptions + let parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t + (show $ getModuleName parsed) `shouldBe` "Just (ModuleName \"DupDef.Dd1\",\"DupDef.Dd1\")" + showGhc (map GM.mpModule mg) `shouldBe` "[DupDef.Dd2, DupDef.Dd3]" + + + -- ------------------------------------------------------------------- + + describe "runRefactGhc" $ do + it "contains a State monad" $ do + let + comp = do + s <- get + parseSourceFileGhc "./TypeUtils/B.hs" + + g <- GHC.getModuleGraph + gs <- mapM GHC.showModule g + + put (s {rsUniqState = 100}) + return (show gs) + + (_,s) <- ct $ runRefactGhc comp (initialState { rsModule = Nothing }) testOptions + (rsUniqState s) `shouldBe` 100 + + -- --------------------------------- + + it "contains the GhcT monad" $ do + let + comp = do + s <- get + parseSourceFileGhc "./TypeUtils/B.hs" + + g <- GHC.getModuleGraph + gs <- mapM GHC.showModule g + + put (s {rsUniqState = 100}) + return (gs) + + (r,_) <- ct $ runRefactGhc comp initialState testOptions + (sort r) `shouldBe` ["TypeUtils.B ( TypeUtils/B.hs, nothing )", + "TypeUtils.C ( TypeUtils/C.hs, nothing )"] + + -- ------------------------------------------------------------------- + + describe "RefactFlags" $ do + it "puts the RefactDone flag through its paces" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareTypes.hs" + let + comp = do + v1 <- getRefactDone + clearRefactDone + v2 <- getRefactDone + setRefactDone + v3 <- getRefactDone + + return (v1,v2,v3) + ((v1',v2',v3'), _s) <- runRefactGhc comp (initialState { rsModule = initRefactModule t }) testOptions + + (show (v1',v2',v3')) `shouldBe` "(False,False,True)" + + -- ------------------------------------------------------------------- + + describe "directoryManagement" $ do + it "loads a file from a sub directory" $ do + t <- ct $ parsedFileGhc "./FreeAndDeclared/DeclareS.hs" + let renamed = fromJust $ GHC.tm_renamed_source t + let + comp = do + parseSourceFileGhc "./FreeAndDeclared/DeclareS.hs" + r <- hsFreeAndDeclaredPNs renamed + return r + ((res),_s) <- cdAndDo "./test/testdata/FreeAndDeclared" $ + runRefactGhcCd comp initialState testOptions + + -- Free Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (fst res)) `shouldBe` "[]" + + -- Declared Vars + (showGhcQual $ map (\n -> (n, getGhcLoc $ GHC.nameSrcSpan n)) (snd res)) `shouldBe` "[(FreeAndDeclared.DeclareS.c, (6, 1))]" + +-- --------------------------------------------------------------------- + diff --git a/test/testdata/AddParams1.hs b/test/testdata/AddParams1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/AddParams1.hs @@ -0,0 +1,7 @@ +module AddParams1 where + +sq 0 = 0 +sq z = z^2 + +foo = 3 + diff --git a/test/testdata/B.hs b/test/testdata/B.hs new file mode 100644 --- /dev/null +++ b/test/testdata/B.hs @@ -0,0 +1,7 @@ +module B where + + +bob :: Int -> Int -> Int +bob x y = x + y + + diff --git a/test/testdata/BCpp.hs b/test/testdata/BCpp.hs new file mode 100644 --- /dev/null +++ b/test/testdata/BCpp.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +-- Check that we can parse a file which requires CPP +module BCpp where + +bob :: Int -> Int -> Int +#if __GLASGOW_HASKELL__ > 704 +bob x y = x + y +#else +bob x y = x + y * 2 +#endif + + diff --git a/test/testdata/C.hs b/test/testdata/C.hs new file mode 100644 --- /dev/null +++ b/test/testdata/C.hs @@ -0,0 +1,5 @@ +module C where +-- Test file + +baz = 13 + diff --git a/test/testdata/Case/B.hs b/test/testdata/Case/B.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Case/B.hs @@ -0,0 +1,19 @@ +module B where +-- Test for refactor of if to case + +foo x = if (odd x) then "Odd" else "Even" + +bob x y = x + y + + +foo' x = case (odd x) of + True -> "Odd" + False -> "Even" + +main = do + putStrLn $ show $ foo 5 + +mary = [1,2,3] + +h = bob 1 2 + diff --git a/test/testdata/Case/B.hs.expected b/test/testdata/Case/B.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Case/B.hs.expected @@ -0,0 +1,21 @@ +module B where +-- Test for refactor of if to case + +foo x = case (odd x) of + True -> "Odd" + False -> "Even" + +bob x y = x + y + + +foo' x = case (odd x) of + True -> "Odd" + False -> "Even" + +main = do + putStrLn $ show $ foo 5 + +mary = [1,2,3] + +h = bob 1 2 + diff --git a/test/testdata/Case/B.hs.expected.dd b/test/testdata/Case/B.hs.expected.dd new file mode 100644 --- /dev/null +++ b/test/testdata/Case/B.hs.expected.dd @@ -0,0 +1,23 @@ +module B where +-- Test for refactor of if to case + +foo x = if (odd x) then "Odd" else "Even" + +bob x y = x + y + + +foo' x = case (odd x) of + True -> "Odd" + False -> "Even" + +joe x = case (odd x) of + True -> "Odd" + False -> "Even" + +main = do + putStrLn $ show $ foo 5 + +mary = [1,2,3] + +h = bob 1 2 + diff --git a/test/testdata/Case/BSimple.hs b/test/testdata/Case/BSimple.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Case/BSimple.hs @@ -0,0 +1,5 @@ +module BSimple where +-- Test for refactor of if to case + +foo x = if (odd x) then "Odd" else "Even" + diff --git a/test/testdata/Case/BSimpleExpected.hs b/test/testdata/Case/BSimpleExpected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Case/BSimpleExpected.hs @@ -0,0 +1,7 @@ +module BSimple where +-- Test for refactor of if to case + +foo x = case (odd x) of + True -> "Odd" + False -> "Even" + diff --git a/test/testdata/Case/C.hs b/test/testdata/Case/C.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Case/C.hs @@ -0,0 +1,12 @@ +module C where +-- Test for refactor of if to case +-- The comments on the then and else legs should be preserved + +foo x = if (odd x) + then -- This is an odd result + bob x 1 + else -- This is an even result + bob x 2 + +bob x y = x + y + diff --git a/test/testdata/Case/C.hs.expected b/test/testdata/Case/C.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Case/C.hs.expected @@ -0,0 +1,12 @@ +module C where +-- Test for refactor of if to case +-- The comments on the then and else legs should be preserved + +foo x = case (odd x) of + True -> -- This is an odd result + bob x 1 + False -> -- This is an even result + bob x 2 + +bob x y = x + y + diff --git a/test/testdata/Case/CExpected.hs b/test/testdata/Case/CExpected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Case/CExpected.hs @@ -0,0 +1,12 @@ +module C where +-- Test for refactor of if to case +-- The comments on the then and else legs should be preserved + +foo x = case (odd x) of + True -> -- This is an odd result + bob x 1 + False -> -- This is an even result + bob x 2 + +bob x y = x + y + diff --git a/test/testdata/Case/D.hs b/test/testdata/Case/D.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Case/D.hs @@ -0,0 +1,14 @@ +module C where +-- Test for refactor of if to case +-- The comments on the then and else legs should be preserved + +foo x = if (odd x) + then do + -- This is an odd result + bob x 1 + else do + -- This is an even result + bob x 2 + +bob x y = x + y + diff --git a/test/testdata/Case/D.hs.expected b/test/testdata/Case/D.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Case/D.hs.expected @@ -0,0 +1,14 @@ +module C where +-- Test for refactor of if to case +-- The comments on the then and else legs should be preserved + +foo x = case (odd x) of + True -> do + -- This is an odd result + bob x 1 + False -> do + -- This is an even result + bob x 2 + +bob x y = x + y + diff --git a/test/testdata/Case/E.hs b/test/testdata/Case/E.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Case/E.hs @@ -0,0 +1,16 @@ +module E where +-- Test for refactor of if to case in a complex sub level +-- The comments on the then and else legs should be preserved + +foo x = bob x f + where + f = (if (odd x) + then do + -- This is an odd result + bob x 1 + else do + -- This is an even result + bob x 2) + 2 + +bob x y = x + y + diff --git a/test/testdata/Case/E.hs.expected b/test/testdata/Case/E.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Case/E.hs.expected @@ -0,0 +1,16 @@ +module E where +-- Test for refactor of if to case in a complex sub level +-- The comments on the then and else legs should be preserved + +foo x = bob x f + where + f = (case (odd x) of + True -> do + -- This is an odd result + bob x 1 + False -> do + -- This is an even result + bob x 2) + 2 + +bob x y = x + y + diff --git a/test/testdata/Case/F.hs b/test/testdata/Case/F.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Case/F.hs @@ -0,0 +1,10 @@ +module F where +-- Test for refactor of if to case + +foo x = if (odd x) + then do + bob x 1 + else do + bob x 2 + +bob x y = x + y diff --git a/test/testdata/Case/F.hs.expected b/test/testdata/Case/F.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Case/F.hs.expected @@ -0,0 +1,10 @@ +module F where +-- Test for refactor of if to case + +foo x = case (odd x) of + True -> do + bob x 1 + False -> do + bob x 2 + +bob x y = x + y diff --git a/test/testdata/Case/FExpected.hs b/test/testdata/Case/FExpected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Case/FExpected.hs @@ -0,0 +1,10 @@ +module F where +-- Test for refactor of if to case + +foo x = case (odd x) of + True -> do + bob x 1 + False -> do + bob x 2 + +bob x y = x + y diff --git a/test/testdata/Case/Foo.hs b/test/testdata/Case/Foo.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Case/Foo.hs @@ -0,0 +1,8 @@ + + +main = + if 1 > 10 + then do putStrLn "hello" + putStrLn "there" + else do putStrLn "blah" + putStrLn "blah" diff --git a/test/testdata/Case/Foo.hs.expected b/test/testdata/Case/Foo.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Case/Foo.hs.expected @@ -0,0 +1,8 @@ + + +main = + case 1 > 10 of + True -> do putStrLn "hello" + putStrLn "there" + False -> do putStrLn "blah" + putStrLn "blah" diff --git a/test/testdata/Case/FooExpected.hs b/test/testdata/Case/FooExpected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Case/FooExpected.hs @@ -0,0 +1,8 @@ + + +main = + case 1 > 10 of + True -> do putStrLn "hello" + putStrLn "there" + False -> do putStrLn "blah" + putStrLn "blah" diff --git a/test/testdata/Cons.hs b/test/testdata/Cons.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Cons.hs @@ -0,0 +1,10 @@ + + +data Foo = Ff {fooA :: Integer} + +xx = 4 + +instance Eq Foo where + a == b = undefined + +main = putStrLn "hello" diff --git a/test/testdata/Demote/A1.hs b/test/testdata/Demote/A1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/A1.hs @@ -0,0 +1,8 @@ +module Demote.A1 where + +import Demote.C1 + +main xs = case xs of + [] -> 0 + [x:xs] -> x^pow + sumSquares xs + diff --git a/test/testdata/Demote/A2.hs b/test/testdata/Demote/A2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/A2.hs @@ -0,0 +1,8 @@ +module Demote.A2 where + +import Demote.C2 + +main xs = case xs of + [] -> 0 + [x:xs] -> x^pow + sumSquares xs + diff --git a/test/testdata/Demote/C1.hs b/test/testdata/Demote/C1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/C1.hs @@ -0,0 +1,10 @@ +module Demote.C1 (module Demote.D1, module Demote.C1) where + +import Demote.D1 hiding (main, sq) + +sumSquares1 (x:xs) = sq x + sumSquares1 xs + where sq x = x ^pow +sumSquares1 [] = 0 + + + diff --git a/test/testdata/Demote/C2.hs b/test/testdata/Demote/C2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/C2.hs @@ -0,0 +1,10 @@ +module Demote.C2 (module Demote.D2, module Demote.C2) where + +import Demote.D2 hiding (main, sq) + +sumSquares1 (x:xs) = sq x + sumSquares1 xs + where sq x = x ^pow +sumSquares1 [] = 0 + + + diff --git a/test/testdata/Demote/CaseIn1.hs b/test/testdata/Demote/CaseIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/CaseIn1.hs @@ -0,0 +1,18 @@ +module Demote.CaseIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'addthree' to 'main' +--This example also aims to test the removing of parameters +--The 'addthree' was originally lifted from the first case alternative. the example +--show that lifting and demoting are not inverse. + +main x y z = case x of + 0 -> addthree x y z + 1 -> inc y + where inc a =a+1 +addthree a b c=a+b+c + + diff --git a/test/testdata/Demote/CaseIn1.hs.expected b/test/testdata/Demote/CaseIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/CaseIn1.hs.expected @@ -0,0 +1,19 @@ +module Demote.CaseIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'addthree' to 'main' +--This example also aims to test the removing of parameters +--The 'addthree' was originally lifted from the first case alternative. the example +--show that lifting and demoting are not inverse. + +main x y z = case x of + 0 -> addthree + 1 -> inc y + where inc a =a+1 + where + addthree=x+y+z + + diff --git a/test/testdata/Demote/D1.hs b/test/testdata/Demote/D1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/D1.hs @@ -0,0 +1,14 @@ +module Demote.D1 where + +{-demote 'sq' to 'sumSquares'. This refactoring + affects module 'D1' and 'C1' -} + +sumSquares (x:xs) = sq x + sumSquares xs +sumSquares [] = 0 + +sq x = x ^pow + +pow = 2 + +main = sumSquares [1..4] + diff --git a/test/testdata/Demote/D1.hs.expected b/test/testdata/Demote/D1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/D1.hs.expected @@ -0,0 +1,14 @@ +module Demote.D1 where + +{-demote 'sq' to 'sumSquares'. This refactoring + affects module 'D1' and 'C1' -} + +sumSquares (x:xs) = sq + sumSquares xs + where + sq = x ^pow +sumSquares [] = 0 + +pow = 2 + +main = sumSquares [1..4] + diff --git a/test/testdata/Demote/D2.hs b/test/testdata/Demote/D2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/D2.hs @@ -0,0 +1,13 @@ +module Demote.D2 where + +--demote 'sumSquares' should fail as it used by module 'A2'. + +sumSquares (x:xs) = sq x + sumSquares xs +sumSquares [] = 0 + +sq x = x ^pow + +pow = 2 + +main = sumSquares [1..4] + diff --git a/test/testdata/Demote/D2.hs.expected b/test/testdata/Demote/D2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/D2.hs.expected @@ -0,0 +1,12 @@ +module Demote.D2 where + +sq x = x ^pow + +pow = 2 + +main = sumSquares [1..4] + where + --demote 'sumSquares' should fail as it used by module 'A2'. + sumSquares (x:xs) = sq x + sumSquares xs + sumSquares [] = 0 + diff --git a/test/testdata/Demote/D3.hs b/test/testdata/Demote/D3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/D3.hs @@ -0,0 +1,13 @@ +module Demote.D3(sumSquares) where + +--demote 'sumSquares' should fail as it is explicitly exported. + +sumSquares (x:xs) = sq x + sumSquares xs +sumSquares [] = 0 + +sq x = x ^pow + +pow = 2 + +main = sumSquares [1..4] + diff --git a/test/testdata/Demote/LetIn1.hs b/test/testdata/Demote/LetIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/LetIn1.hs @@ -0,0 +1,19 @@ +module Demote.LetIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the local 'pow' to 'sq' +--This example also aims to test the demoting a local declaration in 'let'. + +sumSquares x y = let sq 0=0 + sq z=z^pow + pow=2 + in sq x + sq y + + +anotherFun 0 y = sq y + where sq x = x^2 + + diff --git a/test/testdata/Demote/LetIn1.hs.expected b/test/testdata/Demote/LetIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/LetIn1.hs.expected @@ -0,0 +1,20 @@ +module Demote.LetIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the local 'pow' to 'sq' +--This example also aims to test the demoting a local declaration in 'let'. + +sumSquares x y = let sq 0=0 + sq z=z^pow + where + pow=2 + in sq x + sq y + + +anotherFun 0 y = sq y + where sq x = x^2 + + diff --git a/test/testdata/Demote/LetIn2.hs b/test/testdata/Demote/LetIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/LetIn2.hs @@ -0,0 +1,18 @@ +module Demote.LetIn2 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the local 'pow' will fail. + +sumSquares x y = let sq 0=0 + sq z=z^pow + pow=2 + in sq x + sq y +pow + + +anotherFun 0 y = sq y + where sq x = x^2 + + diff --git a/test/testdata/Demote/MultiLeg.hs b/test/testdata/Demote/MultiLeg.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/MultiLeg.hs @@ -0,0 +1,14 @@ +module Demote.MultiLeg where + +data Constraint = Include String + | Exclude String + deriving (Show) + +is_excluded stringQueueName (Include regex) = do + reg <- mkr regex + return True +is_excluded stringQueueName (Exclude regex) = do + reg <- mkr regex + return False + +mkr reg = show reg diff --git a/test/testdata/Demote/MultiLeg2.hs b/test/testdata/Demote/MultiLeg2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/MultiLeg2.hs @@ -0,0 +1,14 @@ +module Demote.MultiLeg where + +data Constraint = Include String + | Exclude String + deriving (Show) + +is_excluded stringQueueName (Include regex) = do + reg <- mkr regex + return True +is_excluded stringQueueName (Exclude regex) = do + -- reg <- mkr regex + return False + +mkr reg = show reg diff --git a/test/testdata/Demote/MultiLeg2.hs.expected b/test/testdata/Demote/MultiLeg2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/MultiLeg2.hs.expected @@ -0,0 +1,14 @@ +module Demote.MultiLeg where + +data Constraint = Include String + | Exclude String + deriving (Show) + +is_excluded stringQueueName (Include regex) = do + reg <- mkr + return True + where + mkr = show regex +is_excluded stringQueueName (Exclude regex) = do + -- reg <- mkr regex + return False diff --git a/test/testdata/Demote/PatBindIn1.hs b/test/testdata/Demote/PatBindIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/PatBindIn1.hs @@ -0,0 +1,21 @@ +module Demote.PatBindIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'tup' to 'foo' +--This example aims to test demoting pattern binding. + +main :: Int +main = foo 3 + +foo :: Int -> Int +foo x = h + t + (snd tup) + +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..15] + + diff --git a/test/testdata/Demote/PatBindIn1.hs.expected b/test/testdata/Demote/PatBindIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/PatBindIn1.hs.expected @@ -0,0 +1,21 @@ +module Demote.PatBindIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'tup' to 'foo' +--This example aims to test demoting pattern binding. + +main :: Int +main = foo 3 + +foo :: Int -> Int +foo x = h + t + (snd tup) + where + tup :: (Int, Int) + h :: Int + t :: Int + tup@(h,t) = head $ zip [1..10] [3..15] + + diff --git a/test/testdata/Demote/PatBindIn4.hs b/test/testdata/Demote/PatBindIn4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/PatBindIn4.hs @@ -0,0 +1,21 @@ +module Demote.PatBindIn4 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'tup' will fail. + +main :: Int +main = foo 3 + +foo :: Int -> Int +foo x = h + t + (snd tup) + +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..15] + +fun=h + diff --git a/test/testdata/Demote/UsedAtLevel.expected.hs b/test/testdata/Demote/UsedAtLevel.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/UsedAtLevel.expected.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Demote.UsedAtLevel where + +foo :: IO () +foo = do + let xx = uses declaredPns [] + return () + where + ---find how many matches/pattern bindings use 'pn'------- + -- uses :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> [Int] + uses pns t2 + = concatMap used t2 + where + + usedInMatch _ _ = [] + + used :: LHsBind Name -> [Int] + used (L _ (FunBind _n _ (MatchGroup matches _) _ _ _)) + = usedInMatch pns matches + + +data HsBind a = FunBind a Int (MatchGroup a) Int Int Int + | PatBind String String Int Int a +data Name = N String +data Located a = L Int a +data MatchGroup a = MatchGroup [LMatch a] a +type LMatch a = Located (Match a) +data Match a = Match String Int a +data Renamer = Renamer +type LHsBind a = Located (HsBind a) +declaredPns = undefined diff --git a/test/testdata/Demote/UsedAtLevel.hs b/test/testdata/Demote/UsedAtLevel.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/UsedAtLevel.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Demote.UsedAtLevel where + +foo :: IO () +foo = do + let xx = uses declaredPns [] + return () + where + ---find how many matches/pattern bindings use 'pn'------- + -- uses :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> [Int] + uses pns t2 + = concatMap used t2 + where + + used :: LHsBind Name -> [Int] + used (L _ (FunBind _n _ (MatchGroup matches _) _ _ _)) + = usedInMatch pns matches + + usedInMatch _ _ = [] + + +data HsBind a = FunBind a Int (MatchGroup a) Int Int Int + | PatBind String String Int Int a +data Name = N String +data Located a = L Int a +data MatchGroup a = MatchGroup [LMatch a] a +type LMatch a = Located (Match a) +data Match a = Match String Int a +data Renamer = Renamer +type LHsBind a = Located (HsBind a) +declaredPns = undefined diff --git a/test/testdata/Demote/UsedAtLevel2.expected.hs b/test/testdata/Demote/UsedAtLevel2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/UsedAtLevel2.expected.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Demote.UsedAtLevel2 where + +foo :: IO () +foo = do + let xx = uses declaredPns [] + return () + where + ---find how many matches/pattern bindings use 'pn'------- + -- uses :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> [Int] + uses pns t2 + = concatMap used t2 + where + + usedInMatch _ _ = [] + + used :: LHsBind Name -> [Int] + used (L _ (FunBind _n _ (MatchGroup matches _) _ _ _)) + = usedInMatch pns matches + + used (L _ (PatBind _pat _rhs _ _ _)) + = [1::Int] + used _ = [] + + duplicateDecls = undefined + +data HsBind a = FunBind a Int (MatchGroup a) Int Int Int + | PatBind String String Int Int a +data Name = N String +data Located a = L Int a +data MatchGroup a = MatchGroup [LMatch a] a +type LMatch a = Located (Match a) +data Match a = Match String Int a +data Renamer = Renamer +type LHsBind a = Located (HsBind a) +declaredPns = undefined diff --git a/test/testdata/Demote/UsedAtLevel2.hs b/test/testdata/Demote/UsedAtLevel2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/UsedAtLevel2.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Demote.UsedAtLevel2 where + +foo :: IO () +foo = do + let xx = uses declaredPns [] + return () + where + ---find how many matches/pattern bindings use 'pn'------- + -- uses :: [GHC.Name] -> [GHC.LHsBind GHC.Name] -> [Int] + uses pns t2 + = concatMap used t2 + where + + used :: LHsBind Name -> [Int] + used (L _ (FunBind _n _ (MatchGroup matches _) _ _ _)) + = usedInMatch pns matches + + used (L _ (PatBind _pat _rhs _ _ _)) + = [1::Int] + used _ = [] + + usedInMatch _ _ = [] + + duplicateDecls = undefined + +data HsBind a = FunBind a Int (MatchGroup a) Int Int Int + | PatBind String String Int Int a +data Name = N String +data Located a = L Int a +data MatchGroup a = MatchGroup [LMatch a] a +type LMatch a = Located (Match a) +data Match a = Match String Int a +data Renamer = Renamer +type LHsBind a = Located (HsBind a) +declaredPns = undefined diff --git a/test/testdata/Demote/WhereIn1.hs b/test/testdata/Demote/WhereIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn1.hs @@ -0,0 +1,19 @@ +module Demote.WhereIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--This example also aims to test the adding of a 'where' claus. + +sumSquares x y = sq x + sq y + +sq 0 = 0 +sq z = z^pow + +pow=2 + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/test/testdata/Demote/WhereIn1.hs.expected b/test/testdata/Demote/WhereIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn1.hs.expected @@ -0,0 +1,19 @@ +module Demote.WhereIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--This example also aims to test the adding of a 'where' claus. + +sumSquares x y = sq x + sq y + where + sq 0 = 0 + sq z = z^pow + +pow=2 + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/test/testdata/Demote/WhereIn2.hs b/test/testdata/Demote/WhereIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn2.hs @@ -0,0 +1,20 @@ +module Demote.WhereIn2 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--This example also aims to test the renaming of clashed/capture names. + +sumSquares x y = sq x + sq y +pow + where pow=2 + sq z = z^pow -- Added to make test fail with no avail dest +sq 0 = 0 +sq z = z^pow + +pow=2 + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/test/testdata/Demote/WhereIn3.hs b/test/testdata/Demote/WhereIn3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn3.hs @@ -0,0 +1,19 @@ +module Demote.WhereIn3 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there are multi matches), the parameters are not folded after demoting. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq :: Int -> Int -> Int +sq pow 0 = 0 +sq pow z = z^pow --there is a comment + +{- foo bar -} +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/Demote/WhereIn3.hs.expected b/test/testdata/Demote/WhereIn3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn3.hs.expected @@ -0,0 +1,19 @@ +module Demote.WhereIn3 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there are multi matches), the parameters are not folded after demoting. + +sumSquares x y = sq p x + sq p y + where sq :: Int -> Int -> Int + sq pow 0 = 0 + sq pow z = z^pow --there is a comment + + p=2 {-There is a comment-} + +{- foo bar -} +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/Demote/WhereIn4.hs b/test/testdata/Demote/WhereIn4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn4.hs @@ -0,0 +1,19 @@ +module Demote.WhereIn4 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there is single matches), if possible, +--the parameters will be folded after demoting and type sigature will be removed. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq::Int->Int->Int +sq pow z = z^pow --there is a comment + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/test/testdata/Demote/WhereIn4.hs.expected b/test/testdata/Demote/WhereIn4.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn4.hs.expected @@ -0,0 +1,18 @@ +module Demote.WhereIn4 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there is single matches), if possible, +--the parameters will be folded after demoting and type sigature will be removed. + +sumSquares x y = sq x + sq y + where sq z = z^p --there is a comment + + p=2 {-There is a comment-} + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/test/testdata/Demote/WhereIn5.hs b/test/testdata/Demote/WhereIn5.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn5.hs @@ -0,0 +1,18 @@ +module Demote.WhereIn5 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'pow' to 'sq' +--This example aims to test demoting a function/pattern binding multi-levels. + +sumSquares x y = sq x + sq y + where sq 0=0 + sq z=z^pow {-There +is a comment-} +pow=2 + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/test/testdata/Demote/WhereIn5.hs.expected b/test/testdata/Demote/WhereIn5.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn5.hs.expected @@ -0,0 +1,18 @@ +module Demote.WhereIn5 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'pow' to 'sq' +--This example aims to test demoting a function/pattern binding multi-levels. + +sumSquares x y = sq x + sq y + where pow=2 + + sq 0=0 + sq z=z^pow {-There +is a comment-} +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/test/testdata/Demote/WhereIn6.hs b/test/testdata/Demote/WhereIn6.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn6.hs @@ -0,0 +1,15 @@ +module Demote.WhereIn6 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'addthree' to 'fun' +--This example also aims to test the removing of parameters and parentheses. + +fun x y z =inc (addthree x y z) + where inc a =a +1 + +addthree a b c=a+b+c + + diff --git a/test/testdata/Demote/WhereIn6.hs.expected b/test/testdata/Demote/WhereIn6.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn6.hs.expected @@ -0,0 +1,15 @@ +module Demote.WhereIn6 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'addthree' to 'fun' +--This example also aims to test the removing of parameters and parentheses. + +fun x y z =inc addthree + where addthree=x+y+z + + inc a =a +1 + + diff --git a/test/testdata/Demote/WhereIn7.hs b/test/testdata/Demote/WhereIn7.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn7.hs @@ -0,0 +1,18 @@ +module WhereIn7 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--This example also aims to test the split of type signature. + +sumSquares x y = sq x + sq y + +sq,anotherFun :: Int -> Int +sq 0 = 0 +sq z = z^pow + where pow=2 + +anotherFun x = x^2 + diff --git a/test/testdata/Demote/WhereIn7.hs.expected b/test/testdata/Demote/WhereIn7.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn7.hs.expected @@ -0,0 +1,20 @@ +module WhereIn7 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--This example also aims to test the split of type signature. + +sumSquares x y = sq x + sq y + where + sq :: Int -> Int + sq 0 = 0 + sq z = z^pow + where pow=2 + +anotherFun :: Int -> Int + +anotherFun x = x^2 + diff --git a/test/testdata/Demote/WhereIn8.hs b/test/testdata/Demote/WhereIn8.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Demote/WhereIn8.hs @@ -0,0 +1,17 @@ +module WhereIn8 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote 'anotherFun' will fail. + +sumSquares x y = sq x + sq y + +sq,anotherFun :: Int -> Int +sq 0 = 0 +sq z = z^pow + where pow=2 + +anotherFun x = x^2 + diff --git a/test/testdata/DupDef/Dd1.hs b/test/testdata/DupDef/Dd1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/DupDef/Dd1.hs @@ -0,0 +1,33 @@ +module DupDef.Dd1 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +data D = A | B String | C + +ff y = y + zz + where + zz = 1 + +l z = + let + ll = 34 + in ll + z + +dd q = do + let ss = 5 + return (ss + q) + diff --git a/test/testdata/DupDef/Dd1.hs.expected b/test/testdata/DupDef/Dd1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/DupDef/Dd1.hs.expected @@ -0,0 +1,36 @@ +module DupDef.Dd1 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +tl2 :: Integer -> Integer +tl2 x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +data D = A | B String | C + +ff y = y + zz + where + zz = 1 + +l z = + let + ll = 34 + in ll + z + +dd q = do + let ss = 5 + return (ss + q) + diff --git a/test/testdata/DupDef/Dd1.hs.expected.dd b/test/testdata/DupDef/Dd1.hs.expected.dd new file mode 100644 --- /dev/null +++ b/test/testdata/DupDef/Dd1.hs.expected.dd @@ -0,0 +1,35 @@ +module DupDef.Dd1 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +data D = A | B String | C + +ff y = y + zz + where + zz = 1 + +l z = + let + ll = 34 + in ll + z + +dd q = do + let ss = 5 + + sss = 5 + return (ss + q) + diff --git a/test/testdata/DupDef/Dd1.hs.expected.gg b/test/testdata/DupDef/Dd1.hs.expected.gg new file mode 100644 --- /dev/null +++ b/test/testdata/DupDef/Dd1.hs.expected.gg @@ -0,0 +1,36 @@ +module DupDef.Dd1 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + + gg :: Int + gg = 15 + +data D = A | B String | C + +ff y = y + zz + where + zz = 1 + +l z = + let + ll = 34 + in ll + z + +dd q = do + let ss = 5 + return (ss + q) + diff --git a/test/testdata/DupDef/Dd1.hs.expected.ll b/test/testdata/DupDef/Dd1.hs.expected.ll new file mode 100644 --- /dev/null +++ b/test/testdata/DupDef/Dd1.hs.expected.ll @@ -0,0 +1,35 @@ +module DupDef.Dd1 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +data D = A | B String | C + +ff y = y + zz + where + zz = 1 + +l z = + let + ll = 34 + + lll = 34 + in ll + z + +dd q = do + let ss = 5 + return (ss + q) + diff --git a/test/testdata/DupDef/Dd1.hs.expected.mm b/test/testdata/DupDef/Dd1.hs.expected.mm new file mode 100644 --- /dev/null +++ b/test/testdata/DupDef/Dd1.hs.expected.mm @@ -0,0 +1,37 @@ +module DupDef.Dd1 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +data D = A | B String | C + +ff y = y + zz + where + zz = 1 + +mm y = y + zz + where + zz = 1 + +l z = + let + ll = 34 + in ll + z + +dd q = do + let ss = 5 + return (ss + q) + diff --git a/test/testdata/DupDef/Dd1.hs.expected.nn b/test/testdata/DupDef/Dd1.hs.expected.nn new file mode 100644 --- /dev/null +++ b/test/testdata/DupDef/Dd1.hs.expected.nn @@ -0,0 +1,35 @@ +module DupDef.Dd1 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +data D = A | B String | C + +ff y = y + zz + where + zz = 1 + + nn = 1 + +l z = + let + ll = 34 + in ll + z + +dd q = do + let ss = 5 + return (ss + q) + diff --git a/test/testdata/DupDef/Dd2.hs b/test/testdata/DupDef/Dd2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/DupDef/Dd2.hs @@ -0,0 +1,10 @@ +module DupDef.Dd2 where + +import DupDef.Dd1 + + +f2 x = ff (x+1) + +mm = 5 + + diff --git a/test/testdata/DupDef/Dd2.hs.expected b/test/testdata/DupDef/Dd2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/DupDef/Dd2.hs.expected @@ -0,0 +1,10 @@ +module DupDef.Dd2 where + +import DupDef.Dd1 hiding (mm) + + +f2 x = ff (x+1) + +mm = 5 + + diff --git a/test/testdata/DupDef/Dd3.hs b/test/testdata/DupDef/Dd3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/DupDef/Dd3.hs @@ -0,0 +1,10 @@ +module DupDef.Dd3 where + +import DupDef.Dd1 hiding (dd) + + +f2 x = ff (x+1) + +mm = 5 + + diff --git a/test/testdata/DupDef/Dd3.hs.expected b/test/testdata/DupDef/Dd3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/DupDef/Dd3.hs.expected @@ -0,0 +1,10 @@ +module DupDef.Dd3 where + +import DupDef.Dd1 hiding (dd,mm) + + +f2 x = ff (x+1) + +mm = 5 + + diff --git a/test/testdata/Exports.hs b/test/testdata/Exports.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Exports.hs @@ -0,0 +1,9 @@ +module Exports + ( + down + ) where + +import Prelude hiding (head) +import Data.Text (head) + +down = undefined diff --git a/test/testdata/FreeAndDeclared/Binders.hs b/test/testdata/FreeAndDeclared/Binders.hs new file mode 100644 --- /dev/null +++ b/test/testdata/FreeAndDeclared/Binders.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +module FreeAndDeclared.Binders where + +import Data.Generics + +-- | Find the the new definition name in GHC.Name format. +findNewPName :: String -> RenamedSource -> Name +findNewPName name renamed = gfromJust "findNewPName" res + where + res = somethingStaged Renamer Nothing renamed + -- (Nothing `mkQ` worker) renamed + + worker (pname::Name) + | (occNameString $ getOccName pname) == name = Just pname + worker _ = Nothing + +data Renamer = Renamer +somethingStaged = undefined +data Name = NameCon deriving Typeable +occNameString = undefined +getOccName = undefined +data RenamedSource = RNS +gfromJust = undefined diff --git a/test/testdata/FreeAndDeclared/Declare.hs b/test/testdata/FreeAndDeclared/Declare.hs new file mode 100644 --- /dev/null +++ b/test/testdata/FreeAndDeclared/Declare.hs @@ -0,0 +1,37 @@ +module FreeAndDeclared.Declare (module FreeAndDeclared.Declare) where + +import qualified Data.Generics as G + +toplevel :: Integer -> Integer +toplevel x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..15] + +data D = A | B String | C + +-- Retrieve the String from a B +unD (B y) = y +-- But no others. + +-- Infix data constructor, see http://stackoverflow.com/a/6420943/595714 +data F = G | (:|) String String + +unF (a :| b) = (a,b) + +-- Main routine +main = do + a <- getChar + putStrLn "foo" + +mkT = "no clash with Data.Generics" + +ff z = G.gshow z + diff --git a/test/testdata/FreeAndDeclared/Declare1.hs b/test/testdata/FreeAndDeclared/Declare1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/FreeAndDeclared/Declare1.hs @@ -0,0 +1,35 @@ +module FreeAndDeclared.Declare1 where + +import qualified Data.Generics as G + +toplevel :: Integer -> Integer +toplevel x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..15] + +data D = A | B String | C + +-- Retrieve the String from a B +unD (B y) = y +-- But no others. + +-- Infix data constructor, see http://stackoverflow.com/a/6420943/595714 +data F = G | (:|) String String + +unF (a :| b) = (a,b) + +-- Main routine +main = do + a <- getChar + putStrLn "foo" + +mkT = "no clash with Data.Generics" + diff --git a/test/testdata/FreeAndDeclared/Declare2.hs b/test/testdata/FreeAndDeclared/Declare2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/FreeAndDeclared/Declare2.hs @@ -0,0 +1,35 @@ +module FreeAndDeclared.Declare2 () where + +import qualified Data.Generics as G + +toplevel :: Integer -> Integer +toplevel x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..15] + +data D = A | B String | C + +-- Retrieve the String from a B +unD (B y) = y +-- But no others. + +-- Infix data constructor, see http://stackoverflow.com/a/6420943/595714 +data F = G | (:|) String String + +unF (a :| b) = (a,b) + +-- Main routine +main = do + a <- getChar + putStrLn "foo" + +mkT = "no clash with Data.Generics" + diff --git a/test/testdata/FreeAndDeclared/DeclareRec.hs b/test/testdata/FreeAndDeclared/DeclareRec.hs new file mode 100644 --- /dev/null +++ b/test/testdata/FreeAndDeclared/DeclareRec.hs @@ -0,0 +1,12 @@ +module FreeAndDeclared.DeclareRec where + +data R = RCon { r1 :: Int, r2 :: Char } + +unR (RCon a b) = a + +unR2 (RCon {r1 = a}) = a + + + + + diff --git a/test/testdata/FreeAndDeclared/DeclareS.hs b/test/testdata/FreeAndDeclared/DeclareS.hs new file mode 100644 --- /dev/null +++ b/test/testdata/FreeAndDeclared/DeclareS.hs @@ -0,0 +1,7 @@ +module FreeAndDeclared.DeclareS where + +-- toplevel :: Integer -> Integer +-- toplevel x = 3 * x + +c = 'a' + diff --git a/test/testdata/FreeAndDeclared/DeclareTypes.hs b/test/testdata/FreeAndDeclared/DeclareTypes.hs new file mode 100644 --- /dev/null +++ b/test/testdata/FreeAndDeclared/DeclareTypes.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TypeFamilies #-} +module FreeAndDeclared.DeclareTypes where + +-- Type families + +-- See http://www.haskell.org/haskellwiki/GHC/Type_families +-- Declare a list-like data family +data family XList a + +-- Declare a list-like instance for Char +data instance XList Char = XCons !Char !(XList Char) | XNil + +-- Declare a number-like instance for () +data instance XList () = XListUnit !Int + +-- ------------------------------------- + + +data X = Y Integer | Z | W Foo + +type Foo = Integer + +class Bar a where + type BarVar a + data BarData a :: * -> * + + doBar :: a -> Int + + + + + diff --git a/test/testdata/Layout/Arrow.hs b/test/testdata/Layout/Arrow.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Arrow.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE Arrows #-} +module Layout.Arrow where + +import Control.Arrow +import qualified Control.Category as Cat + +addA :: Arrow a => a b Int -> a b Int -> a b Int +addA f g = proc x -> do + y <- f -< x + z <- g -< x + returnA -< y + z + +newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) } + +instance Cat.Category Circuit where + id = Circuit $ \a -> (Cat.id, a) + (.) = dot + where + (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a -> + let (cir1', b) = cir1 a + (cir2', c) = cir2 b + in (cir2' `dot` cir1', c) + +instance Arrow Circuit where + arr f = Circuit $ \a -> (arr f, f a) + first (Circuit cir) = Circuit $ \(b, d) -> + let (cir', c) = cir b + in (first cir', (c, d)) + +-- | Accumulator that outputs a value determined by the supplied function. +accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b +accum acc f = Circuit $ \input -> + let (output, acc') = input `f` acc + in (accum acc' f, output) + +-- | Accumulator that outputs the accumulator value. +accum' :: b -> (a -> b -> b) -> Circuit a b +accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b')) + +total :: Num a => Circuit a a +total = accum' 0 (+) + +mean3 :: Fractional a => Circuit a a +mean3 = proc value -> do + (t, n) <- (| (&&&) (total -< value) (total -< 1) |) + returnA -< t / n diff --git a/test/testdata/Layout/Bare.hs b/test/testdata/Layout/Bare.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Bare.hs @@ -0,0 +1,4 @@ + + +main = putStrLn "hello" + diff --git a/test/testdata/Layout/CaseExpr.hs b/test/testdata/Layout/CaseExpr.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/CaseExpr.hs @@ -0,0 +1,8 @@ +-- A simple case expression, to ensure the layout is detected + +module Layout.CaseExpr where + +foo x = case x of + 1 -> "a" + 2 -> "b" + diff --git a/test/testdata/Layout/Class.hs b/test/testdata/Layout/Class.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Class.hs @@ -0,0 +1,9 @@ +module Layout.Class where + +class Foo a where + foo :: a -> Int -> Char + +instance Foo Double where + foo p1 p2 = 'a' + + diff --git a/test/testdata/Layout/Comments1.hs b/test/testdata/Layout/Comments1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Comments1.hs @@ -0,0 +1,7 @@ +module Layout.Comments1 where + +aFun x = x + p + where p=2 {-There is a comment-} + +anotherFun = 3 + diff --git a/test/testdata/Layout/D5Simple.hs b/test/testdata/Layout/D5Simple.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/D5Simple.hs @@ -0,0 +1,7 @@ +module Layout.D5Simple where + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 diff --git a/test/testdata/Layout/Default.hs b/test/testdata/Layout/Default.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Default.hs @@ -0,0 +1,6 @@ +module Layout.Default where + +default (Float,Integer,Double) + + +foo = 5 diff --git a/test/testdata/Layout/Derive.hs b/test/testdata/Layout/Derive.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Derive.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE StandaloneDeriving #-} +module Layout.Derive where + +-- import Data.Generics + +data B = B Integer + +deriving instance Show B + + diff --git a/test/testdata/Layout/Do1.hs b/test/testdata/Layout/Do1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Do1.hs @@ -0,0 +1,13 @@ +module Layout.Do1 where + +getCurrentModuleGraph = undefined +topSortModuleGraph = undefined + +-- sortCurrentModuleGraph :: GHC.Ghc [GHC.SCC GHC.ModSummary] +sortCurrentModuleGraph :: IO [Int] +sortCurrentModuleGraph = do + -- g <- GHC.getModuleGraph + g <- getCurrentModuleGraph + let scc = topSortModuleGraph False g Nothing + return scc + diff --git a/test/testdata/Layout/Do1.hs.expected b/test/testdata/Layout/Do1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Do1.hs.expected @@ -0,0 +1,13 @@ +module Layout.Do1 where + +getCurrentModuleGraph = undefined +topSortModuleGraph = undefined + +-- sortCurrentModuleGraph :: GHC.Ghc [GHC.SCC GHC.ModSummary] +sortCurrentModuleGraph :: IO [Int] +sortCurrentModuleGraph = do + -- g <- GHC.getModuleGraph + g2 <- getCurrentModuleGraph + let scc = topSortModuleGraph False g2 Nothing + return scc + diff --git a/test/testdata/Layout/ForAll.hs b/test/testdata/Layout/ForAll.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/ForAll.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes #-} +module Layout.ForAll where + +import Data.Data + +foo :: (forall a. Data a => a -> a) -> forall a. Data a => a -> a +foo a = a diff --git a/test/testdata/Layout/Foreign.hs b/test/testdata/Layout/Foreign.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Foreign.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Layout.Foreign where + + +import Foreign.C.Types +import GHC.Exts + +foreign import ccall "wxStyledTextCtrl_ShowLines" wxStyledTextCtrl_ShowLines :: Ptr (Int) -> CInt -> CInt -> IO () + +foreign export ccall "wxStyledTextCtrl_ShowLines" wxStyledTextCtrl_ShowLines :: Ptr (Int) -> CInt -> CInt -> IO () + +foo = 0 + + + diff --git a/test/testdata/Layout/FromMd1.hs b/test/testdata/Layout/FromMd1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/FromMd1.hs @@ -0,0 +1,10 @@ +module Layout.FromMd1 where + +data D = A | B String | C + +ff :: Int -> Int +ff y = y + zz + where + zz = 1 + +x = 3 diff --git a/test/testdata/Layout/HsDo.hs b/test/testdata/Layout/HsDo.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/HsDo.hs @@ -0,0 +1,22 @@ +module Layout.HsDo where + +import qualified Data.Map as Map + +moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] + + +graphFromEdgedVertices = undefined +nodes = undefined +lookup_node = undefined +type NodeMap a = Map.Map (Int,Int) (Int,Int,Int) +data SummaryNode = SummaryNode +moduleName = undefined +ms_mod = undefined +ms_hsc_src = undefined + diff --git a/test/testdata/Layout/LetExpr.hs b/test/testdata/Layout/LetExpr.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/LetExpr.hs @@ -0,0 +1,8 @@ +-- A simple let expression, to ensure the layout is detected + +module Layout.LetExpr where + +foo = let x = 1 + y = 2 + in x + y + diff --git a/test/testdata/Layout/LetStmt.hs b/test/testdata/Layout/LetStmt.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/LetStmt.hs @@ -0,0 +1,9 @@ +-- A simple let statement, to ensure the layout is detected + +module Layout.LetStmt where + +foo = do + let x = 1 + y = 2 + x+y + diff --git a/test/testdata/Layout/Lift.hs b/test/testdata/Layout/Lift.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Lift.hs @@ -0,0 +1,7 @@ +module Layout.Lift where + +ff y = y + zz + where + zz = 1 + +x = 1 diff --git a/test/testdata/Layout/Move1.hs b/test/testdata/Layout/Move1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Move1.hs @@ -0,0 +1,51 @@ +module Layout.Move1 where + +data Located a = L Int a +type Name = String +hsBinds = undefined +divideDecls = undefined +definingDeclsNames = undefined +nub = undefined +definedPNs = undefined +logm = undefined +showGhc = undefined +pnsNeedRenaming = undefined + +-- liftToTopLevel' :: ModuleName -- -> (ParseResult,[PosToken]) -> FilePath +-- -> Located Name +-- -> RefactGhc [a] +liftToTopLevel' :: Int -> Located Name -> IO [a] +liftToTopLevel' modName pn@(L _ n) = do + liftToMod + return [] + where + {-step1: divide the module's top level declaration list into three parts: + 'parent' is the top level declaration containing the lifted declaration, + 'before' and `after` are those declarations before and after 'parent'. + step2: get the declarations to be lifted from parent, bind it to liftedDecls + step3: remove the lifted declarations from parent and extra arguments may be introduce. + step4. test whether there are any names need to be renamed. + -} + liftToMod :: IO () + liftToMod = do + -- renamed <- getRefactRenamed + let renamed = undefined + let declsr = hsBinds renamed + let (before,parent,after) = divideDecls declsr pn + -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ++ + {- ++AZ++ : hsBinds does not return class or instance definitions + when (isClassDecl $ ghead "liftToMod" parent) + $ error "Sorry, the refactorer cannot lift a definition from a class declaration!" + when (isInstDecl $ ghead "liftToMod" parent) + $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!" + -} + let liftedDecls = definingDeclsNames [n] parent True True + declaredPns = nub $ concatMap definedPNs liftedDecls + + -- TODO: what about declarations between this + -- one and the top level that are used in this one? + + logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns)) + -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns + -- pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns + return () diff --git a/test/testdata/Layout/PArr.hs b/test/testdata/Layout/PArr.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/PArr.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ParallelListComp #-} + +module Layout.PArr where + +blah xs ys = [ (x, y) | x <- xs | y <- ys ] + +-- bar = [: 1, 2 .. 3 :] + + +-- entry point for desugaring a parallel array comprehension + +-- parr = [:e | qss:] = <<[:e | qss:]>> () [:():] + +{- +ary = let arr1 = toP [1..10] + arr2 = toP [1..10] + f = [: i1 + i2 | i1 <- arr1 | i2 <- arr2 :] + in f !: 1 +-} + + +foo = 'a' + diff --git a/test/testdata/Layout/PatBind.hs b/test/testdata/Layout/PatBind.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/PatBind.hs @@ -0,0 +1,12 @@ +module Layout.PatBind where + + -- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + + diff --git a/test/testdata/Layout/TH.hs b/test/testdata/Layout/TH.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/TH.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +module Layout.TH where + +import Language.Haskell.TH + +emptyShow :: Name -> Q [Dec] +emptyShow name = [d|instance Show $(conT name) where show _ = ""|] + +foo = 1 diff --git a/test/testdata/Layout/Where.hs b/test/testdata/Layout/Where.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Where.hs @@ -0,0 +1,4 @@ +module LiftToToplevel.Where where + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/Layout/Where2.hs b/test/testdata/Layout/Where2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Layout/Where2.hs @@ -0,0 +1,8 @@ +module Layout.Where2 where + +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +x = 3 diff --git a/test/testdata/LiftOneLevel/A1.hs b/test/testdata/LiftOneLevel/A1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/A1.hs @@ -0,0 +1,7 @@ +module LiftOneLevel.A1 where + +import LiftOneLevel.C1 + +main xs = case xs of + [] -> 0 + [x:xs] -> x^pow + sumSquares1 xs diff --git a/test/testdata/LiftOneLevel/A2.hs b/test/testdata/LiftOneLevel/A2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/A2.hs @@ -0,0 +1,5 @@ +module LiftOneLevel.A2 where + +import LiftOneLevel.C2 + +main = sumSquares [1..4] + anotherFun [1..4] diff --git a/test/testdata/LiftOneLevel/A3.hs b/test/testdata/LiftOneLevel/A3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/A3.hs @@ -0,0 +1,6 @@ +module LiftOneLevel.A3 where + +import LiftOneLevel.C3 (anotherFun) +import LiftOneLevel.D3 (sumSquares) + +main = sumSquares [1..4] + anotherFun [1..4] diff --git a/test/testdata/LiftOneLevel/C1.hs b/test/testdata/LiftOneLevel/C1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/C1.hs @@ -0,0 +1,12 @@ +module LiftOneLevel.C1 where + +import LiftOneLevel.D1 hiding (main) + +sumSquares1 (x:xs) = sq x + sumSquares1 xs + +sumSquares1 [] = 0 + +sq x =x ^pow + +pow = 2 + diff --git a/test/testdata/LiftOneLevel/C1.hs.expected b/test/testdata/LiftOneLevel/C1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/C1.hs.expected @@ -0,0 +1,12 @@ +module LiftOneLevel.C1 where + +import LiftOneLevel.D1 hiding (main,sq) + +sumSquares1 (x:xs) = sq x + sumSquares1 xs + +sumSquares1 [] = 0 + +sq x =x ^pow + +pow = 2 + diff --git a/test/testdata/LiftOneLevel/C2.hs b/test/testdata/LiftOneLevel/C2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/C2.hs @@ -0,0 +1,8 @@ +module LiftOneLevel.C2 (module LiftOneLevel.D2, module LiftOneLevel.C2) where + +import LiftOneLevel.D2 + +anotherFun (x:xs) = x^4 + anotherFun xs + +anotherFun [] = 0 + diff --git a/test/testdata/LiftOneLevel/C2.hs.expected b/test/testdata/LiftOneLevel/C2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/C2.hs.expected @@ -0,0 +1,8 @@ +module LiftOneLevel.C2 (module LiftOneLevel.D2, module LiftOneLevel.C2) where + +import LiftOneLevel.D2 hiding (sq) + +anotherFun (x:xs) = x^4 + anotherFun xs + +anotherFun [] = 0 + diff --git a/test/testdata/LiftOneLevel/C3.hs b/test/testdata/LiftOneLevel/C3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/C3.hs @@ -0,0 +1,8 @@ +module LiftOneLevel.C3 where + +import LiftOneLevel.D3(pow) + +anotherFun (x:xs) = x^pow + anotherFun xs + +anotherFun [] = 0 + diff --git a/test/testdata/LiftOneLevel/CaseIn1.hs b/test/testdata/LiftOneLevel/CaseIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/CaseIn1.hs @@ -0,0 +1,12 @@ +module LiftOneLevel.CaseIn1 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'addthree' defined in main + +main x y z = case x of + 0 -> addthree x y z + where addthree a b c=a+b+c + 1 -> inc y + where inc a =a+1 diff --git a/test/testdata/LiftOneLevel/CaseIn1.hs.expected b/test/testdata/LiftOneLevel/CaseIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/CaseIn1.hs.expected @@ -0,0 +1,13 @@ +module LiftOneLevel.CaseIn1 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'addthree' defined in main + +main x y z = case x of + 0 -> addthree x y z + 1 -> inc y + where inc a =a+1 + where + addthree a b c=a+b+c diff --git a/test/testdata/LiftOneLevel/D1.hs b/test/testdata/LiftOneLevel/D1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/D1.hs @@ -0,0 +1,13 @@ +module LiftOneLevel.D1 where + +{-lift 'sq' to top level. This refactoring +affects module 'D1' and 'C1' -} + +sumSquares (x:xs) = sq x + sumSquares xs + where + sq x = x ^ pow + pow =2 + +sumSquares [] = 0 + +main = sumSquares [1..4] diff --git a/test/testdata/LiftOneLevel/D1.hs.expected b/test/testdata/LiftOneLevel/D1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/D1.hs.expected @@ -0,0 +1,14 @@ +module LiftOneLevel.D1 where + +{-lift 'sq' to top level. This refactoring +affects module 'D1' and 'C1' -} + +sumSquares (x:xs) = (sq pow) x + sumSquares xs + where + pow =2 + +sumSquares [] = 0 + +sq pow x = x ^ pow + +main = sumSquares [1..4] diff --git a/test/testdata/LiftOneLevel/D2.hs b/test/testdata/LiftOneLevel/D2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/D2.hs @@ -0,0 +1,12 @@ +module LiftOneLevel.D2 where + +{-lift 'sq' to top level. In this refactoring, 'sq' will +be hided in the import declaraion of module 'D2' in module 'C2'.-} + +sumSquares (x:xs) = sq x + sumSquares xs + where + sq x = x ^ pow + pow =2 + +sumSquares [] = 0 + diff --git a/test/testdata/LiftOneLevel/D2.hs.expected b/test/testdata/LiftOneLevel/D2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/D2.hs.expected @@ -0,0 +1,13 @@ +module LiftOneLevel.D2 where + +{-lift 'sq' to top level. In this refactoring, 'sq' will +be hided in the import declaraion of module 'D2' in module 'C2'.-} + +sumSquares (x:xs) = (sq pow) x + sumSquares xs + where + pow =2 + +sumSquares [] = 0 + +sq pow x = x ^ pow + diff --git a/test/testdata/LiftOneLevel/D3.hs b/test/testdata/LiftOneLevel/D3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/D3.hs @@ -0,0 +1,13 @@ +module LiftOneLevel.D3 where + +{-lift 'sq' to top level. This refactoring only affects the +current module. -} + +sumSquares (x:xs) = sq x + sumSquares xs + where + sq x = x ^ pow + +sumSquares [] = 0 + +pow = 2 + diff --git a/test/testdata/LiftOneLevel/D3.hs.expected b/test/testdata/LiftOneLevel/D3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/D3.hs.expected @@ -0,0 +1,13 @@ +module LiftOneLevel.D3 where + +{-lift 'sq' to top level. This refactoring only affects the +current module. -} + +sumSquares (x:xs) = sq x + sumSquares xs + +sumSquares [] = 0 + +sq x = x ^ pow + +pow = 2 + diff --git a/test/testdata/LiftOneLevel/LetIn1.hs b/test/testdata/LiftOneLevel/LetIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/LetIn1.hs @@ -0,0 +1,16 @@ +module LiftOneLevel.LetIn1 where + +--A definition can be lifted from a where or let into the surronding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to a where clause, +--and the elimination of the keywords 'let' and 'in' + +sumSquares x y = let sq 0=0 + sq z=z^pow + in sq x + sq y + where pow=2 + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftOneLevel/LetIn1.hs.expected b/test/testdata/LiftOneLevel/LetIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/LetIn1.hs.expected @@ -0,0 +1,17 @@ +module LiftOneLevel.LetIn1 where + +--A definition can be lifted from a where or let into the surronding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to a where clause, +--and the elimination of the keywords 'let' and 'in' + +sumSquares x y = sq x + sq y + where pow=2 + + sq 0=0 + sq z=z^pow + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftOneLevel/LetIn2.hs b/test/testdata/LiftOneLevel/LetIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/LetIn2.hs @@ -0,0 +1,17 @@ +module LiftOneLevel.LetIn2 where + +--A definition can be lifted from a where or let into the surronding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to a where clause, +--adding parameters and the keyword 'where'. + +sumSquares x y = let sq 0=0 + sq z=z^pow + pow=2 + in sq x + sq y + + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftOneLevel/LetIn2.hs.expected b/test/testdata/LiftOneLevel/LetIn2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/LetIn2.hs.expected @@ -0,0 +1,18 @@ +module LiftOneLevel.LetIn2 where + +--A definition can be lifted from a where or let into the surronding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to a where clause, +--adding parameters and the keyword 'where'. + +sumSquares x y = let pow=2 + in (sq pow) x + (sq pow) y + where + sq pow 0=0 + sq pow z=z^pow + + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftOneLevel/LetIn3.hs b/test/testdata/LiftOneLevel/LetIn3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/LetIn3.hs @@ -0,0 +1,15 @@ +module LiftOneLevel.LetIn3 where + +--A definition can be lifted from a where or let into the surronding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to a let clause, + +sumSquares x y = let pow=2 + in (let sq 0=0 + sq z=z^pow + in sq x + sq y) + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftOneLevel/LetIn3.hs.expected b/test/testdata/LiftOneLevel/LetIn3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/LetIn3.hs.expected @@ -0,0 +1,16 @@ +module LiftOneLevel.LetIn3 where + +--A definition can be lifted from a where or let into the surronding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to a let clause, + +sumSquares x y = let pow=2 + + sq 0=0 + sq z=z^pow + in ( sq x + sq y) + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftOneLevel/PatBindIn2.hs b/test/testdata/LiftOneLevel/PatBindIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/PatBindIn2.hs @@ -0,0 +1,17 @@ +module LiftOneLevel.PatBindIn2 where + +--A definition can be lifted from a where or let into the surrounding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'tup' defined in 'foo' will fail. + +main :: Int +main = foo 3 + +foo :: Int -> Int +foo x = h + t + (snd tup) + where + h :: Int + t :: Int + tup :: (Int,Int) + tup@(h,t) = head $ zip [1..x] [3..15] diff --git a/test/testdata/LiftOneLevel/PatBindIn3.hs b/test/testdata/LiftOneLevel/PatBindIn3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/PatBindIn3.hs @@ -0,0 +1,15 @@ +module PatBindIn3 where + +--A definition can be lifted from a where or let into the surrounding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' defined in 'sumSquares' +--This example aims to test changing a constant to a function. + +sumSquares x = sq + sq + where + sq = x^pow + pow =2 + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftOneLevel/PatBindIn3.hs.expected b/test/testdata/LiftOneLevel/PatBindIn3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/PatBindIn3.hs.expected @@ -0,0 +1,16 @@ +module PatBindIn3 where + +--A definition can be lifted from a where or let into the surrounding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' defined in 'sumSquares' +--This example aims to test changing a constant to a function. + +sumSquares x = (sq x pow) + (sq x pow) + where + pow =2 + +sq x pow = x^pow + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftOneLevel/WhereIn1.hs b/test/testdata/LiftOneLevel/WhereIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/WhereIn1.hs @@ -0,0 +1,16 @@ +module LiftOneLevel.WhereIn1 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test add parameters to 'sq'. + +sumSquares x y = sq x + sq y + where + sq 0 = 0 + sq z = z^pow + pow=2 + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftOneLevel/WhereIn1.hs.expected b/test/testdata/LiftOneLevel/WhereIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/WhereIn1.hs.expected @@ -0,0 +1,17 @@ +module LiftOneLevel.WhereIn1 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test add parameters to 'sq'. + +sumSquares x y = (sq pow) x + (sq pow) y + where + pow=2 + +sq pow 0 = 0 +sq pow z = z^pow + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftOneLevel/WhereIn2.hs b/test/testdata/LiftOneLevel/WhereIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/WhereIn2.hs @@ -0,0 +1,15 @@ +module LiftOneLevel.WhereIn2 where + +{- Lifting the local function 'sq' will fail because of the +necessity of renaming. +-} +sumSquares x y = sq x + sq y + where + sq 0 = 0 + sq z = z^pow --There is a comment + pow=2 + + +anotherFun 0 y = sq y + +sq x = x^2 diff --git a/test/testdata/LiftOneLevel/WhereIn6.hs b/test/testdata/LiftOneLevel/WhereIn6.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/WhereIn6.hs @@ -0,0 +1,16 @@ +module LiftOneLevel.WhereIn6 where + +--A definition can be lifted from a where or let into the surrounding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'pow' defined in 'sq' + +sumSquares x y = sq x + sq y + where + sq::Int->Int + sq 0 = 0 + sq z = z^pow + where pow=2 + +anotherFun 0 y = sq y + where sq x=x^2 diff --git a/test/testdata/LiftOneLevel/WhereIn6.hs.expected b/test/testdata/LiftOneLevel/WhereIn6.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/WhereIn6.hs.expected @@ -0,0 +1,17 @@ +module LiftOneLevel.WhereIn6 where + +--A definition can be lifted from a where or let into the surrounding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'pow' defined in 'sq' + +sumSquares x y = sq x + sq y + where + sq::Int->Int + sq 0 = 0 + sq z = z^pow + + pow=2 + +anotherFun 0 y = sq y + where sq x=x^2 diff --git a/test/testdata/LiftOneLevel/WhereIn7.hs b/test/testdata/LiftOneLevel/WhereIn7.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/WhereIn7.hs @@ -0,0 +1,12 @@ +module LiftOneLevel.WhereIn7 where + +--A definition can be lifted from a where or let into the surrounding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'addthree' defined in 'fun'. +--This example aims to test adding parenthese. + + +fun x y z =inc addthree + where inc a =a +1 + addthree=x+y+z diff --git a/test/testdata/LiftOneLevel/WhereIn7.hs.expected b/test/testdata/LiftOneLevel/WhereIn7.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/WhereIn7.hs.expected @@ -0,0 +1,13 @@ +module LiftOneLevel.WhereIn7 where + +--A definition can be lifted from a where or let into the surrounding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'addthree' defined in 'fun'. +--This example aims to test adding parenthese. + + +fun x y z =inc (addthree x y z) + where inc a =a +1 + +addthree x y z=x+y+z diff --git a/test/testdata/LiftOneLevel/WhereIn8.hs b/test/testdata/LiftOneLevel/WhereIn8.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/WhereIn8.hs @@ -0,0 +1,9 @@ +module LiftOneLevel.WhereIn8 where + +--lift 'b=17' one level up. +g y = f + 345 + where + f = y + b + where + b=17 + diff --git a/test/testdata/LiftOneLevel/WhereIn8.hs.expected b/test/testdata/LiftOneLevel/WhereIn8.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftOneLevel/WhereIn8.hs.expected @@ -0,0 +1,9 @@ +module LiftOneLevel.WhereIn8 where + +--lift 'b=17' one level up. +g y = f + 345 + where + f = y + b + + b=17 + diff --git a/test/testdata/LiftToToplevel/A1.hs b/test/testdata/LiftToToplevel/A1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/A1.hs @@ -0,0 +1,8 @@ +module LiftToToplevel.A1 where + +import LiftToToplevel.C1 + +main xs = case xs of + [] -> 0 + [x:xs] -> x^pow + sumSquares1 xs + diff --git a/test/testdata/LiftToToplevel/A2.hs b/test/testdata/LiftToToplevel/A2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/A2.hs @@ -0,0 +1,6 @@ +module LiftToToplevel.A2 where + +import LiftToToplevel.C2 + +main = sumSquares [1..4] + anotherFun [1..4] + diff --git a/test/testdata/LiftToToplevel/A3.hs b/test/testdata/LiftToToplevel/A3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/A3.hs @@ -0,0 +1,7 @@ +module LiftToToplevel.A3 where + +import LiftToToplevel.C3 (anotherFun) +import LiftToToplevel.D3 (sumSquares) + +main = sumSquares [1..4] + anotherFun [1..4] + diff --git a/test/testdata/LiftToToplevel/C1.hs b/test/testdata/LiftToToplevel/C1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/C1.hs @@ -0,0 +1,14 @@ +module LiftToToplevel.C1 where + +import LiftToToplevel.D1 hiding (main) + +sumSquares1 (x:xs) = sq x + sumSquares1 xs + +sumSquares1 [] = 0 + +-- sq x =x ^pow +sq x =x ^pow * z + where z = 5 + +pow = 2 + diff --git a/test/testdata/LiftToToplevel/C1.hs.expected b/test/testdata/LiftToToplevel/C1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/C1.hs.expected @@ -0,0 +1,14 @@ +module LiftToToplevel.C1 where + +import LiftToToplevel.D1 hiding (main,sq) + +sumSquares1 (x:xs) = sq x + sumSquares1 xs + +sumSquares1 [] = 0 + +-- sq x =x ^pow +sq x =x ^pow * z + where z = 5 + +pow = 2 + diff --git a/test/testdata/LiftToToplevel/C2.hs b/test/testdata/LiftToToplevel/C2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/C2.hs @@ -0,0 +1,10 @@ +module LiftToToplevel.C2 (module LiftToToplevel.D2, module LiftToToplevel.C2) where + +import LiftToToplevel.D2 + +anotherFun (x:xs) = x^4 + anotherFun xs + +anotherFun [] = 0 + + + diff --git a/test/testdata/LiftToToplevel/C2.hs.expected b/test/testdata/LiftToToplevel/C2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/C2.hs.expected @@ -0,0 +1,10 @@ +module LiftToToplevel.C2 (module LiftToToplevel.D2, module LiftToToplevel.C2) where + +import LiftToToplevel.D2 hiding (sq) + +anotherFun (x:xs) = x^4 + anotherFun xs + +anotherFun [] = 0 + + + diff --git a/test/testdata/LiftToToplevel/C3.hs b/test/testdata/LiftToToplevel/C3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/C3.hs @@ -0,0 +1,10 @@ +module LiftToToplevel.C3 where + +import LiftToToplevel.D3(pow) + +anotherFun (x:xs) = x^pow + anotherFun xs + +anotherFun [] = 0 + + + diff --git a/test/testdata/LiftToToplevel/C3.hs.expected b/test/testdata/LiftToToplevel/C3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/C3.hs.expected @@ -0,0 +1,10 @@ +module LiftToToplevel.C3 where + +import LiftToToplevel.D3(pow) + +anotherFun (x:xs) = x^pow + anotherFun xs + +anotherFun [] = 0 + + + diff --git a/test/testdata/LiftToToplevel/CaseIn1.hs b/test/testdata/LiftToToplevel/CaseIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/CaseIn1.hs @@ -0,0 +1,13 @@ +module LiftToToplevel.CaseIn1 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'addthree' defined in main + +main x y z = case x of + 0 -> addthree x y z + where addthree a b c=a+b+c + 1 -> inc y + where inc a =a+1 + diff --git a/test/testdata/LiftToToplevel/CaseIn1.hs.expected b/test/testdata/LiftToToplevel/CaseIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/CaseIn1.hs.expected @@ -0,0 +1,14 @@ +module LiftToToplevel.CaseIn1 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'addthree' defined in main + +main x y z = case x of + 0 -> addthree x y z + 1 -> inc y + where inc a =a+1 + +addthree a b c=a+b+c + diff --git a/test/testdata/LiftToToplevel/D1.hs b/test/testdata/LiftToToplevel/D1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/D1.hs @@ -0,0 +1,15 @@ +module LiftToToplevel.D1 where + +{-lift 'sq' to top level. This refactoring + affects module 'D1' and 'C1' -} + +sumSquares (x:xs) = sq x + sumSquares xs + where + sq x = x ^ pow + pow =2 + +sumSquares [] = 0 + +main = sumSquares [1..4] + + diff --git a/test/testdata/LiftToToplevel/D1.hs.expected b/test/testdata/LiftToToplevel/D1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/D1.hs.expected @@ -0,0 +1,16 @@ +module LiftToToplevel.D1 where + +{-lift 'sq' to top level. This refactoring + affects module 'D1' and 'C1' -} + +sumSquares (x:xs) = (sq pow) x + sumSquares xs + where + pow =2 + +sumSquares [] = 0 + +sq pow x = x ^ pow + +main = sumSquares [1..4] + + diff --git a/test/testdata/LiftToToplevel/D1A.hs b/test/testdata/LiftToToplevel/D1A.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/D1A.hs @@ -0,0 +1,16 @@ +module LiftToToplevel.D1A where + +{-lift 'sq' to top level. This refactoring + affects module 'D1' and 'C1' -} + +sumSquares (x:xs) = sq x + sumSquares xs + where + sq x = x ^ pow + -- sq x = x ^ 2 + pow =2 + +sumSquares [] = 0 + +main = sumSquares [1..4] + + diff --git a/test/testdata/LiftToToplevel/D2.hs b/test/testdata/LiftToToplevel/D2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/D2.hs @@ -0,0 +1,12 @@ +module LiftToToplevel.D2 where + +{-lift 'sq' to top level. In this refactoring, 'sq' will + be hided in the import declaraion of module 'D2' in module 'C2'.-} + +sumSquares (x:xs) = sq x + sumSquares xs + where + sq x = x ^ pow + pow =2 + +sumSquares [] = 0 + diff --git a/test/testdata/LiftToToplevel/D2.hs.expected b/test/testdata/LiftToToplevel/D2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/D2.hs.expected @@ -0,0 +1,13 @@ +module LiftToToplevel.D2 where + +{-lift 'sq' to top level. In this refactoring, 'sq' will + be hided in the import declaraion of module 'D2' in module 'C2'.-} + +sumSquares (x:xs) = (sq pow) x + sumSquares xs + where + pow =2 + +sumSquares [] = 0 + +sq pow x = x ^ pow + diff --git a/test/testdata/LiftToToplevel/D3.hs b/test/testdata/LiftToToplevel/D3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/D3.hs @@ -0,0 +1,13 @@ +module LiftToToplevel.D3 where + +{-lift 'sq' to top level. This refactoring only affects the + current module. -} + +sumSquares (x:xs) = sq x + sumSquares xs + where + sq x = x ^ pow + +sumSquares [] = 0 + +pow = 2 + diff --git a/test/testdata/LiftToToplevel/D3.hs.expected b/test/testdata/LiftToToplevel/D3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/D3.hs.expected @@ -0,0 +1,13 @@ +module LiftToToplevel.D3 where + +{-lift 'sq' to top level. This refactoring only affects the + current module. -} + +sumSquares (x:xs) = sq x + sumSquares xs + +sumSquares [] = 0 + +sq x = x ^ pow + +pow = 2 + diff --git a/test/testdata/LiftToToplevel/LetIn1.hs b/test/testdata/LiftToToplevel/LetIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/LetIn1.hs @@ -0,0 +1,16 @@ +module LiftToToplevel.LetIn1 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to top level, +--and the elimination of the keywords 'let' and 'in' + +sumSquares x y = let sq 0=0 + sq z=z^pow + in sq x + sq y + where pow=2 + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftToToplevel/LetIn1.hs.expected b/test/testdata/LiftToToplevel/LetIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/LetIn1.hs.expected @@ -0,0 +1,17 @@ +module LiftToToplevel.LetIn1 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to top level, +--and the elimination of the keywords 'let' and 'in' + +sumSquares x y = (sq pow) x + (sq pow) y + where pow=2 + +sq pow 0=0 +sq pow z=z^pow + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftToToplevel/LetIn2.hs b/test/testdata/LiftToToplevel/LetIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/LetIn2.hs @@ -0,0 +1,15 @@ +module LiftToToplevel.LetIn2 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to top Level. + +sumSquares x y = let sq 0=0 + sq z=z^pow + pow=2 + in sq x + sq y + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftToToplevel/LetIn2.hs.expected b/test/testdata/LiftToToplevel/LetIn2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/LetIn2.hs.expected @@ -0,0 +1,16 @@ +module LiftToToplevel.LetIn2 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to top Level. + +sumSquares x y = let pow=2 + in (sq pow) x + (sq pow) y + +sq pow 0=0 +sq pow z=z^pow + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftToToplevel/LetIn3.hs b/test/testdata/LiftToToplevel/LetIn3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/LetIn3.hs @@ -0,0 +1,15 @@ +module LiftToToplevel.LetIn3 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to top level. + +sumSquares x y = let pow=2 + in (let sq 0=0 + sq z=z^pow + in sq x + sq y) + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftToToplevel/LetIn3.hs.expected b/test/testdata/LiftToToplevel/LetIn3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/LetIn3.hs.expected @@ -0,0 +1,16 @@ +module LiftToToplevel.LetIn3 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test lifting a definition from a let clause to top level. + +sumSquares x y = let pow=2 + in ( (sq pow) x + (sq pow) y) + +sq pow 0=0 +sq pow z=z^pow + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftToToplevel/LiftInLambda.expected.hs b/test/testdata/LiftToToplevel/LiftInLambda.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/LiftInLambda.expected.hs @@ -0,0 +1,14 @@ +module LiftToToplevel.LiftInLambda where + +foo :: IO [(Char,[Int])] +foo = do + let + xx = map (\b -> (b,(uses everythingStaged) declaredPns [b])) ['a','b'] + return xx + + where + declaredPns = undefined + everythingStaged = undefined + +uses everythingStaged pns t2 = everythingStaged pns [1..10] + diff --git a/test/testdata/LiftToToplevel/LiftInLambda.hs b/test/testdata/LiftToToplevel/LiftInLambda.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/LiftInLambda.hs @@ -0,0 +1,14 @@ +module LiftToToplevel.LiftInLambda where + +foo :: IO [(Char,[Int])] +foo = do + let + xx = map (\b -> (b,uses declaredPns [b])) ['a','b'] + return xx + + where + uses pns t2 = everythingStaged pns [1..10] + + declaredPns = undefined + everythingStaged = undefined + diff --git a/test/testdata/LiftToToplevel/NoWhere.expected.hs b/test/testdata/LiftToToplevel/NoWhere.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/NoWhere.expected.hs @@ -0,0 +1,17 @@ +module LiftToToplevel.NoWhere where + +liftToTopLevel' modName pn = do + renamed <- getRefactRenamed + return [] + +{-step1: divide the module's top level declaration list into three parts: + 'parent' is the top level declaration containing the lifted declaration, + 'before' and `after` are those declarations before and after 'parent'. + step2: get the declarations to be lifted from parent, bind it to liftedDecls + step3: remove the lifted declarations from parent and extra arguments may be introduce. + step4. test whether there are any names need to be renamed. + -} +liftToMod = ['a'] -- do + +getRefactRenamed :: IO String +getRefactRenamed = undefined diff --git a/test/testdata/LiftToToplevel/NoWhere.hs b/test/testdata/LiftToToplevel/NoWhere.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/NoWhere.hs @@ -0,0 +1,17 @@ +module LiftToToplevel.NoWhere where + +liftToTopLevel' modName pn = do + renamed <- getRefactRenamed + return [] + where + {-step1: divide the module's top level declaration list into three parts: + 'parent' is the top level declaration containing the lifted declaration, + 'before' and `after` are those declarations before and after 'parent'. + step2: get the declarations to be lifted from parent, bind it to liftedDecls + step3: remove the lifted declarations from parent and extra arguments may be introduce. + step4. test whether there are any names need to be renamed. + -} + liftToMod = ['a'] -- do + +getRefactRenamed :: IO String +getRefactRenamed = undefined diff --git a/test/testdata/LiftToToplevel/PatBindIn1.hs b/test/testdata/LiftToToplevel/PatBindIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/PatBindIn1.hs @@ -0,0 +1,18 @@ +module LiftToToplevel.PatBindIn1 where + +--A definition can be lifted from a where or let into the surrounding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'tup' defined in 'foo' +--This example aims to test renaming and the lifting of type signatures. + +main :: Int +main = foo 3 + +foo :: Int -> Int +foo x = h + t + (snd tup) + where + h :: Int + t :: Int + tup :: (Int,Int) + tup@(h,t) = head $ zip [1..10] [3..15] diff --git a/test/testdata/LiftToToplevel/PatBindIn1.hs.expected b/test/testdata/LiftToToplevel/PatBindIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/PatBindIn1.hs.expected @@ -0,0 +1,18 @@ +module LiftToToplevel.PatBindIn1 where + +--A definition can be lifted from a where or let into the surrounding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'tup' defined in 'foo' +--This example aims to test renaming and the lifting of type signatures. + +main :: Int +main = foo 3 + +foo :: Int -> Int +foo x = h + t + (snd tup) + +h :: Int +t :: Int +tup :: (Int,Int) +tup@(h,t) = head $ zip [1..10] [3..15] diff --git a/test/testdata/LiftToToplevel/PatBindIn2.hs b/test/testdata/LiftToToplevel/PatBindIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/PatBindIn2.hs @@ -0,0 +1,17 @@ +module PatBindIn2 where + +--A definition can be lifted from a where or let into the surrounding binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'tup' defined in 'foo' will fail. + +main :: Int +main = foo 3 + +foo :: Int -> Int +foo x = h + t + (snd tup) + where + h :: Int + t :: Int + tup :: (Int,Int) + tup@(h,t) = head $ zip [1..x] [3..15] diff --git a/test/testdata/LiftToToplevel/PatBindIn3.hs b/test/testdata/LiftToToplevel/PatBindIn3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/PatBindIn3.hs @@ -0,0 +1,16 @@ +module LiftToToplevel.PatBindIn3 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' defined in 'sumSquares' +--This example aims to test changing a constant to a function. + +sumSquares x = sq + sq + where + sq = x^pow + pow =2 + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/test/testdata/LiftToToplevel/PatBindIn3.hs.expected b/test/testdata/LiftToToplevel/PatBindIn3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/PatBindIn3.hs.expected @@ -0,0 +1,17 @@ +module LiftToToplevel.PatBindIn3 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' defined in 'sumSquares' +--This example aims to test changing a constant to a function. + +sumSquares x = (sq x pow) + (sq x pow) + where + pow =2 + +sq x pow = x^pow + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/test/testdata/LiftToToplevel/Signature.expected.hs b/test/testdata/LiftToToplevel/Signature.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Signature.expected.hs @@ -0,0 +1,16 @@ +module LiftToTopLevel.Signature where + +{- Lifting Baz to the top level should bring in x and a as parameters, + and update the signature to include these +-} +foo a = (baz x a) + where + x = 1 + + y :: Int -> Int -> Int + y a b = undefined + +baz :: Int -> Int -> Int +baz x a = x + a + + diff --git a/test/testdata/LiftToToplevel/Signature.hs b/test/testdata/LiftToToplevel/Signature.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Signature.hs @@ -0,0 +1,16 @@ +module LiftToTopLevel.Signature where + +{- Lifting Baz to the top level should bring in x and a as parameters, + and update the signature to include these +-} +foo a = baz + where + baz :: Int + baz = x + a + + x = 1 + + y :: Int -> Int -> Int + y a b = undefined + + diff --git a/test/testdata/LiftToToplevel/Signature2.hs b/test/testdata/LiftToToplevel/Signature2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Signature2.hs @@ -0,0 +1,22 @@ +module LiftToTopLevel.Signature2 where + +{- Lifting baz to the top level should bring in xx and a as parameters, + and update the signature to include these. + + The refactoring cannot be attempted as the resulting signature + requires Rank2Types + + baz:: (forall t. Num t => t -> t -> t) -> Int ->Int + baz :: Num a => (a -> t1 -> t) -> t1 -> t + baz xx a= xx 1 a + +-} +foo a = baz + where + baz :: Int + baz = xx 1 a + + xx :: (Num t) => t -> t -> t + xx p1 p2 = p1 + p2 + + diff --git a/test/testdata/LiftToToplevel/Signature2r.expected.hs b/test/testdata/LiftToToplevel/Signature2r.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Signature2r.expected.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Rank2Types #-} +module LiftToTopLevel.Signature2 where + +{- Lifting baz to the top level should bring in xx and a as parameters, + and update the signature to include these. + + The refactoring can be completed as the Rank2Types extension is enabled +-} +foo a = (baz xx a) + where + xx :: (Num t) => t -> t -> t + xx p1 p2 = p1 + p2 + + + + +baz:: (forall t. Num t => t -> t -> t) -> Int ->Int +baz xx a= xx 1 a + diff --git a/test/testdata/LiftToToplevel/Signature2r.hs b/test/testdata/LiftToToplevel/Signature2r.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Signature2r.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Rank2Types #-} +module LiftToTopLevel.Signature2 where + +{- Lifting baz to the top level should bring in xx and a as parameters, + and update the signature to include these. + + The refactoring can be completed as the Rank2Types extension is enabled +-} +foo a = baz + where + baz :: Int + baz = xx 1 a + + xx :: (Num t) => t -> t -> t + xx p1 p2 = p1 + p2 + + diff --git a/test/testdata/LiftToToplevel/Signature3.expected.hs b/test/testdata/LiftToToplevel/Signature3.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Signature3.expected.hs @@ -0,0 +1,14 @@ +module LiftToTopLevel.Signature3 where + +{- Lifting baz to the top level should bring in xx and a as parameters, + and update the signature to include these +-} +foo a = (baz xx a) + where + xx :: Int -> Int -> Int + xx p1 p2 = p1 + p2 + +baz :: ( Int -> Int -> Int) -> Int -> Int +baz xx a = xx 1 a + + diff --git a/test/testdata/LiftToToplevel/Signature3.hs b/test/testdata/LiftToToplevel/Signature3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Signature3.hs @@ -0,0 +1,14 @@ +module LiftToTopLevel.Signature3 where + +{- Lifting baz to the top level should bring in xx and a as parameters, + and update the signature to include these +-} +foo a = baz + where + baz :: Int + baz = xx 1 a + + xx :: Int -> Int -> Int + xx p1 p2 = p1 + p2 + + diff --git a/test/testdata/LiftToToplevel/Signature4.hs b/test/testdata/LiftToToplevel/Signature4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Signature4.hs @@ -0,0 +1,14 @@ +module LiftToTopLevel.Signature3 where + +{- Lifting baz to the top level should bring in xx and a as parameters, + and update the signature to include these +-} +foo a = baz + where + baz :: Int + baz = xx 1 a + + xx :: (Integral t,Num t) => t -> t -> Int + xx p1 p2 = fromIntegral $ p1 + p2 + + diff --git a/test/testdata/LiftToToplevel/Where1.hs b/test/testdata/LiftToToplevel/Where1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Where1.hs @@ -0,0 +1,28 @@ +module LiftToToplevel.Where1 where + +import Data.Tree.DUAL.Internal +import Data.Semigroup +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NEL + +unpack = undefined + +foldDUALNE :: (Semigroup d, Monoid d) + => (d -> l -> r) -- ^ Process a leaf datum along with the + -- accumulation of @d@ values along the + -- path from the root + -> r -- ^ Replace @LeafU@ nodes + -> (NonEmpty r -> r) -- ^ Combine results at a branch node + -> (d -> r -> r) -- ^ Process an internal d node + -> (a -> r -> r) -- ^ Process an internal datum + -> DUALTreeNE d u a l -> r +foldDUALNE = foldDUALNE' (Option Nothing) + where + foldDUALNE' dacc lf _ _ _ _ (Leaf _ l) = lf (option mempty id dacc) l + foldDUALNE' _ _ lfU _ _ _ (LeafU _) = lfU + foldDUALNE' dacc lf lfU con down ann (Concat ts) + = con (NEL.map (foldDUALNE' dacc lf lfU con down ann . snd . unpack) ts) + foldDUALNE' dacc lf lfU con down ann (Act d t) + = down d (foldDUALNE' (dacc <> (Option (Just d))) lf lfU con down ann . snd . unpack $ t) + foldDUALNE' dacc lf lfU con down ann (Annot a t) + = ann a (foldDUALNE' dacc lf lfU con down ann . snd . unpack $ t) diff --git a/test/testdata/LiftToToplevel/Where2.hs b/test/testdata/LiftToToplevel/Where2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Where2.hs @@ -0,0 +1,22 @@ +module LiftToToplevel.Where1 where + +import Data.Tree.DUAL.Internal +import Data.Semigroup +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NEL + +unpack = undefined + +foldDUALNE :: (Semigroup d, Monoid d) + => (d -> l -> r) -- ^ Process a leaf datum along with the + -- accumulation of @d@ values along the + -- path from the root + -> r -- ^ Replace @LeafU@ nodes + -> (NonEmpty r -> r) -- ^ Combine results at a branch node + -> (d -> r -> r) -- ^ Process an internal d node + -> (a -> r -> r) -- ^ Process an internal datum + -> DUALTreeNE d u a l -> r +foldDUALNE = foldDUALNE' (Option Nothing) + where + foldDUALNE' dacc lf lfU con down ann (Concat ts) + = con (NEL.map (foldDUALNE' dacc lf lfU con down ann . snd . unpack) ts) diff --git a/test/testdata/LiftToToplevel/Where3.expected.hs b/test/testdata/LiftToToplevel/Where3.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Where3.expected.hs @@ -0,0 +1,9 @@ +module LiftToToplevel.Where3 where + + +foo n = bar [] n + +bar _ 0 = [] +bar acc c + = acc ++ [c] ++ (bar acc (c-1)) + diff --git a/test/testdata/LiftToToplevel/Where3.hs b/test/testdata/LiftToToplevel/Where3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Where3.hs @@ -0,0 +1,8 @@ +module LiftToToplevel.Where3 where + + +foo n = bar [] n + where + bar _ 0 = [] + bar acc c + = acc ++ [c] ++ (bar acc (c-1)) diff --git a/test/testdata/LiftToToplevel/WhereIn1.hs b/test/testdata/LiftToToplevel/WhereIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/WhereIn1.hs @@ -0,0 +1,16 @@ +module LiftToToplevel.WhereIn1 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test add parameters to 'sq'. + +sumSquares x y = sq x + sq y + where + sq 0 = 0 + sq z = z^pow + pow=2 + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftToToplevel/WhereIn1.hs.expected b/test/testdata/LiftToToplevel/WhereIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/WhereIn1.hs.expected @@ -0,0 +1,17 @@ +module LiftToToplevel.WhereIn1 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test add parameters to 'sq'. + +sumSquares x y = (sq pow) x + (sq pow) y + where + pow=2 + +sq pow 0 = 0 +sq pow z = z^pow + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/test/testdata/LiftToToplevel/WhereIn2.hs b/test/testdata/LiftToToplevel/WhereIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/WhereIn2.hs @@ -0,0 +1,18 @@ +module LiftToToplevel.WhereIn2 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'sq' in 'sumSquares' +--This example aims to test renaming. + +sumSquares x y = sq x + sq y + where + sq 0 = 0 + sq z = z^pow --This is a comment + pow=2 + +anotherFun 0 y = sq y + where sq x = x^2 + +sq x =x ^2 diff --git a/test/testdata/LiftToToplevel/WhereIn6.hs b/test/testdata/LiftToToplevel/WhereIn6.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/WhereIn6.hs @@ -0,0 +1,17 @@ +module LiftToToplevel.WhereIn6 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'pow' defined in 'sq' + +sumSquares x y = sq x + sq y + where + sq::Int->Int + sq 0 = 0 + sq z = z^pow + where pow=2 + +anotherFun 0 y = sq y + where sq x=x^2 + diff --git a/test/testdata/LiftToToplevel/WhereIn6.hs.expected b/test/testdata/LiftToToplevel/WhereIn6.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/WhereIn6.hs.expected @@ -0,0 +1,18 @@ +module LiftToToplevel.WhereIn6 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'pow' defined in 'sq' + +sumSquares x y = sq x + sq y + where + sq::Int->Int + sq 0 = 0 + sq z = z^pow + +pow=2 + +anotherFun 0 y = sq y + where sq x=x^2 + diff --git a/test/testdata/LiftToToplevel/WhereIn7.hs b/test/testdata/LiftToToplevel/WhereIn7.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/WhereIn7.hs @@ -0,0 +1,12 @@ +module LiftToToplevel.WhereIn7 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'addthree' defined in 'fun'. +--This example aims to test adding parenthese. + + +fun x y z =inc addthree + where inc a =a +1 + addthree=x+y+z diff --git a/test/testdata/LiftToToplevel/WhereIn7.hs.expected b/test/testdata/LiftToToplevel/WhereIn7.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/WhereIn7.hs.expected @@ -0,0 +1,13 @@ +module LiftToToplevel.WhereIn7 where + +--A definition can be lifted from a where or let to the top level binding group. +--Lifting a definition widens the scope of the definition. + +--In this example, lift 'addthree' defined in 'fun'. +--This example aims to test adding parenthese. + + +fun x y z =inc (addthree x y z) + where inc a =a +1 + +addthree x y z=x+y+z diff --git a/test/testdata/LiftToToplevel/Zmapq.expected.hs b/test/testdata/LiftToToplevel/Zmapq.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Zmapq.expected.hs @@ -0,0 +1,12 @@ +module LiftToTopLevel.Zmapq where + +-- | Apply a generic query to the immediate children. +-- zmapQ :: GenericQ b -> Zipper a -> [b] +zmapQ f z = reverse $ downQ [] (g f) z + +g f z' = query f z' : leftQ [] (g f) z' + + +downQ = undefined +query = undefined +leftQ = undefined diff --git a/test/testdata/LiftToToplevel/Zmapq.hs b/test/testdata/LiftToToplevel/Zmapq.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LiftToToplevel/Zmapq.hs @@ -0,0 +1,11 @@ +module LiftToTopLevel.Zmapq where + +-- | Apply a generic query to the immediate children. +-- zmapQ :: GenericQ b -> Zipper a -> [b] +zmapQ f z = reverse $ downQ [] g z where + g z' = query f z' : leftQ [] g z' + + +downQ = undefined +query = undefined +leftQ = undefined diff --git a/test/testdata/LocToName.hs b/test/testdata/LocToName.hs new file mode 100644 --- /dev/null +++ b/test/testdata/LocToName.hs @@ -0,0 +1,24 @@ +module LocToName where + +{- + + + + + + + + +-} + + + + + + + +sumSquares (x:xs) = x ^2 + sumSquares xs + -- where sq x = x ^pow + -- pow = 2 + +sumSquares [] = 0 diff --git a/test/testdata/M.hs b/test/testdata/M.hs new file mode 100644 --- /dev/null +++ b/test/testdata/M.hs @@ -0,0 +1,9 @@ +module Main where + +import M3 + +main = do + putStrLn $ "m3=" ++ (show m3) + + + diff --git a/test/testdata/M2.hs b/test/testdata/M2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/M2.hs @@ -0,0 +1,7 @@ +module M2 (m2) where + +import S1 + +m2 = s1 - 7 + + diff --git a/test/testdata/M3.hs b/test/testdata/M3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/M3.hs @@ -0,0 +1,8 @@ +module M3 (m3) where + +import M2 + +m3 = m2 + 4 + + + diff --git a/test/testdata/MoveDef/Demote.hs b/test/testdata/MoveDef/Demote.hs new file mode 100644 --- /dev/null +++ b/test/testdata/MoveDef/Demote.hs @@ -0,0 +1,10 @@ +module MoveDef.Demote where + +toplevel :: Integer -> Integer +toplevel x = c * x + +-- c,d :: Integer +c = 7 +d = 9 + + diff --git a/test/testdata/MoveDef/Demote.hs.expected b/test/testdata/MoveDef/Demote.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/MoveDef/Demote.hs.expected @@ -0,0 +1,11 @@ +module MoveDef.Demote where + +toplevel :: Integer -> Integer +toplevel x = c * x + where + -- c,d :: Integer + c = 7 + +d = 9 + + diff --git a/test/testdata/MoveDef/Md1.hs b/test/testdata/MoveDef/Md1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/MoveDef/Md1.hs @@ -0,0 +1,43 @@ +module MoveDef.Md1 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +data D = A | B String | C + +ff :: Int -> Int +ff y = y + zz + where + zz = 1 + +l z = + let + ll = 34 + in ll + z + +dd q = do + let ss = 5 + return (ss + q) + +zz1 a = 1 + toplevel a + +-- General Comment +-- |haddock comment +tlFunc :: Integer -> Integer +tlFunc x = c * x +-- Comment at end + + diff --git a/test/testdata/MoveDef/Md1.hs.expected b/test/testdata/MoveDef/Md1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/MoveDef/Md1.hs.expected @@ -0,0 +1,43 @@ +module MoveDef.Md1 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +data D = A | B String | C + +ff :: Int -> Int +ff y = y + zz + +zz = 1 + +l z = + let + ll = 34 + in ll + z + +dd q = do + let ss = 5 + return (ss + q) + +zz1 a = 1 + toplevel a + +-- General Comment +-- |haddock comment +tlFunc :: Integer -> Integer +tlFunc x = c * x +-- Comment at end + + diff --git a/test/testdata/MoveDef/Md1a.hs b/test/testdata/MoveDef/Md1a.hs new file mode 100644 --- /dev/null +++ b/test/testdata/MoveDef/Md1a.hs @@ -0,0 +1,9 @@ +module MoveDef.Md1a where + +data D = A | B String | C + +ff :: Int -> Int +ff y = y + 1 + +l = 1 + diff --git a/test/testdata/MoveDef/Md1b.hs b/test/testdata/MoveDef/Md1b.hs new file mode 100644 --- /dev/null +++ b/test/testdata/MoveDef/Md1b.hs @@ -0,0 +1,14 @@ +module MoveDef.Md1b where + +data D = A | C + +ff :: Int -> Int +ff y = y + zz + where + zz = 1 + +l z = + let + ll = 34 + in ll + z + diff --git a/test/testdata/MoveDef/Md2.hs b/test/testdata/MoveDef/Md2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/MoveDef/Md2.hs @@ -0,0 +1,45 @@ +module MoveDef.Md2 where + +toplevel :: Integer -> Integer +toplevel x = c * x * b + where + b = 3 + +c,d :: Integer +c = 7 +d = 9 + +-- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +data D = A | B String | C + +ff :: Int -> Int +ff y = y + zz + where + zz = 1 + +l z = + let + ll = 34 + in ll + z + +dd q = do + let ss = 5 + return (ss + q) + +zz1 a = 1 + toplevel a + +-- General Comment +-- |haddock comment +tlFunc :: Integer -> Integer +tlFunc x = c * x +-- Comment at end + + diff --git a/test/testdata/MoveDef/MultiFunBind1.hs b/test/testdata/MoveDef/MultiFunBind1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/MoveDef/MultiFunBind1.hs @@ -0,0 +1,6 @@ +module MoveDef.MultiFunBind1 where + +foo 0 = 0 +foo x = y + 1 + +y = 3 diff --git a/test/testdata/MoveDef/PatBind1.hs b/test/testdata/MoveDef/PatBind1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/MoveDef/PatBind1.hs @@ -0,0 +1,6 @@ +module PatBind1 where + +tup@(h,t) = (x,1) + +x = 2 + diff --git a/test/testdata/NoMod.hs b/test/testdata/NoMod.hs new file mode 100644 --- /dev/null +++ b/test/testdata/NoMod.hs @@ -0,0 +1,18 @@ +-- Test for refactor of if to case + +foo x = if (odd x) then "Odd" else "Even" + +bob x y = x + y + + +foo' x = case (odd x) of + True -> "Odd" + False -> "Even" + +main = do + putStrLn $ show $ foo 5 + +mary = [1,2,3] + +h = bob 1 2 + diff --git a/test/testdata/Offset.hs b/test/testdata/Offset.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Offset.hs @@ -0,0 +1,26 @@ +module Offset where + +-- Test getOffset in various indented cases + +bob a b = x + where x = 3 + +bib a b = x + where + x = 3 + + +bab a b = + let bar = 3 + in b + bar + +foo x y = + do c <- getChar + return c + +fud a b = let bar = 3 + in b + bar + + + + diff --git a/test/testdata/Renaming/A1.hs b/test/testdata/Renaming/A1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/A1.hs @@ -0,0 +1,10 @@ +module Renaming.A1 where + +import Renaming.B1 +import Renaming.C1 +import Renaming.D1 + +main :: Tree Int ->Bool +main t = isSame (sumSquares (fringe t)) + (sumSquares (Renaming.B1.myFringe t)+sumSquares (Renaming.C1.myFringe t)) + diff --git a/test/testdata/Renaming/A1.hs.expected b/test/testdata/Renaming/A1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/A1.hs.expected @@ -0,0 +1,10 @@ +module Renaming.A1 where + +import Renaming.B1 +import Renaming.C1 +import Renaming.D1 + +main :: AnotherTree Int ->Bool +main t = isSame (sumSquares (fringe t)) + (sumSquares (Renaming.B1.myFringe t)+sumSquares (Renaming.C1.myFringe t)) + diff --git a/test/testdata/Renaming/A2.hs b/test/testdata/Renaming/A2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/A2.hs @@ -0,0 +1,10 @@ +module Renaming.A2 where + +import Renaming.B2 +import Renaming.C2 +import Renaming.D2 + +main :: Tree Int ->Bool +main t = isSame (sumSquares (fringe t)) + (sumSquares (Renaming.B2.myFringe t)+sumSquares (Renaming.C2.myFringe t)) + diff --git a/test/testdata/Renaming/A2_TokOut.hs b/test/testdata/Renaming/A2_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/A2_TokOut.hs @@ -0,0 +1,10 @@ +module A2 where + +import B2 +import C2 +import D2 + +main :: Tree Int ->Bool +main t = isSame (sumSquares (fringe t)) + (sumSquares (B2.myFringe t)+sumSquares (C2.myFringe t)) + diff --git a/test/testdata/Renaming/A3.hs b/test/testdata/Renaming/A3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/A3.hs @@ -0,0 +1,10 @@ +module Renaming.A3 where + +import Renaming.B3 +import Renaming.C3 +import Renaming.D3 + +main :: Tree Int ->Bool +main t = isSame (sumSquares (fringe t)) + (sumSquares (Renaming.B3.myFringe t)+sumSquares (Renaming.C3.myFringe t)) + diff --git a/test/testdata/Renaming/A3_TokOut.hs b/test/testdata/Renaming/A3_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/A3_TokOut.hs @@ -0,0 +1,10 @@ +module A3 where + +import B3 +import C3 +import D3 + +main :: Tree Int ->Bool +main t = isSame (sumSquares (fringe t)) + (sumSquares (B3.myFringe t)+sumSquares (C3.myFringe t)) + diff --git a/test/testdata/Renaming/A4.hs b/test/testdata/Renaming/A4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/A4.hs @@ -0,0 +1,10 @@ +module Renaming.A4 where + +import Renaming.B4 +import Renaming.C4 +import Renaming.D4 + +main :: Tree Int ->Bool +main t = isSame (sumSquares (fringe t)) + (sumSquares (Renaming.B4.myFringe t)+sumSquares (Renaming.C4.myFringe t)) + diff --git a/test/testdata/Renaming/A4.hs.expected b/test/testdata/Renaming/A4.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/A4.hs.expected @@ -0,0 +1,10 @@ +module Renaming.A4 where + +import Renaming.B4 +import Renaming.C4 +import Renaming.D4 + +main :: Tree Int ->Bool +main t = isSameOrNot (sumSquares (fringe t)) + (sumSquares (Renaming.B4.myFringe t)+sumSquares (Renaming.C4.myFringe t)) + diff --git a/test/testdata/Renaming/A5.hs b/test/testdata/Renaming/A5.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/A5.hs @@ -0,0 +1,10 @@ +module Renaming.A5 where + +import Renaming.B5 +import Renaming.C5 +import Renaming.D5 + +main :: Tree Int ->Bool +main t = isSame (sumSquares (fringe t)) + (sumSquares (Renaming.B5.myFringe t)+sumSquares (Renaming.C5.myFringe t)) + diff --git a/test/testdata/Renaming/A5.hs.expected b/test/testdata/Renaming/A5.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/A5.hs.expected @@ -0,0 +1,10 @@ +module Renaming.A5 where + +import Renaming.B5 +import Renaming.C5 +import Renaming.D5 + +main :: Tree Int ->Bool +main t = isSame (Renaming.D5.sum (fringe t)) + (Renaming.D5.sum (Renaming.B5.myFringe t)+Renaming.D5.sum (Renaming.C5.myFringe t)) + diff --git a/test/testdata/Renaming/A6.hs b/test/testdata/Renaming/A6.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/A6.hs @@ -0,0 +1,10 @@ +module A6 where + +import B6 +import C6 +import D6 + +main :: Tree Int ->Bool +main t = isSame (sumSquares (D6.myFringe t)) + (sumSquares (B6.myFringe t)+sumSquares (C6.myFringe t)) + diff --git a/test/testdata/Renaming/B1.hs b/test/testdata/Renaming/B1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/B1.hs @@ -0,0 +1,20 @@ +module Renaming.B1 (myFringe) where + +import Renaming.D1 hiding (sumSquares) + +import qualified Renaming.D1 + +instance SameOrNot Float where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe right + +sumSquares (x:xs)= x^2 + sumSquares xs +sumSquares [] =0 + + + + diff --git a/test/testdata/Renaming/B1.hs.expected b/test/testdata/Renaming/B1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/B1.hs.expected @@ -0,0 +1,20 @@ +module Renaming.B1 (myFringe) where + +import Renaming.D1 hiding (sumSquares) + +import qualified Renaming.D1 + +instance SameOrNot Float where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: AnotherTree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe right + +sumSquares (x:xs)= x^2 + sumSquares xs +sumSquares [] =0 + + + + diff --git a/test/testdata/Renaming/B2.hs b/test/testdata/Renaming/B2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/B2.hs @@ -0,0 +1,20 @@ +module Renaming.B2 (myFringe)where + +import Renaming.D2 hiding (sumSquares) + +import qualified Renaming.D2 + +instance SameOrNot Float where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe right + +sumSquares (x:xs)= x^2 + sumSquares xs +sumSquares [] =0 + + + + diff --git a/test/testdata/Renaming/B2.hs.expected b/test/testdata/Renaming/B2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/B2.hs.expected @@ -0,0 +1,20 @@ +module Renaming.B2 (myFringe)where + +import Renaming.D2 hiding (sumSquares) + +import qualified Renaming.D2 + +instance SameOrNot Float where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (SubTree left right) = myFringe right + +sumSquares (x:xs)= x^2 + sumSquares xs +sumSquares [] =0 + + + + diff --git a/test/testdata/Renaming/B3.hs b/test/testdata/Renaming/B3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/B3.hs @@ -0,0 +1,20 @@ +module Renaming.B3 (myFringe)where + +import Renaming.D3 hiding (sumSquares) + +import qualified Renaming.D3 + +instance SameOrNot Float where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe right + +sumSquares (x:xs)= x^2 + sumSquares xs +sumSquares [] =0 + + + + diff --git a/test/testdata/Renaming/B3.hs.expected b/test/testdata/Renaming/B3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/B3.hs.expected @@ -0,0 +1,20 @@ +module Renaming.B3 (myFringe)where + +import Renaming.D3 hiding (sumSquares) + +import qualified Renaming.D3 + +instance Same Float where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe right + +sumSquares (x:xs)= x^2 + sumSquares xs +sumSquares [] =0 + + + + diff --git a/test/testdata/Renaming/B4.hs b/test/testdata/Renaming/B4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/B4.hs @@ -0,0 +1,20 @@ +module Renaming.B4 (myFringe)where + +import Renaming.D4 hiding (sumSquares) + +import qualified Renaming.D4 + +instance SameOrNot Float where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe right + +sumSquares (x:xs)= x^2 + sumSquares xs +sumSquares [] =0 + + + + diff --git a/test/testdata/Renaming/B4.hs.expected b/test/testdata/Renaming/B4.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/B4.hs.expected @@ -0,0 +1,20 @@ +module Renaming.B4 (myFringe)where + +import Renaming.D4 hiding (sumSquares) + +import qualified Renaming.D4 + +instance SameOrNot Float where + isSameOrNot a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe right + +sumSquares (x:xs)= x^2 + sumSquares xs +sumSquares [] =0 + + + + diff --git a/test/testdata/Renaming/B5.hs b/test/testdata/Renaming/B5.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/B5.hs @@ -0,0 +1,20 @@ +module Renaming.B5 (myFringe)where + +import Renaming.D5 hiding (sumSquares) + +import qualified Renaming.D5 + +instance SameOrNot Float where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe right + +sumSquares (x:xs)= x^2 + sumSquares xs +sumSquares [] =0 + + + + diff --git a/test/testdata/Renaming/B5.hs.expected b/test/testdata/Renaming/B5.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/B5.hs.expected @@ -0,0 +1,20 @@ +module Renaming.B5 (myFringe)where + +import Renaming.D5 hiding (sum) + +import qualified Renaming.D5 + +instance SameOrNot Float where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe right + +sumSquares (x:xs)= x^2 + sumSquares xs +sumSquares [] =0 + + + + diff --git a/test/testdata/Renaming/C1.hs b/test/testdata/Renaming/C1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C1.hs @@ -0,0 +1,15 @@ +module Renaming.C1 where + +import Renaming.D1 + +instance SameOrNot Double where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe left + + + + diff --git a/test/testdata/Renaming/C1.hs.expected b/test/testdata/Renaming/C1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C1.hs.expected @@ -0,0 +1,15 @@ +module Renaming.C1 where + +import Renaming.D1 + +instance SameOrNot Double where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: AnotherTree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe left + + + + diff --git a/test/testdata/Renaming/C2.hs b/test/testdata/Renaming/C2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C2.hs @@ -0,0 +1,15 @@ +module Renaming.C2 where + +import Renaming.D2 + +instance SameOrNot Double where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe left + + + + diff --git a/test/testdata/Renaming/C2.hs.expected b/test/testdata/Renaming/C2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C2.hs.expected @@ -0,0 +1,15 @@ +module Renaming.C2 where + +import Renaming.D2 + +instance SameOrNot Double where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (SubTree left right) = myFringe left + + + + diff --git a/test/testdata/Renaming/C3.hs b/test/testdata/Renaming/C3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C3.hs @@ -0,0 +1,15 @@ +module Renaming.C3 where + +import Renaming.D3 + +instance SameOrNot Double where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe left + + + + diff --git a/test/testdata/Renaming/C3.hs.expected b/test/testdata/Renaming/C3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C3.hs.expected @@ -0,0 +1,15 @@ +module Renaming.C3 where + +import Renaming.D3 + +instance Same Double where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe left + + + + diff --git a/test/testdata/Renaming/C4.hs b/test/testdata/Renaming/C4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C4.hs @@ -0,0 +1,15 @@ +module Renaming.C4 where + +import Renaming.D4 + +instance SameOrNot Double where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe left + + + + diff --git a/test/testdata/Renaming/C4.hs.expected b/test/testdata/Renaming/C4.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C4.hs.expected @@ -0,0 +1,15 @@ +module Renaming.C4 where + +import Renaming.D4 + +instance SameOrNot Double where + isSameOrNot a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe left + + + + diff --git a/test/testdata/Renaming/C5.hs b/test/testdata/Renaming/C5.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C5.hs @@ -0,0 +1,17 @@ +module Renaming.C5 where + +import Renaming.D5 + +instance SameOrNot Double where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe left + +mySumSq = sumSquares + + + + diff --git a/test/testdata/Renaming/C5.hs.expected b/test/testdata/Renaming/C5.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C5.hs.expected @@ -0,0 +1,17 @@ +module Renaming.C5 where + +import Renaming.D5 + +instance SameOrNot Double where + isSame a b = a ==b + isNotSame a b = a /=b + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe left + +mySumSq = Renaming.D5.sum + + + + diff --git a/test/testdata/Renaming/C7.hs b/test/testdata/Renaming/C7.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C7.hs @@ -0,0 +1,11 @@ +module Renaming.C7(myFringe) where + +import Renaming.D7 + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe left ++ fringe right + + + + diff --git a/test/testdata/Renaming/C7.hs.expected b/test/testdata/Renaming/C7.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/C7.hs.expected @@ -0,0 +1,11 @@ +module Renaming.C7(Renaming.C7.myFringe) where + +import Renaming.D7 + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = Renaming.C7.myFringe left ++ Renaming.D7.myFringe right + + + + diff --git a/test/testdata/Renaming/ClassIn1.hs b/test/testdata/Renaming/ClassIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ClassIn1.hs @@ -0,0 +1,22 @@ +module ClassIn1 where + +--Any class/instance name declared in this module can be renamed + +--Rename class name "Reversable" to "MyReversable" + +class Reversable a where + myreverse :: a -> a + myreverse _ = undefined + +instance Reversable [a] where + myreverse = reverse + +data Foo = Boo | Moo + +instance Eq Foo where + Boo == Boo = True + Moo == Moo = True + _ == _ = False + +main = myreverse [1,2,3] + diff --git a/test/testdata/Renaming/ClassIn1.hs.expected b/test/testdata/Renaming/ClassIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ClassIn1.hs.expected @@ -0,0 +1,22 @@ +module ClassIn1 where + +--Any class/instance name declared in this module can be renamed + +--Rename class name "Reversable" to "MyReversable" + +class MyReversable a where + myreverse :: a -> a + myreverse _ = undefined + +instance MyReversable [a] where + myreverse = reverse + +data Foo = Boo | Moo + +instance Eq Foo where + Boo == Boo = True + Moo == Moo = True + _ == _ = False + +main = myreverse [1,2,3] + diff --git a/test/testdata/Renaming/ClassIn2.hs b/test/testdata/Renaming/ClassIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ClassIn2.hs @@ -0,0 +1,22 @@ +module ClassIn2 where + +--Any class/instance name declared in this module can be renamed + +--Rename instance name 'myreverse' to 'reversable' + +class Reversable a where + myreverse :: a -> a + myreverse _ = undefined + +instance Reversable [a] where + myreverse = reverse + +data Foo = Boo | Moo + +instance Eq Foo where + Boo == Boo = True + Moo == Moo = True + _ == _ = False + +main = myreverse [1,2,3] + diff --git a/test/testdata/Renaming/ClassIn2.hs.expected b/test/testdata/Renaming/ClassIn2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ClassIn2.hs.expected @@ -0,0 +1,22 @@ +module ClassIn2 where + +--Any class/instance name declared in this module can be renamed + +--Rename instance name 'myreverse' to 'reversable' + +class Reversable a where + reversable :: a -> a + reversable _ = undefined + +instance Reversable [a] where + reversable = reverse + +data Foo = Boo | Moo + +instance Eq Foo where + Boo == Boo = True + Moo == Moo = True + _ == _ = False + +main = reversable [1,2,3] + diff --git a/test/testdata/Renaming/ClassIn3.hs b/test/testdata/Renaming/ClassIn3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ClassIn3.hs @@ -0,0 +1,22 @@ +module ClassIn3 where + +--Any class/instance name declared in this module can be renamed + +--Rename class name "Eq" will fail + +class Reversable a where + myreverse :: a -> a + myreverse _ = undefined + +instance Reversable [a] where + myreverse = reverse + +data Foo = Boo | Moo + +instance Eq Foo where + Boo == Boo = True + Moo == Moo = True + _ == _ = False + +main = myreverse [1,2,3] + diff --git a/test/testdata/Renaming/ClassIn3_TokOut.hs b/test/testdata/Renaming/ClassIn3_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ClassIn3_TokOut.hs @@ -0,0 +1,22 @@ +module ClassIn3 where + +--Any class/instance name declared in this module can be renamed + +--Rename class name "Eq" will fail + +class Reversable a where + myreverse :: a -> a + myreverse _ = undefined + +instance Reversable [a] where + myreverse = reverse + +data Foo = Boo | Moo + +instance Eq Foo where + Boo == Boo = True + Moo == Moo = True + _ == _ = False + +main = myreverse [1,2,3] + diff --git a/test/testdata/Renaming/ConflictExport.hs b/test/testdata/Renaming/ConflictExport.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ConflictExport.hs @@ -0,0 +1,15 @@ +module Renaming.ConflictExport (Renaming.D6.fringe, myFringe) where + +{-Rename 'myFringe' to 'fringe' will fail because of + conflicting exports. -} +import Renaming.D6 + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe right + + + + + + diff --git a/test/testdata/Renaming/ConflictExport_TokOut.hs b/test/testdata/Renaming/ConflictExport_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ConflictExport_TokOut.hs @@ -0,0 +1,15 @@ +module ConflictExport (D6.fringe, myFringe) where + +{-Rename 'myFringe' to 'fringe' will fail because of + conflicting exports. -} +import D6 + +myFringe:: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe right + + + + + + diff --git a/test/testdata/Renaming/Constructor3.hs b/test/testdata/Renaming/Constructor3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Constructor3.hs @@ -0,0 +1,23 @@ +module ConstructorIn3 where + + +--Any type/data constructor name declared in this module can be renamed. +--Any type variable can be renamed. + +--Rename tyoe variable 'a' in BTree to 'b' + +data BTree a = Empty | T a (BTree a) (BTree a) + deriving Show + +buildtree :: Ord a => [a] -> BTree a +buildtree [] = Empty +buildtree (x:xs) = insert x (buildtree xs) + +insert :: Ord a => a -> BTree a -> BTree a +insert val Empty = T val Empty Empty +insert val tree@(T tval left right) + | val > tval = T tval left (insert val right) + | otherwise = T tval (insert val left) right + +main :: BTree Int +main = buildtree [3,1,2] diff --git a/test/testdata/Renaming/Constructor3_TokOut.hs b/test/testdata/Renaming/Constructor3_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Constructor3_TokOut.hs @@ -0,0 +1,23 @@ +module ConstructorIn3 where + + +--Any type/data constructor name declared in this module can be renamed. +--Any type variable can be renamed. + +--Rename tyoe variable 'a' in BTree to 'b' + +data BTree b = Empty | T b (BTree b) (BTree b) + deriving Show + +buildtree :: Ord a => [a] -> BTree a +buildtree [] = Empty +buildtree (x:xs) = insert x (buildtree xs) + +insert :: Ord a => a -> BTree a -> BTree a +insert val Empty = T val Empty Empty +insert val tree@(T tval left right) + | val > tval = T tval left (insert val right) + | otherwise = T tval (insert val left) right + +main :: BTree Int +main = buildtree [3,1,2] diff --git a/test/testdata/Renaming/ConstructorIn1.hs b/test/testdata/Renaming/ConstructorIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ConstructorIn1.hs @@ -0,0 +1,22 @@ +module ConstructorIn1 where + + +--Any type/data constructor name declared in this module can be renamed. +--Any type variable can be renamed. + +--Rename type Constructor 'BTree' to 'MyBTree' +data BTree a = Empty | T a (BTree a) (BTree a) + deriving Show + +buildtree :: Ord a => [a] -> BTree a +buildtree [] = Empty +buildtree (x:xs) = insert x (buildtree xs) + +insert :: Ord a => a -> BTree a -> BTree a +insert val Empty = T val Empty Empty +insert val tree@(T tval left right) + | val > tval = T tval left (insert val right) + | otherwise = T tval (insert val left) right + +main :: BTree Int +main = buildtree [3,1,2] diff --git a/test/testdata/Renaming/ConstructorIn1.hs.expected b/test/testdata/Renaming/ConstructorIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ConstructorIn1.hs.expected @@ -0,0 +1,22 @@ +module ConstructorIn1 where + + +--Any type/data constructor name declared in this module can be renamed. +--Any type variable can be renamed. + +--Rename type Constructor 'BTree' to 'MyBTree' +data MyBTree a = Empty | T a (MyBTree a) (MyBTree a) + deriving Show + +buildtree :: Ord a => [a] -> MyBTree a +buildtree [] = Empty +buildtree (x:xs) = insert x (buildtree xs) + +insert :: Ord a => a -> MyBTree a -> MyBTree a +insert val Empty = T val Empty Empty +insert val tree@(T tval left right) + | val > tval = T tval left (insert val right) + | otherwise = T tval (insert val left) right + +main :: MyBTree Int +main = buildtree [3,1,2] diff --git a/test/testdata/Renaming/ConstructorIn2.hs b/test/testdata/Renaming/ConstructorIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ConstructorIn2.hs @@ -0,0 +1,22 @@ +module ConstructorIn2 where + + +--Any type/data constructor name declared in this module can be renamed. +--Any type variable can be renamed. + +--Rename data Constructor 'T' to 'Tree' +data BTree a = Empty | T a (BTree a) (BTree a) + deriving Show + +buildtree :: Ord a => [a] -> BTree a +buildtree [] = Empty +buildtree (x:xs) = insert x (buildtree xs) + +insert :: Ord a => a -> BTree a -> BTree a +insert val Empty = T val Empty Empty +insert val tree@(T tval left right) + | val > tval = T tval left (insert val right) + | otherwise = T tval (insert val left) right + +main :: BTree Int +main = buildtree [3,1,2] diff --git a/test/testdata/Renaming/ConstructorIn2.hs.expected b/test/testdata/Renaming/ConstructorIn2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ConstructorIn2.hs.expected @@ -0,0 +1,22 @@ +module ConstructorIn2 where + + +--Any type/data constructor name declared in this module can be renamed. +--Any type variable can be renamed. + +--Rename data Constructor 'T' to 'Tree' +data BTree a = Empty | Tree a (BTree a) (BTree a) + deriving Show + +buildtree :: Ord a => [a] -> BTree a +buildtree [] = Empty +buildtree (x:xs) = insert x (buildtree xs) + +insert :: Ord a => a -> BTree a -> BTree a +insert val Empty = Tree val Empty Empty +insert val tree@(Tree tval left right) + | val > tval = Tree tval left (insert val right) + | otherwise = Tree tval (insert val left) right + +main :: BTree Int +main = buildtree [3,1,2] diff --git a/test/testdata/Renaming/ConstructorIn3.hs b/test/testdata/Renaming/ConstructorIn3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ConstructorIn3.hs @@ -0,0 +1,23 @@ +module ConstructorIn3 where + + +--Any type/data constructor name declared in this module can be renamed. +--Any type variable can be renamed. + +--Rename tyoe variable 'a' in BTree to 'b' + +data BTree a = Empty | T a (BTree a) (BTree a) + deriving Show + +buildtree :: Ord a => [a] -> BTree a +buildtree [] = Empty +buildtree (x:xs) = insert x (buildtree xs) + +insert :: Ord a => a -> BTree a -> BTree a +insert val Empty = T val Empty Empty +insert val tree@(T tval left right) + | val > tval = T tval left (insert val right) + | otherwise = T tval (insert val left) right + +main :: BTree Int +main = buildtree [3,1,2] diff --git a/test/testdata/Renaming/ConstructorIn3.hs.expected b/test/testdata/Renaming/ConstructorIn3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/ConstructorIn3.hs.expected @@ -0,0 +1,23 @@ +module ConstructorIn3 where + + +--Any type/data constructor name declared in this module can be renamed. +--Any type variable can be renamed. + +--Rename tyoe variable 'a' in BTree to 'b' + +data BTree b = Empty | T b (BTree b) (BTree b) + deriving Show + +buildtree :: Ord a => [a] -> BTree a +buildtree [] = Empty +buildtree (x:xs) = insert x (buildtree xs) + +insert :: Ord a => a -> BTree a -> BTree a +insert val Empty = T val Empty Empty +insert val tree@(T tval left right) + | val > tval = T tval left (insert val right) + | otherwise = T tval (insert val left) right + +main :: BTree Int +main = buildtree [3,1,2] diff --git a/test/testdata/Renaming/D1.hs b/test/testdata/Renaming/D1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D1.hs @@ -0,0 +1,24 @@ +module Renaming.D1 where + +{-Rename data constructor `Tree` to `AnotherTree`. + This refactoring affects module `D1', 'B1' and 'C1' -} + +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +class SameOrNot a where + isSame :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance SameOrNot Int where + isSame a b = a == b + isNotSame a b = a /= b + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 diff --git a/test/testdata/Renaming/D1.hs.expected b/test/testdata/Renaming/D1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D1.hs.expected @@ -0,0 +1,24 @@ +module Renaming.D1 where + +{-Rename data constructor `Tree` to `AnotherTree`. + This refactoring affects module `D1', 'B1' and 'C1' -} + +data AnotherTree a = Leaf a | Branch (AnotherTree a) (AnotherTree a) + +fringe :: AnotherTree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +class SameOrNot a where + isSame :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance SameOrNot Int where + isSame a b = a == b + isNotSame a b = a /= b + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 diff --git a/test/testdata/Renaming/D2.hs b/test/testdata/Renaming/D2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D2.hs @@ -0,0 +1,24 @@ +module Renaming.D2 where + +{-Rename type constructor `Branch` to `SubTree`. + This refactoring affects module `D2', 'B2' and 'C2' -} + +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +class SameOrNot a where + isSame :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance SameOrNot Int where + isSame a b = a == b + isNotSame a b = a /= b + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 diff --git a/test/testdata/Renaming/D2.hs.expected b/test/testdata/Renaming/D2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D2.hs.expected @@ -0,0 +1,24 @@ +module Renaming.D2 where + +{-Rename type constructor `Branch` to `SubTree`. + This refactoring affects module `D2', 'B2' and 'C2' -} + +data Tree a = Leaf a | SubTree (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (SubTree left right) = fringe left ++ fringe right + +class SameOrNot a where + isSame :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance SameOrNot Int where + isSame a b = a == b + isNotSame a b = a /= b + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 diff --git a/test/testdata/Renaming/D3.hs b/test/testdata/Renaming/D3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D3.hs @@ -0,0 +1,24 @@ +module Renaming.D3 where + +{-Rename class name 'SameOrNot' to 'Same'. + This refactoring affects module `D3', 'B3' and 'C3' -} + +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +class SameOrNot a where + isSame :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance SameOrNot Int where + isSame a b = a == b + isNotSame a b = a /= b + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 diff --git a/test/testdata/Renaming/D3.hs.expected b/test/testdata/Renaming/D3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D3.hs.expected @@ -0,0 +1,24 @@ +module Renaming.D3 where + +{-Rename class name 'SameOrNot' to 'Same'. + This refactoring affects module `D3', 'B3' and 'C3' -} + +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +class Same a where + isSame :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance Same Int where + isSame a b = a == b + isNotSame a b = a /= b + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 diff --git a/test/testdata/Renaming/D4.hs b/test/testdata/Renaming/D4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D4.hs @@ -0,0 +1,24 @@ +module Renaming.D4 where + +{-Rename instance name 'isSame'' to 'sameOrNot'. + This refactoring affects module `D4', 'B4' and 'C4' -} + +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +class SameOrNot a where + isSame :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance SameOrNot Int where + isSame a b = a == b + isNotSame a b = a /= b + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 diff --git a/test/testdata/Renaming/D4.hs.expected b/test/testdata/Renaming/D4.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D4.hs.expected @@ -0,0 +1,24 @@ +module Renaming.D4 where + +{-Rename instance name 'isSame'' to 'sameOrNot'. + This refactoring affects module `D4', 'B4' and 'C4' -} + +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +class SameOrNot a where + isSameOrNot :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance SameOrNot Int where + isSameOrNot a b = a == b + isNotSame a b = a /= b + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 diff --git a/test/testdata/Renaming/D5.hs b/test/testdata/Renaming/D5.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D5.hs @@ -0,0 +1,24 @@ +module Renaming.D5 where + +{-Rename top level identifier 'sumSquares' to 'sum'. + This refactoring affects module `D5', 'B5' , 'C5' and 'A5' -} + +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +class SameOrNot a where + isSame :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance SameOrNot Int where + isSame a b = a == b + isNotSame a b = a /= b + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 diff --git a/test/testdata/Renaming/D5.hs.expected b/test/testdata/Renaming/D5.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D5.hs.expected @@ -0,0 +1,24 @@ +module Renaming.D5 where + +{-Rename top level identifier 'sumSquares' to 'sum'. + This refactoring affects module `D5', 'B5' , 'C5' and 'A5' -} + +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +class SameOrNot a where + isSame :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance SameOrNot Int where + isSame a b = a == b + isNotSame a b = a /= b + +sum (x:xs) = sq x + Renaming.D5.sum xs + where sq x = x ^pow + pow = 2 + +sum [] = 0 diff --git a/test/testdata/Renaming/D6.hs b/test/testdata/Renaming/D6.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D6.hs @@ -0,0 +1,16 @@ +module Renaming.D6 where + +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +class SameOrNot a where + isSame :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance SameOrNot Int where + isSame a b = a == b + isNotSame a b = a /= b + diff --git a/test/testdata/Renaming/D6_TokOut.hs b/test/testdata/Renaming/D6_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D6_TokOut.hs @@ -0,0 +1,16 @@ +module D6 where + +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right + +class SameOrNot a where + isSame :: a -> a -> Bool + isNotSame :: a -> a -> Bool + +instance SameOrNot Int where + isSame a b = a == b + isNotSame a b = a /= b + diff --git a/test/testdata/Renaming/D7.hs b/test/testdata/Renaming/D7.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D7.hs @@ -0,0 +1,10 @@ +module Renaming.D7 where + +{- Rename 'fringe' to 'myFringe'. + This affects module 'D7' and 'C7' +-} +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +fringe :: Tree a -> [a] +fringe (Leaf x ) = [x] +fringe (Branch left right) = fringe left ++ fringe right diff --git a/test/testdata/Renaming/D7.hs.expected b/test/testdata/Renaming/D7.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/D7.hs.expected @@ -0,0 +1,10 @@ +module Renaming.D7 where + +{- Rename 'fringe' to 'myFringe'. + This affects module 'D7' and 'C7' +-} +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +myFringe :: Tree a -> [a] +myFringe (Leaf x ) = [x] +myFringe (Branch left right) = myFringe left ++ myFringe right diff --git a/test/testdata/Renaming/Field1.hs b/test/testdata/Renaming/Field1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Field1.hs @@ -0,0 +1,10 @@ +module Field1 where + +--Rename field name 'pointx' to 'pointx1' + +data Point = Pt {pointx, pointy :: Float} + +absPoint :: Point -> Float +absPoint p = sqrt (pointx p * pointx p + + pointy p * pointy p) + diff --git a/test/testdata/Renaming/Field1.hs.expected b/test/testdata/Renaming/Field1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Field1.hs.expected @@ -0,0 +1,10 @@ +module Field1 where + +--Rename field name 'pointx' to 'pointx1' + +data Point = Pt {pointx1, pointy :: Float} + +absPoint :: Point -> Float +absPoint p = sqrt (pointx1 p * pointx1 p + + pointy p * pointy p) + diff --git a/test/testdata/Renaming/Field1_TokOut.hs b/test/testdata/Renaming/Field1_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Field1_TokOut.hs @@ -0,0 +1,10 @@ +module Field1 where + +--Rename field name 'pointx' to 'pointx1' + +data Point = Pt {pointx1, pointy :: Float} + +absPoint :: Point -> Float +absPoint p = sqrt (pointx1 p * pointx1 p + + pointy p * pointy p) + diff --git a/test/testdata/Renaming/Field2.hs b/test/testdata/Renaming/Field2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Field2.hs @@ -0,0 +1,10 @@ +module Field2 where + +--Rename field name 'pointx' to 'absPoint' should fail because of name clash. + +data Point = Pt {pointx, pointy :: Float} + +absPoint :: Point -> Float +absPoint p = sqrt (pointx p * pointx p + + pointy p * pointy p) + diff --git a/test/testdata/Renaming/Field2_TokOut.hs b/test/testdata/Renaming/Field2_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Field2_TokOut.hs @@ -0,0 +1,10 @@ +module Field2 where + +--Rename field name 'pointx' to 'absPoint' should fail because of name clash. + +data Point = Pt {pointx, pointy :: Float} + +absPoint :: Point -> Float +absPoint p = sqrt (pointx p * pointx p + + pointy p * pointy p) + diff --git a/test/testdata/Renaming/Field3.hs b/test/testdata/Renaming/Field3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Field3.hs @@ -0,0 +1,13 @@ +module Field3 where + +{-Rename 'absPoint' to 'abs'. The use of 'abs' in + the 'main' function should become qualified. -} + + +data Point = Pt {pointx, pointy :: Float} + +absPoint :: Point -> Float +absPoint p = sqrt (pointx p * pointx p + + pointy p * pointy p) + +main = absPoint (Pt 1 2) diff --git a/test/testdata/Renaming/Field3.hs.expected b/test/testdata/Renaming/Field3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Field3.hs.expected @@ -0,0 +1,13 @@ +module Field3 where + +{-Rename 'absPoint' to 'abs'. The use of 'abs' in + the 'main' function should become qualified. -} + + +data Point = Pt {pointx, pointy :: Float} + +abs :: Point -> Float +abs p = sqrt (pointx p * pointx p + + pointy p * pointy p) + +main = Field3.abs (Pt 1 2) diff --git a/test/testdata/Renaming/Field4.hs b/test/testdata/Renaming/Field4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Field4.hs @@ -0,0 +1,11 @@ +module Field4 where + +--Rename field name 'value1' to 'value2' should success. + +data Vtree a = Vleaf {value1::a} | + Vnode {value2::a, left,right ::Vtree a} + +fringe :: Vtree a -> [a] +fringe t@(Vleaf _ ) = [value1 t] +fringe t@(Vnode _ _ _) =fringe (left t) ++ fringe (right t) + diff --git a/test/testdata/Renaming/Field4.hs.expected b/test/testdata/Renaming/Field4.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Field4.hs.expected @@ -0,0 +1,11 @@ +module Field4 where + +--Rename field name 'value1' to 'value2' should success. + +data Vtree a = Vleaf {value2::a} | + Vnode {value2::a, left,right ::Vtree a} + +fringe :: Vtree a -> [a] +fringe t@(Vleaf _ ) = [value2 t] +fringe t@(Vnode _ _ _) =fringe (left t) ++ fringe (right t) + diff --git a/test/testdata/Renaming/IdIn1.hs b/test/testdata/Renaming/IdIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/IdIn1.hs @@ -0,0 +1,19 @@ +module IdIn1 where + +{-To rename an identifier name, stop the cursor at any occurrence of the name, + then input the new name in the mini-buffer, after that, select the 'rename' + command from the 'Refactor' menu.-} + +--Any value variable name declared in this module can be renamed. + +--Rename top level 'x' to 'x1' + +x=5 + +foo=x+3 + +bar z=x+y+z + where x=7 + y=3 + +main=(foo,bar x, foo) diff --git a/test/testdata/Renaming/IdIn1.hs.expected b/test/testdata/Renaming/IdIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/IdIn1.hs.expected @@ -0,0 +1,19 @@ +module IdIn1 where + +{-To rename an identifier name, stop the cursor at any occurrence of the name, + then input the new name in the mini-buffer, after that, select the 'rename' + command from the 'Refactor' menu.-} + +--Any value variable name declared in this module can be renamed. + +--Rename top level 'x' to 'x1' + +x1=5 + +foo=x1+3 + +bar z=x+y+z + where x=7 + y=3 + +main=(foo,bar x1, foo) diff --git a/test/testdata/Renaming/IdIn2.hs b/test/testdata/Renaming/IdIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/IdIn2.hs @@ -0,0 +1,19 @@ +module IdIn2 where + +{-To rename an identifier name, stop the cursor at any occurrence of the name, + then input the new name in the mini-buffer, after that, select the 'rename' + command from the 'Refactor' menu.-} + +--Any value variable name declared in this module can be renamed. + +--Rename local 'x' to 'x1' + +x=5 + +foo=x+3 + +bar z=x+y+z + where x=7 + y=3 + +main=(foo,bar x, foo) diff --git a/test/testdata/Renaming/IdIn2.hs.expected b/test/testdata/Renaming/IdIn2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/IdIn2.hs.expected @@ -0,0 +1,19 @@ +module IdIn2 where + +{-To rename an identifier name, stop the cursor at any occurrence of the name, + then input the new name in the mini-buffer, after that, select the 'rename' + command from the 'Refactor' menu.-} + +--Any value variable name declared in this module can be renamed. + +--Rename local 'x' to 'x1' + +x=5 + +foo=x+3 + +bar z=x1+y+z + where x1=7 + y=3 + +main=(foo,bar x, foo) diff --git a/test/testdata/Renaming/IdIn3.hs b/test/testdata/Renaming/IdIn3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/IdIn3.hs @@ -0,0 +1,18 @@ +module IdIn3 where + +{-To rename an identifier name, stop the cursor at any occurrence of the name, + then input the new name in the mini-buffer, after that, select the 'rename' + command from the 'Refactor' menu.-} + +--Any value variable name declared in this module can be renamed. + +--Reanme 'x' to 'foo' will fail. +x=5 + +foo=x+3 + +bar z=x+y+z + where x=7 + y=3 + +main=(foo,bar x, foo) diff --git a/test/testdata/Renaming/IdIn3_TokOut.hs b/test/testdata/Renaming/IdIn3_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/IdIn3_TokOut.hs @@ -0,0 +1,18 @@ +module IdIn3 where + +{-To rename an identifier name, stop the cursor at any occurrence of the name, + then input the new name in the mini-buffer, after that, select the 'rename' + command from the 'Refactor' menu.-} + +--Any value variable name declared in this module can be renamed. + +--Reanme 'x' to 'foo' will fail. +x=5 + +foo=x+3 + +bar z=x+y+z + where x=7 + y=3 + +main=(foo,bar x, foo) diff --git a/test/testdata/Renaming/IdIn4.hs b/test/testdata/Renaming/IdIn4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/IdIn4.hs @@ -0,0 +1,18 @@ +module IdIn4 where + +{-To rename an identifier name, stop the cursor at any occurrence of the name, + then input the new name in the mini-buffer, after that, select the 'rename' + command from the 'Refactor' menu.-} + +--Any value variable name declared in this module can be renamed. + +--Rename 'foo' to 'Foo' will fail. +x=5 + +foo=x+3 + +bar z=x+y+z + where x=7 + y=3 + +main=(foo,bar x, foo) diff --git a/test/testdata/Renaming/IdIn4_TokOut.hs b/test/testdata/Renaming/IdIn4_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/IdIn4_TokOut.hs @@ -0,0 +1,18 @@ +module IdIn4 where + +{-To rename an identifier name, stop the cursor at any occurrence of the name, + then input the new name in the mini-buffer, after that, select the 'rename' + command from the 'Refactor' menu.-} + +--Any value variable name declared in this module can be renamed. + +--Rename 'foo' to 'Foo' will fail. +x=5 + +foo=x+3 + +bar z=x+y+z + where x=7 + y=3 + +main=(foo,bar x, foo) diff --git a/test/testdata/Renaming/IdIn5.hs b/test/testdata/Renaming/IdIn5.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/IdIn5.hs @@ -0,0 +1,17 @@ +module IdIn5 where + +{-To rename an identifier name, stop the cursor at any occurrence of the name, + then input the new name in the mini-buffer, after that, select the 'rename' + command from the 'Refactor' menu.-} + +--Any value variable name declared in this module can be renamed. + +--Rename top level 'x' to 'y' will fail. +x=5 + +foo=x+3 + +bar z=x+y+z + where y=3 + +main=(foo,bar x, foo) diff --git a/test/testdata/Renaming/IdIn5_TokOut.hs b/test/testdata/Renaming/IdIn5_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/IdIn5_TokOut.hs @@ -0,0 +1,17 @@ +module IdIn5 where + +{-To rename an identifier name, stop the cursor at any occurrence of the name, + then input the new name in the mini-buffer, after that, select the 'rename' + command from the 'Refactor' menu.-} + +--Any value variable name declared in this module can be renamed. + +--Rename top level 'x' to 'y' will fail. +x=5 + +foo=x+3 + +bar z=x+y+z + where y=3 + +main=(foo,bar x, foo) diff --git a/test/testdata/Renaming/LayoutIn1.hs b/test/testdata/Renaming/LayoutIn1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/LayoutIn1.hs @@ -0,0 +1,9 @@ +module LayoutIn1 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'sq' to 'square'. + +sumSquares x y= sq x + sq y where sq x= x^pow + --There is a comment. + pow=2 diff --git a/test/testdata/Renaming/LayoutIn1.hs.expected b/test/testdata/Renaming/LayoutIn1.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/LayoutIn1.hs.expected @@ -0,0 +1,9 @@ +module LayoutIn1 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'sq' to 'square'. + +sumSquares x y= square x + square y where square x= x^pow + --There is a comment. + pow=2 diff --git a/test/testdata/Renaming/LayoutIn2.hs b/test/testdata/Renaming/LayoutIn2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/LayoutIn2.hs @@ -0,0 +1,13 @@ +module LayoutIn2 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'list' to 'ls'. + +silly :: [Int] -> Int +silly list = case list of (1:xs) -> 1 +--There is a comment + (2:xs) + | x < 10 -> 4 where x = last xs + otherwise -> 12 + diff --git a/test/testdata/Renaming/LayoutIn2.hs.expected b/test/testdata/Renaming/LayoutIn2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/LayoutIn2.hs.expected @@ -0,0 +1,13 @@ +module LayoutIn2 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'list' to 'ls'. + +silly :: [Int] -> Int +silly ls = case ls of (1:xs) -> 1 +--There is a comment + (2:xs) + | x < 10 -> 4 where x = last xs + otherwise -> 12 + diff --git a/test/testdata/Renaming/LayoutIn3.hs b/test/testdata/Renaming/LayoutIn3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/LayoutIn3.hs @@ -0,0 +1,13 @@ +module LayoutIn3 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let x = 12 in (let y = 3 + z = 2 in x * y * z * w) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/test/testdata/Renaming/LayoutIn3.hs.expected b/test/testdata/Renaming/LayoutIn3.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/LayoutIn3.hs.expected @@ -0,0 +1,13 @@ +module LayoutIn3 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let anotherX = 12 in (let y = 3 + z = 2 in anotherX * y * z * w) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/test/testdata/Renaming/LayoutIn4.hs b/test/testdata/Renaming/LayoutIn4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/LayoutIn4.hs @@ -0,0 +1,13 @@ +module LayoutIn4 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'ioFun' to 'io' + +main = ioFun "hello" where ioFun s= do let k = reverse s + --There is a comment + s <- getLine + let q = (k ++ s) + putStr q + putStr "foo" + diff --git a/test/testdata/Renaming/LayoutIn4.hs.expected b/test/testdata/Renaming/LayoutIn4.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/LayoutIn4.hs.expected @@ -0,0 +1,13 @@ +module LayoutIn4 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'ioFun' to 'io' + +main = io "hello" where io s= do let k = reverse s +--There is a comment + s <- getLine + let q = (k ++ s) + putStr q + putStr "foo" + diff --git a/test/testdata/Renaming/Main.hs b/test/testdata/Renaming/Main.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Main.hs @@ -0,0 +1,11 @@ +module Main where + +--Rename 'main' will fail. + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 + +main=return $ sumSquares [1..4] diff --git a/test/testdata/Renaming/Main2.hs b/test/testdata/Renaming/Main2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Main2.hs @@ -0,0 +1,7 @@ +-- This is a main module without an explicit module statement. +-- renaming "bar" should succeed, but "main" fail. + +main = putStrLn "hello" + +bar x = x ^ 2 + diff --git a/test/testdata/Renaming/Main2.hs.expected b/test/testdata/Renaming/Main2.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Main2.hs.expected @@ -0,0 +1,7 @@ +-- This is a main module without an explicit module statement. +-- renaming "bar" should succeed, but "main" fail. + +main = putStrLn "hello" + +baz x = x ^ 2 + diff --git a/test/testdata/Renaming/Main_TokOut.hs b/test/testdata/Renaming/Main_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Main_TokOut.hs @@ -0,0 +1,11 @@ +module Main where + +--Rename 'main' will fail. + +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 + +main=sumSquares [1..4] diff --git a/test/testdata/Renaming/QualClient.expected.hs b/test/testdata/Renaming/QualClient.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/QualClient.expected.hs @@ -0,0 +1,10 @@ +module Renaming.QualClient where + +{- foo is imported qualified as in QualClient. Renaming should + preserve the qualification there +-} + +import qualified Renaming.QualServer as QS + +baz :: String +baz = QS.foo1 : "hello" diff --git a/test/testdata/Renaming/QualClient.hs b/test/testdata/Renaming/QualClient.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/QualClient.hs @@ -0,0 +1,10 @@ +module Renaming.QualClient where + +{- foo is imported qualified as in QualClient. Renaming should + preserve the qualification there +-} + +import qualified Renaming.QualServer as QS + +baz :: String +baz = QS.foo : "hello" diff --git a/test/testdata/Renaming/QualServer.expected.hs b/test/testdata/Renaming/QualServer.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/QualServer.expected.hs @@ -0,0 +1,12 @@ +module Renaming.QualServer + ( + foo1 + ) where + +{- foo is imported qualified as in QualClient. Renaming should + preserve the qualification there +-} + + +foo1 :: Char +foo1 = 'a' diff --git a/test/testdata/Renaming/QualServer.hs b/test/testdata/Renaming/QualServer.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/QualServer.hs @@ -0,0 +1,12 @@ +module Renaming.QualServer + ( + foo + ) where + +{- foo is imported qualified as in QualClient. Renaming should + preserve the qualification there +-} + + +foo :: Char +foo = 'a' diff --git a/test/testdata/Renaming/Qualifier.hs b/test/testdata/Renaming/Qualifier.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Qualifier.hs @@ -0,0 +1,15 @@ +module Qualifier where + +{-Rename 'sumSquares' to 'sum' will fail. The user + need to qualify the use of 'sum' first. Another + implemenation option is to let the refactorer qualify + the use of 'sum' automatically, but the user might overlook + notice this change. + -} +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 + +main = sumSquares [1..4] + sum [1..4] diff --git a/test/testdata/Renaming/Qualifier_TokOut.hs b/test/testdata/Renaming/Qualifier_TokOut.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Qualifier_TokOut.hs @@ -0,0 +1,15 @@ +module Qualifier where + +{-Rename 'sumSquares' to 'sum' will fail. The user + need to qualify the use of 'sum' first. Another + implemenation option is to let the refactorer qualify + the use of 'sum' automatically, but the user might overlook + notice this change. + -} +sumSquares (x:xs) = sq x + sumSquares xs + where sq x = x ^pow + pow = 2 + +sumSquares [] = 0 + +main = sumSquares [1..4] + sum [1..4] diff --git a/test/testdata/Renaming/RenameInExportedType.expected.hs b/test/testdata/Renaming/RenameInExportedType.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/RenameInExportedType.expected.hs @@ -0,0 +1,8 @@ +module Renaming.RenameInExportedType + ( + NewType + ) where + +data NewType = MT Int + + diff --git a/test/testdata/Renaming/RenameInExportedType.hs b/test/testdata/Renaming/RenameInExportedType.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/RenameInExportedType.hs @@ -0,0 +1,8 @@ +module Renaming.RenameInExportedType + ( + MyType + ) where + +data MyType = MT Int + + diff --git a/test/testdata/Renaming/RenameInExportedType2.expected.hs b/test/testdata/Renaming/RenameInExportedType2.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/RenameInExportedType2.expected.hs @@ -0,0 +1,8 @@ +module Renaming.RenameInExportedType + ( + MyType (NewType) + ) where + +data MyType = MT Int | NewType + + diff --git a/test/testdata/Renaming/RenameInExportedType2.hs b/test/testdata/Renaming/RenameInExportedType2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/RenameInExportedType2.hs @@ -0,0 +1,8 @@ +module Renaming.RenameInExportedType + ( + MyType (NT) + ) where + +data MyType = MT Int | NT + + diff --git a/test/testdata/Renaming/Utils.expected.hs b/test/testdata/Renaming/Utils.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Utils.expected.hs @@ -0,0 +1,8 @@ +module Layout.Utils where + +foo :: IO () +foo = do + let parsed1 = 3 + + let expr = 2 + return () diff --git a/test/testdata/Renaming/Utils.hs b/test/testdata/Renaming/Utils.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Renaming/Utils.hs @@ -0,0 +1,8 @@ +module Layout.Utils where + +foo :: IO () +foo = do + let parsed = 3 + + let expr = 2 + return () diff --git a/test/testdata/RmDecl3.hs b/test/testdata/RmDecl3.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmDecl3.hs @@ -0,0 +1,8 @@ +module RmDecl3 where + +-- Remove last declaration from a where clause, where should disappear too +ff y = y + zz + where + zz = 1 + +-- EOF diff --git a/test/testdata/RmDecl4.hs b/test/testdata/RmDecl4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/RmDecl4.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} +module RmDecl4 where + +-- Remove first declaration from a where clause, rest should still be indented +ff y = y + zz ++ xx + where + zz = 1 + xx = 2 + +-- EOF diff --git a/test/testdata/S1.hs b/test/testdata/S1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/S1.hs @@ -0,0 +1,3 @@ +module S1 (s1) where + +s1 = 7 diff --git a/test/testdata/ScopeAndQual.hs b/test/testdata/ScopeAndQual.hs new file mode 100644 --- /dev/null +++ b/test/testdata/ScopeAndQual.hs @@ -0,0 +1,13 @@ +module ScopeAndQual where + +import qualified Data.List as L +import Prelude hiding (sum) + +main :: IO () +main = putStrLn (show $ L.sum [1,2,3]) + +sum a b = a + b + +sumSquares xs = L.sum $ map (\x -> x*x) xs + +mySumSq = sumSquares diff --git a/test/testdata/Simple/A.hs b/test/testdata/Simple/A.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Simple/A.hs @@ -0,0 +1,4 @@ +module A where +-- Test for refactor of remove bracket + +foo = (id) diff --git a/test/testdata/Simple/A.hs.expected b/test/testdata/Simple/A.hs.expected new file mode 100644 --- /dev/null +++ b/test/testdata/Simple/A.hs.expected @@ -0,0 +1,4 @@ +module A where +-- Test for refactor of remove bracket + +foo = id diff --git a/test/testdata/SwapArgs/B.hs b/test/testdata/SwapArgs/B.hs new file mode 100644 --- /dev/null +++ b/test/testdata/SwapArgs/B.hs @@ -0,0 +1,36 @@ +module SwapArgs.B where +-- Test for refactor of if to case + +import Data.List -- For testing module graph +-- import C -- For testing module graph + +foo x = if (odd x) then "Odd" else "Even" + +bob :: a -> b -> Int +bob x y = 1 + 2 + +-- let foo x = x + 2 in (let foo x = x+1 in x + foo y) +-- where +-- foo x = x + 1 + + +foo' x = case (odd x) of + True -> "Odd" + False -> "Even" + +main :: IO () +main = do + putStrLn $ show $ (foo (5 + 42)) + +mary :: [Integer] +mary = [1,2,3] + +h z = bob z 2 + +data D = A | B String | C + +subdecl x = zz x + where + zz n = n + 1 + + diff --git a/test/testdata/TH/Main.hs b/test/testdata/TH/Main.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TH/Main.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUGE QuasiQuotes #-} + +{- Main.hs -} +module TH.Main where + +-- Import our template "pr" +import TH.Printf + +-- The splice operator $ takes the Haskell source code +-- generated at compile time by "pr" and splices it into +-- the argument of "putStrLn". +main = putStrLn ( $(pr "Hello") ) + +-- import Control.Lens +-- data Foo a = Foo { _fooArgs :: [String], _fooValue :: a } +-- makeLenses ''Foo + +-- main = putStrLn "hello" + +-- longString = [str| hello |] + + +baz = 'a' + +sillyString = [e|baz|] + diff --git a/test/testdata/TH/Printf.hs b/test/testdata/TH/Printf.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TH/Printf.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{- Printf.hs -} +module TH.Printf where + +-- Skeletal printf from the paper. +-- It needs to be in a separate module to the one where +-- you intend to use it. + +-- Import some Template Haskell syntax +-- import Language.Haskell.THSyntax +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import qualified Language.Haskell.TH as TH + +-- Describe a format string +data Format = D | S | L String + +-- Parse a format string. This is left largely to you +-- as we are here interested in building our first ever +-- Template Haskell program and not in building printf. +parse :: String -> [Format] +parse s = [ L s ] + +-- Generate Haskell source code from a parsed representation +-- of the format string. This code will be spliced into +-- the module which calls "pr", at compile time. +gen :: [Format] -> ExpQ +gen [D] = [| \n -> show n |] +gen [S] = [| \s -> s |] +gen [L s] = stringE s + +-- Here we generate the Haskell code for the splice +-- from an input format string. +pr :: String -> ExpQ +pr s = gen (parse s) + +-- str :: QuasiQuoter +-- str = QuasiQuoter { quoteExp = stringE } + +silly :: QuasiQuoter +silly = QuasiQuoter { quoteExp = \_ -> [| "yeah!!!" |] } + +silly2 :: QuasiQuoter +silly2 = QuasiQuoter { quoteExp = \_ -> stringE "yeah!!!" + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + diff --git a/test/testdata/TokenTest.hs b/test/testdata/TokenTest.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TokenTest.hs @@ -0,0 +1,25 @@ +module TokenTest where + +-- Test new style token manager + +bob a b = x + where x = 3 + +bib a b = x + where + x = 3 + + +bab a b = + let bar = 3 + in b + bar -- ^trailing comment + + +-- leading comment +foo x y = + do c <- getChar + return c + + + + diff --git a/test/testdata/TypeUtils/B.hs b/test/testdata/TypeUtils/B.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/B.hs @@ -0,0 +1,32 @@ +module TypeUtils.B where +-- Test for refactor of if to case + +import Data.List -- For testing module graph +import TypeUtils.C -- For testing module graph + +foo x = if (odd x) then "Odd" else "Even" + +bob x y = let foo x = x + 2 in (let foo x = x+1 in x + foo y) + where + foo x = x + 1 + + +foo' x = case (odd x) of + True -> "Odd" + False -> "Even" + +main :: IO () +main = do + putStrLn $ show $ (foo (5 + 42)) + +mary :: [Integer] +mary = [1,2,3] + +h z = bob z 2 + +data D = A | B String | C + +subdecl x = zz x + where + zz n = n + 1 + diff --git a/test/testdata/TypeUtils/C.hs b/test/testdata/TypeUtils/C.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/C.hs @@ -0,0 +1,5 @@ +module TypeUtils.C where +-- Test file + +baz = 13 + diff --git a/test/testdata/TypeUtils/Empty.hs b/test/testdata/TypeUtils/Empty.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/Empty.hs @@ -0,0 +1,2 @@ +module Empty where + diff --git a/test/testdata/TypeUtils/JustImports.hs b/test/testdata/TypeUtils/JustImports.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/JustImports.hs @@ -0,0 +1,3 @@ +module JustImports where + +import Data.Maybe diff --git a/test/testdata/TypeUtils/LayoutLet1.hs b/test/testdata/TypeUtils/LayoutLet1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/LayoutLet1.hs @@ -0,0 +1,9 @@ +module LayoutLet1 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly + +foo xxx = let a = 1 + b = 2 + in xxx + a + b + diff --git a/test/testdata/TypeUtils/LayoutLet2.hs b/test/testdata/TypeUtils/LayoutLet2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/LayoutLet2.hs @@ -0,0 +1,9 @@ +module LayoutLet2 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 in xxx + a + b + diff --git a/test/testdata/TypeUtils/Qualified.hs b/test/testdata/TypeUtils/Qualified.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/Qualified.hs @@ -0,0 +1,5 @@ +-- module TypeUtils.Qualified where + +import TypeUtils.C + +main = return TypeUtils.C.baz diff --git a/test/testdata/TypeUtils/S.hs b/test/testdata/TypeUtils/S.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/S.hs @@ -0,0 +1,11 @@ +module TypeUtils.S where +-- Test for refactor of if to case + +foo x = if (odd x) then "Odd" else "Even" + +data D = A | B String | C + +subdecl x = zz x + where + zz n = n + 1 + diff --git a/test/testdata/TypeUtils/SelectivelyImports.hs b/test/testdata/TypeUtils/SelectivelyImports.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/SelectivelyImports.hs @@ -0,0 +1,5 @@ +module SelectivelyImports where + +import Data.Maybe (fromJust) + +__ = id diff --git a/test/testdata/TypeUtils/Simplest.hs b/test/testdata/TypeUtils/Simplest.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/Simplest.hs @@ -0,0 +1,4 @@ +module Simplest where + + +simple x = x diff --git a/test/testdata/TypeUtils/TyClDecls.hs b/test/testdata/TypeUtils/TyClDecls.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/TyClDecls.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TypeFamilies #-} + module TypeUtils.TyClDEcls where + + +-- Declare a list-like data family +data family XList a + +-- Declare a list-like instance for Char +data instance XList Char = XCons !Char !(XList Char) | XNil + +data Foo = Foo Int + +type Foo2 = String + +class Bar a where + bar :: a -> Bool + diff --git a/test/testdata/TypeUtils/TypeSigs.hs b/test/testdata/TypeUtils/TypeSigs.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/TypeSigs.hs @@ -0,0 +1,14 @@ +module TypeSigs where + +sq,anotherFun :: Int -> Int +sq 0 = 0 +sq z = z^2 + +anotherFun x = x^2 + +a,b,c::Int->Integer->Char + +a x y = undefined +b x y = undefined +c x y = undefined + diff --git a/test/testdata/TypeUtils/VisiblePNs.hs b/test/testdata/TypeUtils/VisiblePNs.hs new file mode 100644 --- /dev/null +++ b/test/testdata/TypeUtils/VisiblePNs.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE CPP #-} +module TypeUtils.VisiblePNs where + + +import Test.Hspec +-- import Test.QuickCheck + +-- import TestUtils + +-- import qualified Digraph as GHC +-- import qualified GHC as GHC +-- import qualified HscTypes as GHC + +-- import Control.Exception +-- import Control.Monad.State +-- import Data.Maybe +-- import Language.Haskell.GhcMod +-- import Language.Haskell.Refact.Renaming +-- import Language.Haskell.Refact.Utils +-- import Language.Haskell.Refact.Utils.GhcBugWorkArounds +-- import Language.Haskell.Refact.Utils.GhcVersionSpecific +-- import Language.Haskell.Refact.Utils.LocUtils +-- import Language.Haskell.Refact.Utils.Monad +-- import Language.Haskell.Refact.Utils.MonadFunctions +-- import Language.Haskell.Refact.Utils.TypeSyn +-- import Language.Haskell.Refact.Utils.TypeUtils +-- import System.Directory + +-- --------------------------------------------------------------------- + +main :: IO () +main = do + hspec spec + +spec :: Spec +spec = do + + describe "locToExp on ParsedSource" $ do + it "finds the largest leftmost expression contained in a given region #1" $ do + (t, _toks) <- parsedFileBGhc + let modu = yy -- GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let (Just expr) = ww -- locToExp (7,7) (7,43) modu -- :: Maybe (GHC.Located (GHC.HsExpr GHC.RdrName)) + getLocatedStart expr `shouldBe` (7,9) + getLocatedEnd expr `shouldBe` (7,42) + + it "finds the largest leftmost expression contained in a given region #2" $ do + -- ((_, _, mod), toks) <- parsedFileBGhc + (t, _toks) <- parsedFileBGhc + let modu = yy -- GHC.pm_parsed_source $ GHC.tm_parsed_module t + + let (Just expr) = (Just xx) -- locToExp (7,7) (7,41) modu :: Maybe (GHC.Located (GHC.HsExpr GHC.RdrName)) + getLocatedStart expr `shouldBe` (7,12) + getLocatedEnd expr `shouldBe` (7,19) + + -- ------------------------------------------------------------------- + + describe "getModuleGhc" $ do + it "retrieves a module from an existing module graph" $ do + let + comp = do + loadModuleGraphGhc $ Just ["./test/testdata/M.hs"] + getModuleGhc "./test/testdata/S1.hs" + pr <- getTypecheckedModule + toks <- fetchOrigToks + -- g <- clientModsAndFiles $ GHC.mkModuleName "S1" + let g = undefined + + return ((pr,toks),g) + + (( ( (t,_)), mg ), _s) <- runRefactGhcState comp + let parsed = zz -- GHC.pm_parsed_source $ GHC.tm_parsed_module t + + (show $ getModuleName parsed) `shouldBe` "Just (S1,\"S1\")" + -- showGhc (map (GHC.ms_mod . snd) mg) `shouldBe` "[main:M2, main:M3, main:Main]" + +ww = undefined +xx = undefined +yy = undefined +zz = undefined +runRefactGhcState = undefined +parsedFileGhc = undefined +getTypecheckedModule = undefined +fetchOrigToks = undefined +data PosToken = PT +data ParseResult = PR +loadModuleGraphGhc = undefined +getLocatedStart = undefined +getLocatedEnd = undefined +getModuleGhc = undefined +getModuleName= undefined + +-- --------------------------------------------------------------------- +-- Helper functions + +-- bFileName :: GHC.FastString +-- bFileName = GHC.mkFastString "./test/testdata/TypeUtils/B.hs" + +parsedFileBGhc :: IO (ParseResult,[PosToken]) +parsedFileBGhc = parsedFileGhc "./test/testdata/TypeUtils/B.hs" + +-- parsedFileMGhc :: IO (ParseResult,[PosToken]) +-- parsedFileMGhc = parsedFileGhc "./test/testdata/M.hs" + +-- --------------------------------------------------------------------- + diff --git a/test/testdata/Visible/Simple.hs b/test/testdata/Visible/Simple.hs new file mode 100644 --- /dev/null +++ b/test/testdata/Visible/Simple.hs @@ -0,0 +1,13 @@ +module Visible.Simple where + +-- Both a and b should be visible in the RHS +params :: Int -> Int -> Int +params a b = a + b + +-- B should be free, x declared, from RHS +param2 :: B -> Int +param2 (B x) = x + + + +data B = B Int diff --git a/test/testdata/cabal/cabal1/Setup.hs b/test/testdata/cabal/cabal1/Setup.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal1/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/testdata/cabal/cabal1/cabal1.cabal b/test/testdata/cabal/cabal1/cabal1.cabal new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal1/cabal1.cabal @@ -0,0 +1,24 @@ +-- Initial cabal1.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: cabal1 +version: 0.1.0.0 +-- synopsis: +-- description: +license: PublicDomain +-- license-file: LICENSE +author: Alan Zimmerman +maintainer: alan.zimm@gmail.com +-- copyright: +-- category: +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +executable cabal1 + main-is: main.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4.6 && <5 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/test/testdata/cabal/cabal1/src/Foo/Bar.hs b/test/testdata/cabal/cabal1/src/Foo/Bar.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal1/src/Foo/Bar.hs @@ -0,0 +1,3 @@ +module Foo.Bar where + +baz = 6 diff --git a/test/testdata/cabal/cabal1/src/main.hs b/test/testdata/cabal/cabal1/src/main.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal1/src/main.hs @@ -0,0 +1,7 @@ +-- | Testing that HaRe can find source files from a cabal file + +import qualified Foo.Bar as B + +main = putStrLn "foo" + +baz = 3 + B.baz diff --git a/test/testdata/cabal/cabal2/Setup.hs b/test/testdata/cabal/cabal2/Setup.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal2/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/testdata/cabal/cabal2/cabal2.cabal b/test/testdata/cabal/cabal2/cabal2.cabal new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal2/cabal2.cabal @@ -0,0 +1,33 @@ +-- Initial cabal2.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: cabal2 +version: 0.1.0.0 +-- synopsis: +-- description: +license: PublicDomain +-- license-file: LICENSE +author: Alan Zimmerman +maintainer: alan.zimm@gmail.com +-- copyright: +-- category: +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +executable cabal1 + main-is: main1.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4.6 && <5 + hs-source-dirs: src + default-language: Haskell2010 + +executable cabal2 + main-is: main2.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4.6 && <5 + hs-source-dirs: src + default-language: Haskell2010 + diff --git a/test/testdata/cabal/cabal2/src/Foo/Bar.hs b/test/testdata/cabal/cabal2/src/Foo/Bar.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal2/src/Foo/Bar.hs @@ -0,0 +1,3 @@ +module Foo.Bar where + +baz = 6 diff --git a/test/testdata/cabal/cabal2/src/main1.hs b/test/testdata/cabal/cabal2/src/main1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal2/src/main1.hs @@ -0,0 +1,7 @@ +-- | Testing that HaRe can find source files from a cabal file + +import qualified Foo.Bar as B + +main = putStrLn "foo" + +baz = 3 + B.baz diff --git a/test/testdata/cabal/cabal2/src/main2.hs b/test/testdata/cabal/cabal2/src/main2.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal2/src/main2.hs @@ -0,0 +1,9 @@ +-- | Testing that HaRe can find source files from a cabal file + +-- This is main module 2 + +import qualified Foo.Bar as B + +main = putStrLn "foo" + +baz = 3 + B.baz diff --git a/test/testdata/cabal/cabal3/Setup.hs b/test/testdata/cabal/cabal3/Setup.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal3/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/testdata/cabal/cabal3/cabal3.cabal b/test/testdata/cabal/cabal3/cabal3.cabal new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal3/cabal3.cabal @@ -0,0 +1,32 @@ +-- Initial cabal2.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: cabal3 +version: 0.1.0.0 +-- synopsis: +-- description: +license: PublicDomain +-- license-file: LICENSE +author: Alan Zimmerman +maintainer: alan.zimm@gmail.com +-- copyright: +-- category: +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + build-depends: base >=4.6 && <5 + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Foo.Bar + default-language: Haskell2010 + +executable cabal1 + main-is: main1.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4.6 && <5 + hs-source-dirs: src + default-language: Haskell2010 + diff --git a/test/testdata/cabal/cabal3/src/Foo/Bar.hs b/test/testdata/cabal/cabal3/src/Foo/Bar.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal3/src/Foo/Bar.hs @@ -0,0 +1,3 @@ +module Foo.Bar where + +baz = 6 diff --git a/test/testdata/cabal/cabal3/src/main1.hs b/test/testdata/cabal/cabal3/src/main1.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal3/src/main1.hs @@ -0,0 +1,7 @@ +-- | Testing that HaRe can find source files from a cabal file + +import qualified Foo.Bar as B + +main = putStrLn "foo" + +baz = 3 + B.baz diff --git a/test/testdata/cabal/cabal4/Setup.hs b/test/testdata/cabal/cabal4/Setup.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal4/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/testdata/cabal/cabal4/cabal4.cabal b/test/testdata/cabal/cabal4/cabal4.cabal new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal4/cabal4.cabal @@ -0,0 +1,29 @@ + +name: cabal4 +version: 0.1.0.0 +-- synopsis: +-- description: +license: PublicDomain +-- license-file: LICENSE +author: Alan Zimmerman +maintainer: alan.zimm@gmail.com +-- copyright: +-- category: +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + build-depends: base >=4.6 && <5 + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Foo.Bar + default-language: Haskell2010 + +executable cabal4 + main-is: main4.hs + build-depends: base >=4.6 && <5 + , parsec >= 3.1.6 + hs-source-dirs: src + default-language: Haskell2010 + diff --git a/test/testdata/cabal/cabal4/src/Foo/Bar.expected.hs b/test/testdata/cabal/cabal4/src/Foo/Bar.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal4/src/Foo/Bar.expected.hs @@ -0,0 +1,3 @@ +module Foo.Bar where + +baz1 = 6 diff --git a/test/testdata/cabal/cabal4/src/Foo/Bar.hs b/test/testdata/cabal/cabal4/src/Foo/Bar.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal4/src/Foo/Bar.hs @@ -0,0 +1,3 @@ +module Foo.Bar where + +baz = 6 diff --git a/test/testdata/cabal/cabal4/src/main4.expected.hs b/test/testdata/cabal/cabal4/src/main4.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal4/src/main4.expected.hs @@ -0,0 +1,11 @@ +-- | Testing that HaRe can find source files from a cabal file + +import qualified Foo.Bar as B + +import Text.Parsec.Combinator +import Text.Parsec.Prim +import Text.Parsec.Char + +main = putStrLn "foo" + +baz = 3 + B.baz1 diff --git a/test/testdata/cabal/cabal4/src/main4.hs b/test/testdata/cabal/cabal4/src/main4.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/cabal4/src/main4.hs @@ -0,0 +1,11 @@ +-- | Testing that HaRe can find source files from a cabal file + +import qualified Foo.Bar as B + +import Text.Parsec.Combinator +import Text.Parsec.Prim +import Text.Parsec.Char + +main = putStrLn "foo" + +baz = 3 + B.baz diff --git a/test/testdata/cabal/foo/Setup.hs b/test/testdata/cabal/foo/Setup.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/foo/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/testdata/cabal/foo/foo.cabal b/test/testdata/cabal/foo/foo.cabal new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/foo/foo.cabal @@ -0,0 +1,32 @@ +-- Initial foo.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: foo +version: 0.1.0.0 +-- synopsis: +-- description: +-- license: +-- license-file: LICENSE +author: Alan Zimmerman +maintainer: alan.zimm@gmail.com +-- copyright: +-- category: +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +Library + Build-Depends: base >= 4.0 && < 4.9 + Hs-Source-Dirs: src + Exposed-modules: + Foo.Bar + Foo.Baz + default-language: Haskell2010 + +executable foo + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4.8 && <4.9 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/test/testdata/cabal/foo/src/Foo/Bar.expected.hs b/test/testdata/cabal/foo/src/Foo/Bar.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/foo/src/Foo/Bar.expected.hs @@ -0,0 +1,3 @@ +module Foo.Bar where + +bar1 = 2 diff --git a/test/testdata/cabal/foo/src/Foo/Bar.hs b/test/testdata/cabal/foo/src/Foo/Bar.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/foo/src/Foo/Bar.hs @@ -0,0 +1,3 @@ +module Foo.Bar where + +bar = 2 diff --git a/test/testdata/cabal/foo/src/Foo/Baz.hs b/test/testdata/cabal/foo/src/Foo/Baz.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/foo/src/Foo/Baz.hs @@ -0,0 +1,3 @@ +module Foo.Baz where + +bar = 4 diff --git a/test/testdata/cabal/foo/src/Main.expected.hs b/test/testdata/cabal/foo/src/Main.expected.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/foo/src/Main.expected.hs @@ -0,0 +1,8 @@ + +import Foo.Bar + +import qualified Foo.Baz as Z + +main = putStrLn "hello" + +baz = Z.bar + bar1 diff --git a/test/testdata/cabal/foo/src/Main.hs b/test/testdata/cabal/foo/src/Main.hs new file mode 100644 --- /dev/null +++ b/test/testdata/cabal/foo/src/Main.hs @@ -0,0 +1,8 @@ + +import Foo.Bar + +import qualified Foo.Baz as Z + +main = putStrLn "hello" + +baz = Z.bar + bar diff --git a/test/testdata/testdata.cabal b/test/testdata/testdata.cabal new file mode 100644 --- /dev/null +++ b/test/testdata/testdata.cabal @@ -0,0 +1,155 @@ +Name: HaRe-tests +Version: 0 +Author: Alan Zimmerman +Maintainer: Alan Zimmerman +Cabal-Version: >= 1.10 +Build-Type: Simple + +Executable bcpp + Main-Is: BCpp.hs + Build-Depends: base >= 4.0 && < 4.9 + , syb + default-language: Haskell2010 + +Executable foo + Main-Is: TokenTest.hs + Build-Depends: base >= 4.0 && < 4.9 + , syb + default-language: Haskell2010 + +Executable dd2 + Main-Is: DupDef/Dd2.hs + Build-Depends: base >= 4.0 && < 4.9 + , syb + default-language: Haskell2010 + +Executable dd3 + Main-Is: DupDef/Dd3.hs + Build-Depends: base >= 4.0 && < 4.9 + default-language: Haskell2010 + +Executable m + Main-Is: M.hs + Hs-Source-Dirs: . + Build-Depends: base >= 4.0 && < 4.9 + , syb + default-language: Haskell2010 + +Executable a1 + Main-Is: Renaming/A1.hs + Build-Depends: base >= 4.0 && < 4.9 + , syb + default-language: Haskell2010 + +Executable a2 + Main-Is: Renaming/A2.hs + Build-Depends: base >= 4.0 && < 4.9 + , syb + default-language: Haskell2010 + +Executable a3 + Main-Is: Renaming/A3.hs + Build-Depends: base >= 4.0 && < 4.9 + , syb + default-language: Haskell2010 + +Executable a4 + Main-Is: Renaming/A4.hs + Build-Depends: base >= 4.0 && < 4.9 + , syb + default-language: Haskell2010 + +Executable a5 + Main-Is: Renaming/A5.hs + Build-Depends: base >= 4.0 && < 4.9 + , syb + default-language: Haskell2010 + +Executable c7 + Main-Is: Renaming/C7.hs + Other-Modules : Renaming.D7 + Build-Depends: base >= 4.0 && < 4.9 + , syb + default-language: Haskell2010 + +Executable qualclient + Main-Is: Renaming/QualClient.hs + Build-Depends: base >= 4.0 && < 4.9 + , syb + default-language: Haskell2010 + +Executable th + Main-Is: TH/Main.hs + Build-Depends: base >= 4.0 && < 4.9 + , syb + , template-haskell + default-language: Haskell2010 + +-- --------------------------------------------------------------------- + +Executable ltta1 + + Main-Is: LiftToToplevel/A1.hs + Other-Modules : LiftToToplevel.C1 + LiftToToplevel.D1 + Build-Depends: base >= 4.0 && < 4.9 + default-language: Haskell2010 + + +Executable ltta2 + + Main-Is: LiftToToplevel/A2.hs + Other-Modules : LiftToToplevel.C2 + LiftToToplevel.D2 + Build-Depends: base >= 4.0 && < 4.9 + default-language: Haskell2010 + +-- --------------------------------------------------------------------- + +Executable lola1 + Main-Is: LiftOneLevel/A1.hs + Other-Modules : LiftOneLevel.C1 + LiftOneLevel.D1 + Build-Depends: base >= 4.0 && < 4.9 + default-language: Haskell2010 + + +Executable lola2 + Main-Is: LiftOneLevel/A2.hs + Other-Modules : LiftOneLevel.C2 + LiftOneLevel.D2 + Build-Depends: base >= 4.0 && < 4.9 + default-language: Haskell2010 + + +Executable lola3 + Main-Is: LiftOneLevel/A3.hs + Other-Modules : LiftOneLevel.C3 + LiftOneLevel.D3 + Build-Depends: base >= 4.0 && < 4.9 + default-language: Haskell2010 + +-- --------------------------------------------------------------------- + +Executable demotea1 + Main-Is: Demote/A1.hs + Other-Modules : Demote.C1 + Demote.D1 + Build-Depends: base >= 4.0 && < 4.9 + default-language: Haskell2010 + + +Executable demotea2 + Main-Is: Demote/A2.hs + Other-Modules : Demote.C2 + Demote.D2 + Build-Depends: base >= 4.0 && < 4.9 + default-language: Haskell2010 + +-- --------------------------------------------------------------------- + +Executable qualified + Main-Is: TypeUtils/Qualified.hs + Other-Modules : TypeUtils.C + Build-Depends: base >= 4.0 && < 4.9 + default-language: Haskell2010