path: root/utils/check-exact/Main.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

import Data.List (intercalate)
import Data.Data
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader
import GHC hiding (moduleName)
import GHC.Driver.Ppr
import GHC.Driver.Session
import GHC.Hs.Dump
import GHC.Data.Bag
import System.Environment( getArgs )
import System.Exit
import System.FilePath
import System.IO

import Types
import Utils
import ExactPrint
import Transform
import Parsers

import GHC.Parser.Lexer
import GHC.Data.FastString
import GHC.Types.SrcLoc

-- ---------------------------------------------------------------------

_tt :: IO ()
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib"
_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"

 -- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1)
 -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet2.hs" (Just changeLayoutLet2)
 -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet3.hs" (Just changeLayoutLet3)
 -- "../../testsuite/tests/ghc-api/exactprint/LayoutLet4.hs" (Just changeLayoutLet3)
 -- "../../testsuite/tests/ghc-api/exactprint/Rename1.hs" (Just changeRename1)
 -- "../../testsuite/tests/ghc-api/exactprint/Rename2.hs" (Just changeRename2)
 -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn1.hs" (Just changeLayoutIn1)
 -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn3.hs" (Just changeLayoutIn3)
 -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn3a.hs" (Just changeLayoutIn3)
 -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn3b.hs" (Just changeLayoutIn3)
 -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn4.hs" (Just changeLayoutIn4)
 -- "../../testsuite/tests/ghc-api/exactprint/LocToName.hs" (Just changeLocToName)
 -- "../../testsuite/tests/ghc-api/exactprint/LetIn1.hs" (Just changeLetIn1)
 -- "../../testsuite/tests/ghc-api/exactprint/WhereIn4.hs" (Just changeWhereIn4)
 "../../testsuite/tests/ghc-api/exactprint/AddDecl1.hs" (Just changeAddDecl1)
 -- "../../testsuite/tests/ghc-api/exactprint/AddDecl2.hs" (Just changeAddDecl2)
 -- "../../testsuite/tests/ghc-api/exactprint/AddDecl3.hs" (Just changeAddDecl3)
 -- "../../testsuite/tests/ghc-api/exactprint/LocalDecls.hs" (Just changeLocalDecls)
 -- "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.hs" (Just changeLocalDecls2)
 -- "../../testsuite/tests/ghc-api/exactprint/WhereIn3a.hs" (Just changeWhereIn3a)
 -- "../../testsuite/tests/ghc-api/exactprint/WhereIn3b.hs" (Just changeWhereIn3b)
 -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl1.hs" (Just addLocaLDecl1)
 -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl2.hs" (Just addLocaLDecl2)
 -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl3.hs" (Just addLocaLDecl3)
 -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl4.hs" (Just addLocaLDecl4)
 -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl5.hs" (Just addLocaLDecl5)
 -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl6.hs" (Just addLocaLDecl6)
 -- "../../testsuite/tests/ghc-api/exactprint/RmDecl1.hs" (Just rmDecl1)
 -- "../../testsuite/tests/ghc-api/exactprint/RmDecl2.hs" (Just rmDecl2)
 -- "../../testsuite/tests/ghc-api/exactprint/RmDecl3.hs" (Just rmDecl3)
 -- "../../testsuite/tests/ghc-api/exactprint/RmDecl4.hs" (Just rmDecl4)
 -- "../../testsuite/tests/ghc-api/exactprint/RmDecl5.hs" (Just rmDecl5)
 -- "../../testsuite/tests/ghc-api/exactprint/RmDecl6.hs" (Just rmDecl6)
 -- "../../testsuite/tests/ghc-api/exactprint/RmDecl7.hs" (Just rmDecl7)
 -- "../../testsuite/tests/ghc-api/exactprint/RmTypeSig1.hs" (Just rmTypeSig1)
 -- "../../testsuite/tests/ghc-api/exactprint/RmTypeSig2.hs" (Just rmTypeSig2)
 -- "../../testsuite/tests/ghc-api/exactprint/AddHiding1.hs" (Just addHiding1)
 -- "../../testsuite/tests/ghc-api/exactprint/AddHiding2.hs" (Just addHiding2)

 -- "../../testsuite/tests/printer/Ppr001.hs" Nothing
 -- "../../testsuite/tests/ghc-api/annotations/CommentsTest.hs" Nothing
 -- "../../testsuite/tests/hiefile/should_compile/Constructors.hs" Nothing
 -- "../../testsuite/tests/hiefile/should_compile/Scopes.hs" Nothing
 -- "../../testsuite/tests/hiefile/should_compile/hie008.hs" Nothing
 -- "../../testsuite/tests/hiefile/should_run/PatTypes.hs" Nothing
 -- "../../testsuite/tests/parser/should_compile/T14189.hs" Nothing

 -- "../../testsuite/tests/printer/AnnotationLet.hs" Nothing
 -- "../../testsuite/tests/printer/AnnotationTuple.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr001.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr002.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr002a.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr003.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr004.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr005.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr006.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr007.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr008.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr009.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr011.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr012.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr013.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr014.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr015.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr016.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr017.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr018.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr019.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr020.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr021.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr022.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr023.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr024.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr025.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr026.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr027.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr028.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr029.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr030.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr031.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr032.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr033.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr034.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr035.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr036.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr037.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr038.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr039.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr040.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr041.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr042.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr043.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr044.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr045.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr046.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr048.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr049.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr050.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr051.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr052.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr053.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr054.hs" Nothing
 -- "../../testsuite/tests/printer/Ppr055.hs" Nothing
 -- "../../testsuite/tests/printer/PprRecordDotSyntax1.hs" Nothing
 -- "../../testsuite/tests/printer/PprRecordDotSyntax2.hs" Nothing
 -- "../../testsuite/tests/printer/PprRecordDotSyntax3.hs" Nothing
 -- "../../testsuite/tests/printer/PprRecordDotSyntax4.hs" Nothing
 -- "../../testsuite/tests/printer/PprRecordDotSyntaxA.hs" Nothing
 -- "../../testsuite/tests/printer/StarBinderAnns.hs" Nothing
 -- "../../testsuite/tests/printer/T13050p.hs" Nothing
 -- "../../testsuite/tests/printer/T13199.hs" Nothing
 -- "../../testsuite/tests/printer/T13550.hs" Nothing
 -- "../../testsuite/tests/printer/T13942.hs" Nothing
 -- "../../testsuite/tests/printer/T14289.hs" Nothing
 -- "../../testsuite/tests/printer/T14289b.hs" Nothing
 -- "../../testsuite/tests/printer/T14289c.hs" Nothing
 -- "../../testsuite/tests/printer/T14306.hs" Nothing
 -- "../../testsuite/tests/printer/T14343.hs" Nothing
 -- "../../testsuite/tests/printer/T14343b.hs" Nothing
 -- "../../testsuite/tests/printer/T15761.hs" Nothing
 -- "../../testsuite/tests/printer/T18052a.hs" Nothing
 -- "../../testsuite/tests/printer/T18247a.hs" Nothing
 -- "../../testsuite/tests/printer/Test10276.hs" Nothing
 -- "../../testsuite/tests/printer/Test10278.hs" Nothing
 -- "../../testsuite/tests/printer/Test10312.hs" Nothing
 -- "../../testsuite/tests/printer/Test10354.hs" Nothing
 -- "../../testsuite/tests/printer/Test10357.hs" Nothing
 -- "../../testsuite/tests/printer/Test10399.hs" Nothing
 -- "../../testsuite/tests/printer/Test11018.hs" Nothing
 -- "../../testsuite/tests/printer/Test11332.hs" Nothing
 -- "../../testsuite/tests/printer/Test12417.hs" Nothing
 -- "../../testsuite/tests/printer/Test16212.hs" Nothing
 -- "../../testsuite/tests/printer/Test16230.hs" Nothing
 -- "../../testsuite/tests/printer/Test16236.hs" Nothing
 -- "../../testsuite/tests/printer/Test17519.hs" Nothing
 -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing

 -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing
 -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing
 -- "../../testsuite/tests/typecheck/should_fail/T17566c.hs" Nothing
 -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl1.hs" Nothing
 -- "../../testsuite/tests/ghc-api/exactprint/EmptyWheres.hs" Nothing
 -- "../../testsuite/tests/ghc-api/exactprint/LayoutIn1.hs" Nothing
 -- "../../testsuite/tests/ghc-api/exactprint/LocalDecls2.expected.hs" Nothing
 -- "../../testsuite/tests/ghc-api/exactprint/WhereIn3a.hs" Nothing
 -- "../../testsuite/tests/ghc-api/exactprint/Windows.hs" Nothing

-- cloneT does not need a test, function can be retired


-- exact = ppr

changers :: [(String, Changer)]
changers =
  [("noChange",          noChange)
  ,("changeRenameCase1", changeRenameCase1)
  ,("changeLayoutLet2",  changeLayoutLet2)
  ,("changeLayoutLet3",  changeLayoutLet3)
  ,("changeLayoutIn1",   changeLayoutIn1)
  ,("changeLayoutIn3",   changeLayoutIn3)
  ,("changeLayoutIn4",   changeLayoutIn4)
  ,("changeLocToName",   changeLocToName)
  ,("changeRename1",     changeRename1)
  ,("changeRename2",     changeRename2)
  ,("changeWhereIn4",    changeWhereIn4)
  ,("changeLetIn1",      changeLetIn1)
  ,("changeAddDecl1",    changeAddDecl1)
  ,("changeAddDecl2",    changeAddDecl2)
  ,("changeAddDecl3",    changeAddDecl3)
  ,("changeLocalDecls",  changeLocalDecls)
  ,("changeLocalDecls2", changeLocalDecls2)
  ,("changeWhereIn3a",   changeWhereIn3a)
  ,("changeWhereIn3b",   changeWhereIn3b)
  ,("ADDLOCALDECL1",     addLocaLDecl1)
  ,("ADDLOCALDECL2",     addLocaLDecl2)
  ,("ADDLOCALDECL3",     addLocaLDecl3)
  ,("ADDLOCALDECL4",     addLocaLDecl4)
  ,("ADDLOCALDECL5",     addLocaLDecl5)
  ,("ADDLOCALDECL6",     addLocaLDecl6)
  ,("ADDLOCALDECL6",     addLocaLDecl6)
  ,("rmDecl1",           rmDecl1)
  ,("rmDecl2",           rmDecl2)
  ,("rmDecl3",           rmDecl3)
  ,("rmDecl4",           rmDecl4)
  ,("rmDecl5",           rmDecl5)
  ,("rmDecl6",           rmDecl6)
  ,("rmDecl7",           rmDecl7)
  ,("rmTypeSig1",        rmTypeSig1)
  ,("rmTypeSig2",        rmTypeSig2)
  ,("addHiding1",        addHiding1)
  ,("addHiding2",        addHiding2)
   ]

-- ---------------------------------------------------------------------

usage :: String
usage = unlines
    [ "usage: check-exact (libdir) (file)"
    , "       check-exact (libdir) (file) (changer)"
    , ""
    , "where libdir is the GHC library directory (e.g. the output of"
    , "ghc --print-libdir), file is the file to parse"
    , "and changer is an optional name of a 'changer' to modify the"
    , " AST before printing."
    ]

main :: IO()
main = do
  args <- getArgs
  case args of
   [libdir,fileName] -> testOneFile changers libdir fileName Nothing
   [libdir,fileName,changerStr] -> do
     case lookup changerStr changers of
       Just doChange -> testOneFile changers libdir fileName (Just doChange)
       Nothing -> do
         putStrLn $ "exactprint: could not find changer for [" ++ changerStr ++ "]"
         putStrLn $ "valid changers are:\n" ++ unlines (map fst changers)
         putStrLn $ "(see utils/check-exact/Main.hs)"
         exitFailure
   _ -> putStrLn usage

deriving instance Data Token
deriving instance Data PsSpan
deriving instance Data BufSpan
deriving instance Data BufPos

writeBinFile :: FilePath -> String -> IO()
writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 >> hPutStr h x)

testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO ()
testOneFile _ libdir fileName mchanger = do
       (p,_toks) <- parseOneFile libdir fileName
       -- putStrLn $ "\n\ngot p" ++ showAst (take 4 $ reverse _toks)
       let
         origAst = ppAst (pm_parsed_source p)
         pped    = exactPrint (pm_parsed_source p)

         newFile         = dropExtension fileName <.> "ppr"      <.> takeExtension fileName
         newFileChanged  = dropExtension fileName <.> "changed"  <.> takeExtension fileName
         newFileExpected = dropExtension fileName <.> "expected" <.> takeExtension fileName
         astFile        = fileName <.> "ast"
         newAstFile     = fileName <.> "ast.new"
         changedAstFile = fileName <.> "ast.changed"

       writeBinFile astFile origAst
       writeBinFile newFile pped

       (changedSourceOk, expectedSource, changedSource) <- case mchanger of
         Just changer -> do
           (pped', ast') <- exactprintWithChange libdir changer (pm_parsed_source p)
           writeBinFile changedAstFile (ppAst ast')
           writeBinFile newFileChanged pped'

           expectedSource <- readFile newFileExpected
           changedSource  <- readFile newFileChanged
           return (expectedSource == changedSource, expectedSource, changedSource)
         Nothing -> return (True, "", "")


       (p',_) <- parseOneFile libdir newFile
       let newAstStr :: String
           newAstStr = ppAst (pm_parsed_source p')
       writeBinFile newAstFile newAstStr

       let origAstOk = origAst == newAstStr

       if origAstOk && changedSourceOk
         then do
           exitSuccess
         else if not origAstOk
           then do
             putStrLn "exactPrint: AST Match Failed"
             putStrLn "\n===================================\nOrig\n\n"
             putStrLn origAst
             putStrLn "\n===================================\nNew\n\n"
             putStrLn newAstStr
             exitFailure
           else do
             putStrLn "exactPrint: Changed AST Source Mismatch"
             putStrLn "\n===================================\nExpected\n\n"
             putStrLn expectedSource
             putStrLn "\n===================================\nChanged\n\n"
             putStrLn changedSource
             putStrLn "\n===================================\n"
             putStrLn $ show changedSourceOk
             exitFailure

ppAst :: Data a => a -> String
ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast

parseOneFile :: FilePath -> FilePath -> IO (ParsedModule, [Located Token])
parseOneFile libdir fileName = do
       let modByFile m =
             case ml_hs_file $ ms_location m of
               Nothing -> False
               Just fn -> fn == fileName
       runGhc (Just libdir) $ do
         dflags <- getSessionDynFlags
         let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
         _ <- setSessionDynFlags dflags2
         addTarget Target { targetId = TargetFile fileName Nothing
                          , targetUnitId = homeUnitId_ dflags
                          , targetAllowObjCode = True
                          , targetContents = Nothing }
         _ <- load LoadAllTargets
         graph <- getModuleGraph
         let
           modSum = case filter modByFile (mgModSummaries graph) of
                     [x] -> x
                     xs -> error $ "Can't find module, got:"
                              ++ show (map (ml_hs_file . ms_location) xs)
         pm <- GHC.parseModule modSum
         toks <- getTokenStream (ms_mod modSum)
         return (pm, toks)


-- ---------------------------------------------------------------------

exactprintWithChange :: FilePath -> Changer -> ParsedSource -> IO (String, ParsedSource)
exactprintWithChange libdir f p = do
  p' <- f libdir p
  return (exactPrint p', p')

-- First param is libdir
type Changer = FilePath -> (ParsedSource -> IO ParsedSource)

noChange :: Changer
noChange _libdir parsed = return parsed

changeRenameCase1 :: Changer
changeRenameCase1 _libdir parsed = return (rename "bazLonger" [((3,15),(3,18))] parsed)

changeLayoutLet2 :: Changer
changeLayoutLet2 _libdir parsed = return (rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed)

changeLayoutLet3 :: Changer
changeLayoutLet3 _libdir parsed = return (rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed)

changeLayoutIn1 :: Changer
changeLayoutIn1 _libdir parsed = return (rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed)

changeLayoutIn3 :: Changer
changeLayoutIn3 _libdir parsed = return (rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed)

changeLayoutIn4 :: Changer
changeLayoutIn4 _libdir parsed = return (rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed)

changeLocToName :: Changer
changeLocToName _libdir parsed = return (rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed)


changeRename1 :: Changer
changeRename1 _libdir parsed = return (rename "bar2" [((3,1),(3,4))] parsed)

changeRename2 :: Changer
changeRename2 _libdir parsed = return (rename "joe" [((2,1),(2,5))] parsed)

rename :: (Data a) => String -> [(Pos, Pos)] -> a -> a
rename newNameStr spans' a
  = everywhere (mkT replaceRdr) a
  where
    newName = mkRdrUnqual (mkVarOcc newNameStr)

    cond :: SrcSpan -> Bool
    cond ln = ss2range ln `elem` spans'

    replaceRdr :: LocatedN RdrName -> LocatedN RdrName
    replaceRdr (L ln _)
        | cond (locA ln) = L ln newName
    replaceRdr x = x

-- ---------------------------------------------------------------------

changeWhereIn4 :: Changer
changeWhereIn4 _libdir parsed
  = return (everywhere (mkT replace) parsed)
  where
    replace :: LocatedN RdrName -> LocatedN RdrName
    replace (L ln _n)
      | ss2range (locA ln) == ((12,16),(12,17)) = L ln (mkRdrUnqual (mkVarOcc "p_2"))
    replace x = x

-- ---------------------------------------------------------------------

changeLetIn1 :: Changer
changeLetIn1 _libdir parsed
  = return (everywhere (mkT replace) parsed)
  where
    replace :: HsExpr GhcPs -> HsExpr GhcPs
    replace (HsLet (EpAnn anc (AnnsLet l _i) cs) localDecls expr)
      =
         let (HsValBinds x (ValBinds xv bagDecls sigs)) = localDecls
             [l2,_l1] = map wrapDecl $ bagToList bagDecls
             bagDecls' = listToBag $ concatMap decl2Bind [l2]
             (L (SrcSpanAnn _ le) e) = expr
             a = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan le) (MovedAnchor (SameLine 1))) mempty emptyComments) le)
             expr' = L a e
         in (HsLet (EpAnn anc (AnnsLet l (EpaDelta (DifferentLine 1 0))) cs)
                (HsValBinds x (ValBinds xv bagDecls' sigs)) expr')

    replace x = x

-- ---------------------------------------------------------------------

-- | Add a declaration to AddDecl
changeAddDecl1 :: Changer
changeAddDecl1 libdir top = do
  Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
  let decl' = setEntryDP' decl (DifferentLine 2 0)

  let (p',(_,_),_) = runTransform mempty doAddDecl
      doAddDecl = everywhereM (mkM replaceTopLevelDecls) top
      replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
      replaceTopLevelDecls m = insertAtStart m decl'
  return p'

-- ---------------------------------------------------------------------
changeAddDecl2 :: Changer
changeAddDecl2 libdir top = do
  Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
  let decl' = setEntryDP' decl (DifferentLine 2 0)
  let top' = anchorEof top

  let (p',(_,_),_) = runTransform mempty doAddDecl
      doAddDecl = everywhereM (mkM replaceTopLevelDecls) top'
      replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
      replaceTopLevelDecls m = insertAtEnd m decl'
  return p'

-- ---------------------------------------------------------------------

changeAddDecl3 :: Changer
changeAddDecl3 libdir top = do
  Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
  let decl' = setEntryDP' decl (DifferentLine 2 0)

  let (p',(_,_),_) = runTransform mempty doAddDecl
      doAddDecl = everywhereM (mkM replaceTopLevelDecls) top
      f d (l1:l2:ls) = l1:d:l2':ls
        where
          l2' = setEntryDP' l2 (DifferentLine 2 0)
      replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
      replaceTopLevelDecls m = insertAt f m decl'
  return p'

-- ---------------------------------------------------------------------

-- | Add a local declaration with signature to LocalDecl
changeLocalDecls :: Changer
changeLocalDecls libdir (L l p) = do
  Right s@(L ls (SigD _ sig))  <- withDynFlags libdir (\df -> parseDecl df "sig"  "nn :: Int")
  Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
  let decl' = setEntryDP' (L ld decl) (DifferentLine 1 0)
  let  sig' = setEntryDP' (L ls sig)  (SameLine 0)
  let (p',(_,_),_w) = runTransform mempty doAddLocal
      doAddLocal = everywhereM (mkM replaceLocalBinds) p
      replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
                        -> Transform (LMatch GhcPs (LHsExpr GhcPs))
      replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ binds sigs))))) = do
        let oldDecls = sortLocatedA $ map wrapDecl (bagToList binds) ++ map wrapSig sigs
        let decls = s:d:oldDecls
        let oldDecls' = captureLineSpacing oldDecls
        let oldBinds     = concatMap decl2Bind oldDecls'
            (os:oldSigs) = concatMap decl2Sig  oldDecls'
            os' = setEntryDP' os (DifferentLine 2 0)
        let sortKey = captureOrder decls
        let (EpAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van
        let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 4)))) a b c dd) cs)
        let binds' = (HsValBinds van'
                          (ValBinds sortKey (listToBag $ decl':oldBinds)
                                          (sig':os':oldSigs)))
        return (L lm (Match an mln pats (GRHSs noExtField rhs binds')))
      replaceLocalBinds x = return x
  return (L l p')

-- ---------------------------------------------------------------------

-- | Add a local declaration with signature to LocalDecl, where there was no
-- prior local decl. So it adds a "where" annotation.
changeLocalDecls2 :: Changer
changeLocalDecls2 libdir (L l p) = do
  Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
  Right s@(L ls (SigD _ sig))  <- withDynFlags libdir (\df -> parseDecl df "sig"  "nn :: Int")
  let decl' = setEntryDP' (L ld decl) (DifferentLine 1 0)
  let  sig' = setEntryDP' (L ls  sig) (SameLine 2)
  let (p',(_,_),_w) = runTransform mempty doAddLocal
      doAddLocal = everywhereM (mkM replaceLocalBinds) p
      replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
                        -> Transform (LMatch GhcPs (LHsExpr GhcPs))
      replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do
        newSpan <- uniqueSrcSpanT
        let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2)))
        let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4)))
        let an = EpAnn anc
                        (AnnList (Just anc2) Nothing Nothing
                                 [(undeltaSpan (rs newSpan) AnnWhere (SameLine 0))] [])
                        emptyComments
        let decls = [s,d]
        let sortKey = captureOrder decls
        let binds = (HsValBinds an (ValBinds sortKey (listToBag $ [decl'])
                                    [sig']))
        return (L lm (Match ma mln pats (GRHSs noExtField rhs binds)))
      replaceLocalBinds x = return x
  return (L l p')

-- ---------------------------------------------------------------------

-- | Check that balanceCommentsList is idempotent
changeWhereIn3a :: Changer
changeWhereIn3a _libdir (L l p) = do
  let decls0 = hsmodDecls p
      (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0)
      (_de0:_:de1:_d2:_) = decls
  debugM $ unlines w
  debugM $ "changeWhereIn3a:de1:" ++ showAst de1
  let p2 = p { hsmodDecls = decls}
  return (L l p2)

-- ---------------------------------------------------------------------

changeWhereIn3b :: Changer
changeWhereIn3b _libdir (L l p) = do
  let decls0 = hsmodDecls p
      (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0)
      (de0:_:de1:d2:_) = decls
      de0' = setEntryDP' de0 (DifferentLine 2 0)
      de1' = setEntryDP' de1 (DifferentLine 2 0)
      d2' = setEntryDP' d2 (DifferentLine 2 0)
      decls' = d2':de1':de0':(tail decls)
  debugM $ unlines w
  debugM $ "changeWhereIn3b:de1':" ++ showAst de1'
  let p2 = p { hsmodDecls = decls'}
  return (L l p2)

-- ---------------------------------------------------------------------

addLocaLDecl1 :: Changer
addLocaLDecl1 libdir lp = do
  Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
  let decl' = setEntryDP' (L ld decl) (DifferentLine 1 4)
      doAddLocal = do
        (de1:d2:d3:_) <- hsDecls lp
        (de1'',d2') <- balanceComments de1 d2
        (de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do
          return ((wrapDecl decl' : d),Nothing)
        replaceDecls lp [de1', d2', d3]

  (lp',(_,_),w) <- runTransformT mempty doAddLocal
  debugM $ "addLocaLDecl1:" ++ intercalate "\n" w
  return lp'

-- ---------------------------------------------------------------------

addLocaLDecl2 :: Changer
addLocaLDecl2 libdir lp = do
  Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
  let
      doAddLocal = do
         (de1:d2:_) <- hsDecls lp
         (de1'',d2') <- balanceComments de1 d2

         (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do
           newDecl' <- transferEntryDP' d newDecl
           let d' = setEntryDP' d (DifferentLine 1 0)
           return ((newDecl':d':ds),Nothing)

         replaceDecls lp [parent',d2']

  (lp',(_,_),_w) <- runTransformT mempty doAddLocal
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

addLocaLDecl3 :: Changer
addLocaLDecl3 libdir lp = do
  Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
  let
      doAddLocal = do
         (de1:d2:_) <- hsDecls lp
         (de1'',d2') <- balanceComments de1 d2

         (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do
           let newDecl' = setEntryDP' newDecl (DifferentLine 1 0)
           return (((d:ds) ++ [newDecl']),Nothing)

         replaceDecls (anchorEof lp) [parent',d2']

  (lp',(_,_),_w) <- runTransformT mempty doAddLocal
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

addLocaLDecl4 :: Changer
addLocaLDecl4 libdir lp = do
  Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
  Right newSig  <- withDynFlags libdir (\df -> parseDecl df "sig"  "nn :: Int")
  let
      doAddLocal = do
         (parent:ds) <- hsDecls lp

         let newDecl' = setEntryDP' newDecl (DifferentLine 1 0)
         let newSig'  = setEntryDP' newSig  (DifferentLine 1 4)

         (parent',_) <- modifyValD (getLocA parent) parent $ \_m decls -> do
           return ((decls++[newSig',newDecl']),Nothing)

         replaceDecls (anchorEof lp) (parent':ds)

  (lp',(_,_),_w) <- runTransformT mempty doAddLocal
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'


-- ---------------------------------------------------------------------

addLocaLDecl5 :: Changer
addLocaLDecl5 _libdir lp = do
  let
      doAddLocal = do
         decls <- hsDecls lp
         [s1,de1,d2,d3] <- balanceCommentsList decls

         let d3' = setEntryDP' d3 (DifferentLine 2 0)

         (de1',_) <- modifyValD (getLocA de1) de1 $ \_m _decls -> do
           let d2' = setEntryDP' d2 (DifferentLine 1 0)
           return ([d2'],Nothing)
         replaceDecls lp [s1,de1',d3']

  (lp',(_,_),_w) <- runTransformT mempty doAddLocal
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

addLocaLDecl6 :: Changer
addLocaLDecl6 libdir lp = do
  Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3")
  let
      newDecl' = setEntryDP' newDecl (DifferentLine 1 4)
      doAddLocal = do
        decls0 <- hsDecls lp
        [de1'',d2] <- balanceCommentsList decls0

        let de1 = captureMatchLineSpacing de1''
        let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms) _) _)) = de1
        let [ma1,_ma2] = ms

        (de1',_) <- modifyValD (getLocA ma1) de1 $ \_m decls -> do
           return ((newDecl' : decls),Nothing)
        replaceDecls lp [de1', d2]

  (lp',(_,_),_w) <- runTransformT mempty doAddLocal
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

rmDecl1 :: Changer
rmDecl1 _libdir lp = do
  let doRmDecl = do
         tlDecs0 <- hsDecls lp
         tlDecs <- balanceCommentsList $ captureLineSpacing tlDecs0
         let (de1:_s1:_d2:ds) = tlDecs

         replaceDecls lp (de1:ds)

  (lp',(_,_),_w) <- runTransformT mempty doRmDecl
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

rmDecl2 :: Changer
rmDecl2 _libdir lp = do
  let
      doRmDecl = do
        let
          go :: GHC.LHsExpr GhcPs -> Transform (GHC.LHsExpr GhcPs)
          go e@(GHC.L _ (GHC.HsLet{})) = do
            decs0 <- hsDecls e
            decs <- balanceCommentsList $ captureLineSpacing decs0
            e' <- replaceDecls e (init decs)
            return e'
          go x = return x

        everywhereM (mkM go) lp

  let (lp',(_,_),_w) = runTransform mempty doRmDecl
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

rmDecl3 :: Changer
rmDecl3 _libdir lp = do
  let
      doRmDecl = do
         [de1,d2] <- hsDecls lp

         (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1] -> do
           let sd1' = setEntryDP' sd1 (DifferentLine 2 0)
           return ([],Just sd1')

         replaceDecls lp [de1',sd1,d2]

  (lp',(_,_),_w) <- runTransformT mempty doRmDecl
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

rmDecl4 :: Changer
rmDecl4 _libdir lp = do
  let
      doRmDecl = do
         [de1] <- hsDecls lp

         (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> do
           sd2' <- transferEntryDP' sd1 sd2

           let sd1' = setEntryDP' sd1 (DifferentLine 2 0)
           return ([sd2'],Just sd1')

         replaceDecls (anchorEof lp) [de1',sd1]

  (lp',(_,_),_w) <- runTransformT mempty doRmDecl
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

rmDecl5 :: Changer
rmDecl5 _libdir lp = do
  let
      doRmDecl = do
        let
          go :: HsExpr GhcPs -> Transform (HsExpr GhcPs)
          go (HsLet a lb expr) = do
            decs <- hsDeclsValBinds lb
            let dec = last decs
            _ <- transferEntryDPT (head decs) dec
            lb' <- replaceDeclsValbinds WithoutWhere lb [dec]
            return (HsLet a lb' expr)
          go x = return x

        everywhereM (mkM go) lp

  let (lp',(_,_),_w) = runTransform mempty doRmDecl
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

rmDecl6 :: Changer
rmDecl6 _libdir lp = do
  let
      doRmDecl = do
         [de1] <- hsDecls lp

         (de1',_) <- modifyValD (getLocA de1) de1 $ \_m subDecs -> do
           let (ss1:_sd1:sd2:sds) = subDecs
           sd2' <- transferEntryDP' ss1 sd2

           return (sd2':sds,Nothing)

         replaceDecls lp [de1']

  (lp',(_,_),_w) <- runTransformT mempty doRmDecl
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

rmDecl7 :: Changer
rmDecl7 _libdir lp = do
  let
      doRmDecl = do
         tlDecs <- hsDecls lp
         [s1,de1,d2,d3] <- balanceCommentsList tlDecs

         d3' <- transferEntryDP' d2 d3

         replaceDecls lp [s1,de1,d3']

  (lp',(_,_),_w) <- runTransformT mempty doRmDecl
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

rmTypeSig1 :: Changer
rmTypeSig1 _libdir lp = do
  let doRmDecl = do
         tlDecs <- hsDecls lp
         let (s0:de1:d2) = tlDecs
             s1 = captureTypeSigSpacing s0
             (L l (SigD x1 (TypeSig x2 [n1,n2] typ))) = s1
         n2' <- transferEntryDP n1 n2
         let s1' = (L l (SigD x1 (TypeSig x2 [n2'] typ)))
         replaceDecls lp (s1':de1:d2)

  let (lp',(_,_),_w) = runTransform mempty doRmDecl
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

rmTypeSig2 :: Changer
rmTypeSig2 _libdir lp = do
  let doRmDecl = do
         tlDecs <- hsDecls lp
         let [de1] = tlDecs

         (de1',_) <- modifyValD (getLocA de1) de1 $ \_m [s,d] -> do
           d' <- transferEntryDPT s d
           return ([d'],Nothing)
         replaceDecls lp [de1']

  let (lp',(_,_),_w) = runTransform mempty doRmDecl
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

addHiding1 :: Changer
addHiding1 _libdir (L l p) = do
  let doTransform = do
        l0 <- uniqueSrcSpanT
        l1 <- uniqueSrcSpanT
        l2 <- uniqueSrcSpanT
        let
          [L li imp1,imp2] = hsmodImports p
          n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1"))
          n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2"))
          v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1)))
          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2)))
          impHiding = L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan l0) m0)
                                     (AnnList Nothing
                                              (Just (AddEpAnn AnnOpenP  d1))
                                              (Just (AddEpAnn AnnCloseP d0))
                                              [(AddEpAnn AnnHiding d1)]
                                              [])
                                       emptyComments) l0) [v1,v2]
          imp1' = imp1 { ideclHiding = Just (True,impHiding)}
          p' = p { hsmodImports = [L li imp1',imp2]}
        return (L l p')

  let (lp',(_ans',_),_w) = runTransform mempty doTransform
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'

-- ---------------------------------------------------------------------

addHiding2 :: Changer
addHiding2 _libdir (L l p) = do
  let doTransform = do
        l1 <- uniqueSrcSpanT
        l2 <- uniqueSrcSpanT
        let
          [L li imp1] = hsmodImports p
          Just (_,L lh ns) = ideclHiding imp1
          lh' = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan (locA lh)) m0)
                                     (AnnList Nothing
                                              (Just (AddEpAnn AnnOpenP  d1))
                                              (Just (AddEpAnn AnnCloseP d0))
                                              [(AddEpAnn AnnHiding d1)]
                                              [])
                                       emptyComments) (locA lh))
          n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1"))
          n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2"))
          v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1)))
          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2)))
          L ln n = last ns
          n' = L (addComma ln) n
          imp1' = imp1 { ideclHiding = Just (True,L lh' (init ns ++ [n',v1,v2]))}
          p' = p { hsmodImports = [L li imp1']}
        return (L l p')

  let (lp',(_ans',_),_w) = runTransform mempty doTransform
  debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
  return lp'


-- ---------------------------------------------------------------------
-- From SYB

-- | Apply transformation on each level of a tree.
--
-- Just like 'everything', this is stolen from SYB package.
everywhere :: (forall a. Data a => a -> a) -> (forall a. Data a => a -> a)
everywhere f = f . gmapT (everywhere f)

-- | Create generic transformation.
--
-- Another function stolen from SYB package.
mkT :: (Typeable a, Typeable b) => (b -> b) -> (a -> a)
mkT f = case cast f of
    Just f' -> f'
    Nothing -> id

-- ---------------------------------------------------------------------