WIP/RFC: LTS build constraints

.gitignore

@@ -9,3 +9,4 @@ check-plan.yaml
 /constraints.yaml
 /snapshot.yaml
 /snapshot-incomplete.yaml
+/constraints.yaml.previous

check-lts

@@ -0,0 +1,21 @@
+#!/bin/bash
+
+# Convenience script for checking constraints locally
+
+set -euxo pipefail
+
+cd `dirname $0`
+
+MAJOR=$1
+MINOR=$2
+LTS="lts-$MAJOR.$MINOR"
+
+echo "$MAJOR $MINOR $LTS"
+
+export GHCVER=$(sed -n "s/^ghc-version: \"\(.*\)\"/\1/p" "lts-$MAJOR-build-constraints.yaml")
+
+curator update &&
+  curator constraints --target=$LTS &&
+  curator snapshot-incomplete --target=$LTS &&
+  curator snapshot &&
+  stack --resolver ghc-$GHCVER exec curator check-snapshot

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,2 @@
+packages: ./lts-constraints.cabal
+with-compiler: ghc-9.4.7

etc/lts-constraints/cabal.project.local

@@ -0,0 +1,2 @@
+package *
+  ghc-options: -fwrite-ide-info

etc/lts-constraints/lts-constraints.cabal

@@ -0,0 +1,42 @@
+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:         [email protected]
+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
+  other-modules:
+    BuildConstraints
+    Snapshot
+    Types
+
+  build-depends:
+      aeson
+    , base                >=4.7 && <5
+    , Cabal
+    , containers
+    , mtl
+    , optparse-generic
+    , pantry
+    , parsec
+    , rio
+    , safe
+    , split
+    , string-conversions
+    , text
+    , transformers
+    , yaml

etc/lts-constraints/src/BuildConstraints.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# OPTIONS -Wno-name-shadowing #-}
+module BuildConstraints where
+
+import Control.Arrow
+import Data.Char
+import Data.Maybe
+import Data.String.Conversions
+import Distribution.Text (display, simpleParse)
+import Distribution.Types.VersionRange (VersionRange, normaliseVersionRange, anyVersion, intersectVersionRanges, majorBoundVersion, earlierVersion)
+import RIO.Map (Map)
+import RIO.Text (Text)
+import qualified Data.Text as T
+import qualified Distribution.Types.Version as C (mkVersion)
+import qualified RIO.Map as M
+
+import Types
+
+takeDropWhile :: (Char -> Bool) -> Text -> Maybe (Text, Text)
+takeDropWhile p s = if T.null a then Nothing else Just (a, b)
+  where
+    (a, b) = takeDropWhile_ p s
+
+takeDropWhile_ :: (Char -> Bool) -> Text -> (Text, Text)
+takeDropWhile_ p s = (T.takeWhile p s, T.dropWhile p s)
+
+takePrefix :: Text -> Text -> Maybe (Text, Text)
+takePrefix p s =
+  if p `T.isPrefixOf` s
+  then Just (p, T.drop (T.length p) s)
+  else Nothing
+
+takePackageName :: Text -> Maybe (PackageName, Text)
+takePackageName = fmap (first mkPackageName) . takeDropWhile (/= ' ')
+
+maybeTakeVersionRange :: Text -> (Maybe VersionRange, Text)
+maybeTakeVersionRange s = (simpleParse $ cs range, comment)
+  where
+    (range, comment) = takeDropWhile_ (/= '#') s
+
+parsePackageDecl :: Text -> Maybe PackageDecl
+parsePackageDecl s = do
+  (prefix, s0) <- takePrefix "        - " s
+  (package, s1) <- takePackageName s0
+  let (range, s2) = maybeTakeVersionRange s1
+  pure PackageDecl { prefix, package, range = fromMaybe anyVersion range, suffix = s2 }
+
+handlePackage :: Map PackageName Version -> PackageDecl -> Text
+handlePackage snap PackageDecl { prefix, package, range, suffix } =
+  prefix <> (cs . display . unPackageName) package <> rng <> suff
+  where
+    suff :: Text
+    suff = if T.null suffix then suffix else " " <> suffix
+
+    rng = case (majorBoundVersion . unVersion <$> snapshotVersion) `intersect` range of
+      Just rng | rng == anyVersion -> ""
+      Nothing -> ""
+      Just rng -> (" " <>) . (\(a,b) -> a <> " " <> b) . takeDropWhile_ (not . isDigit) . cs $ display rng
+    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)

etc/lts-constraints/src/Main.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS -Wno-name-shadowing #-}
+module Main (main) where
+
+import Control.Monad
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.State (MonadState (..), runStateT)
+import Data.Text (Text)
+import Options.Generic (getRecord, ParseRecord)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+import GHC.Generics (Generic)
+import RIO.Map (Map)
+import System.IO (openFile, IOMode (..), hFlush, hClose)
+
+import BuildConstraints (parsePackageDecl, handlePackage)
+import Snapshot (snapshotMap, loadSnapshot)
+import Types (PackageName, Version)
+
+src :: String
+src = "../../build-constraints.yaml"
+
+target :: Int -> String
+target major = "lts-" <> show major <> "-build-constraints.yaml"
+
+data Args = Args
+  { major :: Int
+  , baseSnapshotPath :: FilePath
+  } deriving Generic
+
+instance ParseRecord Args
+
+data State
+  = LookingForLibBounds
+  | ProcessingLibBounds
+  | Done
+
+main :: IO ()
+main = do
+  Args { major, baseSnapshotPath } <- getRecord "lts-constraints"
+  map <- snapshotMap <$> loadSnapshot baseSnapshotPath
+  output <- openFile (target major) WriteMode
+  let putLine = liftIO . T.hPutStrLn output
+  lines <- T.lines <$> T.readFile src
+  void $ flip runStateT LookingForLibBounds $ do
+    forM_ lines $ putLine <=< processLine map
+  hFlush output
+  hClose output
+  putStrLn $ "Done. Wrote to " <> target major
+
+processLine :: MonadState State m => Map PackageName Version -> Text -> m Text
+processLine map line = do
+  st <- get
+  case st of
+    LookingForLibBounds -> do
+      when (line == "packages:") $
+        put ProcessingLibBounds
+      pure line
+    ProcessingLibBounds ->
+      if line == "# end of packages"
+      then do
+        put Done
+        pure line
+      else
+        case parsePackageDecl line of
+          Just p -> pure $ handlePackage map p
+          Nothing -> pure line
+    Done -> pure line

etc/lts-constraints/src/Snapshot.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS -Wno-name-shadowing #-}
+module Snapshot (loadSnapshot, snapshotMap) where
+
+import Control.Arrow
+import Data.Aeson
+import GHC.Generics
+import RIO.Map (Map)
+import qualified Data.Text as T
+import qualified Data.Yaml as Y
+import qualified RIO.Map as M
+
+import Types
+
+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 s0
+    let s2 = T.takeWhile (/= '@') s1
+    let xs = T.splitOn "-" s2
+    pvPackage <- parseJSON $ String $ T.intercalate "-" (init xs)
+    pvVersion <- parseJSON $ String $ last xs
+    pure PackageVersion { pvPackage, pvVersion }
+
+snapshotMap :: Snapshot -> Map PackageName Version
+snapshotMap = M.fromList . map ((pvPackage &&& pvVersion) . hackage) . packages
+
+loadSnapshot :: FilePath -> IO Snapshot
+loadSnapshot = fmap (either (error . show) id) . Y.decodeFileEither

etc/lts-constraints/src/Types.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# OPTIONS -Wno-name-shadowing #-}
+module Types where
+
+import Control.Monad
+import Data.Aeson
+import Data.String.Conversions.Monomorphic
+import Distribution.Text (simpleParse)
+import Distribution.Types.VersionRange (VersionRange)
+import RIO.Text (Text)
+import qualified Distribution.Types.PackageName as C (PackageName, mkPackageName)
+import qualified Distribution.Types.Version as C (Version)
+
+newtype PackageName = PackageName { unPackageName :: C.PackageName }
+  deriving (Eq, Ord, FromJSONKey, Show)
+
+mkPackageName :: Text -> PackageName
+mkPackageName = PackageName . C.mkPackageName . fromStrictText
+
+instance FromJSON PackageName where
+  parseJSON = fmap (PackageName . C.mkPackageName) . parseJSON
+
+newtype Version = Version { unVersion :: C.Version }
+  deriving Show
+
+instance FromJSON Version where
+  parseJSON =
+    maybe (fail "Invalid Version") (pure . Version) . simpleParse <=< parseJSON
+
+
+data PackageDecl = PackageDecl
+  { prefix :: Text
+  , package :: PackageName
+  , range :: VersionRange
+  , suffix :: Text
+  }

etc/lts-constraints/stack.yaml

@@ -0,0 +1,4 @@
+resolver:
+  url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/0.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:
+    sha256: e176944bc843f740e05242fa7a66ca1f440c127e425254f7f1257f9b19add23f
+    size: 712153
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/0.yaml
+  original:
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/0.yaml

etc/lts-constraints/weeder.toml

@@ -0,0 +1,7 @@
+roots = ["Main.main","^Paths_.*"]
+
+type-class-roots = false
+
+root-instances = [{ class = "\\.IsString$" },{ class = "\\.IsList$" }]
+
+unused-types = false