Add a nicer test case (by @edsko)

Author: bergmark

haskell-src-meta/src/Language/Haskell/Meta/Syntax/Translate.hs

@@ -601,10 +601,10 @@ instance ToDec (Exts.Decl l) where
 
   toDec (Exts.AnnPragma _ ann) = TH.PragmaD (TH.AnnP (target ann) (expann ann))
     where
-      target (Exts.Ann _ n _) = TH.ValueAnnotation (toName n)
+      target (Exts.Ann _ n _)     = TH.ValueAnnotation (toName n)
       target (Exts.TypeAnn _ n _) = TH.TypeAnnotation (toName n)
       target (Exts.ModuleAnn _ _) = TH.ModuleAnnotation
-      expann (Exts.Ann _ _ e) = toExp e
+      expann (Exts.Ann _ _ e)     = toExp e
       expann (Exts.TypeAnn _ _ e) = toExp e
       expann (Exts.ModuleAnn _ e) = toExp e
 

haskell-src-meta/tests/Main.hs

@@ -1,16 +1,22 @@
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Main where
 
-import qualified Control.Monad.Fail              as Fail
-import qualified Language.Haskell.Exts           as Exts
-import qualified Language.Haskell.Exts.Extension as Extension
-import qualified Language.Haskell.Exts.Parser    as Parser
+import qualified Control.Monad.Fail                     as Fail
+import           Data.Data                              (Data, cast, gfoldl)
+import           Data.Functor.Const
+  (Const (Const, getConst))
+import qualified Language.Haskell.Exts                  as Exts
+import qualified Language.Haskell.Exts.Extension        as Extension
+import qualified Language.Haskell.Exts.Parser           as Parser
 import           Language.Haskell.Meta.Parse
 import           Language.Haskell.Meta.Syntax.Translate
-import qualified Language.Haskell.TH             as TH
-import           Test.HUnit                      (Assertion, (@?=))
+import qualified Language.Haskell.TH                    as TH
+import           Test.HUnit                             (Assertion, (@?=))
 import           Test.Tasty
   (TestTree, defaultMain, testGroup)
-import           Test.Tasty.HUnit                (testCase)
+import           Test.Tasty.HUnit                       (testCase)
 
 type Test = TestTree
 
@@ -27,14 +33,38 @@ derivingClausesTest :: Test
 derivingClausesTest = testCase "Deriving clauses preserved" $
     roundTripDecls "data Foo = Foo deriving (A, B, C)"
 
--- Very ugly test, illustrating incorrect order of promoted type tuples reconstructed into TH
 orderInTypeTuples :: Test
-orderInTypeTuples = testCase "Ensure that type tuples reconstructed in proper order" $ do
-  let Parser.ParseOk parsed = show . toExp <$> Parser.parseExpWithMode mode "getField @'(\"a\", \"b\", \"c\") localVar"
-  parsed @?= expected
+orderInTypeTuples =
+  testCase "Ensure that type tuples reconstructed in proper order" $ do
+    expected @?= actual
+  where
+    expected :: [TH.TyLit]
+    expected = collectAll (toExp parsed)
+    actual   = [TH.StrTyLit "a", TH.StrTyLit "b"]
+
+    parsed :: Exts.Exp Exts.SrcSpanInfo
+    parsed = case Exts.parseExpWithMode mode "foo @'(\"a\", \"b\")" of
+      Exts.ParseOk v -> v
+      e              -> error $ show e
+    mode :: Exts.ParseMode
+    mode = Exts.defaultParseMode {
+          Exts.extensions = [
+              Exts.EnableExtension Exts.TypeApplications
+            , Exts.EnableExtension Exts.DataKinds
+            ]
+        }
+
+collectAll :: (Data a, Data b) => a -> [b]
+collectAll = ($ []) . go
   where
-    mode = Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.TypeApplications, Extension.EnableExtension Extension.DataKinds  ] }
-    expected = "(AppE (AppTypeE (VarE getField) (AppT (AppT (AppT (PromotedTupleT 3) (LitT (StrTyLit \"a\"))) (LitT (StrTyLit \"b\"))) (LitT (StrTyLit \"c\")))) (VarE localVar))"
+    go :: forall a b. (Data a, Data b) => a -> [b] -> [b]
+    go = \x ->
+        case cast x of
+          Just x' -> (x' :)
+          Nothing -> getConst $ gfoldl ap (const $ Const id) x
+      where
+        ap :: Data x => Const ([b] -> [b]) (x -> y) -> x -> Const ([b] -> [b]) y
+        ap (Const acc) x = Const $ acc . go x
 
 typeAppMode :: Exts.ParseMode
 typeAppMode = Parser.defaultParseMode { Parser.extensions = [Extension.EnableExtension Extension.TypeApplications] }