never executed always true always false

    1 {-# LANGUAGE ConstraintKinds      #-}
    2 {-# LANGUAGE DeriveAnyClass       #-}
    3 {-# LANGUAGE DeriveGeneric        #-}
    4 {-# LANGUAGE FlexibleContexts     #-}
    5 {-# LANGUAGE OverloadedStrings    #-}
    6 {-# LANGUAGE RankNTypes           #-}
    7 {-# LANGUAGE StandaloneDeriving   #-}
    8 {-# LANGUAGE UndecidableInstances #-}
    9 module Distribution.Client.Types.SourceRepo (
   10     SourceRepositoryPackage (..),
   11     SourceRepoList,
   12     SourceRepoMaybe,
   13     SourceRepoProxy,
   14     srpHoist,
   15     srpToProxy,
   16     srpFanOut,
   17     sourceRepositoryPackageGrammar,
   18 ) where
   19 
   20 import Distribution.Client.Compat.Prelude
   21 import Distribution.Compat.Lens           (Lens, Lens')
   22 import Prelude ()
   23 
   24 import Distribution.FieldGrammar
   25 import Distribution.Types.SourceRepo (RepoType (..))
   26 
   27 -- | @source-repository-package@ definition
   28 --
   29 data SourceRepositoryPackage f = SourceRepositoryPackage
   30     { srpType     :: !RepoType
   31     , srpLocation :: !String
   32     , srpTag      :: !(Maybe String)
   33     , srpBranch   :: !(Maybe String)
   34     , srpSubdir   :: !(f FilePath)
   35     , srpCommand  :: ![String]
   36     }
   37   deriving (Generic)
   38 
   39 deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f)
   40 deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f)
   41 deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f)
   42 deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f)
   43 deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f)
   44 
   45 -- | Read from @cabal.project@
   46 type SourceRepoList  = SourceRepositoryPackage []
   47 
   48 -- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo'
   49 type SourceRepoMaybe = SourceRepositoryPackage Maybe
   50 
   51 -- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory.
   52 type SourceRepoProxy = SourceRepositoryPackage Proxy
   53 
   54 srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g
   55 srpHoist nt s = s { srpSubdir = nt (srpSubdir s) }
   56 
   57 srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy
   58 srpToProxy s = s { srpSubdir = Proxy }
   59 
   60 -- | Split single @source-repository-package@ declaration with multiple subdirs,
   61 -- into multiple ones with at most single subdir.
   62 srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe)
   63 srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } =
   64     s { srpSubdir = Nothing } :| []
   65 srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where
   66     f subdir = s { srpSubdir = Just subdir }
   67 
   68 -------------------------------------------------------------------------------
   69 -- Lens
   70 -------------------------------------------------------------------------------
   71 
   72 srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType
   73 srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s))
   74 {-# INLINE srpTypeLens #-}
   75 
   76 srpLocationLens :: Lens' (SourceRepositoryPackage f) String
   77 srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s))
   78 {-# INLINE srpLocationLens #-}
   79 
   80 srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String)
   81 srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s))
   82 {-# INLINE srpTagLens #-}
   83 
   84 srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String)
   85 srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s))
   86 {-# INLINE srpBranchLens #-}
   87 
   88 srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath)
   89 srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s))
   90 {-# INLINE srpSubdirLens #-}
   91 
   92 srpCommandLensNE :: Lens' (SourceRepositoryPackage f) (Maybe (NonEmpty String))
   93 srpCommandLensNE f s = fmap (\x -> s { srpCommand = maybe [] toList x }) (f (nonEmpty (srpCommand s)))
   94 {-# INLINE srpCommandLensNE #-}
   95 
   96 -------------------------------------------------------------------------------
   97 -- Parser & PPrinter
   98 -------------------------------------------------------------------------------
   99 
  100 sourceRepositoryPackageGrammar
  101     :: ( FieldGrammar c g, Applicative (g SourceRepoList)
  102        , c (Identity RepoType)
  103        , c (List NoCommaFSep FilePathNT String)
  104        , c (NonEmpty' NoCommaFSep Token String)
  105        )
  106     => g SourceRepoList SourceRepoList
  107 sourceRepositoryPackageGrammar = SourceRepositoryPackage
  108     <$> uniqueField      "type"                                       srpTypeLens
  109     <*> uniqueFieldAla   "location" Token                             srpLocationLens
  110     <*> optionalFieldAla "tag"      Token                             srpTagLens
  111     <*> optionalFieldAla "branch"   Token                             srpBranchLens
  112     <*> monoidalFieldAla "subdir"   (alaList' NoCommaFSep FilePathNT) srpSubdirLens  -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there...
  113     <*> fmap (maybe [] toList) pcc
  114   where
  115     pcc = optionalFieldAla "post-checkout-command" (alaNonEmpty' NoCommaFSep Token) srpCommandLensNE
  116 {-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-}
  117 {-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-}