{-# language NoMonomorphismRestriction #-}
{-# language NamedFieldPuns #-}
{-# language OverloadedStrings #-}
{-# language RecordWildCards #-}
{-# language ViewPatterns #-}
module Main ( main ) where
import Control.Applicative ( (<**>), Const(..), optional, (<|>) )
import Control.Monad ( guard )
import Data.Char ( isAlphaNum )
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.State ( State, execState, get, modify, put )
import Control.Monad.Trans.Writer ( WriterT, execWriterT, tell )
import Data.Foldable ( asum, traverse_ )
import Data.Function ( (&) )
import Data.Functor.Product ( Product(..) )
import Data.Functor.Identity ( Identity(..) )
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Monoid ( Any(..) )
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.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(..), Var(..), Binding(..), shift )
import qualified Distribution.PackageDescription as Cabal
import qualified Dhall.Map as Map
import qualified Dhall.Parser
import qualified Dhall.TypeCheck as Dhall
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
data KnownType
= Library
| ForeignLibrary
| Benchmark
| Executable
| TestSuite
| BuildInfo
| Config
| SourceRepo
| RepoType
| RepoKind
| Compiler
| OS
| Extension
| CompilerOptions
| Arch
| Language
| License
| BuildType
| Package
| VersionRange
| Version
| SPDX
| LicenseId
| LicenseExceptionId
deriving (Bounded, Enum, Eq, Ord, Read, Show)
-- | A 'Benchmark' is a proper subrecord of an 'Executable', but we
-- don't want to write 'Executable' in terms of 'Benchmark'! Hence,
-- limit which types we will do the common-field extraction for to
-- only 'BuildInfo', for the time being.
isCandidateSubrecord :: KnownType -> Bool
isCandidateSubrecord BuildInfo = True
isCandidateSubrecord _ = False
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 }
data CSEState a = CSEState
{ _factoredOutTypes :: [ ( KnownType, Expr.Expr Dhall.Parser.Src a ) ]
-- ^ Things we've already factored out (which may undergo further factoring themselves).
, _rootType :: Expr.Expr Dhall.Parser.Src a
-- ^ The original type, which we started factoring things from.
}
traverseTypes
:: ( Applicative f )
=> ( Expr.Expr Dhall.Parser.Src a -> f ( Expr.Expr Dhall.Parser.Src b ) )
-> CSEState a
-> f ( CSEState b )
traverseTypes f (CSEState types root) =
CSEState
<$> traverse (traverse f) types
<*> f root
printType :: PrintTypeOptions -> IO ()
printType PrintTypeOptions { .. } = do
Pretty.renderIO
System.IO.stdout
( Pretty.layoutSmart opts
( Pretty.pretty factoredType )
)
putStrLn ""
where
dhallType :: KnownType -> Dhall.Expr Dhall.Parser.Src a
dhallType t = fmap Dhall.absurd
( case t of
Config -> configRecordType
Library -> Dhall.expected library
ForeignLibrary -> Dhall.expected foreignLib
Executable -> Dhall.expected executable
Benchmark -> Dhall.expected benchmark
TestSuite -> Dhall.expected testSuite
BuildInfo -> buildInfoType
SourceRepo -> Dhall.expected sourceRepo
RepoType -> Dhall.expected repoType
RepoKind -> Dhall.expected repoKind
Compiler -> Dhall.expected compilerFlavor
OS -> Dhall.expected operatingSystem
Extension -> Dhall.expected extension
CompilerOptions -> Dhall.expected compilerOptions
Arch -> Dhall.expected arch
Language -> Dhall.expected language
License -> Dhall.expected license
BuildType -> Dhall.expected buildType
Package -> Dhall.expected genericPackageDescription
VersionRange -> Dhall.expected versionRange
Version -> Dhall.expected version
SPDX -> Dhall.expected spdxLicense
LicenseId -> Dhall.expected spdxLicenseId
LicenseExceptionId -> Dhall.expected spdxLicenseExceptionId
)
makeLetOrImport t val reduced =
let
name = fromString ( show t )
in if shouldBeImported t && not selfContained
then Dhall.subst ( Expr.V name 0 ) ( Expr.Var ( Expr.V "types" 0 ) `Expr.Field` name ) reduced
else Expr.Let (Expr.Binding name Nothing val :| []) reduced
factoredType :: Expr.Expr Dhall.Parser.Src Dhall.Import
factoredType =
let
initialState :: CSEState Dhall.Import
initialState = CSEState mempty ( dhallType typeToPrint )
CSEState types expr =
execState
( traverse_ step [ minBound .. maxBound ] )
initialState
-- Note: right fold here, though the above traversal is a left
-- fold. We need the types we factor out last to be the
-- outermost-bound.
body = foldr ( uncurry makeLetOrImport ) expr types
importing = if any shouldBeImported ( fst <$> types ) && not selfContained
then Expr.Let
( Expr.Binding "types" Nothing ( Expr.Embed ( typesLocation dhallFromGitHub ) ) :| [] )
else id
in
importing body
step
:: (Eq a)
=> KnownType
-- ^ Name of the type we're trying to factor out
-> State ( CSEState a ) ()
step factorType = do
Any usedFactor <- execWriterT
( lift . put =<< traverseTypes ( tryCSE factorType ) =<< lift get )
let
addingUsedFactor =
if usedFactor then ( ( factorType, ( dhallType factorType ) ) : ) else id
modify $ \ ( CSEState types expr ) -> CSEState ( addingUsedFactor types ) expr
tryCSE
:: (Eq a, Monad m)
=> KnownType -- ^ The type we're factoring out
-> Expr.Expr Dhall.Parser.Src a
-> WriterT Any m ( Expr.Expr Dhall.Parser.Src a )
tryCSE factorType expr =
let
name = fromString ( show factorType )
subrecord = isCandidateSubrecord factorType
in
case liftCSE subrecord name ( dhallType factorType ) expr of
Just expr' -> do
tell (Any True)
return expr'
Nothing ->
return expr
liftCSE
:: (Eq s, Eq a)
=> Bool
-- ^ Should we attempt to find the subexpression as a sub-record?
-> Text
-- ^ The name of the binding
-> Expr.Expr s a
-- ^ The common subexpression to lift
-> Expr.Expr s a
-- ^ The expression to remove a common subexpression from
-> Maybe (Expr.Expr s a)
-- ^ 'Just' the CSE-ed expression, or Nothing if the subexpression wasn't found.
liftCSE subrecord name body expr =
let
v0 =
Expr.V name 0
in
case go ( Expr.shift 1 v0 expr ) v0 of
Pair ( Const ( Any False ) ) _ ->
-- There was nothing to lift
Nothing
Pair _ ( Identity reduced ) | reduced == Expr.Var v0 ->
-- We lifted the whole expression out. This is not a win, so don't bother.
Nothing
Pair _ ( Identity reduced ) ->
Just reduced
where
shiftName n v | n == name =
shiftVar 1 v
shiftName _ v =
v
shiftVar delta ( Expr.V name' n ) =
Expr.V name' ( n + delta )
subtractRecordFields a b = do
guard subrecord
Expr.Record left <-
return a
Expr.Record right <-
return b
let
intersection =
Map.intersectionWith (==) left right
-- The right record cannot have any fields not in left.
guard ( null ( Map.difference right left ) )
-- We must have at least one field with a common name
guard ( not ( null intersection ) )
-- All common fields must have identical types
guard ( and intersection )
let
extra =
Map.difference left right
guard ( not ( null extra ) )
return ( Expr.Record extra )
go e v | e == body =
Pair ( Const ( Any True ) ) ( Identity ( Expr.Var v ) )
go ( ( `subtractRecordFields` body ) -> Just extra ) v =
Pair
( Const ( Any True ) )
( Identity ( Expr.CombineTypes ( Expr.Var v ) extra ) )
go e v =
case e of
Expr.Lam n t b ->
Expr.Lam n t <$> go b ( shiftName n v )
Expr.Pi n t b ->
Expr.Pi n <$> go t v <*> go b ( shiftName n v )
Expr.App f a ->
Expr.App <$> go f v <*> go a v
Expr.Let bs e ->
Expr.Let <$> traverse go' bs <*> go e shifted
where go' (Expr.Binding n t b) = Expr.Binding n t <$> go b v
shifted = foldr (shiftName . Expr.variable) v bs
Expr.Annot a b ->
Expr.Annot <$> go a v <*> go b v
Expr.BoolAnd a b ->
Expr.BoolAnd <$> go a v <*> go b v
Expr.BoolOr a b ->
Expr.BoolOr <$> go a v <*> go b v
Expr.BoolEQ a b ->
Expr.BoolEQ <$> go a v <*> go b v
Expr.BoolNE a b ->
Expr.BoolNE <$> go a v <*> go b v
Expr.BoolIf a b c ->
Expr.BoolIf <$> go a v <*> go b v <*> go c v
Expr.NaturalPlus a b ->
Expr.NaturalPlus <$> go a v <*> go b v
Expr.NaturalTimes a b ->
Expr.NaturalTimes <$> go a v <*> go b v
Expr.ListAppend a b ->
Expr.ListAppend <$> go a v <*> go b v
Expr.Combine a b ->
Expr.Combine <$> go a v <*> go b v
Expr.Prefer a b ->
Expr.Prefer <$> go a v <*> go b v
Expr.TextAppend a b ->
Expr.TextAppend <$> go a v <*> go b v
Expr.ListLit t elems ->
Expr.ListLit
<$> ( traverse ( `go` v ) t )
<*> ( traverse ( `go` v ) elems )
Expr.OptionalLit t elems ->
Expr.OptionalLit
<$> go t v
<*> ( traverse ( `go` v ) elems )
Expr.Some a ->
Expr.Some <$> go a v
Expr.None ->
pure Expr.None
Expr.Record fields ->
Expr.Record <$> traverse ( `go` v ) fields
Expr.RecordLit fields ->
Expr.RecordLit <$> traverse ( `go` v ) fields
Expr.Union fields ->
Expr.Union <$> traverse ( `go` v ) fields
Expr.UnionLit n a fields ->
Expr.UnionLit n <$> go a v <*> traverse ( `go` v ) fields
Expr.Merge a b t ->
Expr.Merge <$> go a v <*> go b v <*> traverse ( `go` v ) t
Expr.Constructors e ->
Expr.Constructors <$> go e v
Expr.Field e f ->
Expr.Field <$> go e v <*> pure f
Expr.Note s e ->
Expr.Note s <$> go e v
Expr.CombineTypes a b ->
Expr.CombineTypes <$> go a v <*> go b v
Expr.Project e fs ->
Expr.Project <$> go e v <*> pure fs
Expr.ImportAlt l r ->
Expr.ImportAlt <$> go l v <*> go r v
Expr.IntegerToDouble ->
pure Expr.IntegerToDouble
Expr.Embed{} ->
pure e
Expr.Const{} ->
pure e
Expr.Var{} ->
pure e
Expr.Bool{} ->
pure e
Expr.BoolLit{} ->
pure e
Expr.Natural{} ->
pure e
Expr.NaturalLit{} ->
pure e
Expr.NaturalFold{} ->
pure e
Expr.NaturalBuild{} ->
pure e
Expr.NaturalIsZero{} ->
pure e
Expr.NaturalEven{} ->
pure e
Expr.NaturalOdd{} ->
pure e
Expr.NaturalToInteger{} ->
pure e
Expr.NaturalShow{} ->
pure e
Expr.Integer{} ->
pure e
Expr.IntegerShow{} ->
pure e
Expr.IntegerLit{} ->
pure e
Expr.Double{} ->
pure e
Expr.DoubleShow{} ->
pure e
Expr.DoubleLit{} ->
pure e
Expr.Text{} ->
pure e
Expr.TextLit{} ->
pure e
Expr.List ->
pure e
Expr.ListBuild ->
pure e
Expr.ListFold ->
pure e
Expr.ListLength ->
pure e
Expr.ListHead ->
pure e
Expr.ListLast ->
pure e
Expr.ListIndexed ->
pure e
Expr.ListReverse ->
pure e
Expr.Optional ->
pure e
Expr.OptionalFold ->
pure e
Expr.OptionalBuild ->
pure e
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 ( withPreludeImport expr ) )
)
putStrLn ""
where
withPreludeImport =
Expr.Let (Expr.Binding "prelude" Nothing
( Expr.Embed ( preludeLocation dhallFromGitHub ) ) :| [])
expr :: Expr.Expr Dhall.Parser.Src Dhall.Import
expr = getDefault
( typesLocation dhallFromGitHub )
resolvePreludeVar defaultToPrint