From 4729720073be9245a0350f8b419e5da5b1163c77 Mon Sep 17 00:00:00 2001 From: Adam Bergmark Date: Mon, 20 Dec 2021 21:36:36 +0100 Subject: [PATCH] cleanup --- etc/lts-constraints/lts-constraints.cabal | 67 +++---- etc/lts-constraints/src/BuildConstraints.hs | 66 +++++++ etc/lts-constraints/src/Main.hs | 188 ++++---------------- etc/lts-constraints/src/Snapshot.hs | 44 +++++ etc/lts-constraints/src/Types.hs | 39 ++++ 5 files changed, 222 insertions(+), 182 deletions(-) create mode 100644 etc/lts-constraints/src/BuildConstraints.hs create mode 100644 etc/lts-constraints/src/Snapshot.hs create mode 100644 etc/lts-constraints/src/Types.hs diff --git a/etc/lts-constraints/lts-constraints.cabal b/etc/lts-constraints/lts-constraints.cabal index 9af3b1d0..9edf39a7 100644 --- a/etc/lts-constraints/lts-constraints.cabal +++ b/etc/lts-constraints/lts-constraints.cabal @@ -1,34 +1,41 @@ -name: lts-constraints -version: 0.1.0.0 +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 +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 + 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 + , pantry + , parsec + , rio + , safe + , split + , string-conversions + , text + , transformers + , yaml diff --git a/etc/lts-constraints/src/BuildConstraints.hs b/etc/lts-constraints/src/BuildConstraints.hs new file mode 100644 index 00000000..90e2ce6d --- /dev/null +++ b/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) diff --git a/etc/lts-constraints/src/Main.hs b/etc/lts-constraints/src/Main.hs index 2c54fb28..8b22e7e3 100644 --- a/etc/lts-constraints/src/Main.hs +++ b/etc/lts-constraints/src/Main.hs @@ -1,30 +1,20 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS -Wno-name-shadowing #-} -module Main where +module Main (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 Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.State (MonadState (..), runStateT) +import Data.Text (Text) 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 +import System.IO (openFile, IOMode (..), hFlush, hClose) +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import BuildConstraints (parsePackageDecl, handlePackage) +import Snapshot (snapshotMap, loadSnapshot) +import Types (PackageName, Version) src :: String src = "../../build-constraints.yaml" @@ -32,143 +22,37 @@ 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 + map <- snapshotMap <$> loadSnapshot "../../nightly-2012-12-11.yaml" output <- openFile target WriteMode - let putLine = io . hPutStrLn output - lines <- lines <$> readFile src + let putLine = liftIO . T.hPutStrLn output + lines <- T.lines <$> T.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 + forM_ lines $ putLine <=< processLine map hFlush output hClose output + +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 diff --git a/etc/lts-constraints/src/Snapshot.hs b/etc/lts-constraints/src/Snapshot.hs new file mode 100644 index 00000000..d2c98ecd --- /dev/null +++ b/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 diff --git a/etc/lts-constraints/src/Types.hs b/etc/lts-constraints/src/Types.hs new file mode 100644 index 00000000..4e14ad9b --- /dev/null +++ b/etc/lts-constraints/src/Types.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# 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 GHC.Generics +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, Generic, 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 (Generic, 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 + }