content: {-# 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)
  