cleanup

etc/lts-constraints/lts-constraints.cabal

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

@@ -1,30 +1,20 @@
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TupleSections #-}
 {-# OPTIONS -Wno-name-shadowing #-}
-module Main where
+module Main (main) where
 
-import Control.Arrow
 import Control.Monad
-import Control.Monad.State
+import Control.Monad.IO.Class (MonadIO (..))
-import Data.Aeson
+import Control.Monad.State (MonadState (..), runStateT)
-import Data.Char
+import Data.Text (Text)
-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 System.IO (openFile, IOMode (..), hFlush, hClose)
-import qualified Data.Yaml as Y
+import qualified Data.Text as T
-import qualified Distribution.Types.PackageName as C (PackageName, mkPackageName)
+import qualified Data.Text.IO as T
-import qualified Distribution.Types.Version as C (Version, mkVersion)
+
-import qualified RIO.Map as M
+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"
+  map <- snapshotMap <$> 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
+  let putLine = liftIO . T.hPutStrLn output
-  lines <- lines <$> readFile src
+  lines <- T.lines <$> T.readFile src
   void $ flip runStateT LookingForLibBounds $ do
-    forM_ lines $ \line -> do
+    forM_ lines $ putLine <=< processLine map
-      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
+
+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,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
+  }