Implement #min-ghc keyword for test script

src-literatetests/10-tests.blt

@@ -365,6 +365,7 @@ data Foo = Bar
   deriving newtype (Traversable, Foldable)
 
 #test record deriving via
+#min-ghc 8.6
 data Foo = Bar
   { foo  :: Baz
   , bars :: Bizzz
@@ -424,13 +425,28 @@ data Foo = Bar
                   , -- e
                     FromJSON --f
                             ) -- g
-                              via  -- h
+
-                                  ( -- i
+#test record comments in deriving via
-                                   SomeType --j
+## maybe we want to switch to a differnt layout when there are such comments.
-                                           , -- k
+## Don't hesitate to modify this testcase, it clearly is not the ideal layout
-                                             ABC --l
+## for this.
+#min-ghc 8.6
+
+data Foo = Bar
+  { foo  :: Baz
+  , bars :: Bizzz
+  }
+  -- a
+  deriving --a
+           ToJSON --b
+                  via  -- c
+                      ( -- d
+                       SomeType --e
+                               , -- f
+                                 ABC --g
                                     )
 
+
 ###############################################################################
 ###############################################################################
 ###############################################################################

src-literatetests/Main.hs

@@ -1,13 +1,20 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
 
-module Main (main) where
+module Main
+  ( main
+  )
+where
 
 
 
 #include "prelude.inc"
 
 import           Test.Hspec
-import Test.Hspec.Runner ( hspecWith, defaultConfig, configConcurrentJobs )
+import           Test.Hspec.Runner              ( hspecWith
+                                                , defaultConfig
+                                                , configConcurrentJobs
+                                                )
 
 import           NeatInterpolation
 
@@ -32,11 +39,18 @@ import           System.FilePath ( (</>) )
 data InputLine
   = GroupLine Text
   | HeaderLine Text
+  | GhcVersionGuardLine Text
   | PendingLine
   | NormalLine Text
   | CommentLine
   deriving Show
 
+data TestCase = TestCase
+  { testName :: Text
+  , isPending :: Bool
+  , minGHCVersion :: Maybe Text
+  , content :: Text
+  }
 
 main :: IO ()
 main = do
@@ -49,23 +63,34 @@ main = do
   let groups = createChunks =<< inputs
   inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt"
   let groupsCtxFree = createChunks inputCtxFree
+  let parseVersion :: Text -> Maybe [Int]
+      parseVersion =
+        mapM (readMaybe . Text.unpack) . Text.splitOn (Text.pack ".")
+  let ghcVersion = Data.Maybe.fromJust $ parseVersion $ Text.pack VERSION_ghc
+  let checkVersion = \case
+        Nothing -> True -- no version constraint
+        Just s  -> case parseVersion s of
+          Nothing -> error $ "could not parse version " ++ Text.unpack s
+          Just v  -> v <= ghcVersion
   hspec $ do
     groups `forM_` \(groupname, tests) -> do
-      describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do
+      describe (Text.unpack groupname) $ do
-        (if pend then before_ pending else id)
+        tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do
-          $ it (Text.unpack name)
+          (if isPending test then before_ pending else id)
-          $ roundTripEqual defaultTestConfig inp
+            $ it (Text.unpack $ testName test)
+            $ roundTripEqual defaultTestConfig
+            $ content test
     groupsCtxFree `forM_` \(groupname, tests) -> do
-      describe ("context free: " ++ Text.unpack groupname)
+      describe ("context free: " ++ Text.unpack groupname) $ do
-        $       tests
+        tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do
-        `forM_` \(name, pend, inp) -> do
+          (if isPending test then before_ pending else id)
-                  (if pend then before_ pending else id)
+            $ it (Text.unpack $ testName test)
-                    $ it (Text.unpack name)
+            $ roundTripEqual contextFreeTestConfig
-                    $ roundTripEqual contextFreeTestConfig inp
+            $ content test
  where
   -- this function might be implemented in a weirdly complex fashion; the
   -- reason being that it was copied from a somewhat more complex variant.
-  createChunks :: Text -> [(Text, [(Text, Bool, Text)])]
+  createChunks :: Text -> [(Text, [TestCase])]
   createChunks input =
 --    fmap (\case
 --        HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines)
@@ -73,35 +98,39 @@ main = do
 --        l -> error $ "first non-empty line must start with #test footest\n" ++ show l
 --      )
 --      $   fmap (groupBy grouperT)
-    fmap
+    fmap groupProcessor
-        ( \case
+      $ groupBy grouperG
+      $ filter (not . lineIsSpace)
+      $ fmap lineMapper
+      $ Text.lines input
+   where
+    groupProcessor :: [InputLine] -> (Text, [TestCase])
+    groupProcessor = \case
       GroupLine g : grouprest ->
         (,) g
-              $ fmap
+          $ fmap testProcessor
-                  ( \case
-                    HeaderLine n:PendingLine:rest | Just rlines <- mapM
-                      extractNormal
-                      rest ->
-                      (n, True, Text.unlines rlines)
-                    HeaderLine n:rest | Just rlines <- mapM extractNormal rest ->
-                      (n, False, Text.unlines rlines)
-                    l ->
-                      error
-                        $ "first non-empty line must start with #test footest\n"
-                        ++ show l
-                  )
           $ groupBy grouperT
           $ filter (not . lineIsSpace)
           $ grouprest
       l -> error $ "first non-empty line must be a #group\n" ++ show l
-        )
+    testProcessor :: [InputLine] -> TestCase
-      $   groupBy grouperG
+    testProcessor = \case
-      $   filter (not . lineIsSpace)
+      HeaderLine n : rest ->
-      $   lineMapper
+        let normalLines = Data.Maybe.mapMaybe extractNormal rest
-      <$> Text.lines input
+        in  TestCase
-   where
+              { testName      = n
+              , isPending     = any isPendingLine rest
+              , minGHCVersion = Data.List.Extra.firstJust extractMinGhc rest
+              , content       = Text.unlines normalLines
+              }
+      l ->
+        error $ "first non-empty line must start with #test footest\n" ++ show l
     extractNormal (NormalLine l) = Just l
     extractNormal _              = Nothing
+    extractMinGhc (GhcVersionGuardLine v) = Just v
+    extractMinGhc _                       = Nothing
+    isPendingLine PendingLine{} = True
+    isPendingLine _             = False
     specialLineParser :: Parser InputLine
     specialLineParser = Parsec.choice
       [ [ GroupLine $ Text.pack name
@@ -116,6 +145,11 @@ main = do
         , name <- Parsec.many1 $ Parsec.noneOf "\r\n:"
         , _    <- Parsec.eof
         ]
+      , [ GhcVersionGuardLine $ Text.pack version
+        | _       <- Parsec.try $ Parsec.string "#min-ghc"
+        , _       <- Parsec.many1 $ Parsec.oneOf " \t"
+        , version <- Parsec.many1 $ Parsec.noneOf "\r\n:"
+        ]
       , [ PendingLine
         | _ <- Parsec.try $ Parsec.string "#pending"
         , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n")
@@ -123,8 +157,8 @@ main = do
         ]
       , [ CommentLine
         | _ <- Parsec.many $ Parsec.oneOf " \t"
-        , _ <-
+        , _ <- Parsec.optional $ Parsec.string "##" <* many
-          Parsec.optional $ Parsec.string "##" <* many (Parsec.noneOf "\r\n")
+          (Parsec.noneOf "\r\n")
         , _ <- Parsec.eof
         ]
       ]
@@ -148,8 +182,7 @@ main = do
 --------------------
 roundTripEqual :: Config -> Text -> Expectation
 roundTripEqual c t =
-  fmap (fmap PPTextWrapper)
+  fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t)
-       (parsePrintModuleTests c "TestFakeFileName.hs" t)
     `shouldReturn` Right (PPTextWrapper t)
 
 newtype PPTextWrapper = PPTextWrapper Text
@@ -158,7 +191,8 @@ newtype PPTextWrapper = PPTextWrapper Text
 instance Show PPTextWrapper where
   show (PPTextWrapper t) = "\n" ++ Text.unpack t
 
-
+-- brittany-next-binding --columns 160
+-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
 defaultTestConfig :: Config
 defaultTestConfig = Config
   { _conf_version                   = _conf_version staticDefaultConfig
@@ -181,9 +215,7 @@ defaultTestConfig = Config
     , _lconfig_allowHangingQuasiQuotes   = coerce True
     , _lconfig_experimentalSemicolonNewlines = coerce False
     }
-  , _conf_errorHandling             = (_conf_errorHandling staticDefaultConfig)
+  , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True }
-    { _econf_omit_output_valid_check = coerce True
-    }
   , _conf_preprocessor              = _conf_preprocessor staticDefaultConfig
   , _conf_forward                   = ForwardOptions { _options_ghc = Identity [] }
   , _conf_roundtrip_exactprint_only = coerce False
@@ -191,8 +223,7 @@ defaultTestConfig = Config
   }
 
 contextFreeTestConfig :: Config
-contextFreeTestConfig =
+contextFreeTestConfig = defaultTestConfig
-  defaultTestConfig
   { _conf_layout = (_conf_layout defaultTestConfig)
                      { _lconfig_indentPolicy    = coerce IndentPolicyLeft
                      , _lconfig_alignmentLimit  = coerce (1 :: Int)