{-# language FlexibleInstances #-} {-# language GeneralizedNewtypeDeriving #-} {-# language LambdaCase #-} {-# language MultiWayIf #-} {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-} {-# language ViewPatterns #-} module CabalToDhall ( cabalToDhall , parseGenericPackageDescriptionThrows , KnownDefault (..) , PreludeReference (..) , resolvePreludeVar , getDefault ) where import Data.Foldable ( foldMap ) import Data.Functor.Contravariant ( (>$<), Contravariant( contramap ) ) import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Monoid ( First(..) ) import Data.Semigroup ( Semigroup, (<>) ) import GHC.Stack import Numeric.Natural ( Natural ) import qualified Data.ByteString as ByteString import qualified Data.Sequence as Seq import qualified Data.Text as StrictText import qualified Dhall import qualified Dhall.Core import qualified Dhall.Core as Expr ( Expr(..), Var(..), Binding(..), Chunks(..) ) import qualified Dhall.Map as Map import qualified Dhall.Parser import qualified Dhall.TypeCheck import qualified Distribution.Compiler as Cabal import qualified Distribution.License as Cabal import qualified Distribution.ModuleName as Cabal import qualified Distribution.PackageDescription.Parsec as Cabal import qualified Distribution.SPDX as SPDX import qualified Distribution.System as Cabal import qualified Distribution.Text as Cabal import qualified Distribution.Types.Benchmark as Cabal import qualified Distribution.Types.BenchmarkInterface as Cabal import qualified Distribution.Types.BuildInfo as Cabal import qualified Distribution.Types.BuildType as Cabal import qualified Distribution.Types.CondTree as Cabal import qualified Distribution.Types.Condition as Cabal import qualified Distribution.Types.Dependency as Cabal import qualified Distribution.Types.ExeDependency as Cabal import qualified Distribution.Types.Executable as Cabal import qualified Distribution.Types.ExecutableScope as Cabal import qualified Distribution.Types.ForeignLib as Cabal import qualified Distribution.Types.ForeignLibOption as Cabal import qualified Distribution.Types.ForeignLibType as Cabal import qualified Distribution.Types.GenericPackageDescription as Cabal import qualified Distribution.Types.IncludeRenaming as Cabal import qualified Distribution.Types.LegacyExeDependency as Cabal import qualified Distribution.Types.Library as Cabal import qualified Distribution.Types.Mixin as Cabal import qualified Distribution.Types.ModuleReexport as Cabal import qualified Distribution.Types.ModuleRenaming as Cabal import qualified Distribution.Types.PackageDescription as Cabal import qualified Distribution.Types.PackageId as Cabal import qualified Distribution.Types.PackageName as Cabal import qualified Distribution.Types.PkgconfigDependency as Cabal import qualified Distribution.Types.PkgconfigName as Cabal import qualified Distribution.Types.SetupBuildInfo as Cabal import qualified Distribution.Types.SourceRepo as Cabal import qualified Distribution.Types.TestSuite as Cabal import qualified Distribution.Types.TestSuiteInterface as Cabal import qualified Distribution.Types.UnqualComponentName as Cabal import qualified Distribution.Version as Cabal import qualified Language.Haskell.Extension as Cabal import DhallLocation ( DhallLocation(..) ) import DhallToCabal ( sortExpr ) import DhallToCabal.ConfigTree ( ConfigTree(..) ) type DhallExpr = Dhall.Core.Expr Dhall.Parser.Src Dhall.TypeCheck.X dhallString :: String -> Expr.Expr s a dhallString = Expr.TextLit . Dhall.Core.Chunks [] . StrictText.pack parseGenericPackageDescriptionThrows :: ByteString.ByteString -> IO Cabal.GenericPackageDescription parseGenericPackageDescriptionThrows source = case Cabal.runParseResult ( Cabal.parseGenericPackageDescription source ) of (_warnings, Left e) -> do putStrLn "Could not parse Cabal file: " error ( show e ) (_warnings, Right genericPackageDescription) -> return genericPackageDescription cabalToDhall :: DhallLocation -> Cabal.GenericPackageDescription -> Expr.Expr Dhall.Parser.Src Dhall.Core.Import cabalToDhall dhallLocation genericPackageDescription = Expr.Let ( Expr.Binding "prelude" Nothing ( Expr.Embed ( preludeLocation dhallLocation ) ) :| [ Expr.Binding "types" Nothing ( Expr.Embed ( typesLocation dhallLocation ) ) ] ) $ Dhall.TypeCheck.absurd <$> Dhall.embed genericPackageDescriptionToDhall genericPackageDescription -- Note: the Show instance is used by --print-type. data KnownDefault = CompilerOptions | BuildInfo | Library | Executable | Benchmark | TestSuite | Package | SourceRepo deriving ( Bounded, Enum, Eq, Ord, Read, Show ) data PreludeReference = PreludeDefault KnownDefault | PreludeConstructorsLicense | PreludeConstructorsRepoKind | PreludeConstructorsScope | PreludeV resolvePreludeVar :: PreludeReference -> Expr.Expr s a resolvePreludeVar = \case PreludeDefault typ -> Expr.Var "prelude" `Expr.Field` "defaults" `Expr.Field` StrictText.pack ( show typ ) PreludeV -> Expr.Var "prelude" `Expr.Field` "v" PreludeConstructorsLicense -> Expr.Var "types" `Expr.Field` "License" PreludeConstructorsRepoKind -> Expr.Var "types" `Expr.Field` "RepoKind" PreludeConstructorsScope -> Expr.Var "types" `Expr.Field` "Scope" type Default s a = ( PreludeReference -> Expr.Expr s a ) -> Map.Map StrictText.Text ( Expr.Expr s a ) getDefault :: ( Eq s ) => Dhall.Core.Import -> ( PreludeReference -> Expr.Expr s Dhall.Core.Import ) -> KnownDefault -> Expr.Expr s Dhall.Core.Import getDefault typesLoc resolve typ = withTypesImport expr where withTypesImport = Expr.Let (Expr.Binding "types" Nothing ( Expr.Embed typesLoc ) :| []) factorBuildInfo fields = let shared = Map.filter id ( Map.intersectionWith (==) fields ( buildInfoDefault resolve ) ) in if | null shared -> Expr.RecordLit fields | null ( Map.difference fields shared ) -> resolve ( PreludeDefault BuildInfo ) | otherwise -> Expr.Prefer ( resolve ( PreludeDefault BuildInfo ) ) ( Expr.RecordLit ( Map.difference fields shared ) ) expr = case typ of CompilerOptions -> Expr.RecordLit ( compilerOptionsDefault resolve ) BuildInfo -> Expr.RecordLit ( buildInfoDefault resolve ) Library -> factorBuildInfo ( libraryDefault resolve ) Executable -> factorBuildInfo ( executableDefault resolve ) Benchmark -> factorBuildInfo ( benchmarkDefault resolve ) TestSuite -> factorBuildInfo ( testSuiteDefault resolve ) Package -> Expr.RecordLit ( packageDefault resolve ) SourceRepo -> Expr.RecordLit ( sourceRepoDefault resolve ) emptyListDefault :: StrictText.Text -> Expr.Expr s a -> ( StrictText.Text, Expr.Expr s a ) emptyListDefault name ty = ( name, Expr.ListLit ( Just ty ) mempty ) emptyOptionalDefault :: StrictText.Text -> Expr.Expr s a -> ( StrictText.Text, Expr.Expr s a ) emptyOptionalDefault name ty = ( name, Expr.App Expr.None ty ) textFieldDefault :: StrictText.Text -> StrictText.Text -> ( StrictText.Text, Expr.Expr s a ) textFieldDefault name def = ( name , Expr.TextLit ( Dhall.Core.Chunks [] def ) ) generaliseDeclared = Dhall.Core.denote . fmap Dhall.TypeCheck.absurd . Dhall.declared compilerOptionsDefault :: Default s a compilerOptionsDefault _resolve = ( Map.fromList [ emptyListDefault "Eta" Expr.Text , emptyListDefault "GHC" Expr.Text , emptyListDefault "GHCJS" Expr.Text , emptyListDefault "HBC" Expr.Text , emptyListDefault "Helium" Expr.Text , emptyListDefault "Hugs" Expr.Text , emptyListDefault "JHC" Expr.Text , emptyListDefault "LHC" Expr.Text , emptyListDefault "NHC" Expr.Text , emptyListDefault "UHC" Expr.Text , emptyListDefault "YHC" Expr.Text ] ) buildInfoDefault :: Default s a buildInfoDefault resolve = fields where fields = Map.fromList [ emptyListDefault "autogen-modules" Expr.Text , emptyListDefault "build-depends" ( generaliseDeclared dependency ) , emptyListDefault "build-tool-depends" ( generaliseDeclared exeDependency ) , emptyListDefault "build-tools" ( generaliseDeclared legacyExeDependency ) , ( "buildable", Expr.BoolLit True ) , emptyListDefault "c-sources" Expr.Text , emptyListDefault "cc-options" Expr.Text , ( "compiler-options", resolve ( PreludeDefault CompilerOptions ) ) , emptyListDefault "cpp-options" Expr.Text , emptyListDefault "default-extensions" ( generaliseDeclared extension ) , emptyOptionalDefault "default-language" ( generaliseDeclared language ) , emptyListDefault "extra-framework-dirs" Expr.Text , emptyListDefault "extra-ghci-libraries" Expr.Text , emptyListDefault "extra-lib-dirs" Expr.Text , emptyListDefault "extra-libraries" Expr.Text , emptyListDefault "frameworks" Expr.Text , emptyListDefault "hs-source-dirs" Expr.Text , emptyListDefault "includes" Expr.Text , emptyListDefault "include-dirs" Expr.Text , emptyListDefault "install-includes" Expr.Text , emptyListDefault "js-sources" Expr.Text , emptyListDefault "ld-options" Expr.Text , emptyListDefault "other-extensions" ( generaliseDeclared extension ) , emptyListDefault "other-languages" ( generaliseDeclared language ) , emptyListDefault "other-modules" Expr.Text , emptyListDefault "pkgconfig-depends" ( generaliseDeclared pkgconfigDependency ) , ( "profiling-options", resolve ( PreludeDefault CompilerOptions ) ) , ( "shared-options", resolve ( PreludeDefault CompilerOptions ) ) , ( "static-options", resolve ( PreludeDefault CompilerOptions ) ) , emptyListDefault "mixins" ( generaliseDeclared mixin ) , emptyListDefault "asm-options" Expr.Text , emptyListDefault "asm-sources" Expr.Text , emptyListDefault "cmm-options" Expr.Text , emptyListDefault "cmm-sources" Expr.Text , emptyListDefault "cxx-options" Expr.Text , emptyListDefault "cxx-sources" Expr.Text , emptyListDefault "virtual-modules" Expr.Text , emptyListDefault "extra-lib-flavours" Expr.Text , emptyListDefault "extra-bundled-libs" Expr.Text ] libraryDefault :: Default s a libraryDefault resolve = buildInfoDefault resolve <> specificFields where specificFields = Map.fromList [ emptyListDefault "exposed-modules" Expr.Text , emptyListDefault "other-modules" Expr.Text , emptyListDefault "reexported-modules" ( generaliseDeclared moduleReexport ) , emptyListDefault "signatures" Expr.Text ] benchmarkDefault :: Default s a benchmarkDefault = buildInfoDefault testSuiteDefault :: Default s a testSuiteDefault = buildInfoDefault executableDefault :: Default s a executableDefault resolve = buildInfoDefault resolve <> specificFields where specificFields = Map.singleton "scope" ( Expr.App ( resolve PreludeConstructorsScope `Expr.Field` "Public" ) ( Expr.RecordLit mempty ) ) packageDefault :: Default s a packageDefault resolve = fields where named name typ = Expr.Record ( Map.fromList [ ( "name" , Expr.Text ) , ( name , Expr.Pi "config" ( Expr.Var "types" `Expr.Field` "Config" ) ( generaliseDeclared typ ) ) ] ) fields = Map.fromList [ textFieldDefault "author" "" , emptyListDefault "flags" ( generaliseDeclared flag ) , emptyListDefault "benchmarks" ( named "benchmark" benchmark ) , textFieldDefault "bug-reports" "" , emptyOptionalDefault "build-type" ( generaliseDeclared buildType ) , ( "cabal-version" , Expr.App ( resolve PreludeV ) ( Expr.TextLit ( Dhall.Core.Chunks [] "2.2" ) ) ) , textFieldDefault "category" "" , textFieldDefault "copyright" "" , textFieldDefault "data-dir" "" , emptyListDefault "data-files" Expr.Text , textFieldDefault "description" "" , emptyListDefault "executables" ( named "executable" executable ) , emptyListDefault "extra-doc-files" Expr.Text , emptyListDefault "extra-source-files" Expr.Text , emptyListDefault "extra-tmp-files" Expr.Text , emptyListDefault "foreign-libraries" ( named "foreign-lib" foreignLibrary ) , textFieldDefault "homepage" "" , emptyOptionalDefault "library" ( Expr.Pi "config" ( Expr.Var "types" `Expr.Field` "Config" ) ( generaliseDeclared library ) ) , ( "license" , Expr.App ( resolve PreludeConstructorsLicense `Expr.Field` "AllRightsReserved" ) ( Expr.RecordLit mempty ) ) , emptyListDefault "license-files" Expr.Text , textFieldDefault "maintainer" "" , textFieldDefault "package-url" "" , emptyListDefault "source-repos" ( generaliseDeclared sourceRepo ) , textFieldDefault "stability" "" , emptyListDefault "sub-libraries" ( named "library" library ) , textFieldDefault "synopsis" "" , emptyListDefault "test-suites" ( named "test-suite" testSuite ) , emptyListDefault "tested-with" ( Expr.Record ( Map.fromList [ ( "compiler", generaliseDeclared compilerFlavor ) , ( "version", generaliseDeclared versionRange ) ] ) ) , emptyListDefault "x-fields" ( Expr.Record ( Map.fromList [ ( "_1", Expr.Text ), ( "_2", Expr.Text ) ] ) ) , emptyOptionalDefault "custom-setup" ( generaliseDeclared setupBuildInfo ) ] sourceRepoDefault :: Default s a sourceRepoDefault resolve = fields where fields = Map.fromList [ emptyOptionalDefault "type" ( generaliseDeclared repoType ) , emptyOptionalDefault "location" Expr.Text , emptyOptionalDefault "module" Expr.Text , emptyOptionalDefault "branch" Expr.Text , emptyOptionalDefault "tag" Expr.Text , emptyOptionalDefault "subdir" Expr.Text , ( "kind" , Expr.App ( resolve PreludeConstructorsRepoKind `Expr.Field` "RepoHead" ) ( Expr.RecordLit mempty ) ) ] data DefaultComparison s a = DefaultComparisonMatch | DefaultComparisonReplace ( Expr.Expr s a ) deriving ( Show ) extractDefaultComparisonReplace :: DefaultComparison s a -> Maybe ( Expr.Expr s a ) extractDefaultComparisonReplace DefaultComparisonMatch = Nothing extractDefaultComparisonReplace ( DefaultComparisonReplace expr ) = Just expr nonDefaultFields :: ( Eq a ) => Map.Map StrictText.Text ( Expr.Expr s a ) -> Map.Map StrictText.Text ( Expr.Expr s a ) -> Map.Map StrictText.Text ( Expr.Expr s a ) nonDefaultFields defs fields = let withoutDefaults = Map.difference fields defs compared = Map.intersectionWith compareToDefault defs fields changed = Map.mapMaybe extractDefaultComparisonReplace compared in withoutDefaults <> changed compareToDefault :: ( Eq a ) => Expr.Expr s a -> Expr.Expr s a -> DefaultComparison s a compareToDefault def expr | Dhall.Core.judgmentallyEqual def expr = DefaultComparisonMatch compareToDefault _ expr = DefaultComparisonReplace expr withDefault :: ( Eq a ) => KnownDefault -> Default s a -> Expr.Expr s a -> Expr.Expr s a withDefault typ defs ( Expr.RecordLit fields ) = let nonDefaults = nonDefaultFields ( defs resolvePreludeVar ) fields name = StrictText.pack ( show typ ) in if null nonDefaults then Expr.Var ( Expr.V "prelude" 0 ) `Expr.Field` "defaults" `Expr.Field` name else Expr.Prefer ( Expr.Var ( Expr.V "prelude" 0 ) `Expr.Field` "defaults" `Expr.Field` name ) ( Expr.RecordLit nonDefaults ) withDefault _ _ expr = expr newtype RecordInputType a = RecordInputType { _unRecordInputType :: Map.Map Dhall.Text ( Dhall.InputType a ) } deriving ( Semigroup, Monoid ) instance Contravariant RecordInputType where contramap f ( RecordInputType map ) = RecordInputType ( fmap ( contramap f ) map ) recordField :: Dhall.Text -> Dhall.InputType a -> RecordInputType a recordField k v = RecordInputType ( Map.singleton k v ) runRecordInputType :: RecordInputType a -> Dhall.InputType a runRecordInputType ( RecordInputType m ) = Dhall.InputType { Dhall.embed = \a -> sortExpr ( Expr.RecordLit ( fmap ( \t -> Dhall.embed t a ) m ) ) , Dhall.declared = sortExpr ( Expr.Record ( fmap Dhall.declared m ) ) } runRecordInputTypeWithDefault :: KnownDefault -> Default Dhall.Parser.Src Dhall.TypeCheck.X -> RecordInputType a -> Dhall.InputType a runRecordInputTypeWithDefault typ def m = let Dhall.InputType embed declared = runRecordInputType m in Dhall.InputType ( withDefault typ def . embed ) declared genericPackageDescriptionToDhall :: Dhall.InputType Cabal.GenericPackageDescription genericPackageDescriptionToDhall = let named k v = listOf ( runRecordInputType ( mconcat [ fst >$< recordField "name" unqualComponentName , snd >$< recordField k v ] ) ) in runRecordInputTypeWithDefault Package packageDefault ( mconcat [ Cabal.packageDescription >$< packageDescriptionToRecord , recordField "flags" ( Cabal.genPackageFlags >$< ( listOf flag ) ) , recordField "library" ( Cabal.condLibrary >$< maybeToDhall ( condTree library ) ) , recordField "sub-libraries" ( Cabal.condSubLibraries >$< named "library" ( condTree library ) ) , recordField "foreign-libraries" ( Cabal.condForeignLibs >$< named "foreign-lib" ( condTree foreignLibrary ) ) , recordField "executables" ( Cabal.condExecutables >$< named "executable" ( condTree executable ) ) , recordField "test-suites" ( Cabal.condTestSuites >$< named "test-suite" ( condTree testSuite ) ) , recordField "benchmarks" ( Cabal.condBenchmarks >$< named "benchmark" ( condTree benchmark ) ) ] ) packageDescriptionToRecord :: RecordInputType Cabal.PackageDescription packageDescriptionToRecord = mconcat [ contramap Cabal.package packageIdentifierToRecord , recordField "source-repos" ( contramap Cabal.sourceRepos ( listOf sourceRepo ) ) , recordField "cabal-version" ( contramap Cabal.specVersionRaw specVersion ) , recordField "build-type" ( contramap Cabal.buildTypeRaw ( maybeToDhall buildType ) ) , recordField "license" ( contramap Cabal.licenseRaw licenseToDhall ) , recordField "license-files" ( contramap Cabal.licenseFiles ( listOf stringToDhall ) ) , recordField "copyright" ( contramap Cabal.copyright stringToDhall ) , recordField "maintainer" ( contramap Cabal.maintainer stringToDhall ) , recordField "author" ( contramap Cabal.author stringToDhall ) , recordField "stability" ( contramap Cabal.stability stringToDhall ) , recordField "tested-with" ( contramap Cabal.testedWith ( listOf compiler ) ) , recordField "homepage" ( contramap Cabal.homepage stringToDhall ) , recordField "package-url" ( contramap Cabal.pkgUrl stringToDhall ) , recordField "bug-reports" ( contramap Cabal.bugReports stringToDhall ) , recordField "synopsis" ( contramap Cabal.synopsis stringToDhall ) , recordField "description" ( contramap Cabal.description stringToDhall ) , recordField "category" ( contramap Cabal.category stringToDhall ) , recordField "custom-setup" ( contramap Cabal.setupBuildInfo ( maybeToDhall setupBuildInfo ) ) , recordField "data-files" ( contramap Cabal.dataFiles ( listOf stringToDhall ) ) , recordField "data-dir" ( contramap Cabal.dataDir stringToDhall ) , recordField "extra-source-files" ( contramap Cabal.extraSrcFiles ( listOf stringToDhall ) ) , recordField "extra-tmp-files" ( contramap Cabal.extraTmpFiles ( listOf stringToDhall ) ) , recordField "extra-doc-files" ( contramap Cabal.extraDocFiles ( listOf stringToDhall ) ) , recordField "x-fields" ( Cabal.customFieldsPD >$< listOf ( runRecordInputType ( mconcat [ fst >$< recordField "_1" stringToDhall , snd >$< recordField "_2" stringToDhall ] ) ) ) ] packageIdentifierToRecord :: RecordInputType Cabal.PackageIdentifier packageIdentifierToRecord = mconcat [ recordField "name" ( contramap Cabal.pkgName packageNameToDhall ) , recordField "version" ( contramap Cabal.pkgVersion versionToDhall ) ] packageNameToDhall :: Dhall.InputType Cabal.PackageName packageNameToDhall = contramap Cabal.unPackageName stringToDhall versionToDhall :: Dhall.InputType Cabal.Version versionToDhall = Dhall.InputType { Dhall.embed = Expr.App ( Expr.Var "prelude" `Expr.Field` "v" ) . Dhall.embed stringToDhall . show . Cabal.disp , Dhall.declared = Expr.Var "types" `Expr.Field` "Version" } stringToDhall :: Dhall.InputType String stringToDhall = contramap StrictText.pack Dhall.inject licenseToDhall :: Dhall.InputType (Either SPDX.License Cabal.License) licenseToDhall = Dhall.InputType { Dhall.embed = \l -> case l of Right ( Cabal.GPL v ) -> license "GPL" ( Dhall.embed ( maybeToDhall versionToDhall ) v ) Right ( Cabal.AGPL v ) -> license "AGPL" ( Dhall.embed ( maybeToDhall versionToDhall ) v ) Right ( Cabal.LGPL v ) -> license "LGPL" ( Dhall.embed ( maybeToDhall versionToDhall ) v ) Right Cabal.BSD2 -> license "BSD2" ( Expr.RecordLit mempty ) Right Cabal.BSD3 -> license "BSD3" ( Expr.RecordLit mempty ) Right Cabal.BSD4 -> license "BSD4" ( Expr.RecordLit mempty ) Right Cabal.MIT -> license "MIT" ( Expr.RecordLit mempty ) Right Cabal.ISC -> license "ISC" ( Expr.RecordLit mempty ) Right ( Cabal.MPL v ) -> license "MPL" ( Dhall.embed versionToDhall v ) Right ( Cabal.Apache v ) -> license "Apache" ( Dhall.embed ( maybeToDhall versionToDhall ) v ) Right Cabal.PublicDomain -> license "PublicDomain" ( Expr.RecordLit mempty ) Right Cabal.AllRightsReserved -> license "AllRightsReserved" ( Expr.RecordLit mempty ) -- Note: SPDX.NONE is what Cabal reports for a file without -- a 'license' field, even for pre-2.2 spec versions. Left SPDX.NONE -> license "AllRightsReserved" ( Expr.RecordLit mempty ) Right Cabal.UnspecifiedLicense -> license "Unspecified" ( Expr.RecordLit mempty ) Right ( Cabal.UnknownLicense "UnspecifiedLicense" ) -> license "Unspecified" ( Expr.RecordLit mempty ) Right ( Cabal.UnknownLicense l ) -> license "Unspecified" ( Expr.TextLit (Expr.Chunks [] (StrictText.pack l)) ) Right Cabal.OtherLicense -> license "Other" ( Expr.RecordLit mempty ) Left ( SPDX.License x ) -> license "SPDX" ( Dhall.embed spdxLicenseExpressionToDhall x ) , Dhall.declared = Expr.Var "types" `Expr.Field` "License" } where license name = Expr.App ( Expr.Var "types" `Expr.Field` "License" `Expr.Field` name ) spdxLicenseExpressionToDhall :: Dhall.InputType SPDX.LicenseExpression spdxLicenseExpressionToDhall = Dhall.InputType { Dhall.embed = let go lexp = case lexp of SPDX.ELicense ( SPDX.ELicenseId ident ) exceptionMay -> Expr.App ( Expr.App ( Expr.Var "prelude" `Expr.Field` "SPDX" `Expr.Field` "license" ) ( Dhall.embed spdxLicenseIdToDhall ident ) ) ( Dhall.embed ( maybeToDhall spdxLicenseExceptionIdToDhall ) exceptionMay ) SPDX.ELicense (SPDX.ELicenseIdPlus ident) exceptionMay -> Expr.App ( Expr.App ( Expr.Var "prelude" `Expr.Field` "SPDX" `Expr.Field` "licenseVersionOrLater" ) ( Dhall.embed spdxLicenseIdToDhall ident ) ) ( Dhall.embed ( maybeToDhall spdxLicenseExceptionIdToDhall ) exceptionMay ) SPDX.ELicense (SPDX.ELicenseRef ref) exceptionMay -> case SPDX.licenseDocumentRef ref of Nothing -> Expr.App ( Expr.App ( Expr.Var "prelude" `Expr.Field` "SPDX" `Expr.Field` "ref" ) ( Dhall.embed stringToDhall ( SPDX.licenseRef ref ) ) ) ( Dhall.embed ( maybeToDhall spdxLicenseExceptionIdToDhall ) exceptionMay ) Just file -> Expr.App ( Expr.App ( Expr.App ( Expr.Var "prelude" `Expr.Field` "SPDX" `Expr.Field` "refWithFile" ) ( Dhall.embed stringToDhall ( SPDX.licenseRef ref ) ) ) ( Dhall.embed stringToDhall file ) ) ( Dhall.embed ( maybeToDhall spdxLicenseExceptionIdToDhall ) exceptionMay ) SPDX.EOr a b -> Expr.App ( Expr.App ( Expr.Var "prelude" `Expr.Field` "SPDX" `Expr.Field` "or" ) ( go a ) ) ( go b ) SPDX.EAnd a b -> Expr.App ( Expr.App ( Expr.Var "prelude" `Expr.Field` "SPDX" `Expr.Field` "and" ) ( go a ) ) ( go b ) in go , Dhall.declared = Expr.Var "types" `Expr.Field` "SPDX" } spdxLicenseIdToDhall :: Dhall.InputType SPDX.LicenseId spdxLicenseIdToDhall = Dhall.InputType { Dhall.embed = \ident -> Expr.App ( Expr.Var "types" `Expr.Field` "LicenseId" `Expr.Field` identName ident ) ( Expr.RecordLit mempty ) , Dhall.declared = Expr.Var "types" `Expr.Field` "LicenseId" } where identName :: SPDX.LicenseId -> StrictText.Text identName e = StrictText.pack ( show e ) spdxLicenseExceptionIdToDhall :: Dhall.InputType SPDX.LicenseExceptionId spdxLicenseExceptionIdToDhall = Dhall.InputType { Dhall.embed = \ident -> Expr.App ( Expr.Var "types" `Expr.Field` "LicenseExceptionId" `Expr.Field` identName ident ) ( Expr.RecordLit mempty ) , Dhall.declared = Expr.Var "types" `Expr.Field` "LicenseExceptionId" } where identName :: SPDX.LicenseExceptionId -> StrictText.Text identName e = StrictText.pack ( show e ) newtype Union a = Union { _unUnion :: ( a -> ( First ( Dhall.Text, DhallExpr ) , Map.Map Dhall.Text DhallExpr ) , Map.Map Dhall.Text DhallExpr ) } deriving ( Semigroup, Monoid ) runUnion :: ( HasCallStack, Show a ) => Union a -> Dhall.InputType a runUnion ( Union ( f, t ) ) = Dhall.InputType { Dhall.embed = \a -> case f a of ( First Nothing, _ ) -> error $ "Union did not match anything. Given " ++ show a ( First ( Just ( k, v ) ), alts ) -> Expr.UnionLit k v alts , Dhall.declared = sortExpr ( Expr.Union t ) } unionAlt :: Dhall.Text -> ( a -> Maybe b ) -> Dhall.InputType b -> Union a unionAlt k f t = Union ( \a -> case f a of Nothing -> ( mempty, Map.singleton k ( Dhall.declared t ) ) Just _ -> ( First ( fmap ( \b -> ( k, Dhall.embed t b ) ) ( f a ) ), mempty ) , Map.singleton k ( Dhall.declared t ) ) maybeToDhall :: Dhall.InputType a -> Dhall.InputType ( Maybe a ) maybeToDhall t = Dhall.InputType { Dhall.embed = \a -> case a of Nothing -> Expr.App Expr.None (Dhall.declared t) Just x -> Expr.Some ( Dhall.embed t x ) , Dhall.declared = Expr.App Expr.Optional ( Dhall.declared t ) } listOf :: Dhall.InputType a -> Dhall.InputType [ a ] listOf t = Dhall.InputType { Dhall.embed = \a -> Expr.ListLit ( foldl ( \_ _ -> Nothing ) ( Just ( Dhall.declared t ) ) a ) ( foldMap ( pure . Dhall.embed t ) a ) , Dhall.declared = Expr.App Expr.List ( Dhall.declared t ) } compiler :: Dhall.InputType ( Cabal.CompilerFlavor, Cabal.VersionRange ) compiler = runRecordInputType ( mconcat [ recordField "compiler" ( contramap fst compilerFlavor ) , recordField "version" ( contramap snd versionRange ) ] ) compilerFlavor :: Dhall.InputType Cabal.CompilerFlavor compilerFlavor = let constructor k v = Expr.App ( Expr.Var "types" `Expr.Field` "Compiler" `Expr.Field` k ) v in Dhall.InputType { Dhall.embed = \case Cabal.Eta -> constructor "Eta" ( Expr.RecordLit mempty ) Cabal.GHC -> constructor "GHC" ( Expr.RecordLit mempty ) Cabal.GHCJS -> constructor "GHCJS" ( Expr.RecordLit mempty ) Cabal.HBC -> constructor "HBC" ( Expr.RecordLit mempty ) Cabal.HaskellSuite v -> constructor "HaskellSuite" ( Expr.Record ( Map.singleton "_1" ( dhallString v ) ) ) Cabal.Helium -> constructor "Helium" ( Expr.RecordLit mempty ) Cabal.Hugs -> constructor "Hugs" ( Expr.RecordLit mempty ) Cabal.JHC -> constructor "JHC" ( Expr.RecordLit mempty ) Cabal.LHC -> constructor "LHC" ( Expr.RecordLit mempty ) Cabal.NHC -> constructor "NHC" ( Expr.RecordLit mempty ) Cabal.OtherCompiler v -> constructor "OtherCompiler" ( Expr.Record ( Map.singleton "_1" ( dhallString v ) ) ) Cabal.UHC -> constructor "UHC" ( Expr.RecordLit mempty ) Cabal.YHC -> constructor "YHC" ( Expr.RecordLit mempty ) , Dhall.declared = Expr.Var "types" `Expr.Field` "Compiler" } versionRange :: Dhall.InputType Cabal.VersionRange versionRange = Dhall.InputType { Dhall.embed = \versionRange0 -> let go = Cabal.foldVersionRange -- AnyVersion ( Expr.Var "prelude" `Expr.Field` "anyVersion" ) -- ThisVersion ( \v -> Expr.App ( Expr.Var "prelude" `Expr.Field` "thisVersion" ) ( Dhall.embed versionToDhall v ) ) -- LaterVersion ( \v -> Expr.App ( Expr.Var "prelude" `Expr.Field` "laterVersion" ) ( Dhall.embed versionToDhall v ) ) -- EarlierVersion ( \v -> Expr.App ( Expr.Var "prelude" `Expr.Field` "earlierVersion" ) ( Dhall.embed versionToDhall v ) ) -- UnionVersionRanges ( \a b -> Expr.App ( Expr.App ( Expr.Var "prelude" `Expr.Field` "unionVersionRanges" ) a ) b ) -- IntersectVersionRanges ( \a b -> Expr.App ( Expr.App ( Expr.Var "prelude" `Expr.Field` "intersectVersionRanges" ) a ) b ) in go ( Cabal.fromVersionIntervals ( Cabal.toVersionIntervals versionRange0 ) ) , Dhall.declared = Expr.Var "types" `Expr.Field` "VersionRange" } sourceRepo :: Dhall.InputType Cabal.SourceRepo sourceRepo = ( runRecordInputTypeWithDefault SourceRepo sourceRepoDefault ( mconcat [ recordField "kind" ( contramap Cabal.repoKind repoKind ) , recordField "type" ( contramap Cabal.repoType ( maybeToDhall repoType ) ) , recordField "location" ( contramap Cabal.repoLocation ( maybeToDhall stringToDhall ) ) , recordField "module" ( contramap Cabal.repoModule ( maybeToDhall stringToDhall ) ) , recordField "branch" ( contramap Cabal.repoBranch ( maybeToDhall stringToDhall ) ) , recordField "tag" ( contramap Cabal.repoTag ( maybeToDhall stringToDhall ) ) , recordField "subdir" ( contramap Cabal.repoSubdir ( maybeToDhall stringToDhall ) ) ] ) ) { Dhall.declared = Expr.Var "types" `Expr.Field` "SourceRepo" } repoKind :: Dhall.InputType Cabal.RepoKind repoKind = Dhall.InputType { Dhall.embed = \case Cabal.RepoThis -> Expr.App ( Expr.Var "types" `Expr.Field` "RepoKind" `Expr.Field` "RepoThis" ) ( Expr.RecordLit mempty ) Cabal.RepoHead -> Expr.App ( Expr.Var "types" `Expr.Field` "RepoKind" `Expr.Field` "RepoHead" ) ( Expr.RecordLit mempty ) Cabal.RepoKindUnknown str -> Expr.App ( Expr.Var "types" `Expr.Field` "RepoKind" `Expr.Field` "RepoThis" ) ( Expr.RecordLit ( Map.singleton "_1" ( dhallString str ) ) ) , Dhall.declared = Expr.Var "types" `Expr.Field` "RepoKind" } repoType :: Dhall.InputType Cabal.RepoType repoType = Dhall.InputType { Dhall.embed = \case Cabal.Darcs -> Expr.App ( constr "Darcs" ) ( Expr.RecordLit mempty ) Cabal.Git -> Expr.App ( constr "Git" ) ( Expr.RecordLit mempty ) Cabal.SVN -> Expr.App ( constr "SVN" ) ( Expr.RecordLit mempty ) Cabal.CVS -> Expr.App ( constr "CVS" ) ( Expr.RecordLit mempty ) Cabal.Mercurial -> Expr.App ( constr "Mercurial" ) ( Expr.RecordLit mempty ) Cabal.GnuArch -> Expr.App ( constr "GnuArch" ) ( Expr.RecordLit mempty ) Cabal.Monotone -> Expr.App ( constr "Monotone" ) ( Expr.RecordLit mempty ) Cabal.Bazaar -> Expr.App ( constr "Bazaar" ) ( Expr.RecordLit mempty ) Cabal.OtherRepoType str -> Expr.App ( constr "OtherRepoType" ) ( Expr.RecordLit ( Map.singleton "_1" ( dhallString str ) ) ) , Dhall.declared = Expr.Var "types" `Expr.Field` "RepoType" } where constr name = Expr.Var "types" `Expr.Field` "RepoType" `Expr.Field` name specVersion :: Dhall.InputType ( Either Cabal.Version Cabal.VersionRange ) specVersion = Dhall.InputType { Dhall.embed = either ( Dhall.embed versionToDhall ) ( error "Only exact cabal-versions are supported" ) , Dhall.declared = Dhall.declared versionToDhall } buildType :: Dhall.InputType Cabal.BuildType buildType = Dhall.InputType { Dhall.embed = \case Cabal.Simple -> Expr.App ( Expr.Var "types" `Expr.Field` "BuildType" `Expr.Field` "Simple" ) ( Expr.RecordLit mempty ) Cabal.Configure -> Expr.App ( Expr.Var "types" `Expr.Field` "BuildType" `Expr.Field` "Configure" ) ( Expr.RecordLit mempty ) Cabal.Custom -> Expr.App ( Expr.Var "types" `Expr.Field` "BuildType" `Expr.Field` "Custom" ) ( Expr.RecordLit mempty ) Cabal.Make -> Expr.App ( Expr.Var "types" `Expr.Field` "BuildType" `Expr.Field` "Make" ) ( Expr.RecordLit mempty ) , Dhall.declared = Expr.Var "types" `Expr.Field` "BuildType" } setupBuildInfo :: Dhall.InputType Cabal.SetupBuildInfo setupBuildInfo = ( runRecordInputType ( mconcat [ recordField "setup-depends" ( contramap Cabal.setupDepends ( listOf dependency ) ) ] ) ) { Dhall.declared = Expr.Var "types" `Expr.Field` "CustomSetup" } dependency :: Dhall.InputType Cabal.Dependency dependency = runRecordInputType ( mconcat [ recordField "package" ( contramap ( \( Cabal.Dependency p _ ) -> p ) packageNameToDhall ) , recordField "bounds" ( contramap ( \( Cabal.Dependency _ a ) -> a ) versionRange ) ] ) flag :: Dhall.InputType Cabal.Flag flag = runRecordInputType ( mconcat [ recordField "name" ( contramap Cabal.flagName flagName ) , recordField "default" ( contramap Cabal.flagDefault Dhall.inject ) , recordField "description" ( contramap Cabal.flagDescription stringToDhall ) , recordField "manual" ( contramap Cabal.flagManual Dhall.inject ) ] ) flagName :: Dhall.InputType Cabal.FlagName flagName = contramap Cabal.unFlagName stringToDhall library :: Dhall.InputType Cabal.Library library = ( runRecordInputTypeWithDefault Library libraryDefault ( mconcat [ contramap Cabal.libBuildInfo buildInfoRecord , recordField "exposed-modules" ( contramap Cabal.exposedModules ( listOf moduleName ) ) , recordField "reexported-modules" ( contramap Cabal.reexportedModules ( listOf moduleReexport ) ) , recordField "signatures" ( contramap Cabal.signatures ( listOf moduleName ) ) ] ) ) { Dhall.declared = Expr.Var "types" `Expr.Field` "Library" } unifyCondTree :: ( Monoid a ) => Cabal.CondTree v x a -> ConfigTree ( Cabal.Condition v ) a unifyCondTree = let branch :: ( Monoid a ) => Cabal.CondBranch v x a -> ConfigTree ( Cabal.Condition v ) a branch ( Cabal.CondBranch cond true false ) = Branch cond ( tree true ) ( maybe mempty tree false ) tree :: ( Monoid a ) => Cabal.CondTree v x a -> ConfigTree ( Cabal.Condition v ) a tree ( Cabal.CondNode acc _ branches) = return acc `mappend` foldMap branch branches in tree condTree :: ( Monoid a ) => Dhall.InputType a -> Dhall.InputType ( Cabal.CondTree Cabal.ConfVar x a ) condTree t = let go = \case Leaf a -> Dhall.embed t a Branch cond a b -> Expr.BoolIf ( Dhall.embed condBranchCondition cond ) ( go a ) ( go b ) configRecord = Expr.Var "types" `Expr.Field` "Config" in Dhall.InputType { Dhall.embed = Expr.Lam "config" configRecord . go . unifyCondTree , Dhall.declared = Expr.Pi "_" configRecord ( Dhall.declared t ) } moduleName :: Dhall.InputType Cabal.ModuleName moduleName = contramap ( show . Cabal.disp ) stringToDhall condBranchCondition :: Dhall.InputType (Cabal.Condition Cabal.ConfVar) condBranchCondition = Dhall.InputType { Dhall.declared = Expr.Bool , Dhall.embed = \a -> case a of Cabal.Var ( Cabal.OS os0 ) -> Expr.App ( Expr.Field ( Expr.Var "config" ) "os" ) ( Dhall.embed os os0 ) Cabal.Var ( Cabal.Arch arch0 ) -> Expr.App ( Expr.Field ( Expr.Var "config" ) "arch" ) ( Dhall.embed arch arch0 ) Cabal.Var ( Cabal.Flag flagName0 ) -> Expr.App ( Expr.Field ( Expr.Var "config" ) "flag" ) ( Dhall.embed flagName flagName0 ) Cabal.Var ( Cabal.Impl c v ) -> Expr.App ( Expr.App ( Expr.Field ( Expr.Var "config" ) "impl" ) ( Dhall.embed compilerFlavor c ) ) ( Dhall.embed versionRange v ) Cabal.Lit b -> Expr.BoolLit b Cabal.CNot c -> Expr.BoolEQ ( Expr.BoolLit False ) ( Dhall.embed condBranchCondition c ) Cabal.CAnd a b -> Expr.BoolAnd ( Dhall.embed condBranchCondition a ) ( Dhall.embed condBranchCondition b ) Cabal.COr a b -> Expr.BoolOr ( Dhall.embed condBranchCondition a ) ( Dhall.embed condBranchCondition b ) } os :: Dhall.InputType Cabal.OS os = Dhall.InputType { Dhall.embed = \case Cabal.Linux -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "Linux" ) ( Expr.RecordLit mempty ) Cabal.Windows -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "Windows" ) ( Expr.RecordLit mempty ) Cabal.OSX -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "OSX" ) ( Expr.RecordLit mempty ) Cabal.FreeBSD -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "FreeBSD" ) ( Expr.RecordLit mempty ) Cabal.OpenBSD -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "OpenBSD" ) ( Expr.RecordLit mempty ) Cabal.NetBSD -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "NetBSD" ) ( Expr.RecordLit mempty ) Cabal.DragonFly -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "DragonFly" ) ( Expr.RecordLit mempty ) Cabal.Solaris -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "Solaris" ) ( Expr.RecordLit mempty ) Cabal.AIX -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "AIX" ) ( Expr.RecordLit mempty ) Cabal.HPUX -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "HPUX" ) ( Expr.RecordLit mempty ) Cabal.IRIX -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "IRIX" ) ( Expr.RecordLit mempty ) Cabal.HaLVM -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "HaLVM" ) ( Expr.RecordLit mempty ) Cabal.Hurd -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "Hurd" ) ( Expr.RecordLit mempty ) Cabal.IOS -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "IOS" ) ( Expr.RecordLit mempty ) Cabal.Android -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "Android" ) ( Expr.RecordLit mempty ) Cabal.Ghcjs -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "Ghcjs" ) ( Expr.RecordLit mempty ) Cabal.OtherOS os -> Expr.App ( Expr.Var "types" `Expr.Field` "OS" `Expr.Field` "OtherOS" ) ( Expr.RecordLit ( Map.singleton "_1" ( dhallString os ) ) ) , Dhall.declared = Expr.Var "types" `Expr.Field` "OS" } arch :: Dhall.InputType Cabal.Arch arch = runUnion ( mconcat [ unionAlt "I386" ( \x -> case x of Cabal.I386 -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "X86_64" ( \x -> case x of Cabal.X86_64 -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "PPC" ( \x -> case x of Cabal.PPC -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "PPC64" ( \x -> case x of Cabal.PPC64 -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "Sparc" ( \x -> case x of Cabal.Sparc -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "Arm" ( \x -> case x of Cabal.Arm -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "Mips" ( \x -> case x of Cabal.Mips -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "SH" ( \x -> case x of Cabal.SH -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "IA64" ( \x -> case x of Cabal.IA64 -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "S390" ( \x -> case x of Cabal.S390 -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "Alpha" ( \x -> case x of Cabal.Alpha -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "Hppa" ( \x -> case x of Cabal.Hppa -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "Rs6000" ( \x -> case x of Cabal.Rs6000 -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "M68k" ( \x -> case x of Cabal.M68k -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "Vax" ( \x -> case x of Cabal.Vax -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "JavaScript" ( \x -> case x of Cabal.JavaScript -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "OtherArch" ( \x -> case x of Cabal.OtherArch s -> Just s ; _ -> Nothing ) ( runRecordInputType ( recordField "_1" stringToDhall ) ) ] ) buildInfoRecord :: RecordInputType Cabal.BuildInfo buildInfoRecord = mconcat [ recordField "buildable" ( contramap Cabal.buildable Dhall.inject ) , recordField "build-tools" ( contramap Cabal.buildTools ( listOf legacyExeDependency ) ) , recordField "build-tool-depends" ( contramap Cabal.buildToolDepends ( listOf exeDependency ) ) , recordField "cpp-options" ( contramap Cabal.cppOptions ( listOf stringToDhall ) ) , recordField "cc-options" ( contramap Cabal.ccOptions ( listOf stringToDhall ) ) , recordField "ld-options" ( contramap Cabal.ldOptions ( listOf stringToDhall ) ) , recordField "pkgconfig-depends" ( contramap Cabal.pkgconfigDepends ( listOf pkgconfigDependency ) ) , recordField "frameworks" ( contramap Cabal.frameworks ( listOf stringToDhall ) ) , recordField "extra-framework-dirs" ( contramap Cabal.extraFrameworkDirs ( listOf stringToDhall ) ) , recordField "c-sources" ( contramap Cabal.cSources ( listOf stringToDhall ) ) , recordField "js-sources" ( contramap Cabal.jsSources ( listOf stringToDhall ) ) , recordField "hs-source-dirs" ( contramap Cabal.hsSourceDirs ( listOf stringToDhall ) ) , recordField "other-modules" ( contramap Cabal.otherModules ( listOf moduleName ) ) , recordField "autogen-modules" ( contramap Cabal.autogenModules ( listOf moduleName ) ) , recordField "default-language" ( contramap Cabal.defaultLanguage ( maybeToDhall language ) ) , recordField "other-languages" ( contramap Cabal.otherLanguages ( listOf language ) ) , recordField "default-extensions" ( Cabal.defaultExtensions >$< listOf extension ) , recordField "other-extensions" ( Cabal.otherExtensions >$< listOf extension ) , recordField "extra-libraries" ( Cabal.extraLibs >$< listOf stringToDhall ) , recordField "extra-ghci-libraries" ( Cabal.extraGHCiLibs >$< listOf stringToDhall ) , recordField "extra-lib-dirs" ( Cabal.extraLibDirs >$< listOf stringToDhall ) , recordField "include-dirs" ( Cabal.includeDirs >$< listOf stringToDhall ) , recordField "includes" ( Cabal.includes >$< listOf stringToDhall ) , recordField "install-includes" ( Cabal.installIncludes >$< listOf stringToDhall ) , recordField "compiler-options" ( Cabal.options >$< compilerOptions ) , recordField "profiling-options" ( Cabal.profOptions >$< compilerOptions ) , recordField "shared-options" ( Cabal.sharedOptions >$< compilerOptions ) , recordField "static-options" ( Cabal.staticOptions >$< compilerOptions ) , recordField "build-depends" ( Cabal.targetBuildDepends >$< listOf dependency ) , recordField "mixins" ( Cabal.mixins >$< listOf mixin ) , recordField "asm-options" ( Cabal.asmOptions >$< listOf stringToDhall) , recordField "asm-sources" ( Cabal.asmSources >$< listOf stringToDhall) , recordField "cmm-options" ( Cabal.cmmOptions >$< listOf stringToDhall ) , recordField "cmm-sources" ( Cabal.cmmSources >$< listOf stringToDhall ) , recordField "cxx-options" ( Cabal.cxxOptions >$< listOf stringToDhall ) , recordField "cxx-sources" ( Cabal.cxxSources >$< listOf stringToDhall) , recordField "virtual-modules" ( Cabal.virtualModules >$< listOf moduleName ) , recordField "extra-lib-flavours" ( Cabal.extraLibFlavours >$< listOf stringToDhall ) , recordField "extra-bundled-libs" ( Cabal.extraBundledLibs >$< listOf stringToDhall ) ] moduleReexport :: Dhall.InputType Cabal.ModuleReexport moduleReexport = runRecordInputType ( mconcat [ recordField "original" ( ( \a -> ( Cabal.moduleReexportOriginalPackage a, Cabal.moduleReexportOriginalName a ) ) >$< runRecordInputType ( mconcat [ recordField "package" ( fst >$< maybeToDhall packageNameToDhall ) , recordField "name" ( snd >$< moduleName ) ] ) ) , recordField "name" ( Cabal.moduleReexportName >$< moduleName ) ] ) legacyExeDependency :: Dhall.InputType Cabal.LegacyExeDependency legacyExeDependency = runRecordInputType ( mconcat [ recordField "exe" ( ( \( Cabal.LegacyExeDependency exe _ ) -> exe ) >$< stringToDhall ) , recordField "version" ( ( \( Cabal.LegacyExeDependency _ version ) -> version ) >$< versionRange ) ] ) exeDependency :: Dhall.InputType Cabal.ExeDependency exeDependency = runRecordInputType ( mconcat [ recordField "package" ( ( \( Cabal.ExeDependency packageName _ _ ) -> packageName ) >$< packageNameToDhall ) , recordField "component" ( ( \( Cabal.ExeDependency _ component _ ) -> component ) >$< unqualComponentName ) , recordField "version" ( ( \( Cabal.ExeDependency _ _ version ) -> version ) >$< versionRange ) ] ) unqualComponentName :: Dhall.InputType Cabal.UnqualComponentName unqualComponentName = show . Cabal.disp >$< stringToDhall pkgconfigDependency :: Dhall.InputType Cabal.PkgconfigDependency pkgconfigDependency = runRecordInputType ( mconcat [ recordField "name" ( ( \( Cabal.PkgconfigDependency a _version ) -> a ) >$< pkgconfigName ) , recordField "version" ( ( \( Cabal.PkgconfigDependency _name a ) -> a ) >$< versionRange ) ] ) pkgconfigName :: Dhall.InputType Cabal.PkgconfigName pkgconfigName = show . Cabal.disp >$< stringToDhall language :: Dhall.InputType Cabal.Language language = ( runUnion ( mconcat [ unionAlt "Haskell2010" ( \x -> case x of Cabal.Haskell2010 -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "UnknownLanguage" ( \x -> case x of Cabal.UnknownLanguage s -> Just s ; _ -> Nothing ) ( runRecordInputType ( recordField "_1" stringToDhall ) ) , unionAlt "Haskell98" ( \x -> case x of Cabal.Haskell98 -> Just () ; _ -> Nothing ) Dhall.inject ] ) ) { Dhall.declared = Expr.Var "types" `Expr.Field` "Language" } extension :: Dhall.InputType Cabal.Extension extension = Dhall.InputType { Dhall.embed = \a -> case a of Cabal.EnableExtension ext -> extWith True ext Cabal.DisableExtension ext -> extWith False ext _ -> error "Unknown extension" , Dhall.declared = Expr.Var "types" `Expr.Field` "Extension" } where extName :: Cabal.KnownExtension -> StrictText.Text extName e = StrictText.pack ( show e ) extWith trueFalse ext = Expr.App ( Expr.Var "types" `Expr.Field` "Extension" `Expr.Field` extName ext ) ( Expr.BoolLit trueFalse ) compilerOptions :: Dhall.InputType [ ( Cabal.CompilerFlavor, [ String ] ) ] compilerOptions = Dhall.InputType { Dhall.embed = \xs -> withDefault CompilerOptions compilerOptionsDefault ( Expr.RecordLit ( Map.fromList ( map ( \( c, opts ) -> ( StrictText.pack ( show c ) , Expr.ListLit ( Just Expr.Text ) ( dhallString <$> Seq.fromList opts ) ) ) xs ) ) ) , Dhall.declared = Expr.Var "types" `Expr.Field` "CompilerOptions" } mixin :: Dhall.InputType Cabal.Mixin mixin = ( runRecordInputType ( mconcat [ recordField "package" ( Cabal.mixinPackageName >$< packageNameToDhall ) , recordField "renaming" ( Cabal.mixinIncludeRenaming >$< includeRenaming ) ] ) ) { Dhall.declared = Expr.Var "types" `Expr.Field` "Mixin" } includeRenaming :: Dhall.InputType Cabal.IncludeRenaming includeRenaming = runRecordInputType ( mconcat [ recordField "provides" ( Cabal.includeProvidesRn >$< moduleRenaming ) , recordField "requires" ( Cabal.includeRequiresRn >$< moduleRenaming ) ] ) moduleRenaming :: Dhall.InputType Cabal.ModuleRenaming moduleRenaming = Dhall.InputType { Dhall.embed = \a -> case a of Cabal.ModuleRenaming renamed -> Expr.App ( Expr.Var "types" `Expr.Field` "ModuleRenaming" `Expr.Field` "renaming" ) ( Expr.ListLit Nothing ( fmap (\ ( src, dst ) -> Expr.RecordLit ( Map.fromList [ ( "rename", Dhall.embed moduleName src ) , ( "to", Dhall.embed moduleName dst ) ] ) ) ( Seq.fromList renamed ) ) ) Cabal.DefaultRenaming -> Expr.App ( Expr.Var "types" `Expr.Field` "ModuleRenaming" `Expr.Field` "default" ) ( Expr.RecordLit mempty ) Cabal.HidingRenaming hidden -> Expr.App ( Expr.Var "types" `Expr.Field` "ModuleRenaming" `Expr.Field` "hiding" ) ( Expr.ListLit Nothing ( Dhall.embed moduleName <$> Seq.fromList hidden ) ) , Dhall.declared = Expr.Var "types" `Expr.Field` "ModuleRenaming" } benchmark :: Dhall.InputType Cabal.Benchmark benchmark = ( runRecordInputTypeWithDefault Benchmark benchmarkDefault ( mconcat [ recordField "main-is" ( ( \case Cabal.BenchmarkExeV10 _ fp -> fp Cabal.BenchmarkUnsupported _ -> errorWithoutStackTrace "Unsupported benchmark type" ) . Cabal.benchmarkInterface >$< stringToDhall ) , Cabal.benchmarkBuildInfo >$< buildInfoRecord ] ) ) { Dhall.declared = Expr.Var "types" `Expr.Field` "Benchmark" } testSuite :: Dhall.InputType Cabal.TestSuite testSuite = ( runRecordInputTypeWithDefault TestSuite testSuiteDefault ( mconcat [ recordField "type" ( Cabal.testInterface >$< testSuiteInterface ) , Cabal.testBuildInfo >$< buildInfoRecord ] ) ) { Dhall.declared = Expr.Var "types" `Expr.Field` "TestSuite" } testSuiteInterface :: Dhall.InputType Cabal.TestSuiteInterface testSuiteInterface = runUnion ( mconcat [ unionAlt "exitcode-stdio" ( \x -> case x of Cabal.TestSuiteExeV10 _ main -> Just main _ -> Nothing ) ( runRecordInputType ( recordField "main-is" stringToDhall ) ) , unionAlt "detailed" ( \x -> case x of Cabal.TestSuiteLibV09 _ m -> Just m _ -> Nothing ) ( runRecordInputType ( recordField "module" moduleName ) ) ] ) executable :: Dhall.InputType Cabal.Executable executable = ( runRecordInputTypeWithDefault Executable executableDefault ( mconcat [ recordField "main-is" ( Cabal.modulePath >$< stringToDhall ) , recordField "scope" ( Cabal.exeScope >$< executableScope ) , Cabal.buildInfo >$< buildInfoRecord ] ) ) { Dhall.declared = Expr.Var "types" `Expr.Field` "Executable" } executableScope :: Dhall.InputType Cabal.ExecutableScope executableScope = Dhall.InputType { Dhall.embed = \case Cabal.ExecutablePublic -> Expr.App ( Expr.Var "types" `Expr.Field` "Scope" `Expr.Field` "Public" ) ( Expr.RecordLit mempty ) Cabal.ExecutablePrivate -> Expr.App ( Expr.Var "types" `Expr.Field` "Scope" `Expr.Field` "Private" ) ( Expr.RecordLit mempty ) , Dhall.declared = Expr.Var "types" `Expr.Field` "Scope" } foreignLibrary :: Dhall.InputType Cabal.ForeignLib foreignLibrary = ( runRecordInputType ( mconcat [ recordField "type" ( Cabal.foreignLibType >$< foreignLibType ) , recordField "options" ( Cabal.foreignLibOptions >$< ( listOf foreignLibOption ) ) , Cabal.foreignLibBuildInfo >$< buildInfoRecord , recordField "lib-version-info" ( Cabal.foreignLibVersionInfo >$< maybeToDhall versionInfo ) , recordField "lib-version-linux" ( Cabal.foreignLibVersionLinux >$< maybeToDhall versionToDhall ) , recordField "mod-def-files" ( Cabal.foreignLibModDefFile >$< listOf stringToDhall ) ] ) ) { Dhall.declared = Expr.Var "types" `Expr.Field` "ForeignLibrary" } versionInfo :: Dhall.InputType Cabal.LibVersionInfo versionInfo = Cabal.libVersionInfoCRA >$< runRecordInputType ( mconcat [ recordField "current" ( ( \( a, _, _ ) -> fromIntegral a :: Natural ) >$< ( Dhall.inject ) ) , recordField "revision" ( ( \( _, a, _ ) -> fromIntegral a :: Natural ) >$< ( Dhall.inject ) ) , recordField "age" ( ( \( _, _, a ) -> fromIntegral a :: Natural ) >$< ( Dhall.inject ) ) ] ) foreignLibOption :: Dhall.InputType Cabal.ForeignLibOption foreignLibOption = runUnion ( unionAlt "Standalone" ( \x -> case x of Cabal.ForeignLibStandalone -> Just () ) Dhall.inject ) foreignLibType :: Dhall.InputType Cabal.ForeignLibType foreignLibType = runUnion ( mconcat [ unionAlt "Shared" ( \x -> case x of Cabal.ForeignLibNativeShared -> Just () ; _ -> Nothing ) Dhall.inject , unionAlt "Static" ( \x -> case x of Cabal.ForeignLibNativeStatic -> Just () ; _ -> Nothing ) Dhall.inject ] )