git subrepo clone ../cabal-plan cabal-plan

subrepo:
  subdir:   "cabal-plan"
  merged:   "34506ab"
upstream:
  origin:   "../cabal-plan"
  branch:   "master"
  commit:   "34506ab"
git-subrepo:
  version:  "0.3.1"
  origin:   "https://github.com/ingydotnet/git-subrepo.git"
  commit:   "a7ee886"

2 files changed, 1126 insertions, 0 deletions

diff --git a/cabal-plan/src-exe/LicenseReport.hs b/cabal-plan/src-exe/LicenseReport.hs
new file mode 100644
index 0000000..9427d7a
--- /dev/null
+++ b/cabal-plan/src-exe/LicenseReport.hs
@@ -0,0 +1,271 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+-- | Implements @cabal-plan license-report@ functionality
+module LicenseReport
+    ( generateLicenseReport
+    ) where
+
+#if defined(MIN_VERSION_Cabal)
+import           Cabal.Plan
+import qualified Codec.Archive.Tar                      as Tar
+import qualified Codec.Archive.Tar.Entry                as Tar
+import qualified Codec.Compression.GZip                 as GZip
+import           Control.Monad.Compat                   (forM, forM_, guard, unless, when)
+import qualified Data.ByteString.Lazy                   as BSL
+import qualified Data.ByteString                        as BS
+import           Data.Map                               (Map)
+import           Data.List                              (nub)
+import qualified Data.Map                               as Map
+import           Data.Semigroup
+import           Data.Set                               (Set)
+import qualified Data.Set                               as Set
+import qualified Data.Text                              as T
+import qualified Data.Text.IO                           as T
+import qualified Data.Version                           as DV
+import           Distribution.PackageDescription
+import           Distribution.PackageDescription.Parsec
+import           Distribution.Pretty
+import           System.Directory
+import           System.FilePath
+import           System.IO                              (stderr)
+import           Text.ParserCombinators.ReadP
+import           Prelude ()
+import           Prelude.Compat
+
+-- | Read tarball lazily (and possibly decompress)
+readTarEntries :: FilePath -> IO [Tar.Entry]
+readTarEntries idxtar = do
+    es <- case takeExtension idxtar of
+            ".gz"  -> Tar.read . GZip.decompress <$> BSL.readFile idxtar
+            ".tar" -> Tar.read                   <$> BSL.readFile idxtar
+            ext    -> error ("unknown extension " ++ show ext)
+
+    return (Tar.foldEntries (:) [] (\err -> error ("readTarEntries " ++ show err)) es)
+
+fp2pid :: FilePath -> Maybe PkgId
+fp2pid fn0 = do
+  [pns,pvs,rest] <- Just (splitDirectories fn0)
+  guard (rest == pns <.> "cabal")
+  pv <- parseVer pvs
+  pure (PkgId (PkgName $ T.pack pns) pv)
+
+
+parseVer :: String -> Maybe Ver
+parseVer str = case reverse $ readP_to_S DV.parseVersion str of
+  (ver, "") : _ | not (null (DV.versionBranch ver)), all (>= 0) (DV.versionBranch ver)
+      -> Just (Ver $ DV.versionBranch ver)
+  _   -> Nothing
+
+
+readHackageIndex :: IO [(PkgId, BSL.ByteString)]
+readHackageIndex = do
+    -- TODO: expose package index configuration as CLI flag
+    cabalPkgCacheDir <- getAppUserDataDirectory "cabal/packages/hackage.haskell.org"
+    ents <- readTarEntries (cabalPkgCacheDir </> "01-index.tar")
+
+    pure [ (maybe (error $ show n) id $ fp2pid n,bsl)
+         | e@(Tar.Entry { Tar.entryContent = Tar.NormalFile bsl _ }) <- ents
+         , let n = Tar.entryPath e
+         , takeExtension n == ".cabal"
+         ]
+
+getLicenseFiles :: PkgId -> UnitId -> [FilePath] -> IO [BS.ByteString]
+getLicenseFiles compilerId (UnitId uidt) fns = do
+  storeDir <- getAppUserDataDirectory "cabal/store"
+  let docDir = storeDir </> T.unpack (dispPkgId compilerId) </> T.unpack uidt </> "share" </> "doc"
+  forM fns $ \fn -> BS.readFile (docDir </> fn)
+
+{- WARNING: the code that follows will make you cry; a safety pig is provided below for your benefit.
+
+                         _
+ _._ _..._ .-',     _.._(`))
+'-. `     '  /-._.-'    ',/
+   )         \            '.
+  / _    _    |             \
+ |  a    a    /              |
+ \   .-.                     ;
+  '-('' ).-'       ,'       ;
+     '-;           |      .'
+        \           \    /
+        | 7  .__  _.-\   \
+        | |  |  ``/  /`  /
+       /,_|  |   /,_/   /
+          /,_/      '`-'
+
+-}
+
+-- TODO: emit report to Text or Text builder
+generateLicenseReport :: Maybe FilePath -> PlanJson -> UnitId -> CompName -> IO ()
+generateLicenseReport mlicdir plan uid0 cn0 = do
+    let pidsOfInterest = Set.fromList (map uPId (Map.elems $ pjUnits plan))
+
+    indexDb <- Map.fromList . filter (flip Set.member pidsOfInterest . fst) <$> readHackageIndex
+
+    let -- generally, units belonging to the same package as 'root'
+        rootPkgUnits = [ u | u@(Unit { uPId = PkgId pn' _ }) <- Map.elems (pjUnits plan), pn' == pn0 ]
+        rootPkgUnitIds = Set.fromList (map uId rootPkgUnits)
+
+        -- the component of interest
+        Just root@Unit { uPId = PkgId pn0 _ } = Map.lookup uid0 (pjUnits plan)
+
+        fwdDeps = planJsonIdGraph' plan
+        revDeps = invertMap fwdDeps
+
+    let transUids = transDeps fwdDeps (uId root) Set.\\ rootPkgUnitIds
+
+        indirectDeps = Set.fromList [ u | u <- Set.toList transUids, Set.null (Map.findWithDefault mempty u revDeps `Set.intersection` rootPkgUnitIds) ]
+
+        directDeps = transUids Set.\\ indirectDeps
+
+
+    let printInfo :: UnitId -> IO ()
+        printInfo uid = do
+          let Just u = Map.lookup uid (pjUnits plan)
+
+              PkgId (PkgName pn) pv = uPId u
+
+          case BSL.toStrict <$> Map.lookup (uPId u) indexDb of
+            Nothing
+              | PkgId (PkgName "rts") _ <- uPId u -> pure ()
+              | otherwise -> fail (show u)
+
+            Just x -> do
+              gpd <- maybe (fail "parseGenericPackageDescriptionMaybe") pure $
+                     parseGenericPackageDescriptionMaybe x
+
+              let desc = escapeDesc $ synopsis $ packageDescription gpd
+                  lic  = license  $ packageDescription gpd
+                  -- cr   = copyright $ packageDescription gpd
+                  lfs  = licenseFiles $ packageDescription gpd
+
+                  usedBy = Set.fromList [ uPId (Map.findWithDefault undefined unit (pjUnits plan))
+                                        | unit <- Set.toList (Map.findWithDefault mempty uid revDeps)
+                                        , unit `Set.member` (directDeps <> indirectDeps)
+                                        ]
+
+              let url = "http://hackage.haskell.org/package/" <> dispPkgId (uPId u)
+
+                  isB = uType u == UnitTypeBuiltin
+
+                  -- special core libs whose reverse deps are too noisy
+                  baseLibs = ["base", "ghc-prim", "integer-gmp", "integer-simple", "rts"]
+
+                  licurl = case lfs of
+                             [] -> url
+                             (l:_)
+                               | Just licdir <- mlicdir, uType u == UnitTypeGlobal -> T.pack (licdir </> T.unpack (dispPkgId (uPId u)) </> takeFileName l)
+                               | otherwise              -> url <> "/src/" <> T.pack l
+
+              T.putStrLn $ mconcat
+                [ if isB then "| **`" else "| `", pn, if isB then "`** | [`" else "` | [`", dispVer pv, "`](", url , ")", " | "
+                , "[`", T.pack (prettyShow lic), "`](", licurl , ")", " | "
+                , T.pack desc, " | "
+                , if pn `elem` baseLibs then "*(core library)*"
+                  else T.intercalate ", " [ T.singleton '`' <> (j :: T.Text) <> "`" | PkgId (z@(PkgName j)) _ <- Set.toList usedBy,  z /= pn0], " |"
+                ]
+
+              -- print (pn, pv, prettyShow lic, cr, lfs, [ j | PkgId (PkgName j) _ <- Set.toList usedBy ])
+
+              forM_ mlicdir $ \licdir -> do
+
+                case uType u of
+                  UnitTypeGlobal -> do
+                    let lfs' = nub (map takeFileName lfs)
+
+                    when (length lfs' /= length lfs) $ do
+                      T.hPutStrLn stderr ("WARNING: Overlapping license filenames for " <> dispPkgId (uPId u))
+
+                    crdat <- getLicenseFiles (pjCompilerId plan) uid lfs'
+
+                    forM_ (zip lfs' crdat) $ \(fn,txt) -> do
+                      let d = licdir </> T.unpack (dispPkgId (uPId u))
+                      createDirectoryIfMissing True d
+                      BS.writeFile (d </> fn) txt
+
+                    -- forM_ crdat $ print
+                    pure ()
+
+                  -- TODO:
+                  --   UnitTypeBuiltin
+                  --   UnitTypeLocal
+                  --   UnitTypeInplace
+
+                  UnitTypeBuiltin -> T.hPutStrLn stderr ("WARNING: license files for " <> dispPkgId (uPId u) <> " (global/GHC bundled) not copied")
+                  UnitTypeLocal   -> T.hPutStrLn stderr ("WARNING: license files for " <> dispPkgId (uPId u) <> " (project-local package) not copied")
+                  UnitTypeInplace -> T.hPutStrLn stderr ("WARNING: license files for " <> dispPkgId (uPId u) <> " (project-inplace package) not copied")
+
+                unless (length lfs == Set.size (Set.fromList lfs)) $
+                  fail ("internal invariant broken for " <> show (uPId u))
+
+          pure ()
+
+    T.putStrLn "# Dependency License Report"
+    T.putStrLn ""
+    T.putStrLn ("Bold-faced **`package-name`**s denote standard libraries bundled with `" <> dispPkgId (pjCompilerId plan) <> "`.")
+    T.putStrLn ""
+
+    T.putStrLn ("## Direct dependencies of `" <> unPkgN pn0 <> ":" <> dispCompName cn0 <> "`")
+    T.putStrLn ""
+    T.putStrLn "| Name | Version | [SPDX](https://spdx.org/licenses/) License Id | Description | Also depended upon by |"
+    T.putStrLn "| --- | --- | --- | --- | --- |"
+    forM_ directDeps $ printInfo
+    T.putStrLn ""
+
+    T.putStrLn "## Indirect transitive dependencies"
+    T.putStrLn ""
+    T.putStrLn "| Name | Version | [SPDX](https://spdx.org/licenses/) License Id | Description | Depended upon by |"
+    T.putStrLn "| --- | --- | --- | --- | --- |"
+    forM_ indirectDeps $ printInfo
+    T.putStrLn ""
+
+    pure ()
+
+escapeDesc :: String -> String
+escapeDesc []          = []
+escapeDesc ('\n':rest) = ' ':escapeDesc rest
+escapeDesc ('|':rest)  = '\\':'|':escapeDesc rest
+escapeDesc (x:xs)      = x:escapeDesc xs
+
+unPkgN :: PkgName -> T.Text
+unPkgN (PkgName t) = t
+
+planItemAllLibDeps :: Unit -> Set.Set UnitId
+planItemAllLibDeps Unit{..} = mconcat [ ciLibDeps | (cn,CompInfo{..}) <- Map.toList uComps, wantC cn ]
+  where
+    wantC (CompNameSetup)   = False
+    wantC (CompNameTest _)  = False
+    wantC (CompNameBench _) = False
+    wantC _                 = True
+
+planJsonIdGraph':: PlanJson -> Map UnitId (Set UnitId)
+planJsonIdGraph' PlanJson{..} = Map.fromList [ (uId unit, planItemAllLibDeps unit) | unit <- Map.elems pjUnits ]
+
+
+
+invertMap :: Ord k => Map k (Set k) -> Map k (Set k)
+invertMap m0 = Map.fromListWith mappend [ (v, Set.singleton k) | (k,vs) <- Map.toList m0, v <- Set.toList vs ]
+
+transDeps :: Map UnitId (Set UnitId) -> UnitId -> Set UnitId
+transDeps g n0 = go mempty [n0]
+  where
+    go :: Set UnitId -> [UnitId] -> Set UnitId
+    go acc [] = acc
+    go acc (n:ns)
+      | Set.member n acc = go acc ns
+      | otherwise = go (Set.insert n acc) (ns ++ Set.toList (Map.findWithDefault undefined n g))
+
+#else
+
+----------------------------------------------------------------------------
+import           Cabal.Plan
+import           System.Exit
+import           System.IO
+
+generateLicenseReport :: Maybe FilePath -> PlanJson -> UnitId -> CompName -> IO ()
+generateLicenseReport _ _ _ _ = do
+  hPutStrLn stderr "ERROR: `cabal-plan license-report` sub-command not available! Please recompile/reinstall `cabal-plan` with the `license-report` Cabal flag activated."
+  exitFailure
+
+#endif
diff --git a/cabal-plan/src-exe/cabal-plan.hs b/cabal-plan/src-exe/cabal-plan.hs
new file mode 100644
index 0000000..2da2519
--- /dev/null
+++ b/cabal-plan/src-exe/cabal-plan.hs
@@ -0,0 +1,855 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+module Main where
+
+import           Prelude                     ()
+import           Prelude.Compat
+
+import           Control.Monad.Compat        (forM_, guard, unless, when)
+import           Control.Monad.RWS.Strict    (RWS, evalRWS, gets, modify', tell)
+import           Control.Monad.ST            (runST)
+import           Data.Char                   (isAlphaNum)
+import           Data.Foldable               (for_, toList)
+import qualified Data.Graph                  as G
+import           Data.Map                    (Map)
+import qualified Data.Map                    as M
+import           Data.Maybe                  (fromMaybe, isJust, mapMaybe)
+import           Data.Monoid                 (Any (..))
+import           Data.Semigroup              (Semigroup (..))
+import           Data.Set                    (Set)
+import qualified Data.Set                    as S
+import qualified Data.Text                   as T
+import qualified Data.Text.IO                as T
+import qualified Data.Text.Lazy              as LT
+import qualified Data.Text.Lazy.Builder      as LT
+import qualified Data.Text.Lazy.IO           as LT
+import qualified Data.Tree                   as Tr
+import           Data.Tuple                  (swap)
+import qualified Data.Vector.Unboxed         as U
+import qualified Data.Vector.Unboxed.Mutable as MU
+import           Data.Version
+import           Options.Applicative
+import           System.Console.ANSI
+import           System.Directory            (getCurrentDirectory)
+import           System.Exit                 (exitFailure)
+import           System.IO                   (hPutStrLn, stderr)
+import qualified Text.Parsec                 as P
+import qualified Text.Parsec.String          as P
+import qualified Topograph                   as TG
+
+import           Cabal.Plan
+import           LicenseReport               (generateLicenseReport)
+import           Paths_cabal_plan            (version)
+
+haveUnderlineSupport :: Bool
+#if defined(UNDERLINE_SUPPORT)
+haveUnderlineSupport = True
+#else
+haveUnderlineSupport = False
+#endif
+
+data GlobalOptions = GlobalOptions
+    { buildDir        :: Maybe FilePath
+    , optsShowBuiltin :: Bool
+    , optsShowGlobal  :: Bool
+    , cmd             :: Command
+    }
+
+data Command
+    = InfoCommand
+    | ShowCommand
+    | FingerprintCommand
+    | ListBinsCommand MatchCount [Pattern]
+    | DotCommand Bool Bool [Highlight]
+    | TopoCommand Bool
+    | LicenseReport (Maybe FilePath) Pattern
+
+-------------------------------------------------------------------------------
+-- Pattern
+-------------------------------------------------------------------------------
+
+-- | patterns are @[[pkg:]kind;]cname@
+data Pattern = Pattern (Maybe T.Text) (Maybe CompType) (Maybe T.Text)
+    deriving (Show, Eq)
+
+data CompType = CompTypeLib | CompTypeFLib | CompTypeExe | CompTypeTest | CompTypeBench | CompTypeSetup
+    deriving (Show, Eq, Enum, Bounded)
+
+parsePattern :: String -> Either String Pattern
+parsePattern = either (Left . show) Right . P.runParser (patternP <* P.eof) () "<argument>"
+  where
+    patternP = do
+        -- first we parse up to 3 tokens
+        x <- tokenP
+        y <- optional $ do
+            _ <- P.char ':'
+            y <- tokenP
+            z <- optional $ P.char ':' >> tokenP
+            return (y, z)
+        -- then depending on how many tokens we got, we make a pattern
+        case y of
+            Nothing -> return $ Pattern Nothing Nothing x
+            Just (y', Nothing) -> do
+                t <- traverse toCompType x
+                return $ Pattern Nothing t y'
+            Just (y', Just z') -> do
+                t <-  traverse toCompType y'
+                return $ Pattern x t z'
+
+    tokenP :: P.Parser (Maybe T.Text)
+    tokenP =
+        Nothing <$ P.string "*"
+        <|> (Just . T.pack <$> some (P.satisfy (\c -> isAlphaNum c || c `elem` ("-_" :: String))) P.<?> "part of pattern")
+
+    toCompType :: T.Text -> P.Parser CompType
+    toCompType "bench" = return $ CompTypeBench
+    toCompType "exe"   = return $ CompTypeExe
+    toCompType "lib"   = return $ CompTypeLib
+    toCompType "flib"  = return $ CompTypeFLib
+    toCompType "setup" = return $ CompTypeSetup
+    toCompType "test"  = return $ CompTypeTest
+    toCompType t       = fail $ "Unknown component type: " ++ show t
+
+patternCompleter :: Bool -> Completer
+patternCompleter onlyWithExes = mkCompleter $ \pfx -> do
+    plan <- getCurrentDirectory >>= findAndDecodePlanJson . ProjectRelativeToDir
+    let tpfx  = T.pack pfx
+        components = findComponents plan
+
+    -- One scenario
+    -- $ cabal-plan list-bin cab<TAB>
+    -- $ cabal-plan list-bin cabal-plan<TAB>
+    -- $ cabal-plan list-bin cabal-plan:exe:cabal-plan
+    --
+    -- Note: if this package had `tests` -suite, then we can
+    -- $ cabal-plan list-bin te<TAB>
+    -- $ cabal-plan list-bin tests<TAB>
+    -- $ cabal-plan list-bin cabal-plan:test:tests
+    --
+    -- *BUT* at least zsh script have to be changed to complete from non-prefix.
+    return $ map T.unpack $ firstNonEmpty
+        -- 1. if tpfx matches component exacty, return full path
+        [ single $ map fst $ filter ((tpfx ==) . snd) components
+
+        -- 2. match component parts
+        , uniques $ filter (T.isPrefixOf tpfx) $ map snd components
+
+        -- otherwise match full paths
+        , filter (T.isPrefixOf tpfx) $ map fst components
+        ]
+  where
+    firstNonEmpty :: [[a]] -> [a]
+    firstNonEmpty []         = []
+    firstNonEmpty ([] : xss) = firstNonEmpty xss
+    firstNonEmpty (xs : _)   = xs
+
+    -- single
+    single :: [a] -> [a]
+    single xs@[_] = xs
+    single _      = []
+
+    -- somewhat like 'nub' but drop duplicate names. Doesn't preserve order
+    uniques :: Ord a => [a] -> [a]
+    uniques = M.keys . M.filter (== 1) . M.fromListWith (+) . map (\x -> (x, 1 :: Int))
+
+    impl :: Bool -> Bool -> Bool
+    impl False _ = True
+    impl True  x = x
+
+    -- returns (full, cname) pair
+    findComponents :: PlanJson -> [(T.Text, T.Text)]
+    findComponents plan = do
+        (_, Unit{..}) <- M.toList $ pjUnits plan
+        (cn, ci) <- M.toList $ uComps
+
+        -- if onlyWithExes, component should have binFile
+        guard (onlyWithExes `impl` isJust (ciBinFile ci))
+
+        let PkgId pn@(PkgName pnT) _ = uPId
+            g = case cn of
+                CompNameLib -> pnT <> T.pack":lib:" <> pnT
+                _           -> pnT <> T.pack":" <> dispCompName cn
+
+        let cnT = extractCompName pn cn
+        [ (g, cnT) ]
+
+compNameType :: CompName -> CompType
+compNameType CompNameLib        = CompTypeLib
+compNameType (CompNameSubLib _) = CompTypeLib
+compNameType (CompNameFLib _)   = CompTypeFLib
+compNameType (CompNameExe _)    = CompTypeExe
+compNameType (CompNameTest _)   = CompTypeTest
+compNameType (CompNameBench _)  = CompTypeBench
+compNameType CompNameSetup      = CompTypeSetup
+
+checkPattern :: Pattern -> PkgName -> CompName -> Any
+checkPattern (Pattern n k c) pn cn =
+    Any $ nCheck && kCheck && cCheck
+  where
+    nCheck = case n of
+        Nothing  -> True
+        Just pn' -> pn == PkgName pn'
+
+    kCheck = case k of
+        Nothing -> True
+        Just k' -> k' == compNameType cn
+    cCheck = case c of
+        Nothing -> True
+        Just c' -> c' == extractCompName pn cn
+
+extractCompName :: PkgName -> CompName -> T.Text
+extractCompName (PkgName pn) CompNameLib         = pn
+extractCompName (PkgName pn) CompNameSetup       = pn
+extractCompName _            (CompNameSubLib cn) = cn
+extractCompName _            (CompNameFLib cn)   = cn
+extractCompName _            (CompNameExe cn)    = cn
+extractCompName _            (CompNameTest cn)   = cn
+extractCompName _            (CompNameBench cn)  = cn
+
+-------------------------------------------------------------------------------
+-- Highlight
+-------------------------------------------------------------------------------
+
+data Highlight
+    = Path Pattern Pattern
+    | Revdep Pattern
+    deriving (Show, Eq)
+
+highlightParser :: Parser Highlight
+highlightParser = pathParser <|> revdepParser
+  where
+    pathParser = Path
+        <$> option (eitherReader parsePattern)
+            (long "path-from" <> metavar "PATTERN" <> help "Highlight dependency paths from ...")
+        <*> option (eitherReader parsePattern)
+            (long "path-to" <> metavar "PATTERN")
+
+    revdepParser = Revdep
+        <$> option (eitherReader parsePattern)
+            (long "revdep" <> metavar "PATTERN" <> help "Highlight reverse dependencies")
+
+-------------------------------------------------------------------------------
+-- Main
+-------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+    GlobalOptions{..} <- execParser $ info (helper <*> optVersion <*> optParser) fullDesc
+    (searchMethod, mProjRoot) <- case buildDir of
+            Just dir -> pure (InBuildDir dir, Nothing)
+            Nothing -> do
+                cwd <- getCurrentDirectory
+                root <- findProjectRoot cwd
+                pure (ProjectRelativeToDir cwd, root)
+
+    plan <- findAndDecodePlanJson searchMethod
+    case cmd of
+      InfoCommand -> doInfo mProjRoot plan
+      ShowCommand -> mapM_ print mProjRoot >> print plan
+      ListBinsCommand count pats -> do
+          let bins = doListBin plan pats
+          case (count, bins) of
+              (MatchMany, _) -> for_ bins $ \(g, fn) ->
+                    putStrLn (g ++ "  " ++ fn)
+              (MatchOne, [(_,p)]) -> putStrLn p
+              (MatchOne, []) -> do
+                 hPutStrLn stderr "No matches found."
+                 exitFailure
+              (MatchOne, _) -> do
+                 hPutStrLn stderr "Found more than one matching pattern:"
+                 for_ bins $ \(p,_) -> hPutStrLn stderr $ "  " ++ p
+                 exitFailure
+      FingerprintCommand -> doFingerprint plan
+      DotCommand tred tredWeights highlights -> doDot optsShowBuiltin optsShowGlobal plan tred tredWeights highlights
+      TopoCommand rev -> doTopo optsShowBuiltin optsShowGlobal plan rev
+      LicenseReport mfp pat -> doLicenseReport mfp pat
+  where
+    optVersion = infoOption ("cabal-plan " ++ showVersion version)
+                            (long "version" <> help "output version information and exit")
+
+    optParser = GlobalOptions
+        <$> dirParser
+        <*> showHide "builtin" "Show / hide packages in global (non-nix-style) package db"
+        <*> showHide "global" "Show / hide packages in nix-store"
+        <*> (cmdParser <|> defaultCommand)
+
+    showHide n d =
+        flag' True (long ("show-" ++ n) <> help d)
+        <|> flag' False (long ("hide-" ++ n))
+        <|> pure True
+
+    dirParser = optional . strOption $ mconcat
+        [ long "builddir", metavar "DIR"
+        , help "Build directory to read plan.json from." ]
+
+    subCommand name desc val = command name $ info val (progDesc desc)
+
+    patternParser = argument (eitherReader parsePattern) . mconcat
+
+    switchM = switch . mconcat
+
+    cmdParser = subparser $ mconcat
+        [ subCommand "info" "Info" $ pure InfoCommand
+        , subCommand "show" "Show" $ pure ShowCommand
+        , subCommand "list-bins" "List All Binaries" .
+            listBinParser MatchMany . many $ patternParser
+                [ metavar "PATTERNS...", help "Patterns to match.", completer $ patternCompleter True ]
+        , subCommand "list-bin" "List Single Binary" .
+            listBinParser MatchOne $ pure <$> patternParser
+                [ metavar "PATTERN", help "Pattern to match.", completer $ patternCompleter True ]
+        , subCommand "fingerprint" "Fingerprint" $ pure FingerprintCommand
+        , subCommand "dot" "Dependency .dot" $ DotCommand
+              <$> switchM
+                  [ long "tred", help "Transitive reduction" ]
+              <*> switchM
+                  [ long "tred-weights", help "Adjust edge thickness during transitive reduction" ]
+              <*> many highlightParser
+              <**> helper
+        , subCommand "topo" "Plan in a topological sort" $ TopoCommand
+              <$> switchM
+                  [ long "reverse", help "Reverse order" ]
+              <**> helper
+        , subCommand "license-report" "Generate license report for a component" $ LicenseReport
+              <$> optional (strOption $ mconcat [ long "licensedir", metavar "DIR", help "Write per-package license documents to folder" ])
+              <*> patternParser
+                  [ metavar "PATTERN", help "Pattern to match.", completer $ patternCompleter False ]
+              <**> helper
+        ]
+
+    defaultCommand = pure InfoCommand
+
+-------------------------------------------------------------------------------
+-- list-bin
+-------------------------------------------------------------------------------
+
+listBinParser
+    :: MatchCount
+    -> Parser [Pattern]
+    -> Parser Command
+listBinParser count pats
+    = ListBinsCommand count <$> pats <**> helper
+data MatchCount = MatchOne | MatchMany
+    deriving (Show, Eq)
+
+doListBin :: PlanJson -> [Pattern] -> [(String, FilePath)]
+doListBin plan patterns = do
+    (_, Unit{..}) <- M.toList $ pjUnits plan
+    (cn, ci) <- M.toList $ uComps
+    case ciBinFile ci of
+        Nothing -> []
+        Just fn -> do
+            let PkgId pn@(PkgName pnT) _ = uPId
+                g = case cn of
+                    CompNameLib -> T.unpack (pnT <> T.pack":lib:" <> pnT)
+                    _           -> T.unpack (pnT <> T.pack":" <> dispCompName cn)
+            guard . getAny $ patternChecker pn cn
+            [(g, fn)]
+  where
+    patternChecker :: PkgName -> CompName -> Any
+    patternChecker = case patterns of
+        [] -> \_ _ -> Any True
+        _  -> mconcat $ map checkPattern patterns
+
+-------------------------------------------------------------------------------
+-- fingerprint
+-------------------------------------------------------------------------------
+
+doFingerprint :: PlanJson -> IO ()
+doFingerprint plan = do
+    let pids = M.fromList [ (uPId u, u) | (_,u) <- M.toList (pjUnits plan) ]
+
+    for_ (M.toList pids) $ \(_,Unit{..}) -> do
+        let h = maybe "________________________________________________________________"
+                      dispSha256 $ uSha256
+        case uType of
+          UnitTypeBuiltin -> T.putStrLn (h <> " B " <> dispPkgId uPId)
+          UnitTypeGlobal  -> T.putStrLn (h <> " G " <> dispPkgId uPId)
+          UnitTypeLocal   -> T.putStrLn (h <> " L " <> dispPkgId uPId)
+          UnitTypeInplace -> T.putStrLn (h <> " I " <> dispPkgId uPId)
+
+-------------------------------------------------------------------------------
+-- info
+-------------------------------------------------------------------------------
+
+doInfo :: Maybe FilePath -> PlanJson -> IO ()
+doInfo mProjbase plan = do
+    forM_ mProjbase $ \projbase ->
+        putStrLn ("using '" ++ projbase ++ "' as project root")
+    putStrLn ""
+    putStrLn "Tree"
+    putStrLn "~~~~"
+    putStrLn ""
+    LT.putStrLn (dumpPlanJson plan)
+
+    -- print (findCycles (planJsonIdGrap v))
+
+    putStrLn ""
+    putStrLn "Top-sorted"
+    putStrLn "~~~~~~~~~~"
+    putStrLn ""
+
+    let xs = toposort (planJsonIdGraph plan)
+    for_ xs print
+
+    putStrLn ""
+    putStrLn "Direct deps"
+    putStrLn "~~~~~~~~~~~"
+    putStrLn ""
+
+    let locals = [ Unit{..} | Unit{..} <- M.elems pm, uType == UnitTypeLocal ]
+        pm = pjUnits plan
+
+    for_ locals $ \pitem -> do
+        print (uPId pitem)
+        for_ (M.toList $ uComps pitem) $ \(ct,ci) -> do
+            print ct
+            for_ (S.toList $ ciLibDeps ci) $ \dep -> do
+                let Just dep' = M.lookup dep pm
+                    pid = uPId dep'
+                putStrLn ("  " ++ T.unpack (dispPkgId pid))
+            putStrLn ""
+
+    return ()
+
+-------------------------------------------------------------------------------
+-- Dot
+-------------------------------------------------------------------------------
+
+-- | vertex of dot graph.
+--
+-- if @'Maybe' 'CompName'@ is Nothing, this is legacy, multi-component unit.
+data DotUnitId = DU UnitId (Maybe CompName)
+    deriving (Eq, Ord, Show)
+
+planJsonDotUnitGraph :: PlanJson -> Map DotUnitId (Set DotUnitId)
+planJsonDotUnitGraph plan = M.fromList $ do
+    unit <- M.elems units
+    let mkDU = DU (uId unit)
+    let mkDeps cname ci = (mkDU (Just cname), deps ci)
+    case M.toList (uComps unit) of
+        [(cname, ci)] ->
+            [ mkDeps cname ci ]
+        cs            ->
+            [ (mkDU Nothing, S.fromList $ map (mkDU . Just . fst) cs) ]
+            ++ map (uncurry mkDeps) cs
+  where
+    units = pjUnits plan
+
+    unitToDot :: Unit -> DotUnitId
+    unitToDot unit = DU (uId unit) $ case M.toList (uComps unit) of
+        [(cname, _)] -> Just cname
+        _            -> Nothing
+
+    unitIdToDot :: UnitId -> Maybe DotUnitId
+    unitIdToDot i = unitToDot <$> M.lookup i units
+
+    deps :: CompInfo -> Set DotUnitId
+    deps CompInfo{..} =
+        S.fromList $ mapMaybe unitIdToDot $ S.toList $ ciLibDeps <> ciExeDeps
+
+-- | Tree which counts paths under it.
+data Tr a = No !Int a [Tr a]
+  deriving (Show)
+
+trPaths :: Tr a -> Int
+trPaths (No n _ _) = n
+
+-- | Create 'Tr' maintaining the invariant
+mkNo :: a -> [Tr a] -> Tr a
+mkNo x [] = No 1 x []
+mkNo x xs = No (sum $ map trPaths xs) x xs
+
+trFromTree :: Tr.Tree a -> Tr a
+trFromTree (Tr.Node i is) = mkNo i (map trFromTree is)
+
+trPairs :: Tr a -> [(Int,a,a)]
+trPairs (No _ i js) =
+    [ (n, i, j) | No n j _ <- js ] ++ concatMap trPairs js
+
+doDot :: Bool -> Bool -> PlanJson -> Bool -> Bool -> [Highlight] -> IO ()
+doDot showBuiltin showGlobal plan tred tredWeights highlights = either loopGraph id $ TG.runG am $ \g' -> do
+    let g = if tred then TG.reduction g' else g'
+
+    -- Highlights
+    let paths :: [(DotUnitId, DotUnitId)]
+        paths = flip concatMap highlights $ \h -> case h of
+            Path a b ->
+                [ (x, y)
+                | x <- filter (getAny . checkPatternDotUnit a) $ toList dotUnits
+                , y <- filter (getAny . checkPatternDotUnit b) $ toList dotUnits
+                ]
+            Revdep _ -> []
+
+    let paths' :: [(DotUnitId, DotUnitId)]
+        paths' = flip concatMap paths $ \(a, b) -> fromMaybe [] $ do
+            i <- TG.gToVertex g a
+            j <- TG.gToVertex g b
+            pure $ concatMap TG.pairs $ (fmap . fmap) (TG.gFromVertex g) (TG.allPaths g i j)
+
+    let revdeps :: [DotUnitId]
+        revdeps = flip concatMap highlights $ \h -> case h of
+            Path _ _ -> []
+            Revdep a -> filter (getAny . checkPatternDotUnit a) $ toList dotUnits
+
+    let tg = TG.transpose g
+
+    let revdeps' :: [(DotUnitId, DotUnitId)]
+        revdeps' = flip concatMap revdeps $ \a -> fromMaybe [] $ do
+            i <- TG.gToVertex tg a
+            pure $ map swap $ TG.treePairs $ fmap (TG.gFromVertex tg) (TG.dfsTree tg i)
+
+    let redVertices :: Set DotUnitId
+        redVertices = foldMap (\(a,b) -> S.fromList [a,b]) $ paths' ++ revdeps'
+
+    let redEdges :: Set (DotUnitId, DotUnitId)
+        redEdges = S.fromList $ paths' ++ revdeps'
+
+    -- Edge weights
+    let weights' :: U.Vector Double
+        weights' = runST $ do
+            let orig = TG.edgesSet g'
+                redu = TG.edgesSet g
+                len  = TG.gVerticeCount g
+            v <- MU.replicate (len * len) (0 :: Double)
+
+            -- for each edge (i, j) in original graph, but not in the reduction
+            for_ (S.difference orig redu) $ \(i, j) -> do
+                -- calculate all paths from i to j, in the reduction
+                for_ (fmap trFromTree $ TG.allPathsTree g i j) $ \ps -> do
+                    -- divide weight across paths
+                    let r  = 1 / fromIntegral (trPaths ps)
+
+                    -- and add that weight to every edge on each path
+                    for_ (trPairs ps) $ \(k, a, b) ->
+                        MU.modify v
+                            (\n -> n + fromIntegral k * r)
+                            (TG.gToInt g b + TG.gToInt g a * len)
+
+            U.freeze v
+
+    let weights :: Map (DotUnitId, DotUnitId) Double
+        weights =
+            if tred && tredWeights
+            then M.fromList
+                [ ((a, b), w + 1)
+                | ((i, j), w) <- zip ((,) <$> TG.gVertices g <*> TG.gVertices g) (U.toList weights')
+                , w > 0
+                , let a = TG.gFromVertex g i
+                , let b = TG.gFromVertex g j
+                ]
+            else M.empty
+
+    -- Beging outputting
+
+    putStrLn "digraph plan {"
+    putStrLn "overlap = false;"
+    putStrLn "rankdir=LR;"
+    putStrLn "node [penwidth=2];"
+
+    -- vertices
+    for_ (TG.gVertices g) $ \i -> vertex redVertices (TG.gFromVertex g i)
+
+    -- edges
+    for_ (TG.gVertices g) $ \i -> for_ (TG.gEdges g i) $ \j ->
+        edge weights redEdges (TG.gFromVertex g i) (TG.gFromVertex g j)
+
+    putStrLn "}"
+  where
+    loopGraph [] = putStrLn "digraph plan {}"
+    loopGraph (u : us) = do
+        putStrLn "digraph plan {"
+        for_ (zip (u : us) (us ++ [u])) $ \(unitA, unitB) ->
+            T.putStrLn $ mconcat
+                [ "\""
+                , dispDotUnit unitA
+                , "\""
+                , " -> "
+                , "\""
+                , dispDotUnit unitB
+                , "\""
+                ]
+        putStrLn "}"
+
+    am = planJsonDotUnitGraph plan
+
+    dotUnits :: Set DotUnitId
+    dotUnits = S.fromList $ M.keys am
+
+    units :: Map UnitId Unit
+    units = pjUnits plan
+
+    duShape :: DotUnitId -> T.Text
+    duShape (DU unitId _) = case M.lookup unitId units of
+        Nothing   -> "oval"
+        Just unit -> case uType unit of
+            UnitTypeBuiltin -> "octagon"
+            UnitTypeGlobal  -> "box"
+            UnitTypeInplace -> "box"
+            UnitTypeLocal   -> "box,style=rounded"
+
+    duShow :: DotUnitId -> Bool
+    duShow (DU unitId _) = case M.lookup unitId units of
+        Nothing -> False
+        Just unit -> case uType unit of
+            UnitTypeBuiltin -> showBuiltin
+            UnitTypeGlobal  -> showGlobal
+            UnitTypeLocal   -> True
+            UnitTypeInplace -> True
+
+    vertex :: Set DotUnitId -> DotUnitId -> IO ()
+    vertex redVertices du = when (duShow du) $ T.putStrLn $ mconcat
+        [ "\""
+        , dispDotUnit du
+        , "\""
+        -- shape
+        , " [shape="
+        , duShape du
+        -- color
+        , ",color="
+        , color
+        , "];"
+        ]
+      where
+        color | S.member du redVertices = "red"
+              | otherwise               = borderColor du
+
+    borderColor :: DotUnitId -> T.Text
+    borderColor (DU _ Nothing)           = "darkviolet"
+    borderColor (DU unitId (Just cname)) = case cname of
+        CompNameLib         -> case M.lookup unitId units of
+            Nothing   -> "black"
+            Just unit -> case uType unit of
+                UnitTypeLocal   -> "blue"
+                UnitTypeInplace -> "blue"
+                _               -> "black"
+        (CompNameSubLib _)  -> "gray"
+        (CompNameFLib _)    -> "darkred"
+        (CompNameExe _)     -> "brown"
+        (CompNameBench _)   -> "darkorange"
+        (CompNameTest _)    -> "darkgreen"
+        CompNameSetup       -> "gold"
+
+    edge
+        :: Map (DotUnitId, DotUnitId) Double
+        -> Set (DotUnitId, DotUnitId)
+        -> DotUnitId -> DotUnitId -> IO ()
+    edge weights redEdges duA duB = when (duShow duA) $ when (duShow duB) $
+        T.putStrLn $ mconcat
+            [ "\""
+            , dispDotUnit duA
+            , "\""
+            , " -> "
+            , "\""
+            , dispDotUnit duB
+            , "\" [color="
+            , color
+            , ",penwidth="
+            , T.pack $ show $ logBase 4 w + 1
+            , ",weight="
+            , T.pack $ show $ logBase 4 w + 1
+            , "];"
+            ]
+      where
+        idPair = (duA, duB)
+
+        color | S.member idPair redEdges = "red"
+              | otherwise                     = borderColor duA
+
+        w = fromMaybe 1 $ M.lookup idPair weights
+
+    checkPatternDotUnit :: Pattern -> DotUnitId -> Any
+    checkPatternDotUnit p (DU unitId mcname) = case M.lookup unitId units of
+        Nothing   -> Any False
+        Just unit -> case mcname of
+            Just cname -> checkPattern p pname cname
+            Nothing    -> foldMap (checkPattern p pname) (M.keys (uComps unit))
+          where
+            PkgId pname _ = uPId unit
+
+    dispDotUnit :: DotUnitId -> T.Text
+    dispDotUnit (DU unitId mcname) = case M.lookup unitId units of
+        Nothing   -> "?"
+        Just unit -> dispPkgId (uPId unit) <> maybe ":*" dispCompName' mcname
+
+    dispCompName' :: CompName -> T.Text
+    dispCompName' CompNameLib = ""
+    dispCompName' cname       = ":" <> dispCompName cname
+
+-------------------------------------------------------------------------------
+-- license-report
+-------------------------------------------------------------------------------
+
+doLicenseReport :: Maybe FilePath -> Pattern -> IO ()
+doLicenseReport mlicdir pat = do
+    plan <- getCurrentDirectory >>= findAndDecodePlanJson . ProjectRelativeToDir
+
+    case findUnit plan of
+      [] -> do
+        hPutStrLn stderr "No matches found."
+        exitFailure
+
+      lst@(_:_:_) -> do
+        hPutStrLn stderr "Multiple matching components found:"
+        forM_ lst $ \(pat', uid, cn) -> do
+          hPutStrLn stderr ("- " ++ T.unpack pat' ++ "   " ++ show (uid, cn))
+        exitFailure
+
+      [(_,uid,cn)] -> generateLicenseReport mlicdir plan uid cn
+
+  where
+    findUnit plan = do
+        (_, Unit{..}) <- M.toList $ pjUnits plan
+        (cn, _) <- M.toList $ uComps
+
+        let PkgId pn@(PkgName pnT) _ = uPId
+            g = case cn of
+                CompNameLib -> pnT <> T.pack":lib:" <> pnT
+                _           -> pnT <> T.pack":" <> dispCompName cn
+
+        guard (getAny $ checkPattern pat pn cn)
+
+        pure (g, uId, cn)
+
+
+-------------------------------------------------------------------------------
+-- topo
+-------------------------------------------------------------------------------
+
+doTopo :: Bool -> Bool -> PlanJson -> Bool -> IO ()
+doTopo showBuiltin showGlobal plan rev = do
+    let units = pjUnits plan
+
+    let topo = TG.runG (planJsonIdGraph plan) $ \TG.G {..} ->
+            map gFromVertex gVertices
+
+    let showUnit unit = case uType unit of
+          UnitTypeBuiltin -> showBuiltin
+          UnitTypeGlobal  -> showGlobal
+          UnitTypeLocal   -> True
+          UnitTypeInplace -> True
+
+    let rev' = if rev then reverse else id
+
+    for_ topo $ \topo' -> for_ (rev' topo') $ \unitId ->
+        for_ (M.lookup unitId units) $ \unit ->
+            when (showUnit unit) $ do
+                let colour = case uType unit of
+                        UnitTypeBuiltin -> Blue
+                        UnitTypeGlobal  -> White
+                        UnitTypeLocal   -> Green
+                        UnitTypeInplace -> Red
+                let components = case M.keys (uComps unit) of
+                        [] -> ""
+                        [CompNameLib] -> ""
+                        names -> " " <> T.intercalate " " (map dispCompName names)
+                putStrLn $
+                    colorify colour (T.unpack $ dispPkgId $ uPId unit)
+                    ++ T.unpack components
+
+----------------------------------------------------------------------------
+
+dumpPlanJson :: PlanJson -> LT.Text
+dumpPlanJson (PlanJson { pjUnits = pm }) = LT.toLazyText out
+  where
+    ((),out) = evalRWS (mapM_ (go2 []) (S.toList roots)) () mempty
+
+    id2pid :: Map UnitId PkgId
+    id2pid = M.fromList [ (uId, uPId) | Unit{..} <- M.elems pm ]
+
+    lupPid uid = M.findWithDefault undefined uid id2pid
+
+    go2 :: [(CompName,Bool)] -> UnitId -> (RWS () LT.Builder (Set UnitId)) ()
+    go2 lvl pid = do
+        pidSeen <- gets (S.member pid)
+
+        let pid_label = if preExists then (prettyId pid) else colorify_ White (prettyId pid)
+
+        if not pidSeen
+         then do
+            tell $ LT.fromString (linepfx ++ pid_label ++ "\n")
+            showDeps
+         else do
+            tell $ LT.fromString (linepfx ++ pid_label ++ ccol CompNameLib " ┄┄\n")
+            -- tell $ LT.fromString (linepfx' ++ " └┄\n")
+
+        modify' (S.insert pid)
+
+        return ()
+      where
+        Just x' = M.lookup pid pm
+
+        preExists = uType x' == UnitTypeBuiltin
+
+        showDeps = for_ (M.toList $ uComps x') $ \(ct,deps) -> do
+            unless (ct == CompNameLib) $
+                tell (LT.fromString $ linepfx' ++ " " ++ prettyCompTy (lupPid pid) ct ++ "\n")
+            for_ (lastAnn $ S.toList (ciLibDeps deps)) $ \(l,y) -> do
+                go2 (lvl ++ [(ct, not l)]) y
+
+
+        linepfx = case unsnoc lvl of
+                         Nothing -> ""
+                         Just (xs,(zt,z)) -> concat [ if x then ccol xt " │ " else "   " | (xt,x) <- xs ]
+                                        ++ (ccol zt $ if z then " ├─ " else " └─ ")
+
+        linepfx' = concat [ if x then  " │ " else "   " | (_,x) <- lvl ]
+
+    roots :: Set UnitId
+    roots = M.keysSet pm `S.difference` leafs
+      where
+        leafs = mconcat $ concatMap (map (ciLibDeps . snd) . M.toList . uComps) (M.elems pm)
+
+    prettyId :: UnitId -> String
+    prettyId = prettyPid . lupPid
+    prettyPid = T.unpack . dispPkgId
+
+    prettyCompTy :: PkgId -> CompName -> String
+    prettyCompTy _pid c@CompNameLib       = ccol c "[lib]"
+    prettyCompTy _pid c@CompNameSetup     = ccol c "[setup]"
+    prettyCompTy pid c@(CompNameExe n)    = ccol c $ "[" ++ prettyPid pid ++ ":exe:"   ++ show n ++ "]"
+    prettyCompTy pid c@(CompNameTest n)   = ccol c $ "[" ++ prettyPid pid ++ ":test:"  ++ show n ++ "]"
+    prettyCompTy pid c@(CompNameBench n)  = ccol c $ "[" ++ prettyPid pid ++ ":bench:" ++ show n ++ "]"
+    prettyCompTy pid c@(CompNameSubLib n) = ccol c $ "[" ++ prettyPid pid ++ ":lib:" ++ show n ++ "]"
+    prettyCompTy pid c@(CompNameFLib n)   = ccol c $ "[" ++ prettyPid pid ++ ":flib:" ++ show n ++ "]"
+
+    ccol CompNameLib        = colorify White
+    ccol (CompNameExe _)    = colorify Green
+    ccol CompNameSetup      = colorify Red
+    ccol (CompNameTest _)   = colorify Yellow
+    ccol (CompNameBench _)  = colorify Cyan
+    ccol (CompNameSubLib _) = colorify Blue
+    ccol (CompNameFLib _)   = colorify Magenta
+
+colorify :: Color -> String -> String
+colorify col s = setSGRCode [SetColor Foreground Vivid col] ++ s ++ setSGRCode [Reset]
+
+colorify_ :: Color -> String -> String
+colorify_ col s
+  | haveUnderlineSupport = setSGRCode [SetUnderlining SingleUnderline, SetColor Foreground Vivid col] ++ s ++ setSGRCode [Reset]
+  | otherwise            = colorify col s
+
+lastAnn :: [x] -> [(Bool,x)]
+lastAnn = reverse . firstAnn . reverse
+
+firstAnn :: [x] -> [(Bool,x)]
+firstAnn []     = []
+firstAnn (x:xs) = (True,x) : map ((,) False) xs
+
+unsnoc :: [x] -> Maybe ([x],x)
+unsnoc [] = Nothing
+unsnoc xs = Just (init xs, last xs)
+
+toposort :: Ord a => Map a (Set a) -> [a]
+toposort m = reverse . map f . G.topSort $ g
+  where
+    (g, f) = graphFromMap m
+
+graphFromMap :: Ord a => Map a (Set a) -> (G.Graph, G.Vertex -> a)
+graphFromMap m = (g, v2k')
+  where
+    v2k' v = case v2k v of ((), k, _) -> k
+
+    (g, v2k, _) = G.graphFromEdges [ ((), k, S.toList v)
+                                   | (k,v) <- M.toList m ]