Skip to content

Introduce Distribution.Compat.Lens #4701

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 4 commits into from
Aug 17, 2017
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
8 changes: 8 additions & 0 deletions Cabal/Cabal.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -265,6 +265,7 @@ library
Language.Haskell.Extension
Distribution.Compat.Binary

-- Parsec parser relatedmodules
build-depends:
transformers,
parsec >= 3.1.9 && <3.2
Expand All @@ -283,6 +284,13 @@ library
Distribution.Parsec.Types.FieldDescr
Distribution.Parsec.Types.ParseResult

-- Lens functionality
exposed-modules:
Distribution.Compat.Lens
Distribution.Types.BuildInfo.Lens
Distribution.Types.PackageDescription.Lens
Distribution.Types.GenericPackageDescription.Lens

other-modules:
Distribution.Backpack.PreExistingComponent
Distribution.Backpack.ReadyComponent
Expand Down
203 changes: 203 additions & 0 deletions Cabal/Distribution/Compat/Lens.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,203 @@
{-# LANGUAGE RankNTypes #-}
-- | This module provides very basic lens functionality, without extra dependencies.
--
-- For the documentation of the combinators see <http://hackage.haskell.org/package/lens lens> package.
-- This module uses the same vocabulary.
module Distribution.Compat.Lens (
-- * Types
Lens,
Lens',
Traversal,
Traversal',
-- ** rank-1 types
Getting,
ASetter,
-- * Getter
view,
-- * Setter
set,
over,
-- * Fold
toDListOf,
toListOf,
toSetOf,
-- * Common lenses
_1, _2,
-- * Operators
(&),
(.~), (%~),
(?~),
-- * Cabal developer info
-- $development
) where

import Prelude()
import Distribution.Compat.Prelude

import Control.Applicative (Const (..))
import Data.Functor.Identity (Identity (..))

import qualified Distribution.Compat.DList as DList
import qualified Data.Set as Set

-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------

type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t

type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
type Traversal' s a = forall f. Applicative f => (a -> f a) -> s -> f s

type Getting r s a = (a -> Const r a) -> s -> Const r s
type ASetter s t a b = (a -> Identity b) -> s -> Identity t

-------------------------------------------------------------------------------
-- Getter
-------------------------------------------------------------------------------

view :: s -> Getting a s a -> a
view s l = getConst (l Const s)

-------------------------------------------------------------------------------
-- Setter
-------------------------------------------------------------------------------

set :: ASetter s t a b -> b -> s -> t
set l x = over l (const x)

over :: ASetter s t a b -> (a -> b) -> s -> t
over l f s = runIdentity (l (\x -> Identity (f x)) s)

-------------------------------------------------------------------------------
-- Fold
-------------------------------------------------------------------------------

toDListOf :: Getting (DList.DList a) s a -> s -> DList.DList a
toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s)

toListOf :: Getting (DList.DList a) s a -> s -> [a]
toListOf l = DList.runDList . toDListOf l

toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a
toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s)

-------------------------------------------------------------------------------
-- Lens
-------------------------------------------------------------------------------

{-
lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
lens sa sbt afb s = sbt s <$> afb (sa s)
-}

-------------------------------------------------------------------------------
-- Common
-------------------------------------------------------------------------------

_1 :: Lens (a, c) (b, c) a b
_1 f (a, c) = flip (,) c <$> f a

_2 :: Lens (c, a) (c, b) a b
_2 f (c, a) = (,) c <$> f a

-------------------------------------------------------------------------------
-- Operators
-------------------------------------------------------------------------------


-- | '&' is a reverse application operator
(&) :: a -> (a -> b) -> b
(&) = flip ($)
{-# INLINE (&) #-}
infixl 1 &

infixr 4 .~, %~, ?~

(.~) :: ASetter s t a b -> b -> s -> t
(.~) = set
{-# INLINE (.~) #-}

(?~) :: ASetter s t a (Maybe b) -> b -> s -> t
l ?~ b = set l (Just b)
{-# INLINE (?~) #-}

(%~) :: ASetter s t a b -> (a -> b) -> s -> t
(%~) = over
{-# INLINE (%~) #-}

-------------------------------------------------------------------------------
-- Documentation
-------------------------------------------------------------------------------

-- $development
--
-- We cannot depend on @template-haskell@, because Cabal is a boot library.
-- This fact makes defining optics a manual task. Here is a small recipe to
-- make the process less tedious.
--
-- First start a repl with proper-lens dependency
--
-- > cabal new-repl Cabal:lib:Cabal ???
Copy link
Member

@hvr hvr Aug 17, 2017

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes, the documented but not yet implemented extra-packages: is supposed to provide just that; but until it is implemented, a cabal flag

if flag(deploy-lens-missiles)
   build-depends: lens >= ... && < ...

is a reasonable temporary workaround.

PS: I already have an idea, how we can generate the code w/o dragging in lens nor requiring TH during the generation time. Just needs an afternoon to implement...

--
-- or
--
-- > stack ghci Cabal:lib --package lens
--
-- Then enable Template Haskell and the dumping of splices:
--
-- > :set -XTemplateHaskell -ddump-slices
--
-- Now we can derive lenses, load appropriate modules:
--
-- > :m Control.Lens Distribution.PackageDescription
--
-- and let Template Haskell do the job:
--
-- > ; makeLensesWith (lensRules & lensField .~ mappingNamer return) ''GenericPackageDescription
--
-- At this point, we will get unfancy splices looking like
--
-- @
-- condBenchmarks ::
-- 'Lens'' GenericPackageDescription [(UnqualComponentName,
-- CondTree ConfVar [Dependency] Benchmark)]
-- condBenchmarks
-- f_a2UEg
-- (GenericPackageDescription x1_a2UEh
-- x2_a2UEi
-- x3_a2UEj
-- x4_a2UEk
-- x5_a2UEl
-- x6_a2UEm
-- x7_a2UEn
-- x8_a2UEo)
-- = fmap
-- (\\ y1_a2UEp
-- -> GenericPackageDescription
-- x1_a2UEh
-- x2_a2UEi
-- x3_a2UEj
-- x4_a2UEk
-- x5_a2UEl
-- x6_a2UEm
-- x7_a2UEn
-- y1_a2UEp)
-- (f_a2UEg x8_a2UEo)
-- {-\# INLINE condBenchmarks \#-}
-- @
--
-- yet they can be cleaned up with e.g. VIM magic regexp and @hindent@:
--
-- > :%s/\v(\w+)_\w+/\1/g
-- > :%!hindent --indent-size 4 --line-length 200
--
-- Resulting into
--
-- @
-- condBenchmarks :: 'Lens'' GenericPackageDescription [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
-- condBenchmarks f (GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 x8) =
-- fmap (\\y1 -> GenericPackageDescription x1 x2 x3 x4 x5 x6 x7 y1) (f x8)
-- {-\# INLINE condBenchmarks \#-}
-- @
52 changes: 18 additions & 34 deletions Cabal/Distribution/PackageDescription/Check.hs
Original file line number Diff line number Diff line change
Expand Up @@ -45,7 +45,6 @@ import Distribution.License
import Distribution.Simple.BuildPaths (autogenPathsModuleName)
import Distribution.Simple.BuildToolDepends
import Distribution.Simple.CCompiler
import Distribution.Types.BuildInfo
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.CondTree
import Distribution.Types.Dependency
Expand All @@ -60,7 +59,6 @@ import Distribution.Text
import Distribution.Utils.Generic (isAscii)
import Language.Haskell.Extension

import Control.Applicative (Const (..))
import Control.Monad (mapM)
import qualified Data.ByteString.Lazy as BS
import Data.List (group)
Expand All @@ -80,6 +78,11 @@ import System.FilePath.Windows as FilePath.Windows

import qualified Data.Set as Set

import Distribution.Compat.Lens
import qualified Distribution.Types.BuildInfo.Lens as L
import qualified Distribution.Types.PackageDescription.Lens as L
import qualified Distribution.Types.GenericPackageDescription.Lens as L

-- | Results of some kind of failed package check.
--
-- There are a range of severities, from merely dubious to totally insane.
Expand Down Expand Up @@ -1626,23 +1629,17 @@ checkUnusedFlags gpd
s = commaSep . map unFlagName . Set.toList

declared :: Set.Set FlagName
declared = Set.fromList $ map flagName $ genPackageFlags gpd
declared = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd

used :: Set.Set FlagName
used = Set.fromList $ DList.runDList $ getConst $
(traverse . traverseCondTreeV) tellFlag (condLibrary gpd) *>
(traverse . _2 . traverseCondTreeV) tellFlag (condSubLibraries gpd) *>
(traverse . _2 . traverseCondTreeV) tellFlag (condForeignLibs gpd) *>
(traverse . _2 . traverseCondTreeV) tellFlag (condExecutables gpd) *>
(traverse . _2 . traverseCondTreeV) tellFlag (condTestSuites gpd) *>
(traverse . _2 . traverseCondTreeV) tellFlag (condBenchmarks gpd)

_2 :: Functor f => (a -> f b) -> (c, a) -> f (c, b)
_2 f (c, a) = (,) c <$> f a

tellFlag :: ConfVar -> Const (DList.DList FlagName) ConfVar
tellFlag (Flag fn) = Const (DList.singleton fn)
tellFlag _ = Const mempty
used = mconcat
[ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._Flag) gpd
, toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._Flag) gpd
, toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._Flag) gpd
, toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._Flag) gpd
, toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._Flag) gpd
, toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._Flag) gpd
]

checkUnicodeXFields :: GenericPackageDescription -> [PackageCheck]
checkUnicodeXFields gpd
Expand All @@ -1657,23 +1654,10 @@ checkUnicodeXFields gpd
nonAsciiXFields = [ n | (n, _) <- xfields, any (not . isAscii) n ]

xfields :: [(String,String)]
xfields = DList.runDList $ getConst $
tellXFieldsPD (packageDescription gpd) *>
(traverse . traverse . buildInfo_) tellXFields (condLibrary gpd) *>
(traverse . _2 . traverse . buildInfo_) tellXFields (condSubLibraries gpd) *>
(traverse . _2 . traverse . buildInfo_) tellXFields (condForeignLibs gpd) *>
(traverse . _2 . traverse . buildInfo_) tellXFields (condExecutables gpd) *>
(traverse . _2 . traverse . buildInfo_) tellXFields (condTestSuites gpd) *>
(traverse . _2 . traverse . buildInfo_) tellXFields (condBenchmarks gpd)

tellXFields :: BuildInfo -> Const (DList.DList (String, String)) BuildInfo
tellXFields bi = Const (DList.fromList $ customFieldsBI bi)

tellXFieldsPD :: PackageDescription -> Const (DList.DList (String, String)) PackageDescription
tellXFieldsPD pd = Const (DList.fromList $ customFieldsPD pd)

_2 :: Functor f => (a -> f b) -> (c, a) -> f (c, b)
_2 f (c, a) = (,) c <$> f a
xfields = DList.runDList $ mconcat
[ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd
, toDListOf (L.buildInfos . L.customFieldsBI . traverse) gpd
]

checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck]
checkDevelopmentOnlyFlagsBuildInfo bi =
Expand Down
18 changes: 9 additions & 9 deletions Cabal/Distribution/PackageDescription/Parsec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -65,6 +65,10 @@ import System.Directory
import qualified Text.Parsec as P
import qualified Text.Parsec.Error as P

import Distribution.Compat.Lens
import qualified Distribution.Types.GenericPackageDescription.Lens as L
import qualified Distribution.Types.PackageDescription.Lens as L

-- ---------------------------------------------------------------
-- Parsing

Expand Down Expand Up @@ -282,10 +286,7 @@ parseGenericPackageDescription' lexWarnings fs = do

| name == "custom-setup" && null args = do
sbi <- parseFields setupBInfoFieldDescrs warnUnrec mempty fields
let pd = packageDescription gpd
-- TODO: what if already defined?
let gpd' = gpd { packageDescription = pd { setupBuildInfo = Just sbi } }
pure gpd'
pure $ gpd & L.packageDescription . L.setupBuildInfo ?~ sbi

| name == "source-repository" = do
kind <- case args of
Expand All @@ -298,16 +299,15 @@ parseGenericPackageDescription' lexWarnings fs = do
parseFailure pos $ "Invalid source-repository kind " ++ show args
pure RepoHead
sr <- parseFields sourceRepoFieldDescrs warnUnrec (emptySourceRepo kind) fields
-- I want lens
let pd = packageDescription gpd
let srs = sourceRepos pd
let gpd' = gpd { packageDescription = pd { sourceRepos = srs ++ [sr] } }
pure gpd'

pure $ gpd & L.packageDescription . L.sourceRepos %~ snoc sr

| otherwise = do
parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name
pure gpd

snoc x xs = xs ++ [x]

newSyntaxVersion :: Version
newSyntaxVersion = mkVersion [1, 2]

Expand Down
8 changes: 5 additions & 3 deletions Cabal/Distribution/Types/Benchmark.hs
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,8 @@ import Distribution.Types.UnqualComponentName

import Distribution.ModuleName

import qualified Distribution.Types.BuildInfo.Lens as L

-- | A \"benchmark\" stanza in a cabal file.
--
data Benchmark = Benchmark {
Expand All @@ -28,11 +30,11 @@ data Benchmark = Benchmark {
}
deriving (Generic, Show, Read, Eq, Typeable, Data)

instance HasBuildInfo Benchmark where
buildInfo_ f l = (\x -> l { benchmarkBuildInfo = x }) <$> f (benchmarkBuildInfo l)

instance Binary Benchmark

instance L.HasBuildInfo Benchmark where
buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3)

instance Monoid Benchmark where
mempty = Benchmark {
benchmarkName = mempty,
Expand Down
Loading