{-# language LambdaCase #-}
{-# language OverloadedStrings #-}
{-# language RecordWildCards #-}
{-# language ViewPatterns #-}
module Main
  ( main
  )
  where

import Control.Applicative ( (<**>) )
import Data.Foldable ( for_ )
import Data.String ( fromString )
import System.Directory ( createDirectoryIfMissing )
import System.FilePath
  ( (</>), (<.>), dropTrailingPathSeparator, normalise
  , splitDirectories, splitFileName, takeDirectory
  )

import CabalToDhall
  ( KnownDefault, PreludeReference (..), getDefault )
import DhallToCabal.FactorType
  ( KnownType (..), factored )
import DhallToCabal.Util
  ( relativeTo )

import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
import qualified Dhall.Core
import qualified Dhall.Core as Expr ( Expr(..) )
import qualified Dhall.Lint as Lint
import qualified Dhall.Parser
import qualified Options.Applicative as OptParse
import qualified System.IO


data MetaOptions = MetaOptions
  { prefix :: FilePath }


metaOptionsParser :: OptParse.Parser MetaOptions
metaOptionsParser =
  MetaOptions
    <$>
      OptParse.strOption
        ( mconcat
            [ OptParse.long "prefix"
            , OptParse.value "dhall/"
            , OptParse.metavar "PATH"
            ]
        )


defaultFile :: KnownDefault -> FilePath
defaultFile typ = "./defaults" </> show typ <.> "dhall"


typeFile :: KnownType -> FilePath
typeFile = \case
  Library -> "types/Library.dhall"
  ForeignLibrary -> "types/ForeignLibrary.dhall"
  Benchmark -> "types/Benchmark.dhall"
  Executable -> "types/Executable.dhall"
  TestSuite -> "types/TestSuite.dhall"
  BuildInfo -> "types/BuildInfo.dhall"
  Config -> "types/Config.dhall"
  SourceRepo -> "types/SourceRepo.dhall"
  RepoType -> "types/RepoType.dhall"
  RepoKind -> "types/RepoKind.dhall"
  Compiler -> "types/Compiler.dhall"
  OS -> "types/OS.dhall"
  Extension -> "types/Extension.dhall"
  CompilerOptions -> "types/CompilerOptions.dhall"
  Arch -> "types/Arch.dhall"
  Language -> "types/Language.dhall"
  License -> "types/License.dhall"
  BuildType -> "types/BuildType.dhall"
  Package -> "types/Package.dhall"
  VersionRange -> "types/VersionRange.dhall"
  Version -> "types/Version.dhall"
  SPDX -> "types/SPDX.dhall"
  LicenseId -> "types/SPDX/LicenseId.dhall"
  LicenseExceptionId -> "types/SPDX/LicenseExceptionId.dhall"
  Scope -> "types/Scope.dhall"
  ModuleRenaming -> "types/ModuleRenaming.dhall"
  ForeignLibOption -> "types/ForeignLibOption.dhall"
  ForeignLibType -> "types/ForeignLibType.dhall"
  SetupBuildInfo -> "types/SetupBuildInfo.dhall"
  Dependency -> "types/Dependency.dhall"
  TestType -> "types/TestType.dhall"
  Mixin -> "types/Mixin.dhall"
  Flag -> "types/Flag.dhall"


importFile :: FilePath -> Dhall.Core.Import
importFile ( splitFileName -> ( directory, filename ) ) =
  let
    rawComponents =
      fromString <$>
        splitDirectories ( dropTrailingPathSeparator directory )
    ( components, relativity ) =
      case rawComponents of
        ".." : rest -> ( rest, Dhall.Core.Parent )
        -- `splitFileName "foo"` produces (".", "foo"). It'd be OK to
        -- leave the dot component in, but we might as well remove it
        -- for neatness.
        "." : rest -> ( rest, Dhall.Core.Here )
        _ -> ( rawComponents, Dhall.Core.Here )
  in
    Dhall.Core.Import
      { Dhall.Core.importHashed =
          Dhall.Core.ImportHashed
            { Dhall.Core.hash =
                Nothing
            , Dhall.Core.importType =
                Dhall.Core.Local
                  relativity
                  ( Dhall.Core.File
                     ( Dhall.Core.Directory ( reverse components ) )
                     ( fromString filename )
                  )
            }
      , Dhall.Core.importMode =
          Dhall.Core.Code
      }


writeOutput :: FilePath -> Dhall.Core.Expr s Dhall.Core.Import -> IO ()
writeOutput dest expr =
  System.IO.withFile dest System.IO.WriteMode $ \ hnd -> do
    System.IO.hPutStrLn hnd $
         "-- This file is auto-generated by dhall-to-cabal-meta. Look but"
      ++ " don't touch (unless you want your edits to be over-written)."
    Pretty.renderIO
      hnd
      ( Pretty.layoutSmart prettyOpts
          ( Pretty.pretty expr )
      )
    -- Pretty.renderIO doesn't give us a final newline, so add that ourselves.
    System.IO.hPutStr hnd "\n"


meta :: MetaOptions -> IO ()
meta (MetaOptions {..}) = do
  putStrLn $
    "Generating defaults and types underneath " ++ prefix ++ "."

  putStrLn "Generating types..."

  for_ [ minBound .. maxBound ] $ \ knownType -> do
    let
      localDest =
        typeFile knownType

      expr =
        importFile . relativeTo localDest . typeFile <$> factored knownType

      dest =
        prefix </> localDest

    putStrLn $
      "  Writing type for " ++ show knownType ++ " to " ++ dest ++ "."

    createDirectoryIfMissing True ( takeDirectory dest )

    writeOutput dest expr

  putStrLn "Generating defaults..."

  for_ [ minBound .. maxBound ] $ \ defaultType -> do
    let localDest =
          defaultFile defaultType

        -- normalise for prettiness in display (otherwise we get /./ components)
        dest =
          normalise ( prefix </> localDest )

        resolve = \case
          PreludeDefault typ ->
            Expr.Embed
              ( importFile ( relativeTo localDest ( defaultFile typ ) ) )
          PreludeConstructorsLicense ->
            Expr.Var "types" `Expr.Field` "License"
          PreludeConstructorsRepoKind ->
            Expr.Var "types" `Expr.Field` "RepoKind"
          PreludeConstructorsScope ->
            Expr.Var "types" `Expr.Field` "Scope"
          PreludeV ->
            Expr.Embed
              ( importFile ( relativeTo localDest "./Version/v.dhall" ) )

        expr :: Expr.Expr Dhall.Parser.Src Dhall.Core.Import
        expr =
          getDefault
            ( importFile ( relativeTo localDest "./types.dhall" ) )
            resolve
            defaultType

    putStrLn $
      "  Writing default for " ++ show defaultType ++ " to " ++ dest ++ "."

    createDirectoryIfMissing True ( takeDirectory dest )

    writeOutput dest ( Lint.lint expr )


-- Shamelessly taken from dhall-format
prettyOpts :: Pretty.LayoutOptions
prettyOpts =
  Pretty.defaultLayoutOptions
    { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 }


main :: IO ()
main = do
  metaOpts <-
    OptParse.execParser opts

  meta metaOpts

  where

  opts =
    OptParse.info ( metaOptionsParser <**> OptParse.helper ) mempty