diff --git a/Changelog.md b/Changelog.md index 141c307b..905fc329 100644 --- a/Changelog.md +++ b/Changelog.md @@ -5,6 +5,10 @@ * Remove `dhall/types/CustomSetup.dhall` in favour of the identical `dhall/types/SetupBuildInfo.dhall`. +* Added `dhall/types/ForeignLibOption.dhall`, also available as + `types.ForeignLibOption`, and `--print-type ForeignLibOption`. + Likewise `ForeignLibType`. + ## 1.3.3.0 -- 2019-05-15 * All constructors that previously took an empty record now use the diff --git a/dhall/types.dhall b/dhall/types.dhall index 717d6746..944e7f61 100644 --- a/dhall/types.dhall +++ b/dhall/types.dhall @@ -20,6 +20,10 @@ ./types/Extension.dhall , Flag = ./types/Flag.dhall +, ForeignLibOption = + ./types/ForeignLibOption.dhall +, ForeignLibType = + ./types/ForeignLibType.dhall , ForeignLibrary = ./types/ForeignLibrary.dhall , Language = diff --git a/dhall/types/ForeignLibOption.dhall b/dhall/types/ForeignLibOption.dhall new file mode 100644 index 00000000..da34358f --- /dev/null +++ b/dhall/types/ForeignLibOption.dhall @@ -0,0 +1 @@ +< Standalone > diff --git a/dhall/types/ForeignLibType.dhall b/dhall/types/ForeignLibType.dhall new file mode 100644 index 00000000..98e10d04 --- /dev/null +++ b/dhall/types/ForeignLibType.dhall @@ -0,0 +1 @@ +< Shared | Static > diff --git a/dhall/types/ForeignLibrary.dhall b/dhall/types/ForeignLibrary.dhall index 235293ab..55e51b23 100644 --- a/dhall/types/ForeignLibrary.dhall +++ b/dhall/types/ForeignLibrary.dhall @@ -1,8 +1,8 @@ ./BuildInfo.dhall ⩓ { type : - < Shared | Static > + ./ForeignLibType.dhall , options : - List < Standalone > + List ./ForeignLibOption.dhall , lib-version-info : Optional { current : Natural, revision : Natural, age : Natural } , lib-version-linux : diff --git a/exe/Main.hs b/exe/Main.hs index 8aacc347..95040acb 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -86,6 +86,8 @@ data KnownType | LicenseExceptionId | Scope | ModuleRenaming + | ForeignLibOption + | ForeignLibType deriving (Bounded, Enum, Eq, Ord, Read, Show) @@ -467,6 +469,8 @@ printType PrintTypeOptions { .. } = do LicenseExceptionId -> Dhall.expected spdxLicenseExceptionId Scope -> Dhall.expected executableScope ModuleRenaming -> Dhall.expected moduleRenaming + ForeignLibOption -> Dhall.expected foreignLibOption + ForeignLibType -> Dhall.expected foreignLibType ) makeLetOrImport t val reduced = diff --git a/lib/CabalToDhall.hs b/lib/CabalToDhall.hs index 8671d792..51055f1f 100644 --- a/lib/CabalToDhall.hs +++ b/lib/CabalToDhall.hs @@ -18,9 +18,7 @@ module CabalToDhall 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 @@ -77,10 +75,6 @@ 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 @@ -743,48 +737,6 @@ spdxLicenseExceptionIdToDhall = 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 ( Just <$> alts ) - , Dhall.declared = - sortExpr ( Expr.Union ( Just <$> 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 = @@ -1237,27 +1189,52 @@ 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 ) ) - ] - ) + Dhall.InputType + { Dhall.embed = \case + Cabal.I386 -> + arch "I386" + Cabal.X86_64 -> + arch "X86_64" + Cabal.PPC -> + arch "PPC" + Cabal.PPC64 -> + arch "PPC64" + Cabal.Sparc -> + arch "Sparc" + Cabal.Arm -> + arch "Arm" + Cabal.Mips -> + arch "Mips" + Cabal.SH -> + arch "SH" + Cabal.IA64 -> + arch "IA64" + Cabal.S390 -> + arch "S390" + Cabal.Alpha -> + arch "Alpha" + Cabal.Hppa -> + arch "Hppa" + Cabal.Rs6000 -> + arch "Rs6000" + Cabal.M68k -> + arch "M68k" + Cabal.Vax -> + arch "Vax" + Cabal.JavaScript -> + arch "JavaScript" + Cabal.AArch64 -> + arch "AArch64" + Cabal.OtherArch s -> + Expr.App + ( arch "OtherArch" ) + ( Expr.RecordLit ( Map.singleton "_1" ( dhallString s ) ) ) + , Dhall.declared = + Expr.Var "types" `Expr.Field` "Arch" + } + where + arch name = + Expr.Var "types" `Expr.Field` "Arch" `Expr.Field` name buildInfoRecord :: RecordInputType Cabal.BuildInfo @@ -1365,17 +1342,22 @@ pkgconfigName = 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 = + Dhall.InputType + { Dhall.embed = \case + Cabal.Haskell2010 -> + lang "Haskell2010" + Cabal.Haskell98 -> + lang "Haskell98" + Cabal.UnknownLanguage s -> + Expr.App + ( lang "UnknownLanguage" ) + ( Expr.RecordLit ( Map.singleton "_1" ( dhallString s ) ) ) + , Dhall.declared = Expr.Var "types" `Expr.Field` "Language" } + where + lang name = + Expr.Var "types" `Expr.Field` "Language" `Expr.Field` name extension :: Dhall.InputType Cabal.Extension extension = @@ -1526,32 +1508,28 @@ testSuite = testSuiteInterface :: Dhall.InputType Cabal.TestSuiteInterface testSuiteInterface = - runUnion - ( mconcat - [ unionAlt - "exitcode-stdio" - ( \x -> - case x of - Cabal.TestSuiteExeV10 _ main -> - Just main - - _ -> - Nothing + Dhall.InputType + { Dhall.embed = \case + Cabal.TestSuiteExeV10 _ main -> + Expr.App + ( interface "exitcode-stdio" ) + ( Dhall.embed + ( runRecordInputType ( recordField "main-is" stringToDhall ) ) + main ) - ( runRecordInputType ( recordField "main-is" stringToDhall ) ) - , unionAlt - "detailed" - ( \x -> - case x of - Cabal.TestSuiteLibV09 _ m -> - Just m - - _ -> - Nothing + Cabal.TestSuiteLibV09 _ m -> + Expr.App + ( interface "detailed" ) + ( Dhall.embed + ( runRecordInputType ( recordField "module" moduleName ) ) + m ) - ( runRecordInputType ( recordField "module" moduleName ) ) - ] - ) + , Dhall.declared = + Expr.Var "types" `Expr.Field` "TestType" + } + where + interface name = + Expr.Var "types" `Expr.Field` "TestType" `Expr.Field` name executable :: Dhall.InputType Cabal.Executable @@ -1614,16 +1592,26 @@ versionInfo = foreignLibOption :: Dhall.InputType Cabal.ForeignLibOption foreignLibOption = - runUnion - ( unionAlt "Standalone" ( \x -> case x of Cabal.ForeignLibStandalone -> Just () ) Dhall.inject - ) + Dhall.InputType + { Dhall.embed = \case + Cabal.ForeignLibStandalone -> + Expr.Var "types" `Expr.Field` "ForeignLibOption" `Expr.Field` "Standalone" + , Dhall.declared = + Expr.Var "types" `Expr.Field` "ForeignLibOption" + } 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 - ] - ) + Dhall.InputType + { Dhall.embed = \case + Cabal.ForeignLibNativeShared -> + ty "Shared" + Cabal.ForeignLibNativeStatic -> + ty "Static" + , Dhall.declared = + Expr.Var "types" `Expr.Field` "ForeignLibType" + } + where + ty name = + Expr.Var "types" `Expr.Field` "ForeignLibType" `Expr.Field` name diff --git a/lib/DhallToCabal.hs b/lib/DhallToCabal.hs index 06d37485..763232e7 100644 --- a/lib/DhallToCabal.hs +++ b/lib/DhallToCabal.hs @@ -36,6 +36,8 @@ module DhallToCabal , buildInfoType , executableScope , moduleRenaming + , foreignLibOption + , foreignLibType , sortExpr ) where