gistfile1.hs

{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Main (main) where

import Control.Monad (when)
import qualified Data.ByteString.Lazy as BL
import Data.List
import Data.Aeson
import Data.Aeson.TH
import qualified Data.Text as T
import Distribution.ModuleName (ModuleName)
import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
import Distribution.PackageDescription.Parse (readPackageDescription)
import Distribution.Verbosity
import Distribution.Version
import Distribution.License
import Distribution.Compiler
import Distribution.System
import Distribution.Text
import Language.Haskell.Extension
import System.Environment (getArgs)
import System.FilePath ((</>), (<.>))
import Text.PrettyPrint

deriveToJSON defaultOptions ''PackageDescription
deriveToJSON defaultOptions ''PackageIdentifier
deriveToJSON defaultOptions ''PackageName
deriveToJSON defaultOptions ''SourceRepo
deriveToJSON defaultOptions ''Library
deriveToJSON defaultOptions ''Executable
deriveToJSON defaultOptions ''TestSuite
deriveToJSON defaultOptions ''TestSuiteInterface
deriveToJSON defaultOptions ''BuildInfo
deriveToJSON defaultOptions ''Language
deriveToJSON defaultOptions ''Extension
deriveToJSON defaultOptions ''KnownExtension
deriveToJSON defaultOptions ''TestType
deriveToJSON defaultOptions ''Benchmark
deriveToJSON defaultOptions ''BenchmarkInterface
deriveToJSON defaultOptions ''BenchmarkType

instance ToJSON License where
  toJSON = toJSON . render . disp

instance ToJSON BuildType where
  toJSON = toJSON . render . disp

instance ToJSON ModuleName where
  toJSON = toJSON . render . disp

instance ToJSON RepoKind where
  toJSON = toJSON . render . disp

instance ToJSON RepoType where
  toJSON = toJSON . render . disp

instance ToJSON Version where
  toJSON = toJSON . render . disp

instance ToJSON VersionRange where
  toJSON AnyVersion                     = toJSON ("any" :: T.Text)
  toJSON (ThisVersion ver)              = object ["this" .= ver]
  toJSON (LaterVersion ver)             = object ["later" .= ver]
  toJSON (EarlierVersion ver)           = object ["earlier" .= ver]
  toJSON (WildcardVersion ver)          = object ["wildcard" .= ver]
  toJSON (UnionVersionRanges v1 v2)     = object ["union" .= [v1, v2]]
  toJSON (IntersectVersionRanges v1 v2) = object ["intersect" .= [v1, v2]]
  toJSON (VersionRangeParens ver)       = toJSON ver

instance ToJSON Dependency where
  toJSON (Dependency pkg ver) = object ["package" .= pkg, "version" .= ver]

instance (ToJSON v, ToJSON c, ToJSON a) => ToJSON (CondTree v c a) where
  toJSON (CondNode a c v) = object ["data" .= a, "constraints" .= c, "components" .= v]

instance ToJSON c => ToJSON (Condition c) where
  toJSON (Var c)      = object ["var" .= c]
  toJSON (Lit f)      = object ["lit" .= f]
  toJSON (CNot c)     = object ["not" .= c]
  toJSON (COr c1 c2)  = object ["or"  .= toJSON [c1, c2]]
  toJSON (CAnd c1 c2) = object ["and" .= toJSON [c1, c2]]

instance ToJSON ConfVar where
  toJSON (OS os)         = object ["os" .= os]
  toJSON (Arch arch)     = object ["arch" .= arch]
  toJSON (Flag flag)     = object ["flag" .= flag]
  toJSON (Impl comp ver) = object ["impl" .= comp, "constraints" .= ver]

instance ToJSON FlagName where
  toJSON (FlagName str) = toJSON str

instance ToJSON OS where
  toJSON = toJSON . render . disp

instance ToJSON Arch where
  toJSON = toJSON . render . disp

instance ToJSON Flag where
  toJSON MkFlag{..} =
    object ["name" .= flagName, "description" .= flagDescription, "default" .= flagDefault, "manual" .= flagManual]

instance ToJSON CompilerFlavor where
  toJSON = toJSON . render . disp

data JSONDescription = JSONDescription {jsonDesc :: PackageDescription, jsonFlags :: [Flag], jsonLib :: CondTree ConfVar [Dependency] Library}

instance ToJSON JSONDescription where
  toJSON JSONDescription{..} = object ["desc" .= jsonDesc, "flags" .= jsonFlags, "lib" .= jsonLib]

main :: IO ()
main = do
  args <- getArgs
  when (length args == 0) $ fail "missing .cabal file"

  let (source:_) = args
  gdesc <- readPackageDescription normal source
  let desc = flattenPackageDescription gdesc
  case condLibrary gdesc of
    Just lib -> do
      let filePath = render . disp . package $ packageDescription gdesc
          bs = encode . toJSON $ JSONDescription (packageDescription gdesc) (genPackageFlags gdesc) lib
      BL.writeFile ("/Source/hackage/new3" </> filePath <.> "json") bs
      -- BL.writeFile ("/dev/stdout") bs
    Nothing -> return ()