Maintain a plan.json file for external tools

This is (mostly) hvr's code.

It produces an external representation of the elaborated install plan.
The intention is for it to be used by external tools, editors etc, to
find out relevant details of the project and package configuration and
environment. It is updated whenever the elaborated install plan
changes, so it always reflects the current state.

Currently it only includes a modest subset of the details from the
elaborated install plan, but the goal is to include all relevant details
in a mostly-stable JSON format.

Currently it's based on the elaborated install plan prior to improving
the plan with packages from the store, but ultimately it will need to
include information from both before and after the 'improvement' phase.

cabal-install/Distribution/Client/ProjectPlanOutput.hs

+{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns,
+             DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,
+             ScopedTypeVariables #-}
+
+-- | An experimental new UI for cabal for working with multiple packages
+-----------------------------------------------------------------------------
+module Distribution.Client.ProjectPlanOutput (
+    writePlanExternalRepresentation,
+  ) where
+
+import           Distribution.Client.ProjectPlanning.Types
+                   ( ElaboratedInstallPlan, ElaboratedConfiguredPackage(..)
+                   , ElaboratedSharedConfig(..) )
+import           Distribution.Client.DistDirLayout
+
+import qualified Distribution.Client.InstallPlan as InstallPlan
+import qualified Distribution.Client.Utils.Json as J
+import qualified Distribution.Client.ComponentDeps as ComponentDeps
+
+import           Distribution.Package
+import qualified Distribution.PackageDescription as PD
+import           Distribution.Text
+import           Distribution.Simple.Utils
+import qualified Paths_cabal_install as Our (version)
+
+import           Data.Monoid
+import qualified Data.ByteString.Builder as BB
+
+
+-- | Write out a representation of the elaborated install plan.
+--
+-- This is for the benefit of debugging and external tools like editors.
+--
+writePlanExternalRepresentation :: DistDirLayout
+                                -> ElaboratedInstallPlan
+                                -> ElaboratedSharedConfig
+                                -> IO ()
+writePlanExternalRepresentation distDirLayout elaboratedInstallPlan
+                                elaboratedSharedConfig =
+    writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $
+        BB.toLazyByteString
+      . J.encodeToBuilder
+      $ encodePlanAsJson elaboratedInstallPlan elaboratedSharedConfig
+
+-- | Renders a subset of the elaborated install plan in a semi-stable JSON
+-- format.
+--
+encodePlanAsJson :: ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value
+encodePlanAsJson elaboratedInstallPlan _elaboratedSharedConfig =
+    --TODO: [nice to have] include all of the sharedPackageConfig and all of
+    --      the parts of the elaboratedInstallPlan
+    J.object [ "cabal-version"     J..= jdisplay Our.version
+             , "cabal-lib-version" J..= jdisplay cabalVersion
+             , "install-plan"      J..= jsonIPlan
+             ]
+  where
+    jsonIPlan = map toJ (InstallPlan.toList elaboratedInstallPlan)
+
+    -- ipi :: InstalledPackageInfo
+    toJ (InstallPlan.PreExisting ipi) =
+      -- installed packages currently lack configuration information
+      -- such as their flag settings or non-lib components.
+      --
+      -- TODO: how to find out whether package is "local"?
+      J.object
+        [ "type"       J..= J.String "pre-existing"
+        , "id"         J..= jdisplay (installedUnitId ipi)
+        , "components" J..= J.object
+          [ "lib" J..= J.object [ "depends" J..= map jdisplay (installedDepends ipi) ] ]
+        ]
+
+    -- ecp :: ElaboratedConfiguredPackage
+    toJ (InstallPlan.Configured ecp) =
+      J.object
+        [ "type"       J..= J.String "configured"
+        , "id"         J..= (jdisplay . installedUnitId) ecp
+        , "components" J..= components
+        , "flags"      J..= J.object [ fn J..= v
+                                     | (PD.FlagName fn,v) <- pkgFlagAssignment ecp ]
+        ]
+      where
+        components = J.object
+          [ comp2str c J..= J.object
+            [ "depends" J..= map (jdisplay . installedUnitId) v ]
+          | (c,v) <- ComponentDeps.toList (pkgDependencies ecp) ]
+
+    toJ _ = error "encodePlanToJson: only expecting PreExisting and Configured"
+
+    -- TODO: maybe move this helper to "ComponentDeps" module?
+    --       Or maybe define a 'Text' instance?
+    comp2str c = case c of
+        ComponentDeps.ComponentLib     -> "lib"
+        ComponentDeps.ComponentExe s   -> "exe:"   <> s
+        ComponentDeps.ComponentTest s  -> "test:"  <> s
+        ComponentDeps.ComponentBench s -> "bench:" <> s
+        ComponentDeps.ComponentSetup   -> "setup"
+
+    jdisplay :: Text a => a -> J.Value
+    jdisplay = J.String . display
+

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -58,6 +58,7 @@ import           Distribution.Client.ProjectPlanning.Types
 import           Distribution.Client.PackageHash
 import           Distribution.Client.RebuildMonad
 import           Distribution.Client.ProjectConfig
+import           Distribution.Client.ProjectPlanOutput
 
 import           Distribution.Client.Types
                    hiding ( BuildResult, BuildSuccess(..), BuildFailure(..)
@@ -248,6 +249,7 @@ rebuildInstallPlan verbosity
            elaboratedShared) <- phaseElaboratePlan projectConfigTransient
                                                    compilerEtc
                                                    solverPlan localPackages
+          phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
 
           return (elaboratedPlan, elaboratedShared,
                   projectConfig)
@@ -504,6 +506,24 @@ rebuildInstallPlan verbosity
                         projectConfigBuildOnly
 
 
+    -- Update the files we maintain that reflect our current build environment.
+    -- In particular we maintain a JSON representation of the elaborated
+    -- install plan.
+    --
+    -- TODO: [required eventually] maintain the ghc environment file reflecting
+    -- the libs available. This will need to be after plan improvement phase.
+    --
+    phaseMaintainPlanOutputs :: ElaboratedInstallPlan
+                             -> ElaboratedSharedConfig
+                             -> Rebuild ()
+    phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = do
+        liftIO $ debug verbosity "Updating plan.json"
+        liftIO $ writePlanExternalRepresentation
+                   distDirLayout
+                   elaboratedPlan
+                   elaboratedShared
+
+
     -- Improve the elaborated install plan. The elaborated plan consists
     -- mostly of source packages (with full nix-style hashed ids). Where
     -- corresponding installed packages already exist in the store, replace

cabal-install/Distribution/Client/Utils/Json.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Minimal JSON / RFC 7159 support
+--
+-- The API is heavily inspired by @aeson@'s API but puts emphasis on
+-- simplicity rather than performance. The 'ToJSON' instances are
+-- intended to have an encoding compatible with @aeson@'s encoding.
+--
+module Distribution.Client.Utils.Json
+    ( Value(..)
+    , Object, object, Pair, (.=)
+    , encodeToString
+    , encodeToBuilder
+    , ToJSON(toJSON)
+    )
+    where
+
+import Data.Char
+import Data.Int
+import Data.String
+import Data.Word
+import Data.List
+import Data.Monoid
+
+import Data.ByteString.Builder (Builder)
+import qualified Data.ByteString.Builder as BB
+
+-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'
+
+-- | A JSON value represented as a Haskell value.
+data Value = Object !Object
+           | Array  [Value]
+           | String  String
+           | Number !Double
+           | Bool   !Bool
+           | Null
+           deriving (Eq, Read, Show)
+
+-- | A key\/value pair for an 'Object'
+type Pair = (String, Value)
+
+-- | A JSON \"object\" (key/value map).
+type Object = [Pair]
+
+infixr 8 .=
+
+-- | A key-value pair for encoding a JSON object.
+(.=) :: ToJSON v => String -> v -> Pair
+k .= v  = (k, toJSON v)
+
+-- | Create a 'Value' from a list of name\/value 'Pair's.
+object :: [Pair] -> Value
+object = Object
+
+instance IsString Value where
+  fromString = String
+
+
+-- | A type that can be converted to JSON.
+class ToJSON a where
+  -- | Convert a Haskell value to a JSON-friendly intermediate type.
+  toJSON :: a -> Value
+
+instance ToJSON () where
+  toJSON () = Array []
+
+instance ToJSON Value where
+  toJSON = id
+
+instance ToJSON Bool where
+  toJSON = Bool
+
+instance ToJSON a => ToJSON [a] where
+  toJSON = Array . map toJSON
+
+instance ToJSON a => ToJSON (Maybe a) where
+  toJSON Nothing  = Null
+  toJSON (Just a) = toJSON a
+
+instance (ToJSON a,ToJSON b) => ToJSON (a,b) where
+  toJSON (a,b) = Array [toJSON a, toJSON b]
+
+instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where
+  toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]
+
+instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
+  toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]
+
+instance ToJSON Float where
+  toJSON = Number . realToFrac
+
+instance ToJSON Double where
+  toJSON = Number
+
+instance ToJSON Int    where  toJSON = Number . realToFrac
+instance ToJSON Int8   where  toJSON = Number . realToFrac
+instance ToJSON Int16  where  toJSON = Number . realToFrac
+instance ToJSON Int32  where  toJSON = Number . realToFrac
+
+instance ToJSON Word   where  toJSON = Number . realToFrac
+instance ToJSON Word8  where  toJSON = Number . realToFrac
+instance ToJSON Word16 where  toJSON = Number . realToFrac
+instance ToJSON Word32 where  toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Int64  where  toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Word64 where  toJSON = Number . realToFrac
+
+-- | Possibly lossy due to conversion to 'Double'
+instance ToJSON Integer where toJSON = Number . fromInteger
+
+------------------------------------------------------------------------------
+-- 'BB.Builder'-based encoding
+
+-- | Serialise value as JSON/UTF8-encoded 'Builder'
+encodeToBuilder :: ToJSON a => a -> Builder
+encodeToBuilder = encodeValueBB . toJSON
+
+encodeValueBB :: Value -> Builder
+encodeValueBB jv = case jv of
+  Bool True  -> "true"
+  Bool False -> "false"
+  Null       -> "null"
+  Number n
+    | isNaN n || isInfinite n   -> encodeValueBB Null
+    | Just i <- doubleToInt64 n -> BB.int64Dec i
+    | otherwise                 -> BB.doubleDec n
+  Array a  -> encodeArrayBB a
+  String s -> encodeStringBB s
+  Object o -> encodeObjectBB o
+
+encodeArrayBB :: [Value] -> Builder
+encodeArrayBB [] = "[]"
+encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'
+  where
+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB
+
+encodeObjectBB :: Object -> Builder
+encodeObjectBB [] = "{}"
+encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'
+  where
+    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair
+    encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x
+
+encodeStringBB :: String -> Builder
+encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'
+  where
+    go = BB.stringUtf8 . escapeString
+
+------------------------------------------------------------------------------
+-- 'String'-based encoding
+
+-- | Serialise value as JSON-encoded Unicode 'String'
+encodeToString :: ToJSON a => a -> String
+encodeToString jv = encodeValue (toJSON jv) []
+
+encodeValue :: Value -> ShowS
+encodeValue jv = case jv of
+  Bool b   -> showString (if b then "true" else "false")
+  Null     -> showString "null"
+  Number n
+    | isNaN n || isInfinite n    -> encodeValue Null
+    | Just i <- doubleToInt64 n -> shows i
+    | otherwise                 -> shows n
+  Array a -> encodeArray a
+  String s -> encodeString s
+  Object o -> encodeObject o
+
+encodeArray :: [Value] -> ShowS
+encodeArray [] = showString "[]"
+encodeArray jvs = ('[':) . go jvs . (']':)
+  where
+    go []     = id
+    go [x]    = encodeValue x
+    go (x:xs) = encodeValue x . (',':) . go xs
+
+encodeObject :: Object -> ShowS
+encodeObject [] = showString "{}"
+encodeObject jvs = ('{':) . go jvs . ('}':)
+  where
+    go []          = id
+    go [(l,x)]     = encodeString l . (':':) . encodeValue x
+    go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs
+
+encodeString :: String -> ShowS
+encodeString str = ('"':) . showString (escapeString str) . ('"':)
+
+------------------------------------------------------------------------------
+-- helpers
+
+-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not
+-- representable loss-free as integral 'Int64' value.
+doubleToInt64 :: Double -> Maybe Int64
+doubleToInt64 x
+  | fromInteger x' == x
+  , x' <= toInteger (maxBound :: Int64)
+  , x' >= toInteger (minBound :: Int64)
+    = Just (fromIntegral x')
+  | otherwise = Nothing
+  where
+    x' = round x
+
+-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"
+escapeString :: String -> String
+escapeString s
+  | not (any needsEscape s) = s
+  | otherwise               = escape s
+  where
+    escape [] = []
+    escape (x:xs) = case x of
+      '\\' -> '\\':'\\':escape xs
+      '"'  -> '\\':'"':escape xs
+      '\b' -> '\\':'b':escape xs
+      '\f' -> '\\':'f':escape xs
+      '\n' -> '\\':'n':escape xs
+      '\r' -> '\\':'r':escape xs
+      '\t' -> '\\':'t':escape xs
+      c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs
+        | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs
+        | otherwise    -> c : escape xs
+
+    -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF
+    needsEscape c = ord c < 0x20 || c `elem` ['\\','"']

cabal-install/cabal-install.cabal

@@ -101,6 +101,10 @@ source-repository head
   location: https://github.com/haskell/cabal/
   subdir:   cabal-install
 
+Flag old-bytestring
+  description:  Use bytestring < 0.10.2 and bytestring-builder
+  default: False
+
 Flag old-directory
   description:  Use directory < 1.2 and old-time
   default:      False
@@ -188,6 +192,7 @@ executable cabal
         Distribution.Client.ProjectConfig.Legacy
         Distribution.Client.ProjectPlanning
         Distribution.Client.ProjectPlanning.Types
+        Distribution.Client.ProjectPlanOutput
         Distribution.Client.Run
         Distribution.Client.RebuildMonad
         Distribution.Client.Sandbox
@@ -206,6 +211,7 @@ executable cabal
         Distribution.Client.Upload
         Distribution.Client.Utils
         Distribution.Client.Utils.LabeledGraph
+        Distribution.Client.Utils.Json
         Distribution.Client.World
         Distribution.Client.Win32SelfUpgrade
         Distribution.Client.Compat.ExecutablePath
@@ -238,6 +244,11 @@ executable cabal
         zlib       >= 0.5.3    && < 0.7,
         hackage-security >= 0.5 && < 0.6
 
+    if flag(old-bytestring)
+      build-depends: bytestring <  0.10.2, bytestring-builder >= 0.10 && < 1
+    else
+      build-depends: bytestring >= 0.10.2
+
     if flag(old-directory)
       build-depends: directory >= 1.1 && < 1.2, old-time >= 1 && < 1.2,
                      process   >= 1.0.1.1  && < 1.1.0.2