Replace & remove runUnion

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

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 =

dhall/types/ForeignLibOption.dhall

@@ -0,0 +1 @@
+< Standalone >

dhall/types/ForeignLibType.dhall

@@ -0,0 +1 @@
+< Shared | Static >

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 :

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 =

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

lib/DhallToCabal.hs

@@ -36,6 +36,8 @@ module DhallToCabal
   , buildInfoType
   , executableScope
   , moduleRenaming
+  , foreignLibOption
+  , foreignLibType
 
   , sortExpr
   ) where