Support for lts-build-constraints.yaml generation

etc/lts-constraints/LICENSE

@@ -0,0 +1,30 @@
+Copyright Author name here (c) 2021
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

etc/lts-constraints/README.md

@@ -0,0 +1 @@
+# lts-constraints

etc/lts-constraints/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

etc/lts-constraints/cabal.project

@@ -0,0 +1,6 @@
+source-repository-package
+  type: git
+  location: git://github.com/commercialhaskell/pantry.git
+
+packages: ./lts-constraints.cabal
+with-compiler: ghc-8.10.7

etc/lts-constraints/lts-constraints.cabal

@@ -0,0 +1,34 @@
+name:                lts-constraints
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://github.com/githubuser/lts-constraints#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Author name here
+maintainer:          example@example.com
+copyright:           2021 Author name here
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+extra-source-files:  README.md
+
+executable lts-constraints
+  ghc-options:         -Wall
+  hs-source-dirs:      src
+  main-is:             Main.hs
+  default-language:    Haskell2010
+  build-depends:       base >= 4.7 && < 5
+                     , pantry
+                     , Cabal
+                     , rio
+                     , containers
+                     , parsec
+                     , mtl
+                     , aeson
+                     , yaml
+                     , split
+                     , string-conversions
+                     , safe
+                     , mtl
+                     , transformers

etc/lts-constraints/src/Main.hs

@@ -0,0 +1,174 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS -Wno-name-shadowing #-}
+module Main where
+
+import Control.Arrow
+import Control.Monad
+import Control.Monad.State
+import Data.Aeson
+import Data.Char
+import Data.List
+import Data.List.Split
+import Data.Maybe
+import Data.String.Conversions
+import Distribution.Text (display, simpleParse)
+import Distribution.Types.VersionRange (VersionRange, normaliseVersionRange, anyVersion, intersectVersionRanges, majorBoundVersion, earlierVersion)
+import GHC.Generics
+import RIO ()
+import RIO.Map (Map)
+import System.IO
+import qualified Data.Yaml as Y
+import qualified Distribution.Types.PackageName as C (PackageName, mkPackageName)
+import qualified Distribution.Types.Version as C (Version, mkVersion)
+import qualified RIO.Map as M
+
+src :: String
+src = "../../build-constraints.yaml"
+
+target :: String
+target = "../../lts-build-constraints.yaml"
+
+newtype PackageName = PackageName { unPackageName :: C.PackageName }
+  deriving (Eq, Generic, Ord, FromJSONKey, Show)
+
+instance FromJSON PackageName where
+  parseJSON = fmap (PackageName . C.mkPackageName) . parseJSON
+
+newtype Version = Version { unVersion :: C.Version }
+  deriving (Generic, Show)
+
+instance FromJSON Version where
+  parseJSON v = do
+    s <- parseJSON @ String v
+    case simpleParse s of
+      Nothing -> fail "Invalid Version"
+      Just v -> pure $ Version v
+
+
+data PackageDecl = PackageDecl
+  { prefix :: String
+  , package :: PackageName
+  , range :: VersionRange
+  , suffix :: String
+  }
+
+takeDropWhile :: (Char -> Bool) -> String -> Maybe (String, String)
+takeDropWhile p s = if null a then Nothing else Just (a, b)
+  where
+    (a, b) = takeDropWhile_ p s
+
+takeDropWhile_ :: (Char -> Bool) -> String -> (String, String)
+takeDropWhile_ p s = (takeWhile p s, dropWhile p s)
+
+takePrefix :: String -> String -> Maybe (String, String)
+takePrefix p s =
+  if p `isPrefixOf` s
+  then Just (p, drop (length p) s)
+  else Nothing
+
+takePackageName :: String -> Maybe (PackageName, String)
+takePackageName = fmap (first (PackageName . C.mkPackageName)) . takeDropWhile (/= ' ')
+
+maybeTakeVersionRange :: String -> (Maybe VersionRange, String)
+maybeTakeVersionRange s = (simpleParse range, comment)
+  where
+    (range, comment) = takeDropWhile_ (/= '#') s
+
+p_packageDecl :: String -> Maybe PackageDecl
+p_packageDecl s = do
+  (prefix, s') <- takePrefix "        - " s
+  (package, s'') <- takePackageName s'
+  let (range, s''') = maybeTakeVersionRange s''
+  pure PackageDecl { prefix, package, range = fromMaybe anyVersion range, suffix = s''' }
+
+handlePackage :: Map PackageName Version -> PackageDecl -> String
+handlePackage snap PackageDecl { prefix, package, range, suffix } =
+  prefix ++ display (unPackageName package) ++ rng ++ suff
+  where
+    suff = if null suffix then suffix else (' ': suffix)
+
+
+    rng = case intersect (majorBoundVersion . unVersion <$> snapshotVersion) range of
+      Just rngI | rngI == anyVersion -> ""
+      Nothing -> ""
+      Just rngI -> (' ' :) . (\(a,b) -> a <> " " <> b) . takeDropWhile_ (not . isDigit) $ display rngI
+    snapshotVersion = M.lookup package snap
+
+    intersect Nothing _ = Just . earlierVersion $ C.mkVersion [0] -- package not in snapshot
+    intersect (Just a) b =
+      if b == anyVersion -- drop `&& -any`
+      then Just a
+      else Just $ normaliseVersionRange (intersectVersionRanges a b)
+
+
+data Snapshot = Snapshot
+  { packages :: [SnapshotPackage]
+  } deriving (FromJSON, Generic, Show)
+
+data SnapshotPackage = SnapshotPackage
+  { hackage :: PackageVersion
+  } deriving (FromJSON, Generic, Show)
+
+data PackageVersion = PackageVersion
+  { pvPackage :: PackageName
+  , pvVersion :: Version
+  } deriving Show
+
+instance FromJSON PackageVersion where
+  parseJSON s0 = do
+    s1 <- parseJSON @ String s0
+    let s2 = takeWhile (/= '@') s1
+    let xs = splitOn "-" s2
+    pvPackage <- parseJSON $ String $ cs $ intercalate "-" (init xs)
+    pvVersion <- parseJSON $ String $ cs $ last xs
+    pure PackageVersion { pvPackage, pvVersion }
+
+
+snapshotMap :: Snapshot -> Map PackageName Version
+snapshotMap = M.fromList . map ((pvPackage &&& pvVersion) . hackage) . packages
+
+loadSnapshot :: FilePath -> IO (Either Y.ParseException Snapshot)
+loadSnapshot f = Y.decodeFileEither f
+
+data State
+  = LookingForLibBounds
+  | ProcessingLibBounds
+  | Done
+
+io :: MonadIO m => IO a -> m a
+io = liftIO
+
+main :: IO ()
+main = do
+  snapshot_ <- loadSnapshot "../../nightly-2012-12-11.yaml"
+  let snapshot = case snapshot_ of
+        Left err -> error $ show err
+        Right r -> r
+  let map = snapshotMap snapshot
+  output <- openFile target WriteMode
+  let putLine = io . hPutStrLn output
+  lines <- lines <$> readFile src
+  void $ flip runStateT LookingForLibBounds $ do
+    forM_ lines $ \line -> do
+      st <- get
+      case st of
+        LookingForLibBounds -> do
+          when (line == "packages:") $
+            put ProcessingLibBounds
+          putLine line
+        ProcessingLibBounds ->
+          if line == "# end of packages"
+          then do
+            put Done
+            putLine line
+          else
+            case p_packageDecl line of
+              Just p -> putLine $ handlePackage map p
+              Nothing -> putLine line
+        Done -> putLine line
+  hFlush output
+  hClose output

etc/lts-constraints/stack.yaml

@@ -0,0 +1,4 @@
+resolver:
+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/18.yaml
+packages:
+- .

etc/lts-constraints/stack.yaml.lock

@@ -0,0 +1,13 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 586296
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/18.yaml
+    sha256: 63539429076b7ebbab6daa7656cfb079393bf644971156dc349d7c0453694ac2
+  original:
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/18.yaml