Dual compiler support

Cabal-syntax/Cabal-syntax.cabal

@@ -140,6 +140,7 @@ library
     Distribution.Types.Executable
     Distribution.Types.Executable.Lens
     Distribution.Types.ExecutableScope
+    Distribution.Types.ExtraSource
     Distribution.Types.ExposedModule
     Distribution.Types.Flag
     Distribution.Types.ForeignLib

Cabal-syntax/src/Distribution/Backpack.hs

@@ -53,6 +53,10 @@ import Distribution.Utils.Base62
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
+import GHC.Stack (HasCallStack)
+
+import Unsafe.Coerce (unsafeCoerce)
+
 -----------------------------------------------------------------------
 -- OpenUnitId
 
@@ -147,9 +151,7 @@ mkOpenUnitId uid cid insts =
 mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId
 mkDefUnitId cid insts =
   unsafeMkDefUnitId
-    ( mkUnitId
-        (unComponentId cid ++ maybe "" ("+" ++) (hashModuleSubst insts))
-    )
+    (addSuffixToUnitId (maybe "" ("+" ++) (hashModuleSubst insts)) (unsafeCoerce cid))
 
 -- impose invariant!
 
@@ -254,7 +256,7 @@ openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems
 -- | When typechecking, we don't demand that a freshly instantiated
 -- 'IndefFullUnitId' be compiled; instead, we just depend on the
 -- installed indefinite unit installed at the 'ComponentId'.
-abstractUnitId :: OpenUnitId -> UnitId
+abstractUnitId :: HasCallStack => OpenUnitId -> UnitId
 abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid
 abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid
 

Cabal-syntax/src/Distribution/Compat/Graph.hs

@@ -105,6 +105,8 @@ import qualified Data.Set as Set
 import qualified Data.Tree as Tree
 import qualified Distribution.Compat.Prelude as Prelude
 
+import GHC.Stack (HasCallStack)
+
 -- | A graph of nodes @a@.  The nodes are expected to have instance
 -- of class 'IsNode'.
 data Graph a = Graph
@@ -377,16 +379,18 @@ fromMap m =
     bounds = (0, Map.size m - 1)
 
 -- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph.
-fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a
-fromDistinctList =
+fromDistinctList :: (HasCallStack, IsNode a, Show (Key a)) => [a] -> Graph a
+fromDistinctList xs =
   fromMap
     . Map.fromListWith (\_ -> duplicateError)
-    . map (\n -> n `seq` (nodeKey n, n))
+    . map (\n -> n `seq` (nodeKey n, n)) $ xs
   where
     duplicateError n =
       error $
         "Graph.fromDistinctList: duplicate key: "
           ++ show (nodeKey n)
+          ++ " in "
+          ++ unlines (map (show . nodeKey) xs)
 
 -- Map-like operations
 

Cabal-syntax/src/Distribution/Compiler.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 -----------------------------------------------------------------------------
 
@@ -173,7 +174,7 @@
 -- ------------------------------------------------------------
 
 data CompilerId = CompilerId CompilerFlavor Version
-  deriving (Eq, Generic, Ord, Read, Show)
+  deriving (Eq, Generic, Ord, Read, Show, Data)
 
 instance Binary CompilerId
 instance Structured CompilerId
@@ -184,12 +185,18 @@
     | v == nullVersion = pretty f
     | otherwise = pretty f <<>> Disp.char '-' <<>> pretty v
 
+instance Pretty (Maybe CompilerId) where
+  pretty = maybe Disp.empty pretty
+
 instance Parsec CompilerId where
   parsec = do
     flavour <- parsec
     version <- (P.char '-' >> parsec) <|> return nullVersion
     return (CompilerId flavour version)
 
+instance Parsec (Maybe CompilerId) where
+  parsec = Just <$> parsec <|> return Nothing
+
 lowercase :: String -> String
 lowercase = map toLower
 
@@ -216,17 +223,21 @@
   , compilerInfoExtensions :: Maybe [Extension]
   -- ^ Supported extensions, if known.
   }
-  deriving (Generic, Show, Read)
+  deriving (Generic, Show, Read, Eq)
 
 instance Binary CompilerInfo
+instance Structured CompilerInfo
+instance NFData CompilerInfo where rnf = genericRnf
 
+-- | AbiTag logic
 data AbiTag
   = NoAbiTag
   | AbiTag String
   deriving (Eq, Generic, Show, Read)
 
 instance Binary AbiTag
 instance Structured AbiTag
+instance NFData AbiTag where rnf = genericRnf
 
 instance Pretty AbiTag where
   pretty NoAbiTag = Disp.empty

Cabal-syntax/src/Distribution/FieldGrammar/Class.hs

@@ -23,6 +23,8 @@ import Distribution.FieldGrammar.Newtypes
 import Distribution.Fields.Field
 import Distribution.Utils.ShortText
 
+import GHC.Stack (HasCallStack)
+
 -- | 'FieldGrammar' is parametrised by
 --
 -- * @s@ which is a structure we are parsing. We need this to provide prettyprinter
@@ -43,11 +45,11 @@ class
     | g -> c
   where
   -- | Unfocus, zoom out, /blur/ 'FieldGrammar'.
-  blurFieldGrammar :: ALens' a b -> g b d -> g a d
+  blurFieldGrammar :: HasCallStack => ALens' a b -> g b d -> g a d
 
   -- | Field which should be defined, exactly once.
   uniqueFieldAla
-    :: (c b, Newtype a b)
+    :: (c b, Newtype a b, HasCallStack)
     => FieldName
     -- ^ field name
     -> (a -> b)
@@ -58,7 +60,7 @@ class
 
   -- | Boolean field with a default value.
   booleanFieldDef
-    :: FieldName
+    :: HasCallStack => FieldName
     -- ^ field name
     -> ALens' s Bool
     -- ^ lens into the field
@@ -68,7 +70,7 @@ class
 
   -- | Optional field.
   optionalFieldAla
-    :: (c b, Newtype a b)
+    :: (c b, Newtype a b, HasCallStack)
     => FieldName
     -- ^ field name
     -> (a -> b)
@@ -79,7 +81,7 @@ class
 
   -- | Optional field with default value.
   optionalFieldDefAla
-    :: (c b, Newtype a b, Eq a)
+    :: (c b, Newtype a b, Eq a, HasCallStack)
     => FieldName
     -- ^ field name
     -> (a -> b)
@@ -95,7 +97,7 @@ class
   --
   -- @since 3.0.0.0
   freeTextField
-    :: FieldName
+    :: HasCallStack => FieldName
     -> ALens' s (Maybe String)
     -- ^ lens into the field
     -> g s (Maybe String)
@@ -105,14 +107,14 @@ class
   --
   -- @since 3.0.0.0
   freeTextFieldDef
-    :: FieldName
+    :: HasCallStack => FieldName
     -> ALens' s String
     -- ^ lens into the field
     -> g s String
 
   -- | @since 3.2.0.0
   freeTextFieldDefST
-    :: FieldName
+    :: HasCallStack => FieldName
     -> ALens' s ShortText
     -- ^ lens into the field
     -> g s ShortText
@@ -123,7 +125,7 @@ class
   --
   -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid.
   monoidalFieldAla
-    :: (c b, Monoid a, Newtype a b)
+    :: (c b, Monoid a, Newtype a b, HasCallStack)
     => FieldName
     -- ^ field name
     -> (a -> b)
@@ -134,21 +136,21 @@ class
 
   -- | Parser matching all fields with a name starting with a prefix.
   prefixedFields
-    :: FieldName
+    :: HasCallStack => FieldName
     -- ^ field name prefix
     -> ALens' s [(String, String)]
     -- ^ lens into the field
     -> g s [(String, String)]
 
   -- | Known field, which we don't parse, nor pretty print.
-  knownField :: FieldName -> g s ()
+  knownField :: HasCallStack => FieldName -> g s ()
 
   -- | Field which is parsed but not pretty printed.
-  hiddenField :: g s a -> g s a
+  hiddenField :: HasCallStack => g s a -> g s a
 
   -- | Deprecated since
   deprecatedSince
-    :: CabalSpecVersion
+    :: HasCallStack => CabalSpecVersion
     -- ^ version
     -> String
     -- ^ deprecation message
@@ -157,7 +159,7 @@ class
 
   -- | Removed in. If we encounter removed field, parsing fails.
   removedIn
-    :: CabalSpecVersion
+    :: HasCallStack => CabalSpecVersion
     -- ^ version
     -> String
     -- ^ removal message
@@ -166,7 +168,7 @@ class
 
   -- | Annotate field with since spec-version.
   availableSince
-    :: CabalSpecVersion
+    :: HasCallStack => CabalSpecVersion
     -- ^ spec version
     -> a
     -- ^ default value
@@ -181,15 +183,15 @@ class
   --
   -- @since 3.4.0.0
   availableSinceWarn
-    :: CabalSpecVersion
+    :: HasCallStack => CabalSpecVersion
     -- ^ spec version
     -> g s a
     -> g s a
   availableSinceWarn _ = id
 
 -- | Field which can be defined at most once.
 uniqueField
-  :: (FieldGrammar c g, c (Identity a))
+  :: (FieldGrammar c g, c (Identity a), HasCallStack)
   => FieldName
   -- ^ field name
   -> ALens' s a
@@ -199,7 +201,7 @@ uniqueField fn l = uniqueFieldAla fn Identity l
 
 -- | Field which can be defined at most once.
 optionalField
-  :: (FieldGrammar c g, c (Identity a))
+  :: (FieldGrammar c g, c (Identity a), HasCallStack)
   => FieldName
   -- ^ field name
   -> ALens' s (Maybe a)
@@ -209,7 +211,7 @@ optionalField fn l = optionalFieldAla fn Identity l
 
 -- | Optional field with default value.
 optionalFieldDef
-  :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a)
+  :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a, HasCallStack)
   => FieldName
   -- ^ field name
   -> ALens' s a
@@ -221,7 +223,7 @@ optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x
 
 -- | Field which can be define multiple times, and the results are @mappend@ed.
 monoidalField
-  :: (FieldGrammar c g, c (Identity a), Monoid a)
+  :: (FieldGrammar c g, c (Identity a), Monoid a, HasCallStack)
   => FieldName
   -- ^ field name
   -> ALens' s a
@@ -231,7 +233,7 @@ monoidalField fn l = monoidalFieldAla fn Identity l
 
 -- | Default implementation for 'freeTextFieldDefST'.
 defaultFreeTextFieldDefST
-  :: (Functor (g s), FieldGrammar c g)
+  :: (Functor (g s), FieldGrammar c g, HasCallStack)
   => FieldName
   -> ALens' s ShortText
   -- ^ lens into the field

Cabal-syntax/src/Distribution/InstalledPackageInfo.hs

@@ -62,11 +62,15 @@ import qualified Text.PrettyPrint as Disp
 import Distribution.Types.InstalledPackageInfo
 import Distribution.Types.InstalledPackageInfo.FieldGrammar
 
-installedComponentId :: InstalledPackageInfo -> ComponentId
+import GHC.Stack (HasCallStack)
+
+import Unsafe.Coerce (unsafeCoerce)
+
+installedComponentId :: HasCallStack => InstalledPackageInfo -> ComponentId
 installedComponentId ipi =
-  case unComponentId (installedComponentId_ ipi) of
-    "" -> mkComponentId (unUnitId (installedUnitId ipi))
-    _ -> installedComponentId_ ipi
+  fromMaybe
+    (unsafeCoerce (installedUnitId ipi))
+    (installedComponentId_ ipi)
 
 -- | Get the indefinite unit identity representing this package.
 -- This IS NOT guaranteed to give you a substitution; for
@@ -93,7 +97,7 @@ sourceComponentName = CLibName . sourceLibName
 
 -- | Return either errors, or IPI with list of warnings
 parseInstalledPackageInfo
-  :: ByteString
+  :: HasCallStack => ByteString
   -> Either (NonEmpty String) ([String], InstalledPackageInfo)
 parseInstalledPackageInfo s = case P.readFields s of
   Left err -> Left (show err :| [])
@@ -117,20 +121,20 @@ parseInstalledPackageInfo s = case P.readFields s of
 -- | Pretty print 'InstalledPackageInfo'.
 --
 -- @pkgRoot@ isn't printed, as ghc-pkg prints it manually (as GHC-8.4).
-showInstalledPackageInfo :: InstalledPackageInfo -> String
+showInstalledPackageInfo :: HasCallStack => InstalledPackageInfo -> String
 showInstalledPackageInfo ipi =
   showFullInstalledPackageInfo ipi{pkgRoot = Nothing}
 
 -- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too.
-showFullInstalledPackageInfo :: InstalledPackageInfo -> String
+showFullInstalledPackageInfo :: HasCallStack => InstalledPackageInfo -> String
 showFullInstalledPackageInfo = P.showFields (const NoComment) . prettyFieldGrammar cabalSpecLatest ipiFieldGrammar
 
 -- |
 --
 -- >>> let ipi = emptyInstalledPackageInfo { maintainer = fromString "Tester" }
 -- >>> fmap ($ ipi) $ showInstalledPackageInfoField "maintainer"
 -- Just "maintainer: Tester"
-showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
+showInstalledPackageInfoField :: HasCallStack => String -> Maybe (InstalledPackageInfo -> String)
 showInstalledPackageInfoField fn =
   fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn)
 

Cabal-syntax/src/Distribution/PackageDescription.hs

@@ -48,6 +48,9 @@ module Distribution.PackageDescription
   , module Distribution.Types.HookedBuildInfo
   , module Distribution.Types.SetupBuildInfo
 
+   -- * Extra sources
+  , module Distribution.Types.ExtraSource
+
     -- * Flags
   , module Distribution.Types.Flag
 
@@ -95,6 +98,7 @@ import Distribution.Types.ComponentName
 import Distribution.Types.CondTree
 import Distribution.Types.Condition
 import Distribution.Types.ConfVar
+import Distribution.Types.ExtraSource
 import Distribution.Types.Dependency
 import Distribution.Types.ExeDependency
 import Distribution.Types.Executable