{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cabal.Internal.Newtypes where
import Control.Applicative (Alternative (..), liftA2)
import Data.Char (isSpace)
import Data.Function (on)
import Data.Functor.Identity (Identity (..))
import Data.Proxy (Proxy (..))
import Network.URI (URI, parseURI, uriToString)
import qualified Data.Set as S
import qualified Distribution.Compat.CharParsing as C
import qualified Distribution.Compat.Newtype as C
import qualified Distribution.FieldGrammar.Newtypes as C
import qualified Distribution.Parsec as C
import qualified Distribution.Pretty as C
import qualified Distribution.Version as C
import qualified Text.PrettyPrint as PP
-------------------------------------------------------------------------------
-- PackageLocation
-------------------------------------------------------------------------------
newtype PackageLocation = PackageLocation String
deriving anyclass (C.Newtype String)
-- | This is a bit tricky since it has to cover globs which have embedded @,@
-- chars. But we don't just want to parse strictly as a glob since we want to
-- allow http urls which don't parse as globs, and possibly some
-- system-dependent file paths. So we parse fairly liberally as a token, but
-- we allow @,@ inside matched @{}@ braces.
instance C.Parsec PackageLocation where
parsec = PackageLocation <$> outerTerm
where
outerTerm = ($ "") <$> outerChars
outerChars, outerChar, innerChars, innerChar :: C.CabalParsing m => m ShowS
outerChars = foldr (.) id <$> C.some outerChar
innerChars = foldr (.) id <$> C.many innerChar
outerChar = do
c <- C.satisfy $ \c -> not (isSpace c || c == '}' || c == ',')
kont c
innerChar = do
c <- C.satisfy $ \c -> not (isSpace c || c == '}')
kont c
kont :: C.CabalParsing m => Char -> m ShowS
kont c = case c of
'{' -> do
cs <- innerChars
c' <- C.char '}'
return (showChar c . cs . showChar c')
_ -> return $ showChar c
instance C.Pretty PackageLocation where
pretty (PackageLocation p) = PP.text p
-------------------------------------------------------------------------------
-- NoCommas: something which can be comma separated
-------------------------------------------------------------------------------
newtype NoCommas = NoCommas String
deriving anyclass (C.Newtype String)
instance C.Parsec NoCommas where
parsec = NoCommas <$> liftA2 (:) (C.satisfy (not . isSpace)) (C.munch (/= ','))
instance C.Pretty NoCommas where
pretty (NoCommas p) = PP.text p
-------------------------------------------------------------------------------
-- Head version
-------------------------------------------------------------------------------
newtype HeadVersion = HeadVersion { getHeadVersion :: Maybe C.Version }
deriving anyclass (C.Newtype (Maybe C.Version))
instance C.Parsec HeadVersion where
parsec = HeadVersion Nothing <$ C.string "head" <|>
HeadVersion . Just <$> C.parsec
instance C.Pretty HeadVersion where
pretty (HeadVersion Nothing) = PP.text "head"
pretty (HeadVersion (Just v)) = C.pretty v
-------------------------------------------------------------------------------
-- Newtype
-------------------------------------------------------------------------------
newtype Int' = Int' Int
deriving anyclass (C.Newtype Int)
instance C.Parsec Int' where
parsec = Int' <$> C.integral
instance C.Pretty Int' where
pretty (Int' i) = PP.int i
-------------------------------------------------------------------------------
-- Range
-------------------------------------------------------------------------------
newtype Range = Range C.VersionRange
deriving anyclass (C.Newtype C.VersionRange)
instance C.Parsec Range where
parsec = fmap Range $ C.parsec <|> fromBool <$> C.parsec where
fromBool True = C.anyVersion
fromBool False = C.noVersion
instance C.Pretty Range where
pretty (Range r)
| equivVersionRanges r C.anyVersion = C.pretty True
| equivVersionRanges r C.noVersion = C.pretty False
| otherwise = C.pretty r
-------------------------------------------------------------------------------
-- AlaSet
-------------------------------------------------------------------------------
newtype AlaSet sep b a = AlaSet { getAlaSet :: S.Set a }
deriving anyclass (C.Newtype (S.Set a))
alaSet :: sep -> S.Set a -> AlaSet sep (Identity a) a
alaSet _ = AlaSet
-- | More general version of 'alaSet'.
alaSet' :: sep -> (a -> b) -> S.Set a -> AlaSet sep b a
alaSet' _ _ = AlaSet
instance (C.Newtype a b, Ord a, C.Sep sep, C.Parsec b) => C.Parsec (AlaSet sep b a) where
parsec = C.pack . S.fromList . map (C.unpack :: b -> a) <$> C.parseSep (hack (Proxy :: Proxy sep)) C.parsec
instance (C.Newtype a b, C.Sep sep, C.Pretty b) => C.Pretty (AlaSet sep b a) where
pretty = C.prettySep (hack (Proxy :: Proxy sep)) . map (C.pretty . (C.pack :: a -> b)) . S.toList . C.unpack
-- Someone (= me) forgot to export Distribution.Parsec.Newtypes.P
hack :: Proxy a -> proxy a
hack _ = undefined
-------------------------------------------------------------------------------
-- WrapURI
-------------------------------------------------------------------------------
newtype WrappedURI = WrapURI URI
deriving anyclass (C.Newtype URI)
instance C.Parsec WrappedURI where
parsec = do
t <- C.parsecToken
case parseURI t of
Just x -> return (WrapURI x)
Nothing -> C.unexpected $ "Not an URI: " ++ t
instance C.Pretty WrappedURI where
pretty (WrapURI uri) = PP.text (uriToString id uri "")
-------------------------------------------------------------------------------
-- extras
-------------------------------------------------------------------------------
-- | Whether two ranges are equivalent.
equivVersionRanges :: C.VersionRange -> C.VersionRange -> Bool
equivVersionRanges = on (==) C.asVersionIntervals