...
 
Commits (7)
......@@ -22,8 +22,9 @@ fi
curl --silent --show-error \
--request POST \
-F "token=$HEAD_HACKAGE_TRIGGER_TOKEN" \
-F "ref=gitlab-ci-nix" \
-F "ref=master" \
-F "variables[GHC_PIPELINE_ID]=$CI_PIPELINE_ID" \
-F "variables[EXTRA_HC_OPTS]=-dcore-lint" \
https://gitlab.haskell.org/api/v4/projects/$HEAD_HACKAGE_PROJECT_ID/trigger/pipeline \
| tee resp.json
......
......@@ -2198,15 +2198,17 @@ enableCodeGenWhen condition should_modify staticLife dynLife target nodemap =
-- to by the user. But we need them, so we patch their locations in
-- the ModSummary with temporary files.
--
hi_file <-
(hi_file, o_file) <-
-- If ``-fwrite-interface` is specified, then the .o and .hi files
-- are written into `-odir` and `-hidir` respectively. #16670
if gopt Opt_WriteInterface dflags
then return $ ml_hi_file ms_location
else new_temp_file (hiSuf dflags) (dynHiSuf dflags)
o_temp_file <- new_temp_file (objectSuf dflags) (dynObjectSuf dflags)
then return (ml_hi_file ms_location, ml_obj_file ms_location)
else (,) <$> (new_temp_file (hiSuf dflags) (dynHiSuf dflags))
<*> (new_temp_file (objectSuf dflags) (dynObjectSuf dflags))
return $
ms
{ ms_location =
ms_location {ml_hi_file = hi_file, ml_obj_file = o_temp_file}
ms_location {ml_hi_file = hi_file, ml_obj_file = o_file}
, ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target}
}
| otherwise = return ms
......
This diff is collapsed.
......@@ -8,6 +8,7 @@
{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module TcHsType (
-- Type signatures
......@@ -299,7 +300,7 @@ tcTopLHsType hs_sig_type ctxt_kind
tcTopLHsType (XHsImplicitBndrs nec) _ = noExtCon nec
-----------------
tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind]))
tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])
-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause
-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments
-- E.g. class C (a::*) (b::k->k)
......@@ -313,52 +314,37 @@ tcHsDeriv hs_ty
; let (tvs, pred) = splitForAllTys ty
(kind_args, _) = splitFunTys (tcTypeKind pred)
; case getClassPredTys_maybe pred of
Just (cls, tys) -> return (tvs, (cls, tys, kind_args))
Just (cls, tys) -> return (tvs, cls, tys, kind_args)
Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }
-- | Typecheck something within the context of a deriving strategy.
-- This is of particular importance when the deriving strategy is @via@.
-- For instance:
--
-- @
-- deriving via (S a) instance C (T a)
-- @
--
-- We need to typecheck @S a@, and moreover, we need to extend the tyvar
-- environment with @a@ before typechecking @C (T a)@, since @S a@ quantified
-- the type variable @a@.
tcDerivStrategy
:: forall a.
Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy
-> TcM ([TyVar], a) -- ^ The thing to typecheck within the context of the
-- deriving strategy, which might quantify some type
-- variables of its own.
-> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)
-- ^ The typechecked deriving strategy, all quantified tyvars, and
-- the payload of the typechecked thing.
tcDerivStrategy mds thing_inside
= case mds of
-- | Typecheck a deriving strategy. For most deriving strategies, this is a
-- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.
tcDerivStrategy ::
Maybe (LDerivStrategy GhcRn)
-- ^ The deriving strategy
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
-- ^ The typechecked deriving strategy and the tyvars that it binds
-- (if using 'ViaStrategy').
tcDerivStrategy mb_lds
= case mb_lds of
Nothing -> boring_case Nothing
Just ds -> do (ds', tvs, thing) <- tc_deriv_strategy ds
pure (Just ds', tvs, thing)
Just (dL->L loc ds) ->
setSrcSpan loc $ do
(ds', tvs) <- tc_deriv_strategy ds
pure (Just (cL loc ds'), tvs)
where
tc_deriv_strategy :: DerivStrategy GhcRn
-> TcM (DerivStrategy GhcTc, [TyVar], a)
-> TcM (DerivStrategy GhcTc, [TyVar])
tc_deriv_strategy StockStrategy = boring_case StockStrategy
tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy
tc_deriv_strategy NewtypeStrategy = boring_case NewtypeStrategy
tc_deriv_strategy (ViaStrategy ty) = do
ty' <- checkNoErrs $
tcTopLHsType ty AnyKind
ty' <- checkNoErrs $ tcTopLHsType ty AnyKind
let (via_tvs, via_pred) = splitForAllTys ty'
tcExtendTyVarEnv via_tvs $ do
(thing_tvs, thing) <- thing_inside
pure (ViaStrategy via_pred, via_tvs ++ thing_tvs, thing)
boring_case :: mds -> TcM (mds, [TyVar], a)
boring_case mds = do
(thing_tvs, thing) <- thing_inside
pure (mds, thing_tvs, thing)
pure (ViaStrategy via_pred, via_tvs)
boring_case :: ds -> TcM (ds, [TyVar])
boring_case ds = pure (ds, [])
tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt
-> LHsSigType GhcRn
......
......@@ -52,8 +52,17 @@ deleteBys eq xs ys = foldl' (flip (deleteBy eq)) xs ys
-}
-- | Assumes that the arguments contain no duplicates
unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a]
-- Assumes that the arguments contain no duplicates
-- We special case some reasonable common patterns.
unionLists xs [] = xs
unionLists [] ys = ys
unionLists [x] ys
| isIn "unionLists" x ys = ys
| otherwise = x:ys
unionLists xs [y]
| isIn "unionLists" y xs = xs
| otherwise = y:xs
unionLists xs ys
= WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys)
[x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
......@@ -37,6 +39,7 @@ module Data.Fixed
) where
import Data.Data
import GHC.TypeLits (KnownNat, natVal)
import GHC.Read
import Text.ParserCombinators.ReadPrec
import Text.Read.Lex
......@@ -58,7 +61,7 @@ mod' n d = n - (fromInteger f) * d where
f = div' n d
-- | The type parameter should be an instance of 'HasResolution'.
newtype Fixed a = MkFixed Integer
newtype Fixed (a :: k) = MkFixed Integer
deriving ( Eq -- ^ @since 2.01
, Ord -- ^ @since 2.01
)
......@@ -71,17 +74,21 @@ conMkFixed :: Constr
conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
-- | @since 4.1.0.0
instance (Typeable a) => Data (Fixed a) where
instance (Typeable k,Typeable a) => Data (Fixed (a :: k)) where
gfoldl k z (MkFixed a) = k (z MkFixed) a
gunfold k z _ = k (z MkFixed)
dataTypeOf _ = tyFixed
toConstr _ = conMkFixed
class HasResolution a where
class HasResolution (a :: k) where
resolution :: p a -> Integer
withType :: (p a -> f a) -> f a
withType foo = foo undefined
-- | For example, @Fixed 1000@ will give you a 'Fixed' with a resolution of 1000.
instance KnownNat n => HasResolution n where
resolution _ = natVal (Proxy :: Proxy n)
withType :: (Proxy a -> f a) -> f a
withType foo = foo Proxy
withResolution :: (HasResolution a) => (Integer -> f a) -> f a
withResolution foo = withType (foo . resolution)
......@@ -170,7 +177,7 @@ convertFixed :: forall a . HasResolution a => Lexeme -> ReadPrec (Fixed a)
convertFixed (Number n)
| Just (i, f) <- numberToFixed e n =
return (fromInteger i + (fromInteger f / (10 ^ e)))
where r = resolution (undefined :: Fixed a)
where r = resolution (Proxy :: Proxy a)
-- round 'e' up to help make the 'read . show == id' property
-- possible also for cases where 'resolution' is not a
-- power-of-10, such as e.g. when 'resolution = 128'
......
......@@ -21,6 +21,10 @@
The type argument `r` is marked as `Inferred` to prevent it from
interfering with visible type application.
* Make `Fixed` and `HasResolution` poly-kinded.
* Add `HasResolution` instances for `Nat`s.
## 4.13.0.0 *TBA*
* Bundled with GHC *TBA*
......
{-# LANGUAGE DerivingVia #-}
module T16923 where
data Foo deriving () via Maybe Maybe
T16923.hs:4:32: error:
• Expecting one more argument to ‘Maybe’
Expected a type, but ‘Maybe’ has kind ‘* -> *’
• In the first argument of ‘Maybe’, namely ‘Maybe’
In the data declaration for ‘Foo’
......@@ -73,6 +73,7 @@ test('T14728b', normal, compile_fail, [''])
test('T14916', normal, compile_fail, [''])
test('T15073', [extra_files(['T15073a.hs'])], multimod_compile_fail,
['T15073', '-v0'])
test('T16923', normal, compile_fail, [''])
test('deriving-via-fail', normal, compile_fail, [''])
test('deriving-via-fail2', normal, compile_fail, [''])
test('deriving-via-fail3', normal, compile_fail, [''])
......
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
clean:
$(RM) -rf my-odir
T16670_unboxed:
@echo "~~~~~~~~ testing T16670_unboxed"
$(MAKE) -s --no-print-directory clean
mkdir my-odir
echo ":load T16670_unboxed.hs" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) \
-v0 -fwrite-interface -odir my-odir
find . -name T16670_unboxed.o
test -f my-odir/T16670_unboxed.o
T16670_th:
@echo "~~~~~~~~ testing T16670_th"
$(MAKE) -s --no-print-directory clean
mkdir my-odir
echo ":load T16670_th.hs" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) \
-v0 -fno-code -fwrite-interface -odir my-odir
find . -name T16670_th.o
test -f my-odir/T16670_th.o
{-# LANGUAGE TemplateHaskell #-}
module T16670_th where
import TH
x = $(th)
~~~~~~~~ testing T16670_th
./my-odir/T16670_th.o
{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -fwrite-interface #-}
module T16670_unboxed where
data UnboxedTupleData = MkUTD (# (),() #)
doThings :: UnboxedTupleData -> ()
doThings (MkUTD t) = ()
~~~~~~~~ testing T16670_unboxed
./my-odir/T16670_unboxed.o
{-# LANGUAGE TemplateHaskell #-}
module TH where
th = [|909|]
test('T16670_unboxed', [extra_files(['T16670_unboxed.hs']),
req_interp, omit_ways(prof_ways), unless(have_dynamic(), skip)],
makefile_test, ['T16670_unboxed'])
test('T16670_th', [extra_files(['T16670_th.hs', 'TH.hs']),
req_interp, omit_ways(prof_ways), unless(have_dynamic(), skip)],
makefile_test, ['T16670_th'])
-- Regression test for #495
-- inlining an undeclared identifier should give error, not panic...
{-# INLINE blarg #-}
-- even if the identifier is imported in the Prelude...
{-# INLINE lookup #-}
T495.hs:4:12: error:
The INLINE pragma for ‘blarg’ lacks an accompanying binding
T495.hs:7:12: error:
The INLINE pragma for ‘lookup’ lacks an accompanying binding
(The INLINE pragma must be given where ‘lookup’ is declared)
......@@ -60,6 +60,7 @@ test('rnfail056', normal, compile_fail, [''])
test('rnfail057', normal, compile_fail, [''])
test('rn_dup', normal, compile_fail, [''])
test('T495', normal, compile_fail, [''])
test('T2490', normal, compile_fail, [''])
test('T2901', normal, compile_fail, [''])
test('T2723', normal, compile, ['']) # Warnings only
......