{-# language LambdaCase #-}
{-# language NoMonomorphismRestriction #-}
{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}
{-# language RecordWildCards #-}
{-# language ViewPatterns #-}
module Main ( main ) where
import Control.Applicative ( (<**>), optional, (<|>) )
import Control.Monad ( join )
import Data.Char ( isAlphaNum )
import Data.Foldable ( asum, foldl' )
import Data.Function ( (&) )
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe ( fromMaybe )
import Data.Text (Text)
import Data.String ( fromString )
import Data.Version ( showVersion )
import Lens.Micro ( set )
import System.Directory ( createDirectoryIfMissing )
import System.FilePath ( (</>), (<.>), addTrailingPathSeparator, normalise, takeDirectory )
import CabalToDhall ( KnownDefault, getDefault, resolvePreludeVar )
import DhallLocation ( preludeLocation, typesLocation, dhallFromGitHub )
import DhallToCabal
import DhallToCabal.FactorType ( KnownType(..), factored, mapWithBindings )
import DhallToCabal.Util ( relativeTo )
import qualified Paths_dhall_to_cabal as Paths
import qualified Data.Text.IO as StrictText
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty
import qualified Dhall
import qualified Dhall.Core as Dhall
import qualified Dhall.Core as Expr ( Expr(..), Binding(..) )
import qualified Dhall.Lint as Lint
import qualified Dhall.Parser
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription.PrettyPrint as Cabal
import qualified Distribution.Types.PackageId as Cabal
import qualified Distribution.Types.PackageName as Cabal
import qualified Options.Applicative as OptParse
import qualified System.IO
data Command
= RunDhallToCabal DhallToCabalOptions
| PrintType PrintTypeOptions
| PrintDefault PrintDefaultOptions
| PrintVersion
shouldBeImported :: KnownType -> Bool
shouldBeImported Extension = True
shouldBeImported LicenseId = True
shouldBeImported LicenseExceptionId = True
shouldBeImported _ = False
data DhallToCabalOptions = DhallToCabalOptions
{ dhallFilePath :: Maybe String
, explain :: Bool
, outputDirection :: OutputDirection
}
data OutputDirection
= OutputStdout
| OutputDir RelativeDir
data RelativeDir
= RelativeToCWD FilePath
| RelativeToInput FilePath
dhallToCabalOptionsParser :: OptParse.Parser DhallToCabalOptions
dhallToCabalOptionsParser =
DhallToCabalOptions
<$>
optional
( OptParse.argument
OptParse.str
( mconcat
[ OptParse.metavar "<dhall input file>"
, OptParse.help "The Dhall expression to convert to a Cabal file"
]
)
)
<*>
OptParse.flag
False
True
( mconcat
[ OptParse.long "explain"
, OptParse.help "Provide explanations to type Dhall syntax and type errors."
]
)
<*>
outputDirectionParser
where
-- Note order: the --output-dir-input does not fail because it has a default value.
outputDirectionParser =
OptParse.flag'
OutputStdout
( mconcat
[ OptParse.long "output-stdout"
, OptParse.help "Write the .cabal file to standard output."
]
)
<|> OutputDir . RelativeToCWD <$> OptParse.strOption
( mconcat
[ OptParse.long "output-dir-cwd"
, OptParse.metavar "DIR"
, OptParse.help "Write the resulting .cabal file to DIR/NAME.cabal, where NAME is taken from the .cabal file's 'name' field, and DIR is relative to the current working directory."
]
)
<|> OutputDir . RelativeToInput <$> OptParse.strOption
( mconcat
[ OptParse.long "output-dir-input"
, OptParse.metavar "DIR"
, OptParse.help "Write the resulting .cabal file to DIR/NAME.cabal, where NAME is taken from the .cabal file's 'name' field, and DIR is relative to the directory containing the input Dhall file (or the current working directory if the input is from standard input)."
, OptParse.value "."
]
)
data PrintTypeOptions = PrintTypeOptions
{ typeToPrint :: KnownType
, selfContained :: Bool
}
printTypeOptionsParser :: OptParse.Parser PrintTypeOptions
printTypeOptionsParser =
PrintTypeOptions
<$>
OptParse.option OptParse.auto modifiers
<*>
OptParse.flag
False
True
( mconcat
[ OptParse.long "self-contained"
, OptParse.help "Emit self-contained types. Without this flag, some large enumerations are referenced by import."
]
)
where
modifiers =
mconcat
[ OptParse.long "print-type"
, OptParse.help "Print out the description of a type. For a full description, try --print-type Package"
, OptParse.metavar "TYPE"
]
printVersionParser :: OptParse.Parser ()
printVersionParser =
OptParse.flag'
()
( mconcat
[ OptParse.long "version"
, OptParse.help "Display dhall-to-cabal's version and exit."
]
)
data PrintDefaultOptions =
PrintDefaultOptions
{ defaultToPrint :: KnownDefault }
printDefaultOptionsParser :: OptParse.Parser PrintDefaultOptions
printDefaultOptionsParser =
PrintDefaultOptions
<$>
OptParse.option OptParse.auto
( mconcat
[ OptParse.long "print-default"
, OptParse.help "Print out the default values for a type, as found in prelude.defaults"
, OptParse.metavar "TYPE"
]
)
runDhallToCabal :: DhallToCabalOptions -> IO ()
runDhallToCabal DhallToCabalOptions { dhallFilePath, explain, outputDirection } = do
source <-
case dhallFilePath of
Nothing ->
StrictText.getContents
Just filePath ->
StrictText.readFile filePath
let
settings = Dhall.defaultInputSettings
& set Dhall.rootDirectory inputDir
& set Dhall.sourceName ( fromMaybe "(STDIN)" dhallFilePath )
pkgDesc <- explaining ( dhallToCabal settings source )
let
rendered =
addWarningHeader
( Cabal.showGenericPackageDescription pkgDesc )
case outputDirection of
OutputStdout ->
putStrLn rendered
OutputDir _ -> do
createDirectoryIfMissing True destDir
let dest = destDir </> pkgDescName pkgDesc <.> "cabal"
putStrLn ( "Writing to " ++ normalise dest ++ "." )
writeFile dest rendered
where
inputDir = maybe "." takeDirectory dhallFilePath
destDir =
case outputDirection of
OutputStdout ->
"."
OutputDir (RelativeToCWD dir) ->
dir
OutputDir (RelativeToInput relativeDir) ->
inputDir </> relativeDir
explaining =
if explain then Dhall.detailed else id
pkgDescName = Cabal.unPackageName . Cabal.pkgName . Cabal.package . Cabal.packageDescription
-- Make sure that the displayed source path is copy-pasteable to
-- the command line, and won't break the generated Cabal
-- file. This is a somewhat conservative check.
isAcceptableCommentChar c =
isAlphaNum c || c == '.' || c == '/' || c == '_' || c == '-'
-- These regeneration instructions assume that (a) if we are
-- writing to stdout, the user is redirecting it a file in the
-- current directory, (b) the generated file is not moved after we
-- produce it, (c) there are no symlinks breaking .. components,
-- and (d) they will run the regeneration instructions from the
-- directory of the generated .cabal file.
--
-- These assumptions are necessarily approximations, but they're a
-- reasonable guess at the common case and at least give the user
-- something to go on.
regenerationInstructions =
case dhallFilePath of
Just filePath | all isAcceptableCommentChar filePath ->
[ "-- Instead, edit the source Dhall file, namely"
, "-- '" ++ filePath ++ "', and re-generate this file by running"
, "-- 'dhall-to-cabal -- " ++ sourcePath ++ "'."
]
where
sourcePath =
relativeTo ( addTrailingPathSeparator destDir ) filePath
_ ->
[ "-- Instead, edit the source Dhall file (which may have the"
, "-- '.dhall' extension) and re-run dhall-to-cabal, passing "
, "-- the source file's name as its argument."
]
-- Starting with Cabal 2.2, the cabal-version field *has* to be
-- the first thing in the .cabal file. So split that off and plonk
-- the warning header after it.
addWarningHeader str =
case lines str of
[] ->
error "addWarningHeader: no cabal-version line found?"
cabalVersion : rest ->
unlines $ concat
[ [ cabalVersion
, "-- * * * * * * * * * * * * WARNING * * * * * * * * * * * *"
, "-- This file has been AUTO-GENERATED by dhall-to-cabal."
, "--"
, "-- Do not edit it by hand, because your changes will be over-written!"
, "--"
]
, regenerationInstructions
, [ "-- * * * * * * * * * * * * WARNING * * * * * * * * * * * *" ]
, rest
]
main :: IO ()
main = do
command <-
OptParse.execParser opts
case command of
RunDhallToCabal options ->
runDhallToCabal options
PrintType options ->
printType options
PrintDefault options ->
printDefault options
PrintVersion ->
printVersion
where
parser =
asum
[ RunDhallToCabal <$> dhallToCabalOptionsParser
, PrintType <$> printTypeOptionsParser
, PrintDefault <$> printDefaultOptionsParser
, PrintVersion <$ printVersionParser
]
opts =
OptParse.info ( parser <**> OptParse.helper ) modifiers
modifiers =
mconcat
[ OptParse.progDesc "Generate Cabal files from Dhall expressions"
, OptParse.footer
( "The default behaviour is to generate a .cabal file in the "
++ "directory of the input file with a name corresponding to the "
++ "'name' field of the generated package description (i.e., the "
++ "same behaviour as specifying '--output-dir-input .'). In the "
++ "case of reading from standard input, the .cabal file will be "
++ "placed in the current working directory."
)
]
-- Shamelessly taken from dhall-format
opts :: Pretty.LayoutOptions
opts =
Pretty.defaultLayoutOptions
{ Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 }
-- Note: the expression is linted afterwards, so this can do the
-- drop-dead simple thing of adding a new `let` each time.
addBinding :: Text -> Dhall.Expr s a -> Dhall.Expr s a -> Dhall.Expr s a
addBinding name val =
Expr.Let
( Expr.Binding name Nothing val :| [] )
printType :: PrintTypeOptions -> IO ()
printType PrintTypeOptions { .. } = do
Pretty.renderIO
System.IO.stdout
( Pretty.layoutSmart opts
( Pretty.pretty ( Lint.lint result ) )
)
putStrLn ""
where
linkedType =
join . mapWithBindings linkType . factored
linkType var t =
let
name = fromString ( show t )
in if shouldBeImported t && not selfContained
then Expr.Var ( var "types" ) `Expr.Field` name
else Expr.Var ( var name )
bindTypes expr =
foldl' bindType expr [ minBound .. maxBound ]
bindType expr t =
addBinding
( fromString ( show t ) )
( linkedType t )
expr
bindImport =
addBinding
"types"
( Expr.Embed ( typesLocation dhallFromGitHub ) )
-- Unconditionally add everything, since lint will remove the
-- redundant bindings.
result =
bindImport
( bindTypes ( linkedType typeToPrint ) )
printVersion :: IO ()
printVersion = do
putStrLn ( "dhall-to-cabal version " ++ showVersion Paths.version )
printDefault :: PrintDefaultOptions -> IO ()
printDefault PrintDefaultOptions {..} = do
Pretty.renderIO
System.IO.stdout
( Pretty.layoutSmart opts
( Pretty.pretty ( Lint.lint ( withPreludeImport expr ) ) )
)
putStrLn ""
where
withPreludeImport =
addBinding
"prelude"
( Expr.Embed ( preludeLocation dhallFromGitHub ) )
expr :: Expr.Expr Dhall.Parser.Src Dhall.Import
expr = getDefault
( typesLocation dhallFromGitHub )
resolvePreludeVar defaultToPrint