summaryrefslogtreecommitdiff
path: root/tests/Test/Transform.hs
blob: bfe2e27484f43eb39787e2e44b3f4f389be38264 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
{-# LANGUAGE TupleSections #-}
module Test.Transform where

import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Preprocess
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Parsers

import GHC.Paths ( libdir )

import qualified Bag            as GHC
import qualified DynFlags       as GHC
import qualified GHC            as GHC
import qualified OccName        as GHC
import qualified RdrName        as GHC
import qualified SrcLoc         as GHC
import qualified FastString     as GHC

import qualified Data.Generics as SYB

import Control.Monad
import System.FilePath
import System.IO
import qualified Data.Map as Map
import Data.Maybe

import System.IO.Silently

import Test.Common

import Test.HUnit

transformTests :: [Test]
transformTests =
  [
    TestLabel "Low level transformations"
       (TestList transformLowLevelTests)
  , TestLabel "High level transformations"
       (TestList transformHighLevelTests)
  ]

transformLowLevelTests :: [Test]
transformLowLevelTests = [
    mkTestModChange changeLayoutLet2  "LayoutLet2.hs"  "LayoutLet2"
  , mkTestModChange changeLayoutLet3  "LayoutLet3.hs"  "LayoutLet3"
  , mkTestModChange changeLayoutLet3  "LayoutLet4.hs"  "LayoutLet4"
  , mkTestModChange changeRename1     "Rename1.hs"     "Main"
  , mkTestModChange changeLayoutIn1   "LayoutIn1.hs"   "LayoutIn1"
  , mkTestModChange changeLayoutIn3   "LayoutIn3.hs"   "LayoutIn3"
  , mkTestModChange changeLayoutIn3   "LayoutIn3a.hs"  "LayoutIn3a"
  , mkTestModChange changeLayoutIn3   "LayoutIn3b.hs"  "LayoutIn3b"
  , mkTestModChange changeLayoutIn4   "LayoutIn4.hs"   "LayoutIn4"
  , mkTestModChange changeLocToName   "LocToName.hs"   "LocToName"
  , mkTestModChange changeLetIn1      "LetIn1.hs"      "LetIn1"
  , mkTestModChange changeWhereIn4    "WhereIn4.hs"    "WhereIn4"
  , mkTestModChange changeAddDecl     "AddDecl.hs"     "AddDecl"
  , mkTestModChange changeLocalDecls  "LocalDecls.hs"  "LocalDecls"
  , mkTestModChange changeLocalDecls2 "LocalDecls2.hs" "LocalDecls2"
  , mkTestModChange changeWhereIn3a   "WhereIn3a.hs"   "WhereIn3a"
--  , mkTestModChange changeCifToCase  "C.hs"          "C"
  ]

mkTestModChange :: Changer -> FilePath -> String -> Test
mkTestModChange change fileName modName
  = TestCase (do r <- manipulateAstTestWithMod change "expected" fileName modName
                 assertBool fileName r )

type Changer = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource))

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

changeWhereIn3a :: Changer
changeWhereIn3a ans (GHC.L l p) = do
  let decls = GHC.hsmodDecls p
         -- (GHC.L _ (GHC.SigD sig))    = head $ drop 1 decls
      d1 = head $ drop 2 decls
      d2 = head $ drop 3 decls
  let (_p1,(ans',_),_w) = runTransform ans (balanceComments d1 d2)
  let p2 = p { GHC.hsmodDecls = d2:d1:decls}
  return (ans',GHC.L l p2)

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

-- | Add a local declaration with signature to LocalDecl, where there was no
-- prior local decl. So it adds a "where" annotation.
changeLocalDecls2 :: Changer
changeLocalDecls2 ans (GHC.L l p) = do
  Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
  Right (sigAnns, s@(GHC.L ls (GHC.SigD sig)))   <- withDynFlags (\df -> parseDecl df "sig"  "nn :: Int")
  let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns
  let  sigAnns' = setPrecedingLines (GHC.L ls  sig) 1 4 sigAnns
  -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns
  -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns
  -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns'
  let (p',(ans',_),_w) = runTransform ans doAddLocal
      doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p
      replaceLocalBinds :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)
                        -> Transform (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
      replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.EmptyLocalBinds)))) = do
        newSpan <- uniqueSrcSpanT
        let
          newAnnKey = AnnKey newSpan (CN "HsValBinds")
          addWhere mkds =
            case Map.lookup (mkAnnKey m) mkds of
              Nothing -> error "wtf"
              Just ann -> Map.insert newAnnKey ann2 mkds2
                where
                  ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))]
                             , annCapturedSpan = Just newAnnKey
                             , annSortKey = Just [ls, ld]
                             }
                  mkds2 = Map.insert (mkAnnKey m) ann1 mkds
                  ann2 = annNone
                             { annEntryDelta     = DP (1,0) }
        modifyAnnsT addWhere
        let decls = [s,d]
        logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)
        modifyAnnsT (captureOrderAnnKey newAnnKey decls)
        return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs
                        (GHC.HsValBinds
                          (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl])
                                          [GHC.L ls sig])))))
      replaceLocalBinds x = return x
  -- putStrLn $ "log:" ++ intercalate "\n" w
  return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p')

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

-- | Add a local declaration with signature to LocalDecl
changeLocalDecls :: Changer
changeLocalDecls ans (GHC.L l p) = do
  Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
  Right (sigAnns, s@(GHC.L ls (GHC.SigD sig)))   <- withDynFlags (\df -> parseDecl df "sig"  "nn :: Int")
  let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns
  let  sigAnns' = setPrecedingLines (GHC.L ls  sig) 1 4 sigAnns
  -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns
  -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns
  -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns'
  let (p',(ans',_),_w) = runTransform ans doAddLocal
      doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p
      replaceLocalBinds :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)
                        -> Transform (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
      replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs))))) = do
        a1 <- getAnnsT
        a' <- case sigs of
              []    -> return a1
              (s1:_) -> do
                let a2 = setPrecedingLines s1 2 0 a1
                return a2
        putAnnsT a'
        let wrapDecl (GHC.L l' w) = GHC.L l' (GHC.ValD w)
            wrapSig (GHC.L l' w) = GHC.L l' (GHC.SigD w)
        let oldDecls = GHC.sortLocated $ map wrapDecl (GHC.bagToList binds) ++ map wrapSig sigs
        let decls = s:d:oldDecls
        logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)
        modifyAnnsT (captureOrder m decls)
        return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs
                        (GHC.HsValBinds
                          (GHC.ValBindsIn (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds)
                                          (GHC.L ls sig:sigs))))))
      replaceLocalBinds x = return x
  -- putStrLn $ "log:" ++ intercalate "\n" w
  return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p')

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

-- | Add a declaration to AddDecl
changeAddDecl :: Changer
changeAddDecl ans top = do
  Right (declAnns, decl) <- withDynFlags (\df -> parseDecl df "<interactive>" "nn = n2")
  -- putStrLn $ "changeDecl:(declAnns,decl)=" ++ showGhc (declAnns,decl)
  let declAnns' = setPrecedingLines decl 2 0 declAnns
  -- putStrLn $ "changeDecl:(declAnns',decl)=" ++ showGhc (declAnns',decl)

  let (p',(ans',_),_) = runTransform ans doAddDecl
      doAddDecl = SYB.everywhereM (SYB.mkM replaceTopLevelDecls) top
      replaceTopLevelDecls :: GHC.ParsedSource -> Transform (GHC.ParsedSource)
      replaceTopLevelDecls m = insertAtStart m decl
  return (mergeAnns declAnns' ans',p')

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

-- |Remove a decl with a trailing comment, and remove the trailing comment too
changeWhereIn3 :: Int -> Changer
changeWhereIn3 declIndex ans p = return (ans',p')
  where
    (p',(ans',_),_) = runTransform ans doTransform
    doTransform = doRmDecl p

    doRmDecl (GHC.L l (GHC.HsModule mmn mexp imps decls mdepr haddock)) = do
      let
        -- declIndex = 2 -- zero based
        decls1 = take declIndex decls
        decls2 = drop (declIndex + 1) decls
        decls' = decls1 ++ decls2
      return (GHC.L l (GHC.HsModule mmn mexp imps decls' mdepr haddock))
      -- error $ "doRmDecl:decls2=" ++ showGhc (length decls,decls1,decls2)

-- ---------------------------------------------------------------------
{-
-- |Convert the if statement in C.hs to a case, adjusting layout appropriately.
changeCifToCase :: Changer
changeCifToCase ans p = return (ans',p')
  where
    (p',(ans',_),_) = runTransform ans doTransform
    doTransform = SYB.everywhereM (SYB.mkM ifToCaseTransform) p

    ifToCaseTransform :: GHC.Located (GHC.HsExpr GHC.RdrName)
                      -> Transform (GHC.Located (GHC.HsExpr GHC.RdrName))
    ifToCaseTransform li@(GHC.L l (GHC.HsIf _se e1 e2 e3)) = do
      caseLoc        <- uniqueSrcSpanT -- HaRe:-1:1
      trueMatchLoc   <- uniqueSrcSpanT -- HaRe:-1:2
      trueLoc1       <- uniqueSrcSpanT -- HaRe:-1:3
      trueLoc        <- uniqueSrcSpanT -- HaRe:-1:4
      trueRhsLoc     <- uniqueSrcSpanT -- HaRe:-1:5
      falseLoc1      <- uniqueSrcSpanT -- HaRe:-1:6
      falseLoc       <- uniqueSrcSpanT -- HaRe:-1:7
      falseMatchLoc  <- uniqueSrcSpanT -- HaRe:-1:8
      falseRhsLoc    <- uniqueSrcSpanT -- HaRe:-1:9
      caseVirtualLoc <- uniqueSrcSpanT -- HaRe:-1:10
      let trueName  = mkRdrName "True"
      let falseName = mkRdrName "False"
      let ret = GHC.L caseLoc (GHC.HsCase e1
                 (GHC.MG
                  [
                    (GHC.L trueMatchLoc $ GHC.Match
                     Nothing
                     [
                       GHC.L trueLoc1 $ GHC.ConPatIn (GHC.L trueLoc trueName) (GHC.PrefixCon [])
                     ]
                     Nothing
                     (GHC.GRHSs
                       [
                         GHC.L trueRhsLoc $ GHC.GRHS [] e2
                       ] GHC.EmptyLocalBinds)
                    )
                  , (GHC.L falseMatchLoc $ GHC.Match
                     Nothing
                     [
                       GHC.L falseLoc1 $ GHC.ConPatIn (GHC.L falseLoc falseName) (GHC.PrefixCon [])
                     ]
                     Nothing
                     (GHC.GRHSs
                       [
                         GHC.L falseRhsLoc $ GHC.GRHS [] e3
                       ] GHC.EmptyLocalBinds)
                    )
                  ] [] GHC.placeHolderType GHC.FromSource))

      oldAnns <- getAnnsT
      let annIf   = gfromJust "Case.annIf"   $ getAnnotationEP li NotNeeded oldAnns
      let annCond = gfromJust "Case.annCond" $ getAnnotationEP e1 NotNeeded oldAnns
      let annThen = gfromJust "Case.annThen" $ getAnnotationEP e2 NotNeeded oldAnns
      let annElse = gfromJust "Case.annElse" $ getAnnotationEP e3 NotNeeded oldAnns
      logTr $ "Case:annIf="   ++ show annIf
      logTr $ "Case:annThen=" ++ show annThen
      logTr $ "Case:annElse=" ++ show annElse

      -- let ((_ifr,    ifc),  ifDP) = getOriginalPos oldAnns li (G GHC.AnnIf)
      -- let ((_thenr,thenc),thenDP) = getOriginalPos oldAnns li (G GHC.AnnThen)
      -- let ((_elser,elsec),elseDP) = getOriginalPos oldAnns li (G GHC.AnnElse)
      -- let newCol = ifc + 2
      let newCol = 6

      -- 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 ifSpanEntry = annEntryDelta annIf
      let anne2' =
            [ ( AnnKey caseLoc       (CN "HsCase") NotNeeded,   annIf { annsDP = [ (G GHC.AnnCase, ifDelta)
                                                                     , (G GHC.AnnOf,     DP (0,1))]
                                                                     , annCapturedSpan = Just (AnnKey caseVirtualLoc (CN "(:)") NotNeeded)
                                                                     } )
            , ( AnnKey caseVirtualLoc (CN "(:)") NotNeeded,     Ann (DP (1,newCol)) (ColDelta newCol) (DP (1,newCol)) [] [] [(AnnSpanEntry,DP (1,0))] Nothing Nothing)
            , ( AnnKey trueMatchLoc  (CN "Match") NotNeeded,   annNone )
            , ( AnnKey trueLoc1      (CN "ConPatIn") NotNeeded, annNone )
            , ( AnnKey trueLoc       (CN "Unqual") NotNeeded,  annNone )
            , ( AnnKey trueRhsLoc    (CN "GRHS") NotNeeded,     Ann (DP (0,2)) 6 (DP (0,0)) [] [] [(AnnSpanEntry,DP (0,2)),(G GHC.AnnRarrow, DP (0,0))] Nothing Nothing )

            , ( AnnKey falseMatchLoc (CN "Match") NotNeeded,    Ann (DP (1,0)) 0 (DP (0,0)) [] [] [(AnnSpanEntry,DP (1,0))] Nothing Nothing )
            , ( AnnKey falseLoc1     (CN "ConPatIn") NotNeeded, annNone )
            , ( AnnKey falseLoc      (CN "Unqual") NotNeeded, annNone )
            , ( AnnKey falseRhsLoc   (CN "GRHS") NotNeeded,     Ann (DP (0,1)) 6 (DP (0,0)) [] [] [(AnnSpanEntry,DP (0,1)),(G GHC.AnnRarrow, DP (0,0))] Nothing Nothing )
            ]

      let annThen' = adjustAnnOffset (ColDelta 6) annThen
      let anne1 = modifyKeywordDeltas (Map.delete (AnnKey l (CN "HsIf") NotNeeded)) oldAnns
          final = modifyKeywordDeltas (\s -> Map.union s (Map.fromList anne2')) anne1
          anne3 = setLocatedAnns final
                    [ (e1, annCond)
                    , (e2, annThen')
                    , (e3, annElse)
                    ]
      putAnnsT anne3
      return ret
    ifToCaseTransform x = return x

    mkRdrName :: String -> GHC.RdrName
    mkRdrName s = GHC.mkVarUnqual (GHC.mkFastString s)
-}
-- ---------------------------------------------------------------------

noChange :: Changer
noChange ans parsed = return (ans,parsed)

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

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

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

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

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

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

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

changeLayoutLet5 :: Changer
changeLayoutLet5 ans parsed = return (ans,rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed)

rename :: (SYB.Data a) => String -> [(Pos, Pos)] -> a -> a
rename newNameStr spans a
  = SYB.everywhere ( SYB.mkT   replaceRdr
                    `SYB.extT` replaceHsVar
                    `SYB.extT` replacePat
                   ) a
  where
    newName = GHC.mkRdrUnqual (GHC.mkVarOcc newNameStr)

    cond :: GHC.SrcSpan -> Bool
    cond ln = ln `elem` srcSpans
      where
        srcSpans  = map (\(start, end) -> GHC.mkSrcSpan (f start) (f end)) spans
        fname = fromMaybe (GHC.mkFastString "f") (GHC.srcSpanFileName_maybe ln)
        f = uncurry (GHC.mkSrcLoc fname)


    replaceRdr :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName
    replaceRdr (GHC.L ln _)
        | cond ln = GHC.L ln newName
    replaceRdr x = x

    replaceHsVar :: GHC.LHsExpr GHC.RdrName -> GHC.LHsExpr GHC.RdrName
    replaceHsVar (GHC.L ln (GHC.HsVar _))
        | cond ln = GHC.L ln (GHC.HsVar newName)
    replaceHsVar x = x

    replacePat (GHC.L ln (GHC.VarPat _))
        | cond ln = GHC.L ln (GHC.VarPat newName)
    replacePat x = x



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

changeWhereIn4 :: Changer
changeWhereIn4 ans parsed
  = return (ans,SYB.everywhere (SYB.mkT replace) parsed)
  where
    replace :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName
    replace (GHC.L ln _n)
      | ln == (g (12,16) (12,17)) = GHC.L ln (GHC.mkRdrUnqual (GHC.mkVarOcc "p_2"))
      where
        g start end = GHC.mkSrcSpan (f start) (f end)
        fname = fromMaybe (GHC.mkFastString "f") (GHC.srcSpanFileName_maybe ln)
        f = uncurry (GHC.mkSrcLoc fname)
    replace x = x

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

changeLetIn1 :: Changer
changeLetIn1 ans parsed
  = return (ans,SYB.everywhere (SYB.mkT replace) parsed)
  where
    replace :: GHC.HsExpr GHC.RdrName -> GHC.HsExpr GHC.RdrName
    replace (GHC.HsLet localDecls expr@(GHC.L _ _))
      =
         let (GHC.HsValBinds (GHC.ValBindsIn bagDecls sigs)) = localDecls
             bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls
         in (GHC.HsLet (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs)) expr)

    replace x = x

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


manipulateAstTestWithMod :: Changer -> String -> FilePath -> String -> IO Bool
manipulateAstTestWithMod change suffix file modname = manipulateAstTest' (Just (change, suffix)) False file modname

manipulateAstTestWFnameMod :: Changer -> FilePath -> String -> IO (FilePath,Bool)
manipulateAstTestWFnameMod change fileName modname
  = do r <- manipulateAstTestWithMod change "expected" fileName modname
       return (fileName,r)

manipulateAstTestWFnameBad :: FilePath -> String -> IO (FilePath,Bool)
manipulateAstTestWFnameBad fileName modname
  = do r <- manipulateAstTestWithMod noChange "bad" fileName modname
       return (fileName,r)

manipulateAstTest :: FilePath -> String -> IO Bool
manipulateAstTest file modname = manipulateAstTest' Nothing False file modname

manipulateAstTestWFname :: FilePath -> String -> IO (FilePath, Bool)
manipulateAstTestWFname file modname = (file,) <$> manipulateAstTest file modname


mkTestModBad :: FilePath -> String -> Test
mkTestModBad fileName modName
  = TestCase (do r <- manipulateAstTestWithMod noChange "bad" fileName modName
                 assertBool fileName r )

manipulateAstTest' :: Maybe (Changer, String)
                   -> Bool -> FilePath -> String -> IO Bool
manipulateAstTest' mchange useTH file' modname = do
  let testpath = "./tests/examples/"
      file     = testpath </> file'
      out      = file <.> "out"

  contents <- case mchange of
                   Nothing                 -> readFile file
                   Just (_,expectedSuffix) -> readFile (file <.> expectedSuffix)
  (ghcAnns',p,cppComments) <- hSilence [stderr] $  parsedFileGhc file modname useTH
  -- (ghcAnns',p,cppComments) <-                      parsedFileGhc file modname useTH
  let
    parsedOrig = GHC.pm_parsed_source $ p
    (ghcAnns,parsed) = (ghcAnns', parsedOrig)
    parsedAST = showAnnData emptyAnns 0 parsed
    -- cppComments = map (tokComment . commentToAnnotation . fst) cppCommentToks
    -- parsedAST = showGhc parsed
       -- `debug` ("getAnn:=" ++ (show (getAnnotationValue (snd ann) (GHC.getLoc parsed) :: Maybe AnnHsModule)))
    -- try to pretty-print; summarize the test result
    ann = relativiseApiAnnsWithComments cppComments parsedOrig ghcAnns'
      `debug` ("ghcAnns:" ++ showGhc ghcAnns)

  (ann',parsed') <- case mchange of
                   Nothing         -> return (ann,parsed)
                   Just (change,_) -> change ann parsed

  let
    printed = exactPrintWithAnns parsed' ann' -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann))
    outcome = if printed == contents
                then "Match\n"
                else "Fail\n"
    result = printed ++ "\n==============\n"
             ++ outcome ++ "\n==============\n"
             ++ "lengths:" ++ show (length printed,length contents) ++ "\n"
             ++ showAnnData ann' 0 parsed'
             ++ "\n========================\n"
             ++ showGhc ann'
             ++ "\n========================\n"
             ++ showGhc ghcAnns
             ++ "\n========================\n"
             ++ parsedAST
             ++ "\n========================\n"
             ++ showGhc ann
  -- putStrLn $ "Test:ann :" ++ showGhc ann
  writeFile out $ result
  -- putStrLn $ "Test:contents' :" ++ contents
  -- putStrLn $ "Test:parsed=" ++ parsedAST
  -- putStrLn $ "Test:showdata:parsedOrig" ++ SYB.showData SYB.Parser 0 parsedOrig
  -- putStrLn $ "Test:ann :" ++ showGhc ann
  -- putStrLn $ "Test:ghcAnns :" ++ showGhc ghcAnns
  -- putStrLn $ "Test:ghcAnns' :" ++ showGhc ghcAnns'
  -- putStrLn $ "Test:showdata:" ++ showAnnData ann 0 parsed
  -- putStrLn $ "Test:showdata:parsed'" ++ SYB.showData SYB.Parser 0 parsed'
  -- putStrLn $ "Test:showdata:parsed'" ++ showAnnData ann 0 parsed'
  -- putStrLn $ "Test:outcome' :" ++ outcome
  return (printed == contents)


-- ---------------------------------------------------------------------
-- |Result of parsing a Haskell source file. It is simply the
-- TypeCheckedModule produced by GHC.
type ParseResult = GHC.ParsedModule

parsedFileGhc :: String -> String -> Bool -> IO (GHC.ApiAnns,ParseResult,[Comment])
parsedFileGhc fileName _modname useTH = do
    -- putStrLn $ "parsedFileGhc:" ++ show fileName
    GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ do
      GHC.runGhc (Just libdir) $ do
        dflags <- GHC.getSessionDynFlags
        let dflags2 = dflags { GHC.importPaths = ["./tests/examples/","../tests/examples/",
                                                  "./src/","../src/"] }
            tgt = if useTH then GHC.HscInterpreted
                           else GHC.HscNothing -- allows FFI
            dflags3 = dflags2 { GHC.hscTarget = tgt
                              , GHC.ghcLink =  GHC.LinkInMemory
                              }

            dflags4 = GHC.gopt_set dflags3 GHC.Opt_KeepRawTokenStream

        (dflags5,_args,_warns) <- GHC.parseDynamicFlagsCmdLine dflags4 [GHC.noLoc "-package ghc"]
        -- GHC.liftIO $ putStrLn $ "dflags set:(args,warns)" ++ show (map GHC.unLoc _args,map GHC.unLoc _warns)
        void $ GHC.setSessionDynFlags dflags5
        -- GHC.liftIO $ putStrLn $ "dflags set"

        -- hsc_env <- GHC.getSession
        -- (dflags6,fn_pp) <- GHC.liftIO $ GHC.preprocess hsc_env (fileName,Nothing)
        -- GHC.liftIO $ putStrLn $ "preprocess got:" ++ show fn_pp


        target <- GHC.guessTarget fileName Nothing
        GHC.setTargets [target]
        -- GHC.liftIO $ putStrLn $ "target set:" ++ showGhc (GHC.targetId target)
        void $ GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling make
        -- GHC.liftIO $ putStrLn $ "targets loaded"
        -- g <- GHC.getModuleGraph
        -- let showStuff ms = show (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod ms,GHC.ms_location ms)
        -- GHC.liftIO $ putStrLn $ "module graph:" ++ (intercalate "," (map showStuff g))

        -- modSum <- GHC.getModSummary $ GHC.mkModuleName modname
        Just modSum <- getModSummaryForFile fileName
        -- GHC.liftIO $ putStrLn $ "got modSum"
        -- let modSum = head g
        cppComments <-  if (GHC.xopt GHC.Opt_Cpp dflags5)
                        then getCppTokensAsComments defaultCppOptions fileName
                        else return []
        -- let cppComments = [] :: [(GHC.Located GHC.Token, String)]
--        GHC.liftIO $ putStrLn $ "\ncppTokensAsComments for:"  ++ fileName ++ "=========\n"
--                              ++ showGhc cppComments ++ "\n================\n"
{-
        (sourceFile, source, flags) <- getModuleSourceAndFlags (GHC.ms_mod modSum)
        strSrcBuf <- getPreprocessedSrc sourceFile
        GHC.liftIO $ putStrLn $ "preprocessedSrc====\n" ++ strSrcBuf ++ "\n================\n"
-}
        p <- GHC.parseModule modSum
        -- GHC.liftIO $ putStrLn $ "got parsedModule"
--        t <- GHC.typecheckModule p
        -- GHC.liftIO $ putStrLn $ "typechecked"
        -- toks <- GHC.getRichTokenStream (GHC.ms_mod modSum)
        -- GHC.liftIO $ putStrLn $ "toks" ++ show toks
        let anns = GHC.pm_annotations p
        -- GHC.liftIO $ putStrLn $ "anns"
        return (anns,p,cppComments)

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

transformHighLevelTests :: [Test]
transformHighLevelTests =
  [
    mkTestModChange addLocaLDecl1  "AddLocalDecl1.hs"  "AddLocalDecl1"
  , mkTestModChange addLocaLDecl2  "AddLocalDecl2.hs"  "AddLocalDecl2"
  , mkTestModChange addLocaLDecl3  "AddLocalDecl3.hs"  "AddLocalDecl3"

  , mkTestModChange rmDecl1 "RmDecl1.hs" "RmDecl1"
  , mkTestModChange rmDecl2 "RmDecl2.hs" "RmDecl2"
  , mkTestModChange rmDecl3 "RmDecl3.hs" "RmDecl3"

  , mkTestModChange rmTypeSig1 "RmTypeSig1.hs" "RmTypeSig1"
  ]

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

addLocaLDecl1 :: Changer
addLocaLDecl1 ans lp = do
  Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
  let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns

      doAddLocal = do
         tlDecs <- hsDecls lp
         let parent = head tlDecs
         decls <- hsDecls parent
         balanceComments parent (head $ tail tlDecs)

         modifyAnnsT (setPrecedingLines newDecl 1 4)

         parent' <- replaceDecls parent (newDecl:decls)
         replaceDecls lp (parent':tail tlDecs)

  let (lp',(ans',_),_w) = runTransform ans doAddLocal
  return (mergeAnnList [declAnns',ans'],lp')

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

addLocaLDecl2 :: Changer
addLocaLDecl2 ans lp = do
  Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
  let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns

      doAddLocal = do
         tlDecs <- hsDecls lp
         let parent = head tlDecs
         decls <- hsDecls parent
         balanceComments parent (head $ tail tlDecs)

         DP (r,c) <- getEntryDPT (head decls)
         modifyAnnsT (setPrecedingLines newDecl r c)
         modifyAnnsT (setPrecedingLines (head decls) 1 0)

         parent' <- replaceDecls parent (newDecl:decls)
         replaceDecls lp (parent':tail tlDecs)

  let (lp',(ans',_),_w) = runTransform ans doAddLocal
  return (mergeAnnList [declAnns',ans'],lp')

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

addLocaLDecl3 :: Changer
addLocaLDecl3 ans lp = do
  Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
  let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns

      doAddLocal = do
         tlDecs <- hsDecls lp
         let parent = head tlDecs
         decls <- hsDecls parent
         balanceComments parent (head $ tail tlDecs)

         modifyAnnsT (setPrecedingLines newDecl 1 0)

         moveTrailingComments parent (last decls)
         parent' <- replaceDecls parent (decls++[newDecl])
         replaceDecls lp (parent':tail tlDecs)

  let (lp',(ans',_),_w) = runTransform ans doAddLocal
  return (mergeAnnList [declAnns',ans'],lp')

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

rmDecl1 :: Changer
rmDecl1 ans lp = do
  let doRmDecl = do
         tlDecs <- hsDecls lp
         let (d1:s1:d2:ds) = tlDecs

         -- First delete the decl only
         balanceComments d2 (head ds)
         lp1 <- replaceDecls lp (d1:s1:ds)

         -- Then delete the sig separately
         tlDecs1 <- hsDecls lp1
         let (d1':s1':ds') = tlDecs1
         balanceComments d1' s1'
         balanceComments s1' (head ds')
         replaceDecls lp (d1':ds')

  let (lp',(ans',_),_w) = runTransform ans doRmDecl
  return (ans',lp')

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

rmDecl2 :: Changer
rmDecl2 ans lp = do
  let
      doRmDecl = do
        let
          go :: GHC.HsExpr GHC.RdrName -> Transform (GHC.HsExpr GHC.RdrName)
          go (GHC.HsLet lb expr) = do
            decs <- hsDecls lb
            lb' <- replaceDecls lb (init decs)
            return (GHC.HsLet lb' expr)
          go x = return x

        SYB.everywhereM (SYB.mkM go) lp

  let (lp',(ans',_),_w) = runTransform ans doRmDecl
  return (ans',lp')

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

rmDecl3 :: Changer
rmDecl3 ans lp = do
  let
      doRmDecl = do
         tlDecs <- hsDecls lp
         let [d1] = tlDecs

         subDecs <- hsDecls d1
         let [sd1] = subDecs

         modifyAnnsT (setPrecedingLinesDecl sd1 2 0)
         d1' <- replaceDecls d1 []
         replaceDecls lp [d1',sd1]

  let (lp',(ans',_),_w) = runTransform ans doRmDecl
  return (ans',lp')

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

rmTypeSig1 :: Changer
rmTypeSig1 ans lp = do
  let doRmDecl = do
         tlDecs <- hsDecls lp
         let (s1:d1:d2) = tlDecs
             (GHC.L l (GHC.SigD (GHC.TypeSig names typ p))) = s1
             s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ p)))
         replaceDecls lp (s1':d1:d2)

  let (lp',(ans',_),_w) = runTransform ans doRmDecl
  return (ans',lp')

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