Merge pull request #25 from avnik/fix-order-of-promoted-type-tuples

Fix order of promoted type tuples in resulting TH

Author: bergmark

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

@@ -424,7 +424,7 @@ instance ToType (Exts.Type l) where
     Exts.PromotedString _ _ s -> TH.LitT $ TH.StrTyLit s
     Exts.PromotedCon _ _q n -> TH.PromotedT $ toName n
     Exts.PromotedList _ _q ts -> foldr (\t pl -> TH.PromotedConsT `TH.AppT` toType t `TH.AppT` pl) TH.PromotedNilT ts
-    Exts.PromotedTuple _ ts -> foldr (\t pt -> pt `TH.AppT` toType t) (TH.PromotedTupleT $ length ts) ts
+    Exts.PromotedTuple _ ts -> foldl (\pt t -> pt `TH.AppT` toType t) (TH.PromotedTupleT $ length ts) ts
     Exts.PromotedUnit _ -> TH.PromotedT ''()
   toType (Exts.TyEquals _ t1 t2) = TH.EqualityT `TH.AppT` toType t1 `TH.AppT` toType t2
   toType t@Exts.TySplice{} = noTH "toType" t
@@ -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,15 +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 qualified Language.Haskell.TH             as TH
-import           Test.HUnit                      (Assertion, (@?=))
+import           Language.Haskell.Meta.Syntax.Translate
+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
 
@@ -19,12 +26,46 @@ main = defaultMain (testGroup "unit" tests)
 tests :: [Test]
 tests = [ derivingClausesTest
         , typeAppTest
+        , orderInTypeTuples
         ]
 
 derivingClausesTest :: Test
 derivingClausesTest = testCase "Deriving clauses preserved" $
     roundTripDecls "data Foo = Foo deriving (A, B, C)"
 
+orderInTypeTuples :: Test
+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
+    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] }
 

scripts/format/make-stylish.sh

@@ -5,5 +5,5 @@ find . \
   -name "*.hs" \
   -and -not -path "*/.stack-work/*" \
   -and -not -path "*/dist/*" \
-  -and -not -path "*/dist-newstyle/*" \
+  -and -not -path "*/*dist-newstyle*/*" \
   -exec stylish-haskell -i {} \;