{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}

module Transform
  ( toBlocks
  )
where

import           Control.Arrow
import           Control.DeepSeq
import           Control.Monad
import           Data.Char
import           Data.Maybe
import           Distribution.License
import           Distribution.PackageDescription
import           Distribution.Types.CondTree
import           Distribution.Types.ExecutableScope
import           Distribution.Types.ForeignLib
import           Distribution.Types.ForeignLibType
import           Distribution.Types.PackageId
import           Distribution.Types.PackageName
import           Distribution.Types.UnqualComponentName
import           Distribution.Version
import           Prelude.Compat

import           Types.Block
import           Types.Field

(<&>) = flip fmap

toBlocks GenericPackageDescription {..} =
  ( pdToFields packageDescription
  , concat
    [ map setupBuildInfoToBlock
      $ maybeToList (setupBuildInfo packageDescription)
    , map sourceRepoToBlock (sourceRepos packageDescription)
    , map flagToBlock       genPackageFlags
    , map (libToBlock packageDescription Nothing) $ maybeToList condLibrary
    , map (uncurry (libToBlock packageDescription) . first Just)
          condSubLibraries
    , map (uncurry $ foreignLibToBlock packageDescription) condForeignLibs
    , map (uncurry $ exeToBlock packageDescription)        condExecutables
    , map (uncurry $ testToBlock packageDescription)       condTestSuites
    , map (uncurry $ benchToBlock packageDescription)      condBenchmarks
    ]
  )

setupBuildInfoToBlock SetupBuildInfo {..} =
  defaultSetupDepends
    `seq` Block CustomSetup
                [nonEmpty (dependencies "setup-depends") setupDepends]
                []
    -- defaultSetupDepends doesn't correspond to anything in the cabal file

sourceRepoToBlock SourceRepo {..} = Block
  (SourceRepo_ repoKind)
  [ stringField "type" . showType =<< repoType
  , stringField "location" =<< repoLocation
  , file "subdir" =<< repoSubdir
  , file "tag" =<< repoTag
  , file "branch" =<< repoBranch
  , file "module" =<< repoModule
  ]
  []
  where
    showType (OtherRepoType n) = n
    showType x                 = map toLower $ show x

pdToFields pd@PackageDescription {..} =
  [ guard newSpec >> cabalVersion "cabal-version" specVersionRaw
    , stringField "name" (unPackageName $ pkgName package)
    , version "version" (pkgVersion package)
    , nonEmpty (stringField "synopsis") synopsis
    , desc description
    , either (spdxLicenseField "license")
             (ffilter (/= UnspecifiedLicense) (licenseField "license"))
             licenseRaw
    , license' licenseFiles
    , nonEmpty (stringField "copyright")   copyright
    , nonEmpty (stringField "author")      author
    , nonEmpty (stringField "maintainer")  maintainer
    , nonEmpty (stringField "stability")   stability
    , nonEmpty (testedField "tested-with") testedWith
    , nonEmpty (stringField "category")    category
    , nonEmpty (stringField "homepage")    homepage
    , nonEmpty (stringField "package-url") pkgUrl
    , nonEmpty (stringField "bug-reports") bugReports
    , stringField "build-type" . show =<< buildTypeRaw
    , nonEmpty (longList "extra-tmp-files")    extraTmpFiles
    , nonEmpty (longList "extra-source-files") extraSrcFiles
    , nonEmpty (longList "extra-doc-files")    extraDocFiles
    , nonEmpty (longList "data-files")         dataFiles
    , nonEmpty (stringField "data-dir")        dataDir
    , guard (not newSpec) >> cabalVersion "cabal-version" specVersionRaw
    ]
    ++ map (uncurry stringField) customFieldsPD
  where
    newSpec = withinRange packageVersion (orLaterVersion $ mkVersion [2, 1])
    packageVersion = specVersion pd
    license' []  = Nothing
    license' [l] = file "license-file" l
    license' ls  = commas "license-files" ls

flagToBlock MkFlag {..} = Block
  (Flag_ (unFlagName flagName))
  [ stringField "default" (show flagDefault)
  , ffilter id (stringField "manual" . show) flagManual
  , desc flagDescription
  ]
  []

libToBlock pkg libname CondNode {..} = deepseq condTreeConstraints $ Block
  (Library_ $ unUnqualComponentName <$> libname)
  (  libDataToFields condTreeData
  ++ buildInfoToFields pkg (libBuildInfo condTreeData)
  )
  (nodesToBlocks pkg libBuildInfo libDataToFields condTreeComponents)

libDataToFields Library {..} =
  libName
    `deepseq` [ ffilter not (stringField "exposed" . show) libExposed
              , nonEmpty (modules "exposed-modules")        exposedModules
              , nonEmpty (rexpModules "reexported-modules") reexportedModules
              , nonEmpty (modules "signatures")             signatures
              ]

foreignLibToBlock pkg libname CondNode {..} =
  condTreeConstraints `deepseq` Block
    (ForeignLib_ $ unUnqualComponentName libname)
    (  foreignLibDataToFields condTreeData
    ++ buildInfoToFields pkg (foreignLibBuildInfo condTreeData)
    )
    (nodesToBlocks pkg
                   foreignLibBuildInfo
                   foreignLibDataToFields
                   condTreeComponents
    )

foreignLibDataToFields ForeignLib {..} =
  foreignLibName
    `seq` [ ffilter (== ForeignLibNativeShared) (flibType "type") foreignLibType
          , nonEmpty (flibOptions "options") foreignLibOptions
          , stringField "lib-version-info" . showLVI =<< foreignLibVersionInfo
          , version "lib-version-linux" =<< foreignLibVersionLinux
          , nonEmpty (commas "mod-def-file") foreignLibModDefFile
          ]
  where
    showLVI l =
      let (a, b, c) = libVersionInfoCRA l
      in  show a ++ ":" ++ show b ++ ":" ++ show c

exeToBlock pkg exeName CondNode {..} = deepseq condTreeConstraints $ Block
  (Exe_ (unUnqualComponentName exeName))
  (  exeDataToFields condTreeData
  ++ buildInfoToFields pkg (buildInfo condTreeData)
  )
  (nodesToBlocks pkg buildInfo exeDataToFields condTreeComponents)

exeDataToFields Executable {..} =
  exeName
    `seq` [ nonEmpty (stringField "main-is") modulePath
          , ffilter (== ExecutablePrivate)
                    (\_ -> stringField "scope" "private")
                    exeScope
          ]

testToBlock pkg testName CondNode {..} = deepseq condTreeConstraints $ Block
  (TestSuite_ (unUnqualComponentName testName))
  (  testDataToFields condTreeData
  ++ buildInfoToFields pkg (testBuildInfo condTreeData)
  )
  (nodesToBlocks pkg testBuildInfo testDataToFields condTreeComponents)

testDataToFields TestSuite {..} = testName `seq` case testInterface of
  TestSuiteExeV10 v f ->
    v `seq` [stringField "type" "exitcode-stdio-1.0", stringField "main-is" f]
  TestSuiteLibV09 v m ->
    v `seq` [stringField "type" "detailed-0.9", module_ "test-module" m]
  _ -> []

benchToBlock pkg benchName CondNode {..} = deepseq condTreeConstraints $ Block
  (Benchmark_ $ unUnqualComponentName benchName)
  (  benchDataToFields condTreeData
  ++ buildInfoToFields pkg (benchmarkBuildInfo condTreeData)
  )
  (nodesToBlocks pkg benchmarkBuildInfo benchDataToFields condTreeComponents)

benchDataToFields Benchmark {..} =
  benchmarkName `seq` case benchmarkInterface of
    BenchmarkExeV10 v f ->
      v `seq` [stringField "type" "exitcode-stdio-1.0", stringField "main-is" f]
    _ -> []

nodesToBlocks pkg f renderMore = concatMap (condNodeToBlock pkg f renderMore)

condNodeToBlock pkg getBuildInfo extra (CondBranch pred' branch1 branch2) =
  let b1 = deepseq (condTreeConstraints branch1) $ Block
        (If pred')
        (  extra (condTreeData branch1)
        ++ buildInfoToFields pkg (getBuildInfo $ condTreeData branch1)
        )
        (nodesToBlocks pkg getBuildInfo extra (condTreeComponents branch1))
      b2 = branch2 <&> \b -> deepseq (condTreeConstraints b) $ Block
        Else
        (  extra (condTreeData b)
        ++ buildInfoToFields pkg (getBuildInfo $ condTreeData b)
        )
        (nodesToBlocks pkg getBuildInfo extra (condTreeComponents b))
  in  b1 : maybeToList b2

buildInfoToFields _ BuildInfo {..} =
  staticOptions
    `seq` -- staticOptions isn't in the parser yet
          [ nonEmpty (commas "other-languages" . map show) otherLanguages
          , nonEmpty (modules "other-modules") otherModules
          , nonEmpty (modules "virtual-modules") virtualModules
          , nonEmpty (mixins_ "mixins") mixins
          , nonEmpty (modules "autogen-modules") autogenModules
          , nonEmpty (commas "hs-source-dirs") hsSourceDirs
          , buildDeps targetBuildDepends
          , stringField "default-language" . show =<< defaultLanguage
          , nonEmpty (extensions "default-extensions") defaultExtensions
          , nonEmpty (extensions "extensions") oldExtensions
          , nonEmpty (extensions "other-extensions") otherExtensions
          , nonEmpty (commas "extra-library-flavours") extraLibFlavours
          , nonEmpty (commas "extra-libraries") extraLibs
          , nonEmpty (commas "extra-ghci-libraries") extraGHCiLibs
          , nonEmpty (commas "extra-bundled-libraries") extraBundledLibs
          , nonEmpty (pcDepends "pkgconfig-depends") pkgconfigDepends
          , nonEmpty (commas "frameworks") frameworks
          , nonEmpty (commas "extra-framework-dirs") extraFrameworkDirs
          , nonEmpty (spaces "cc-options") ccOptions
          , nonEmpty (spaces "cxx-options") cxxOptions
          , nonEmpty (spaces "cmm-options") cmmOptions
          , nonEmpty (spaces "asm-options") asmOptions
          , nonEmpty (spaces "cpp-options") cppOptions
          , nonEmpty (spaces "ld-options") ldOptions
          , nonEmpty (commas "js-sources") jsSources
          , nonEmpty (commas "cxx-sources") cxxSources
          , nonEmpty (commas "c-sources") cSources
          , nonEmpty (commas "cmm-sources") cmmSources
          , nonEmpty (commas "asm-sources") asmSources
          , nonEmpty (commas "extra-lib-dirs") extraLibDirs
          , nonEmpty (commas "includes") includes
          , nonEmpty (commas "install-includes") installIncludes
          , nonEmpty (commas "include-dirs") includeDirs
          , ffilter not (stringField "buildable" . show) buildable
          , nonEmpty (toolDepends "build-tool-depends") newTools
          , nonEmpty (oldToolDepends "build-tools") oldTools
          ]
    ++    map (optionToField "")        options
    ++    map (optionToField "-prof")   profOptions
    ++    map (optionToField "-shared") sharedOptions
    ++    map (uncurry stringField)     customFieldsBI
  where (oldTools, newTools) = (buildTools, buildToolDepends)

optionToField pref (f, args) =
  spaces (map toLower (show f) ++ pref ++ "-options") args