Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
{-# 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 ()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment