Main.hs

{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Main where

import           Data.Aeson

import qualified Data.ByteString.Lazy.Char8         as LBSC8

import           Data.Text                          (Text)
import qualified Data.Text                          as T

import qualified Data.HashMap.Strict                as HM

import           Data.List
import           Data.Maybe
import           Data.Monoid
import           Data.String

import qualified Data.SPDX                          as SPDX

import qualified Distribution.Compiler              as C
import qualified Distribution.License               as C
import qualified Distribution.ModuleName            as C
import qualified Distribution.Package               as C
import qualified Distribution.PackageDescription    as C
import qualified Distribution.Simple.Configure      as C
import qualified Distribution.Simple.LocalBuildInfo as C
import qualified Distribution.Version               as C

import qualified Language.Haskell.Extension         as L

import           Flow

import           System.Environment                 (getArgs)

versionText :: C.Version -> Text
versionText = toJSON
              .> (\case (String v) -> Just v
                        _          -> Nothing)
              .> fromMaybe (error "versionText: this is bad")

fromSingleton :: [a] -> Maybe a
fromSingleton [l] = Just l
fromSingleton _   = Nothing

parseCabal :: FilePath -> IO C.PackageDescription
parseCabal fp = C.localPkgDescr
                <$> C.getPersistBuildConfig fp

instance IsString SPDX.LicenseId where
  fromString l = SPDX.mkLicenseId l
                 |> fromMaybe (error ("Invalid license: " <> l))

data SPDX
  = AllRightsReserved
  | PublicDomain
  | Licensed !SPDX.LicenseId
  | UnknownLicense !(Maybe Text)

spdxJ :: SPDX -> Value
spdxJ AllRightsReserved         = "AllRightsReserved"
spdxJ PublicDomain              = "PublicDomain"
spdxJ (UnknownLicense (Just t)) = toJSON t
spdxJ (UnknownLicense Nothing)  = Null
spdxJ (Licensed lid)            = object ["spdx" .= SPDX.prettyLicenseId lid]

licenseToSPDX :: C.License -> SPDX
licenseToSPDX = go
  where
    go :: C.License -> SPDX
    go (C.GPL Nothing)                        = UnknownLicense (Just "GPL")
    go (C.GPL (Just (C.Version [2] [])))      = Licensed "GPL-2.0"
    go (C.GPL (Just (C.Version [3] [])))      = Licensed "GPL-3.0"
    go (C.GPL (Just (C.Version [3,0] [])))    = Licensed "GPL-3.0"
    go (C.LGPL Nothing)                       = UnknownLicense (Just "LGPL")
    go (C.LGPL (Just (C.Version [2,1] [])))   = Licensed "LGPL-2.1"
    go (C.LGPL (Just (C.Version [2] [])))     = Licensed "LGPL-2.0"
    go (C.LGPL (Just (C.Version [3] [])))     = Licensed "LGPL-3.0"
    go (C.LGPL (Just (C.Version [3,0] [])))   = Licensed "LGPL-3.0"
    go (C.AGPL Nothing)                       = UnknownLicense (Just "AGPL")
    go (C.AGPL (Just (C.Version [3] [])))     = Licensed "AGPL-3.0"
    go (C.AGPL (Just (C.Version [3,0] [])))   = Licensed "AGPL-3.0"
    go (C.MPL (C.Version [2,0] []))           = Licensed "MPL-2.0"
    go C.BSD2                                 = Licensed "BSD-2-Clause"
    go C.BSD3                                 = Licensed "BSD-3-Clause"
    go C.BSD4                                 = Licensed "BSD-4-Clause"
    go C.MIT                                  = Licensed "MIT"
    go C.PublicDomain                         = PublicDomain
    go C.UnspecifiedLicense                   = AllRightsReserved
    go C.AllRightsReserved                    = AllRightsReserved
    go (C.Apache Nothing)                     = Licensed "Apache-2.0"
    go (C.Apache (Just (C.Version [2,0] []))) = Licensed "Apache-2.0"
    go C.ISC                                  = Licensed "ISC"
    go C.OtherLicense                         = UnknownLicense Nothing
    go l                                      = invalidLicense l

    invalidLicense :: C.License -> a
    invalidLicense l = error ("licenseToSPDX: unknown license: " <> show l)

packageDescriptionJ :: C.PackageDescription -> Value
packageDescriptionJ (C.PackageDescription {..})
  = [ "name"            .= C.unPackageName (C.pkgName package)
    , "version"         .= C.pkgVersion package
    , "meta"            .= meta
    , "custom-fields"   .= HM.fromList customFieldsPD
    , "library"         .= (libraryJ    <$> library)
    , "executables"     .= (executableJ <$> executables)
    , "tests"           .= (testSuiteJ  <$> testSuites)
    , "benchmarks"      .= (benchmarkJ  <$> benchmarks)
    , "data-files"      .= dataFiles
    , "data-dir"        .= dataDir
    , "extra-src-files" .= extraSrcFiles
    , "extra-tmp-files" .= extraTmpFiles
    , "extra-doc-files" .= extraDocFiles
    ] |> object
  where
    meta :: Value
    meta = [ "license"       .= licenseJ license
           , "license-files" .= licenseFiles
           , "copyright"     .= copyright
           , "maintainer"    .= maintainer
           , "author"        .= author
           , "stability"     .= stability
           , "tested-with"   .= map testedWithJ testedWith
           , "homepage"      .= homepage
           , "package-url"   .= pkgUrl
           , "bug-reports"   .= bugReports
           , "source-repos"  .= (sourceRepoJ <$> sourceRepos)
           , "synopsis"      .= synopsis
           , "description"   .= description
           , "category"      .= category
           ] |> object

    testedWithJ :: (C.CompilerFlavor, C.VersionRange) -> Value
    testedWithJ (cf, vr) = [ "compiler" .= compilerFlavorJ cf
                           , "versions" .= versionRangeJ vr
                           ] |> object

compilerFlavorJ :: C.CompilerFlavor -> Value
compilerFlavorJ = go
  where
    go C.GHC               = "GHC"
    go C.GHCJS             = "GHCJS"
    go C.NHC               = "NHC"
    go C.YHC               = "YHC"
    go C.Hugs              = "Hugs"
    go C.HBC               = "HBC"
    go C.Helium            = "Helium"
    go C.JHC               = "JHC"
    go C.LHC               = "LHC"
    go C.UHC               = "UHC"
    go (C.HaskellSuite s)  = object ["haskell-suite" .= s]
    go (C.OtherCompiler s) = object ["other" .= s]

libraryJ :: C.Library -> Value
libraryJ (C.Library {..})
  = [ "modules" .= (moduleNameJ <$> exposedModules)
    , "info"    .= buildInfoJ libBuildInfo
    ] |> object

executableJ :: C.Executable -> Value
executableJ (C.Executable {..})
  = [ "name"   .= exeName
    , "module" .= modulePath
    , "info"   .= buildInfoJ buildInfo
    ] |> object

testSuiteJ :: C.TestSuite -> Value
testSuiteJ (C.TestSuite {..})
  = [ "name"      .= testName
    , "interface" .= testSuiteInterfaceJ testInterface
    , "info"      .= buildInfoJ testBuildInfo
    , "enabled"   .= testEnabled
    ] |> object

benchmarkJ :: C.Benchmark -> Value
benchmarkJ (C.Benchmark {..})
  = [ "name"      .= benchmarkName
    , "interface" .= benchmarkInterfaceJ benchmarkInterface
    , "info"      .= buildInfoJ benchmarkBuildInfo
    , "enabled"   .= benchmarkEnabled
    ] |> object

buildInfoJ :: C.BuildInfo -> Value
buildInfoJ (C.BuildInfo {..})
  = [ "buildable"             .= buildable
    , "build-tools"           .= (dependencyJ <$> buildTools)
    , "cpp-options"           .= cppOptions
    , "cc-options"            .= ccOptions
    , "ld-options"            .= ldOptions
    , "pkgconfig-depends"     .= (dependencyJ <$> pkgconfigDepends)
    , "frameworks"            .= frameworks
    , "extra-framework-dirs"  .= extraFrameworkDirs
    , "c-sources"             .= cSources
    , "js-sources"            .= jsSources
    , "hs-source-dirs"        .= hsSourceDirs
    , "other-modules"         .= (moduleNameJ <$> otherModules)
    , "default-language"      .= (languageJ <$> defaultLanguage)
    , "other-languages"       .= (languageJ <$> otherLanguages)
    , "default-extensions"    .= (extensionJ
                                  <$> (oldExtensions <> defaultExtensions))
    , "other-extensions"      .= (extensionJ <$> otherExtensions)
    , "extra-libs"            .= extraLibs
    , "extra-ghci-libs"       .= extraGHCiLibs
    , "extra-lib-dirs"        .= extraLibDirs
    , "include-dirs"          .= includeDirs
    , "includes"              .= includes
    , "install-includes"      .= installIncludes
    -- , "options"               .= options
    -- , "prof-options"          .= profOptions
    -- , "shared-options"        .= sharedOptions
    , "custom-fields"         .= HM.fromList customFieldsBI
    , "target-build-depends"  .= (dependencyJ <$> targetBuildDepends)
    -- , "target-build-renaming" .= targetBuildRenaming
    ] |> object

dependencyJ :: C.Dependency -> Value
dependencyJ (C.Dependency pkg range) = [ "name"     .= packageNameJ pkg
                                       , "versions" .= versionRangeJ range
                                       ] |> object

versionRangeJ :: C.VersionRange -> Value
versionRangeJ = C.toVersionIntervals .> versionIntervalsJ

packageNameJ :: C.PackageName -> Value
packageNameJ = C.unPackageName .> toJSON

moduleNameJ :: C.ModuleName -> Value
moduleNameJ = C.components .> intercalate "." .> toJSON

versionIntervalsJ :: C.VersionIntervals -> Value
versionIntervalsJ = C.versionIntervals
                    .> (\case xs | any isStar xs -> "*"
                              xs                 -> toJSON (interval <$> xs))
    where
      interval :: C.VersionInterval -> Value
      interval (int@(lower, upper))
        | isSingleVersion int = toJSON (lowerVersion lower)
        | otherwise           = [ "lower" .= lowerBoundJ lower
                                , "upper" .= upperBoundJ upper
                                ] |> object

      lowerVersion :: C.LowerBound -> C.Version
      lowerVersion (C.LowerBound v _) = v

      isStar :: C.VersionInterval -> Bool
      isStar = pure
               .> C.mkVersionIntervals
               .> fromJust
               .> C.fromVersionIntervals
               .> C.isAnyVersion

      isSingleVersion :: C.VersionInterval -> Bool
      isSingleVersion (lower, upper) = (lowerBoundJ lower == upperBoundJ upper)

lowerBoundJ :: C.LowerBound -> Value
lowerBoundJ (C.LowerBound v b) = object ["version" .= v, "type" .= boundJ b]

upperBoundJ :: C.UpperBound -> Value
upperBoundJ C.NoUpperBound     = Null
upperBoundJ (C.UpperBound v b) = object ["version" .= v, "type" .= boundJ b]

boundJ :: C.Bound -> Value
boundJ C.ExclusiveBound = "exclusive"
boundJ C.InclusiveBound = "inclusive"

licenseJ :: C.License -> Value
licenseJ = licenseToSPDX .> spdxJ

sourceRepoJ :: C.SourceRepo -> Value
sourceRepoJ (C.SourceRepo {..})
  = [ "kind"     .= repoKindJ repoKind
    , "type"     .= repoTypeJ (fromJust repoType)
    , "location" .= fromJust repoLocation
    , "module"   .= repoModule
    , "branch"   .= repoBranch
    , "tag"      .= repoTag
    , "subdir"   .= repoSubdir
    ] |> object

repoKindJ :: C.RepoKind -> Value
repoKindJ C.RepoHead            = "head"
repoKindJ C.RepoThis            = "this"
repoKindJ (C.RepoKindUnknown s) = object ["unknown" .= s]

repoTypeJ :: C.RepoType -> Value
repoTypeJ C.Darcs             = "darcs"
repoTypeJ C.Git               = "git"
repoTypeJ C.SVN               = "svn"
repoTypeJ C.CVS               = "cvs"
repoTypeJ C.Mercurial         = "mercurial"
repoTypeJ C.GnuArch           = "arch"
repoTypeJ C.Bazaar            = "bazaar"
repoTypeJ C.Monotone          = "monotone"
repoTypeJ (C.OtherRepoType s) = object ["unknown" .= s]

testSuiteInterfaceJ :: C.TestSuiteInterface -> Value
testSuiteInterfaceJ = go
  where
    go (ti@(C.TestSuiteExeV10 _ fp))   = tiObject ti ["path" .= fp]
    go (ti@(C.TestSuiteLibV09 _ m))    = tiObject ti ["module" .= moduleNameJ m]
    go (ti@(C.TestSuiteUnsupported _)) = tiObject ti []

    tiObject ti attrs = let tt = prettyTT (testType ti)
                        in object (["type" .= tt] <> attrs)

    prettyTT :: C.TestType -> Text
    prettyTT (C.TestTypeExe v)       = "exitcode-stdio-" <> versionText v
    prettyTT (C.TestTypeLib v)       = "detailed-" <> versionText v
    prettyTT (C.TestTypeUnknown s _) = T.pack s

    testType :: C.TestSuiteInterface -> C.TestType
    testType = \case (C.TestSuiteExeV10 ver _)   -> C.TestTypeExe ver
                     (C.TestSuiteLibV09 ver _)   -> C.TestTypeLib ver
                     (C.TestSuiteUnsupported tt) -> tt

benchmarkInterfaceJ :: C.BenchmarkInterface -> Value
benchmarkInterfaceJ = go
  where
    go (bi@(C.BenchmarkExeV10 _ fp))   = biObject bi ["path" .= fp]
    go (bi@(C.BenchmarkUnsupported _)) = biObject bi []

    biObject bi attrs = let bt = prettyBT (benchType bi)
                        in object (["type" .= bt] <> attrs)

    prettyBT :: C.BenchmarkType -> Text
    prettyBT (C.BenchmarkTypeExe v)       = "exitcode-stdio-" <> versionText v
    prettyBT (C.BenchmarkTypeUnknown s _) = T.pack s

    benchType :: C.BenchmarkInterface -> C.BenchmarkType
    benchType = \case (C.BenchmarkExeV10 ver _)   -> C.BenchmarkTypeExe ver
                      (C.BenchmarkUnsupported bt) -> bt

languageJ :: L.Language -> Value
languageJ L.Haskell98           = "Haskell98"
languageJ L.Haskell2010         = "Haskell2010"
languageJ (L.UnknownLanguage s) = fromString s

extensionJ :: L.Extension -> Value
extensionJ (L.EnableExtension  ext) = object ["enable"  .= show ext]
extensionJ (L.DisableExtension ext) = object ["disable" .= show ext]
extensionJ (L.UnknownExtension str) = object ["unknown" .= str]

knownExtensionJ :: L.KnownExtension -> Value
knownExtensionJ = show .> fromString

main :: IO ()
main = do
  [cabal] <- getArgs
  parseCabal cabal >>= packageDescriptionJ .> encode .> LBSC8.putStrLn