{-# 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