diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +2017-05-05 v0.5.3.1 + * Fix bug roundtripping optional semicolons on if statements. 2017-02-07 v0.5.3.0 * Support GHC 8.0.2 * Correct the logic around RigidLayout to function as originally diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,5 +1,5 @@ name: ghc-exactprint -version: 0.5.3.0 +version: 0.5.3.1 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 7.10.2, this library provides a means to round trip any code that can @@ -31,7 +31,7 @@ tests/examples/failing/*.hs tests/examples/ghc710/*.hs tests/examples/ghc710-only/*.hs - tests/examples/ghc8/*.hs + tests/examples/ghc80/*.hs tests/examples/transform/*.hs tests/examples/failing/*.hs.bad tests/examples/transform/*.hs.expected diff --git a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs --- a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs @@ -120,13 +120,14 @@ MarkMany :: GHC.AnnKeywordId -> next -> AnnotationF next MarkManyOptional :: GHC.AnnKeywordId -> next -> AnnotationF next MarkOffsetPrim :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next - MarkOffsetPrimOptional :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next + -- MarkOffsetPrimOptional :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next WithAST :: Data a => GHC.Located a -> Annotated b -> next -> AnnotationF next CountAnns :: GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next WithSortKey :: [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next SetLayoutFlag :: Rigidity -> Annotated () -> next -> AnnotationF next + MarkAnnBeforeAnn :: GHC.AnnKeywordId -> GHC.AnnKeywordId -> next -> AnnotationF next -- Required to work around deficiencies in the GHC AST StoreOriginalSrcSpan :: GHC.SrcSpan -> AnnKey -> (AnnKey -> next) -> AnnotationF next @@ -166,7 +167,7 @@ makeFreeCon 'MarkMany makeFreeCon 'MarkManyOptional makeFreeCon 'MarkOffsetPrim -makeFreeCon 'MarkOffsetPrimOptional +-- makeFreeCon 'MarkOffsetPrimOptional makeFreeCon 'CountAnns makeFreeCon 'StoreOriginalSrcSpan makeFreeCon 'GetSrcSpanForKw @@ -184,6 +185,7 @@ makeFreeCon 'IfInContext makeFreeCon 'WithSortKeyContexts makeFreeCon 'TellContext +makeFreeCon 'MarkAnnBeforeAnn -- --------------------------------------------------------------------- @@ -240,8 +242,8 @@ markOffset :: GHC.AnnKeywordId -> Int -> Annotated () markOffset kwid n = markOffsetPrim kwid n Nothing -markOffsetOptional :: GHC.AnnKeywordId -> Int -> Annotated () -markOffsetOptional kwid n = markOffsetPrimOptional kwid n Nothing +-- markOffsetOptional :: GHC.AnnKeywordId -> Int -> Annotated () +-- markOffsetOptional kwid n = markOffsetPrimOptional kwid n Nothing markTrailingSemi :: Annotated () markTrailingSemi = markOutside GHC.AnnSemi AnnSemiSep @@ -2587,10 +2589,12 @@ -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do mark GHC.AnnIf markLocated e1 - markOffsetOptional GHC.AnnSemi 0 + -- markOffsetOptional GHC.AnnSemi 0 + markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen mark GHC.AnnThen setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 - markOffsetOptional GHC.AnnSemi 1 + -- markOffsetOptional GHC.AnnSemi 1 + markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse mark GHC.AnnElse setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 diff --git a/src/Language/Haskell/GHC/ExactPrint/Delta.hs b/src/Language/Haskell/GHC/ExactPrint/Delta.hs --- a/src/Language/Haskell/GHC/ExactPrint/Delta.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Delta.hs @@ -245,13 +245,14 @@ go (MarkMany akwid next) = addDeltaAnnotations akwid >> next go (MarkManyOptional akwid next) = addDeltaAnnotations akwid >> next go (MarkOffsetPrim akwid n _ next) = addDeltaAnnotationLs akwid n >> next - go (MarkOffsetPrimOptional akwid n _ next) = addDeltaAnnotationLs akwid n >> next + -- go (MarkOffsetPrimOptional akwid n _ next) = addDeltaAnnotationLs akwid n >> next go (WithAST lss prog next) = withAST lss (deltaInterpret prog) >> next go (CountAnns kwid next) = countAnnsDelta kwid >>= next go (SetLayoutFlag r action next) = do rigidity <- asks drRigidity (if r <= rigidity then setLayoutFlag else id) (deltaInterpret action) next + go (MarkAnnBeforeAnn ann1 ann2 next) = deltaMarkAnnBeforeAnn ann1 ann2 >> next go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt ss akwid >> next go (StoreOriginalSrcSpan _ key next) = storeOriginalSrcSpanDelta key >>= next go (GetSrcSpanForKw ss kw next) = getSrcSpanForKw ss kw >>= next @@ -652,6 +653,21 @@ addDeltaComment :: Comment -> DeltaPos -> Delta () addDeltaComment d p = do addAnnDeltaPos (AnnComment d) p + +-- --------------------------------------------------------------------- + +-- |If the first annotation has a smaller SrcSpan than the second, then mark it. +deltaMarkAnnBeforeAnn :: GHC.AnnKeywordId -> GHC.AnnKeywordId -> Delta () +deltaMarkAnnBeforeAnn annBefore annAfter = do + ss <- getSrcSpan + mb <- peekAnnotationDelta annBefore + ma <- peekAnnotationDelta annAfter + let + before = sort $ filter (\s -> GHC.isSubspanOf s ss) mb + after = sort $ filter (\s -> GHC.isSubspanOf s ss) ma + case (before,after) of + (b:_, a:_) -> when (b < a) $ addDeltaAnnotation annBefore + _ -> return () -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs --- a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs @@ -161,7 +161,7 @@ go (MarkMany akwid next) = addPrettyAnnotation (G akwid) >> next go (MarkManyOptional _akwid next) = next go (MarkOffsetPrim akwid n _ next) = addPrettyAnnotationLs akwid n >> next - go (MarkOffsetPrimOptional _akwid _n _ next) = next + -- go (MarkOffsetPrimOptional _akwid _n _ next) = next go (WithAST lss prog next) = withAST lss (prettyInterpret prog) >> next go (CountAnns kwid next) = countAnnsPretty kwid >>= next go (WithSortKey kws next) = withSortKey kws >> next @@ -171,6 +171,7 @@ (if r <= rigidity then setLayoutFlag else id) (prettyInterpret action) next go (StoreOriginalSrcSpan l key next) = storeOriginalSrcSpanPretty l key >>= next + go (MarkAnnBeforeAnn _ann1 _ann2 next) = next go (GetSrcSpanForKw ss kw next) = getSrcSpanForKw ss kw >>= next #if __GLASGOW_HASKELL__ <= 710 go (StoreString s ss next) = storeString s ss >> next diff --git a/src/Language/Haskell/GHC/ExactPrint/Print.hs b/src/Language/Haskell/GHC/ExactPrint/Print.hs --- a/src/Language/Haskell/GHC/ExactPrint/Print.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Print.hs @@ -166,8 +166,8 @@ allAnns akwid >> next go (MarkOffsetPrim kwid _ mstr next) = printStringAtMaybeAnn (G kwid) mstr >> next - go (MarkOffsetPrimOptional kwid _ mstr next) = - printStringAtMaybeAnn (G kwid) mstr >> next + -- go (MarkOffsetPrimOptional kwid _ mstr next) = + -- printStringAtMaybeAnn (G kwid) mstr >> next go (WithAST lss action next) = exactPC lss (printInterpret action) >> next go (CountAnns kwid next) = @@ -176,6 +176,8 @@ rigidity <- asks epRigidity (if r <= rigidity then setLayout else id) (printInterpret action) next + + go (MarkAnnBeforeAnn ann1 ann2 next) = printMarkAnnBeforeAnn (G ann1) (G ann2) >> next go (MarkExternal _ akwid s next) = printStringAtMaybeAnn (G akwid) (Just s) >> next go (StoreOriginalSrcSpan _ _ next) = storeOriginalSrcSpanPrint >>= next @@ -353,6 +355,25 @@ -- |Get the current column offset getLayoutOffset :: (Monad m, Monoid w) => EP w m LayoutStartCol getLayoutOffset = gets epLHS + +-- --------------------------------------------------------------------- + +-- |If the first annotation has a smaller SrcSpan than the second, then mark it. +-- In the printer this means the first appearing before the second in the list +-- of annotations remaining +printMarkAnnBeforeAnn :: (Monad m, Monoid w) => KeywordId -> KeywordId -> EP w m () +printMarkAnnBeforeAnn annBefore annAfter = do + kd <- gets epAnnKds + case kd of + [] -> return () -- Should never be triggered + (k:_kds) -> do + -- find the first ann, then the second. If found in that order, annotate. + let find a = (\(kw,_) -> kw == a) + case break (find annBefore) k of + (_,[]) -> return () -- annBefore not present + (_,rest) -> if null (snd $ break (find annAfter) rest) + then return () + else markPrim annBefore (Nothing) -- --------------------------------------------------------------------- diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -28,12 +28,12 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC710 | GHC8 deriving (Eq, Ord, Show) +data GHCVersion = GHC710 | GHC80 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion ghcVersion = #if __GLASGOW_HASKELL__ >= 711 - GHC8 + GHC80 #else GHC710 #endif @@ -43,7 +43,7 @@ testDirs = case ghcVersion of GHC710 -> ["ghc710-only","ghc710"] - GHC8 -> ["ghc710", "ghc8"] + GHC80 -> ["ghc710", "ghc80"] -- --------------------------------------------------------------------- @@ -148,16 +148,16 @@ tt' :: IO (Counts,Int) tt' = runTestText (putTextToHandle stdout True) $ TestList [ - -- mkParserTest "ghc710" "Unicode.hs" + mkParserTest "ghc80" "SemicolonIf.hs" - -- mkPrettyRoundtrip "ghc8" "StringSource.hs" - -- mkPrettyRoundtrip "ghc8" "records-prov-req.hs" - -- mkPrettyRoundtrip "ghc8" "records-poly-update.hs" - -- mkPrettyRoundtrip "ghc8" "poly-export-fail2.hs" - mkPrettyRoundtrip "ghc8" "pmc007.hs" + -- mkPrettyRoundtrip "ghc80" "StringSource.hs" + -- mkPrettyRoundtrip "ghc80" "records-prov-req.hs" + -- mkPrettyRoundtrip "ghc80" "records-poly-update.hs" + -- mkPrettyRoundtrip "ghc80" "poly-export-fail2.hs" + -- mkPrettyRoundtrip "ghc80" "pmc007.hs" - -- mkParserTest "ghc8" "DatatypeContexts.hs" - -- mkParserTest "ghc8" "Families.hs" + -- mkParserTest "ghc80" "DatatypeContexts.hs" + -- mkParserTest "ghc80" "Families.hs" -- Needs GHC changes -- , mkParserTest "failing" "CtorOp.hs" diff --git a/tests/examples/ghc8/A.hs b/tests/examples/ghc8/A.hs deleted file mode 100644 --- a/tests/examples/ghc8/A.hs +++ /dev/null @@ -1,4 +0,0 @@ -module A where - -class A a where - has :: a diff --git a/tests/examples/ghc8/AddParams2.hs b/tests/examples/ghc8/AddParams2.hs deleted file mode 100644 --- a/tests/examples/ghc8/AddParams2.hs +++ /dev/null @@ -1,9 +0,0 @@ -module AddParams2 where - -collapse rightInner rightOuter = right - where - right = (rightInner, rightOuter) - righ2 = (rightInner, (rightOuter baz bar)) - -baz = undefined -bar = undefined diff --git a/tests/examples/ghc8/Associated.hs b/tests/examples/ghc8/Associated.hs deleted file mode 100644 --- a/tests/examples/ghc8/Associated.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Associated(A(..)) where - -import AssociatedInternal (A(..)) - -foo = MkA 5 -baz = NoA - -qux (MkA x) = x -qux NoA = 0 diff --git a/tests/examples/ghc8/AssociatedInternal.hs b/tests/examples/ghc8/AssociatedInternal.hs deleted file mode 100644 --- a/tests/examples/ghc8/AssociatedInternal.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module AssociatedInternal (A(NewA,MkA, NoA)) where - -newtype A = NewA (Maybe Int) - -pattern MkA n = NewA (Just n) - -pattern NoA = NewA Nothing diff --git a/tests/examples/ghc8/B.hs b/tests/examples/ghc8/B.hs deleted file mode 100644 --- a/tests/examples/ghc8/B.hs +++ /dev/null @@ -1,4 +0,0 @@ -module B where - -class B a where - has :: a diff --git a/tests/examples/ghc8/BadTelescope.hs b/tests/examples/ghc8/BadTelescope.hs deleted file mode 100644 --- a/tests/examples/ghc8/BadTelescope.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module BadTelescope where - -import Data.Kind - -data SameKind :: k -> k -> * - -data X a k (b :: k) (c :: SameKind a b) diff --git a/tests/examples/ghc8/BadTelescope2.hs b/tests/examples/ghc8/BadTelescope2.hs deleted file mode 100644 --- a/tests/examples/ghc8/BadTelescope2.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TypeInType, ExplicitForAll #-} - -module BadTelescope2 where - -import Data.Kind -import Data.Proxy - -data SameKind :: k -> k -> * - -foo :: forall a k (b :: k). SameKind a b -foo = undefined - -bar :: forall a (c :: Proxy b) (d :: Proxy a). Proxy c -> SameKind b d -bar = undefined diff --git a/tests/examples/ghc8/BadTelescope3.hs b/tests/examples/ghc8/BadTelescope3.hs deleted file mode 100644 --- a/tests/examples/ghc8/BadTelescope3.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeInType, ExplicitForAll #-} - -module BadTelescope3 where - -import Data.Kind - -data SameKind :: k -> k -> * - -type S a k (b :: k) = SameKind a b diff --git a/tests/examples/ghc8/BadTelescope4.hs b/tests/examples/ghc8/BadTelescope4.hs deleted file mode 100644 --- a/tests/examples/ghc8/BadTelescope4.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, TypeInType #-} -module BadTelescope4 where - -import Data.Proxy -import Data.Kind - -data SameKind :: k -> k -> * - -data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - -data Borked a (b :: k) = forall (c :: k). B (Proxy c) - -- this last one is OK. But there was a bug involving renaming - -- that failed here, so the test case remains. diff --git a/tests/examples/ghc8/Base.hs b/tests/examples/ghc8/Base.hs deleted file mode 100644 --- a/tests/examples/ghc8/Base.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Base (AClass(..), BClass()) where - -import Extends (BClass ()) - -class AClass a where - has :: a diff --git a/tests/examples/ghc8/Bundle.hs b/tests/examples/ghc8/Bundle.hs deleted file mode 100644 --- a/tests/examples/ghc8/Bundle.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Bundle(A(..)) where - -import BundleInternal (A(..)) - -foo = MkA 5 -baz = NoA - -qux (MkA x) = x -qux NoA = 0 diff --git a/tests/examples/ghc8/Bundle1.hs b/tests/examples/ghc8/Bundle1.hs deleted file mode 100644 --- a/tests/examples/ghc8/Bundle1.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Associated1(A(..)) where - -import BundleInternal1 (A(..)) - -foo = MkA 5 -baz = NoA - -qux (MkA x) = x -qux NoA = 0 diff --git a/tests/examples/ghc8/BundleExport.hs b/tests/examples/ghc8/BundleExport.hs deleted file mode 100644 --- a/tests/examples/ghc8/BundleExport.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module BundleExport(P(.., A), Q(B)) where - -data P = P - -data Q = Q - -pattern A = P -pattern B = Q diff --git a/tests/examples/ghc8/BundleInternal.hs b/tests/examples/ghc8/BundleInternal.hs deleted file mode 100644 --- a/tests/examples/ghc8/BundleInternal.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module BundleInternal (A(NewA,MkA, NoA)) where - -newtype A = NewA (Maybe Int) - -pattern MkA n = NewA (Just n) - -pattern NoA = NewA Nothing diff --git a/tests/examples/ghc8/BundleInternal1.hs b/tests/examples/ghc8/BundleInternal1.hs deleted file mode 100644 --- a/tests/examples/ghc8/BundleInternal1.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module BundleInternal1 (A(NewA,MkA, NoA)) where - -newtype A = NewA (Maybe Int) - -pattern MkA n = NewA (Just n) - -pattern NoA = NewA Nothing diff --git a/tests/examples/ghc8/C.hs b/tests/examples/ghc8/C.hs deleted file mode 100644 --- a/tests/examples/ghc8/C.hs +++ /dev/null @@ -1,3 +0,0 @@ -module C (oops) where - -import {-# SOURCE #-} B diff --git a/tests/examples/ghc8/CheckUtils.hs b/tests/examples/ghc8/CheckUtils.hs deleted file mode 100644 --- a/tests/examples/ghc8/CheckUtils.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - --- This program must be called with GHC's libdir and the file to be checked as --- the command line arguments. -module CheckUtils where - -import Data.Data -import Data.List -import System.IO -import GHC -import BasicTypes -import DynFlags -import MonadUtils -import Outputable -import ApiAnnotation -import Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Dynamic ( fromDynamic,Dynamic ) - -_main::IO() -_main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName - -testOneFile libdir fileName = do - ((anns,cs),p) <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - return (pm_annotations p,p) - - let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p) - - problems = filter (\(s,a) -> not (Set.member s spans)) - $ getAnnSrcSpans (anns,cs) - - exploded = [((kw,ss),[anchor]) - | ((anchor,kw),sss) <- Map.toList anns,ss <- sss] - - exploded' = Map.toList $ Map.fromListWith (++) exploded - - problems' = filter (\(_,anchors) - -> not (any (\a -> Set.member a spans) anchors)) - exploded' - - putStrLn "---Problems---------------------" - putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems]) - putStrLn "---Problems'--------------------" - putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems']) - putStrLn "--------------------------------" - putStrLn (intercalate "\n" [showAnns anns]) - - where - getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))] - getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns - - getAllSrcSpans :: (Data t) => t -> [SrcSpan] - getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast - where - getSrcSpan :: SrcSpan -> [SrcSpan] - getSrcSpan ss = [ss] - - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPpr unsafeGlobalDynFlags a - - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/tests/examples/ghc8/Class.hs b/tests/examples/ghc8/Class.hs deleted file mode 100644 --- a/tests/examples/ghc8/Class.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -module Servant.Auth.Server.Internal.Class where - -import Servant.Auth -import Data.Monoid -import Servant hiding (BasicAuth) - -import Servant.Auth.Server.Internal.Types -import Servant.Auth.Server.Internal.ConfigTypes -import Servant.Auth.Server.Internal.BasicAuth -import Servant.Auth.Server.Internal.Cookie -import Servant.Auth.Server.Internal.JWT - --- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all --- elements of @ctx@ to be the in the Context and whose authentication check --- returns an @AuthCheck v@. -class IsAuth a v where - type family AuthArgs a :: [*] - runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v) - diff --git a/tests/examples/ghc8/ClosedFam1a.hs b/tests/examples/ghc8/ClosedFam1a.hs deleted file mode 100644 --- a/tests/examples/ghc8/ClosedFam1a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module ClosedFam1a where - -import {-# SOURCE #-} ClosedFam1 diff --git a/tests/examples/ghc8/ClosedFam2a.hs b/tests/examples/ghc8/ClosedFam2a.hs deleted file mode 100644 --- a/tests/examples/ghc8/ClosedFam2a.hs +++ /dev/null @@ -1,2 +0,0 @@ -module ClosedFam2a where -import {-# SOURCE #-} ClosedFam2 diff --git a/tests/examples/ghc8/ClosedFam3a.hs b/tests/examples/ghc8/ClosedFam3a.hs deleted file mode 100644 --- a/tests/examples/ghc8/ClosedFam3a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module ClosedFam3a where - -import {-# SOURCE #-} ClosedFam3 diff --git a/tests/examples/ghc8/CmmSwitchTest.hs b/tests/examples/ghc8/CmmSwitchTest.hs deleted file mode 100644 --- a/tests/examples/ghc8/CmmSwitchTest.hs +++ /dev/null @@ -1,505 +0,0 @@ -{-# LANGUAGE MagicHash #-} -import Control.Monad (unless, forM_) -import GHC.Exts -{-# NOINLINE aa #-} -aa :: Int# -> Int# -aa 1# = 42# -aa 2# = 43# -aa 3# = 43# -aa 4# = 44# -aa 5# = 44# -aa 6# = 45# -aa 7# = 45# -aa 8# = 46# -aa 9# = 46# -aa 10# = 47# -aa _ = 1337# - -{-# NOINLINE ab #-} -ab :: Int# -> Int# -ab 0# = 42# -ab 1# = 42# -ab 2# = 43# -ab 3# = 43# -ab 4# = 44# -ab 5# = 44# -ab 6# = 45# -ab 7# = 45# -ab 8# = 46# -ab 9# = 46# -ab 10# = 47# -ab _ = 1337# - -{-# NOINLINE ac #-} -ac :: Int# -> Int# -ac 1# = 42# -ac 2# = 43# -ac 3# = 43# -ac _ = 1337# - -{-# NOINLINE ad #-} -ad :: Int# -> Int# -ad 1# = 42# -ad 2# = 43# -ad 3# = 43# -ad 4# = 44# -ad _ = 1337# - -{-# NOINLINE ae #-} -ae :: Int# -> Int# -ae 1# = 42# -ae 2# = 43# -ae 3# = 43# -ae 4# = 44# -ae 5# = 44# -ae _ = 1337# - -{-# NOINLINE af #-} -af :: Int# -> Int# -af -1# = 41# -af 0# = 42# -af 1# = 42# -af 2# = 43# -af 3# = 43# -af 4# = 44# -af 5# = 44# -af 6# = 45# -af 7# = 45# -af 8# = 46# -af 9# = 46# -af 10# = 47# -af _ = 1337# - -{-# NOINLINE ag #-} -ag :: Int# -> Int# -ag -10# = 37# -ag -9# = 37# -ag -8# = 38# -ag -7# = 38# -ag -6# = 39# -ag -5# = 39# -ag -4# = 40# -ag -3# = 40# -ag -2# = 41# -ag -1# = 41# -ag 0# = 42# -ag 1# = 42# -ag 2# = 43# -ag 3# = 43# -ag 4# = 44# -ag 5# = 44# -ag 6# = 45# -ag 7# = 45# -ag 8# = 46# -ag 9# = 46# -ag 10# = 47# -ag _ = 1337# - -{-# NOINLINE ah #-} -ah :: Int# -> Int# -ah -20# = 32# -ah -19# = 32# -ah -18# = 33# -ah -17# = 33# -ah -16# = 34# -ah -15# = 34# -ah -14# = 35# -ah -13# = 35# -ah -12# = 36# -ah -11# = 36# -ah -10# = 37# -ah 0# = 42# -ah 1# = 42# -ah 2# = 43# -ah 3# = 43# -ah 4# = 44# -ah 5# = 44# -ah 6# = 45# -ah 7# = 45# -ah 8# = 46# -ah 9# = 46# -ah 10# = 47# -ah _ = 1337# - -{-# NOINLINE ai #-} -ai :: Int# -> Int# -ai -20# = 32# -ai -19# = 32# -ai -18# = 33# -ai -17# = 33# -ai -16# = 34# -ai -15# = 34# -ai -14# = 35# -ai -13# = 35# -ai -12# = 36# -ai -11# = 36# -ai -10# = 37# -ai 1# = 42# -ai 2# = 43# -ai 3# = 43# -ai 4# = 44# -ai 5# = 44# -ai 6# = 45# -ai 7# = 45# -ai 8# = 46# -ai 9# = 46# -ai 10# = 47# -ai _ = 1337# - -{-# NOINLINE aj #-} -aj :: Int# -> Int# -aj -9223372036854775808# = -4611686018427387862# -aj 0# = 42# -aj 9223372036854775807# = 4611686018427387945# -aj _ = 1337# - -{-# NOINLINE ak #-} -ak :: Int# -> Int# -ak 9223372036854775797# = 4611686018427387940# -ak 9223372036854775798# = 4611686018427387941# -ak 9223372036854775799# = 4611686018427387941# -ak 9223372036854775800# = 4611686018427387942# -ak 9223372036854775801# = 4611686018427387942# -ak 9223372036854775802# = 4611686018427387943# -ak 9223372036854775803# = 4611686018427387943# -ak 9223372036854775804# = 4611686018427387944# -ak 9223372036854775805# = 4611686018427387944# -ak 9223372036854775806# = 4611686018427387945# -ak 9223372036854775807# = 4611686018427387945# -ak _ = 1337# - -{-# NOINLINE al #-} -al :: Int# -> Int# -al -9223372036854775808# = -4611686018427387862# -al -9223372036854775807# = -4611686018427387862# -al -9223372036854775806# = -4611686018427387861# -al -9223372036854775805# = -4611686018427387861# -al -9223372036854775804# = -4611686018427387860# -al -9223372036854775803# = -4611686018427387860# -al -9223372036854775802# = -4611686018427387859# -al -9223372036854775801# = -4611686018427387859# -al -9223372036854775800# = -4611686018427387858# -al -9223372036854775799# = -4611686018427387858# -al -9223372036854775798# = -4611686018427387857# -al 9223372036854775797# = 4611686018427387940# -al 9223372036854775798# = 4611686018427387941# -al 9223372036854775799# = 4611686018427387941# -al 9223372036854775800# = 4611686018427387942# -al 9223372036854775801# = 4611686018427387942# -al 9223372036854775802# = 4611686018427387943# -al 9223372036854775803# = 4611686018427387943# -al 9223372036854775804# = 4611686018427387944# -al 9223372036854775805# = 4611686018427387944# -al 9223372036854775806# = 4611686018427387945# -al 9223372036854775807# = 4611686018427387945# -al _ = 1337# - -{-# NOINLINE am #-} -am :: Word# -> Word# -am 0## = 42## -am 1## = 42## -am 2## = 43## -am 3## = 43## -am 4## = 44## -am 5## = 44## -am 6## = 45## -am 7## = 45## -am 8## = 46## -am 9## = 46## -am 10## = 47## -am _ = 1337## - -{-# NOINLINE an #-} -an :: Word# -> Word# -an 1## = 42## -an 2## = 43## -an 3## = 43## -an 4## = 44## -an 5## = 44## -an 6## = 45## -an 7## = 45## -an 8## = 46## -an 9## = 46## -an 10## = 47## -an _ = 1337## - -{-# NOINLINE ao #-} -ao :: Word# -> Word# -ao 0## = 42## -ao _ = 1337## - -{-# NOINLINE ap #-} -ap :: Word# -> Word# -ap 0## = 42## -ap 1## = 42## -ap _ = 1337## - -{-# NOINLINE aq #-} -aq :: Word# -> Word# -aq 0## = 42## -aq 1## = 42## -aq 2## = 43## -aq _ = 1337## - -{-# NOINLINE ar #-} -ar :: Word# -> Word# -ar 0## = 42## -ar 1## = 42## -ar 2## = 43## -ar 3## = 43## -ar _ = 1337## - -{-# NOINLINE as #-} -as :: Word# -> Word# -as 0## = 42## -as 1## = 42## -as 2## = 43## -as 3## = 43## -as 4## = 44## -as _ = 1337## - -{-# NOINLINE at #-} -at :: Word# -> Word# -at 1## = 42## -at _ = 1337## - -{-# NOINLINE au #-} -au :: Word# -> Word# -au 1## = 42## -au 2## = 43## -au _ = 1337## - -{-# NOINLINE av #-} -av :: Word# -> Word# -av 1## = 42## -av 2## = 43## -av 3## = 43## -av _ = 1337## - -{-# NOINLINE aw #-} -aw :: Word# -> Word# -aw 1## = 42## -aw 2## = 43## -aw 3## = 43## -aw 4## = 44## -aw _ = 1337## - -{-# NOINLINE ax #-} -ax :: Word# -> Word# -ax 1## = 42## -ax 2## = 43## -ax 3## = 43## -ax 4## = 44## -ax 5## = 44## -ax _ = 1337## - -{-# NOINLINE ay #-} -ay :: Word# -> Word# -ay 0## = 42## -ay 18446744073709551615## = 9223372036854775849## -ay _ = 1337## - -{-# NOINLINE az #-} -az :: Word# -> Word# -az 18446744073709551605## = 9223372036854775844## -az 18446744073709551606## = 9223372036854775845## -az 18446744073709551607## = 9223372036854775845## -az 18446744073709551608## = 9223372036854775846## -az 18446744073709551609## = 9223372036854775846## -az 18446744073709551610## = 9223372036854775847## -az 18446744073709551611## = 9223372036854775847## -az 18446744073709551612## = 9223372036854775848## -az 18446744073709551613## = 9223372036854775848## -az 18446744073709551614## = 9223372036854775849## -az 18446744073709551615## = 9223372036854775849## -az _ = 1337## - -{-# NOINLINE ba #-} -ba :: Word# -> Word# -ba 0## = 42## -ba 1## = 42## -ba 2## = 43## -ba 3## = 43## -ba 4## = 44## -ba 5## = 44## -ba 6## = 45## -ba 7## = 45## -ba 8## = 46## -ba 9## = 46## -ba 10## = 47## -ba 18446744073709551605## = 9223372036854775844## -ba 18446744073709551606## = 9223372036854775845## -ba 18446744073709551607## = 9223372036854775845## -ba 18446744073709551608## = 9223372036854775846## -ba 18446744073709551609## = 9223372036854775846## -ba 18446744073709551610## = 9223372036854775847## -ba 18446744073709551611## = 9223372036854775847## -ba 18446744073709551612## = 9223372036854775848## -ba 18446744073709551613## = 9223372036854775848## -ba 18446744073709551614## = 9223372036854775849## -ba 18446744073709551615## = 9223372036854775849## -ba _ = 1337## - -aa_check :: IO () -aa_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (aa i) - unless (r == o) $ putStrLn $ "ERR: aa (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ab_check :: IO () -ab_check = forM_ [(-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (ab i) - unless (r == o) $ putStrLn $ "ERR: ab (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ac_check :: IO () -ac_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(I# i,o) -> do - let r = I# (ac i) - unless (r == o) $ putStrLn $ "ERR: ac (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ad_check :: IO () -ad_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(I# i,o) -> do - let r = I# (ad i) - unless (r == o) $ putStrLn $ "ERR: ad (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ae_check :: IO () -ae_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(I# i,o) -> do - let r = I# (ae i) - unless (r == o) $ putStrLn $ "ERR: ae (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -af_check :: IO () -af_check = forM_ [(-2,1337), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (af i) - unless (r == o) $ putStrLn $ "ERR: af (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ag_check :: IO () -ag_check = forM_ [(-11,1337), (-10,37), (-9,37), (-8,38), (-7,38), (-6,39), (-5,39), (-4,40), (-3,40), (-2,41), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (ag i) - unless (r == o) $ putStrLn $ "ERR: ag (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ah_check :: IO () -ah_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (ah i) - unless (r == o) $ putStrLn $ "ERR: ah (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ai_check :: IO () -ai_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (ai i) - unless (r == o) $ putStrLn $ "ERR: ai (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -aj_check :: IO () -aj_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,1337), (-1,1337), (0,42), (1,1337), (9223372036854775806,1337), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do - let r = I# (aj i) - unless (r == o) $ putStrLn $ "ERR: aj (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ak_check :: IO () -ak_check = forM_ [(9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do - let r = I# (ak i) - unless (r == o) $ putStrLn $ "ERR: ak (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -al_check :: IO () -al_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,-4611686018427387862), (-9223372036854775806,-4611686018427387861), (-9223372036854775805,-4611686018427387861), (-9223372036854775804,-4611686018427387860), (-9223372036854775803,-4611686018427387860), (-9223372036854775802,-4611686018427387859), (-9223372036854775801,-4611686018427387859), (-9223372036854775800,-4611686018427387858), (-9223372036854775799,-4611686018427387858), (-9223372036854775798,-4611686018427387857), (-9223372036854775797,1337), (9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do - let r = I# (al i) - unless (r == o) $ putStrLn $ "ERR: al (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -am_check :: IO () -am_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do - let r = W# (am i) - unless (r == o) $ putStrLn $ "ERR: am (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -an_check :: IO () -an_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do - let r = W# (an i) - unless (r == o) $ putStrLn $ "ERR: an (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ao_check :: IO () -ao_check = forM_ [(0,42), (1,1337)] $ \(W# i,o) -> do - let r = W# (ao i) - unless (r == o) $ putStrLn $ "ERR: ao (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ap_check :: IO () -ap_check = forM_ [(0,42), (1,42), (2,1337)] $ \(W# i,o) -> do - let r = W# (ap i) - unless (r == o) $ putStrLn $ "ERR: ap (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -aq_check :: IO () -aq_check = forM_ [(0,42), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do - let r = W# (aq i) - unless (r == o) $ putStrLn $ "ERR: aq (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ar_check :: IO () -ar_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do - let r = W# (ar i) - unless (r == o) $ putStrLn $ "ERR: ar (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -as_check :: IO () -as_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do - let r = W# (as i) - unless (r == o) $ putStrLn $ "ERR: as (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -at_check :: IO () -at_check = forM_ [(0,1337), (1,42), (2,1337)] $ \(W# i,o) -> do - let r = W# (at i) - unless (r == o) $ putStrLn $ "ERR: at (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -au_check :: IO () -au_check = forM_ [(0,1337), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do - let r = W# (au i) - unless (r == o) $ putStrLn $ "ERR: au (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -av_check :: IO () -av_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do - let r = W# (av i) - unless (r == o) $ putStrLn $ "ERR: av (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -aw_check :: IO () -aw_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do - let r = W# (aw i) - unless (r == o) $ putStrLn $ "ERR: aw (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ax_check :: IO () -ax_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(W# i,o) -> do - let r = W# (ax i) - unless (r == o) $ putStrLn $ "ERR: ax (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ay_check :: IO () -ay_check = forM_ [(0,42), (1,1337), (18446744073709551614,1337), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do - let r = W# (ay i) - unless (r == o) $ putStrLn $ "ERR: ay (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -az_check :: IO () -az_check = forM_ [(18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do - let r = W# (az i) - unless (r == o) $ putStrLn $ "ERR: az (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ba_check :: IO () -ba_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337), (18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do - let r = W# (ba i) - unless (r == o) $ putStrLn $ "ERR: ba (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -main = do - aa_check - ab_check - ac_check - ad_check - ae_check - af_check - ag_check - ah_check - ai_check - aj_check - ak_check - al_check - am_check - an_check - ao_check - ap_check - aq_check - ar_check - as_check - at_check - au_check - av_check - aw_check - ax_check - ay_check - az_check - ba_check diff --git a/tests/examples/ghc8/CmmSwitchTestGen.hs b/tests/examples/ghc8/CmmSwitchTestGen.hs deleted file mode 100644 --- a/tests/examples/ghc8/CmmSwitchTestGen.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE TupleSections #-} - --- Generates CmmSwitch.hs - -import qualified Data.Set as S -import Data.Word -import Data.List - -output :: Integer -> Integer -output n = n`div`2 + 42 - -def :: Integer -def = 1337 - -type Spec = (String, Bool, [Integer]) - -primtyp True = "Int#" -primtyp False = "Word#" - -con True = "I#" -con False = "W#" - -hash True = "#" -hash False = "##" - -primLit s v = show v ++ hash s - -genSwitch :: Spec -> String -genSwitch (name, signed, values) = unlines $ - [ "{-# NOINLINE " ++ name ++ " #-}" ] ++ - [ name ++ " :: " ++ primtyp signed ++ " -> " ++ primtyp signed ] ++ - [ name ++ " " ++ primLit signed v ++ " = " ++ primLit signed (output v) - | v <- values] ++ - [ name ++ " _ = " ++ primLit signed def ] - -genCheck :: Spec -> String -genCheck (name, signed, values) = unlines $ - [ checkName name ++ " :: IO ()" - , checkName name ++ " = forM_ [" ++ pairs ++ "] $ \\(" ++ con signed ++ " i,o) -> do" - , " let r = " ++ con signed ++ " (" ++ name ++ " i)" - , " unless (r == o) $ putStrLn $ \"ERR: " ++ name ++ " (\" ++ show (" ++ con signed ++ " i)++ \") is \" ++ show r ++ \" and not \" ++ show o ++\".\"" - ] - where - f x | x `S.member` range = output x - | otherwise = def - range = S.fromList values - checkValues = S.toList $ S.fromList $ - [ v' | v <- values, v' <- [v-1,v,v+1], - if signed then v' >= minS && v' <= maxS else v' >= minU && v' <= maxU ] - pairs = intercalate ", " ["(" ++ show v ++ "," ++ show (f v) ++ ")" | v <- checkValues ] - -checkName :: String -> String -checkName f = f ++ "_check" - -genMain :: [Spec] -> String -genMain specs = unlines $ "main = do" : [ " " ++ checkName n | (n,_,_) <- specs ] - -genMod :: [Spec] -> String -genMod specs = unlines $ - "-- This file is generated from CmmSwitchGen!" : - "{-# LANGUAGE MagicHash, NegativeLiterals #-}" : - "import Control.Monad (unless, forM_)" : - "import GHC.Exts" : - map genSwitch specs ++ - map genCheck specs ++ - [ genMain specs ] - -main = putStrLn $ - genMod $ zipWith (\n (s,v) -> (n,s,v)) names $ signedChecks ++ unsignedChecks - - -signedChecks :: [(Bool, [Integer])] -signedChecks = map (True,) - [ [1..10] - , [0..10] - , [1..3] - , [1..4] - , [1..5] - , [-1..10] - , [-10..10] - , [-20.. -10]++[0..10] - , [-20.. -10]++[1..10] - , [minS,0,maxS] - , [maxS-10 .. maxS] - , [minS..minS+10]++[maxS-10 .. maxS] - ] - -minU, maxU, minS, maxS :: Integer -minU = 0 -maxU = fromIntegral (maxBound :: Word) -minS = fromIntegral (minBound :: Int) -maxS = fromIntegral (maxBound :: Int) - - -unsignedChecks :: [(Bool, [Integer])] -unsignedChecks = map (False,) - [ [0..10] - , [1..10] - , [0] - , [0..1] - , [0..2] - , [0..3] - , [0..4] - , [1] - , [1..2] - , [1..3] - , [1..4] - , [1..5] - , [minU,maxU] - , [maxU-10 .. maxU] - , [minU..minU+10]++[maxU-10 .. maxU] - ] - -names :: [String] -names = [ c1:c2:[] | c1 <- ['a'..'z'], c2 <- ['a'..'z']] diff --git a/tests/examples/ghc8/Collapse1.hs b/tests/examples/ghc8/Collapse1.hs deleted file mode 100644 --- a/tests/examples/ghc8/Collapse1.hs +++ /dev/null @@ -1,16 +0,0 @@ -module LiftToTop3evel.Collapse1 where - -collapse' _ _ [] = [] -collapse' left space (t:ts) = new : collapse' right space rest - where - (_, leftInner) = left - rightInner = leftInner + symbolSize t - right = (rightInner, (rightOuter rightInner rights)) - (rights, rest) = span space ts - new = (t, Bounds left right) - -rightOuter rightInner rights = rightInner + symbolSize rights - -data Bounds = Bounds (Int,Int) (Int,Int) -symbolSize t = 4 - diff --git a/tests/examples/ghc8/Compare.hs b/tests/examples/ghc8/Compare.hs deleted file mode 100644 --- a/tests/examples/ghc8/Compare.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE Trustworthy, - TypeOperators, - PolyKinds, DataKinds, - TypeFamilies, - UndecidableInstances #-} - - -module Type.Compare where - -import Data.Ord -import GHC.TypeLits - -type family (a :: Ordering) $$ (b :: Ordering) :: Ordering where - LT $$ b = LT - GT $$ b = GT - EQ $$ b = b -infixl 0 $$ - --- | Compare two types of any (possibly different) kinds. --- Since `Compare` itself is a closed type family, add instances to `CompareUser` if you want to compare other types. -type family Compare (a :: k) (b :: k') :: Ordering where - - Compare '() '() = EQ diff --git a/tests/examples/ghc8/CustomTypeErrors01.hs b/tests/examples/ghc8/CustomTypeErrors01.hs deleted file mode 100644 --- a/tests/examples/ghc8/CustomTypeErrors01.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DataKinds, UndecidableInstances #-} -module T1 where -import GHC.TypeLits - - -data MyType = MyType - -instance - TypeError (Text "Values of type 'MyType' cannot be compared for equality.") - => Eq MyType where (==) = undefined - -err x = x == MyType - - diff --git a/tests/examples/ghc8/CustomTypeErrors02.hs b/tests/examples/ghc8/CustomTypeErrors02.hs deleted file mode 100644 --- a/tests/examples/ghc8/CustomTypeErrors02.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DataKinds, UndecidableInstances #-} -{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts #-} -module T2 where - -import GHC.TypeLits - -type family IntRep a where - IntRep Int = Integer - IntRep Integer = Integer - IntRep Bool = Integer - IntRep a = TypeError (Text "The type '" :<>: ShowType a :<>: - Text "' cannot be represented as an integer.") - -convert :: Num (IntRep a) => a -> IntRep a -convert _ = 5 - -err = convert id - - diff --git a/tests/examples/ghc8/CustomTypeErrors03.hs b/tests/examples/ghc8/CustomTypeErrors03.hs deleted file mode 100644 --- a/tests/examples/ghc8/CustomTypeErrors03.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module T3 where - -import GHC.TypeLits - -f :: TypeError (Text "This is a type error") -f = undefined diff --git a/tests/examples/ghc8/D.hs b/tests/examples/ghc8/D.hs deleted file mode 100644 --- a/tests/examples/ghc8/D.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module D where - -import A -import C - -type instance F a b = a - -unsafeCoerce :: a -> b -unsafeCoerce x = oops x x diff --git a/tests/examples/ghc8/DataFamilyInstanceLHS.hs b/tests/examples/ghc8/DataFamilyInstanceLHS.hs deleted file mode 100644 --- a/tests/examples/ghc8/DataFamilyInstanceLHS.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds #-} -module DataFamilyInstanceLHS where --- Test case from #10586 -data MyKind = A | B - -data family Sing (a :: k) - -data instance Sing (_ :: MyKind) where - SingA :: Sing A - SingB :: Sing B - -foo :: Sing A -foo = SingA diff --git a/tests/examples/ghc8/DatatypeContexts.hs b/tests/examples/ghc8/DatatypeContexts.hs deleted file mode 100644 --- a/tests/examples/ghc8/DatatypeContexts.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DatatypeContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} --- I don't know how to silence the -XDatatypeContexts warnings otherwise... -{-# OPTIONS_GHC -w #-} - -{-| -Module: Derived.DatatypeContexts -Copyright: (C) 2014-2016 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Stability: Provisional -Portability: GHC - -Defines data types with DatatypeContexts (which are gross, but still possible). --} -module Derived.DatatypeContexts where - - -data family TyFamily x y z :: * - -data instance Ord a => TyFamily a b c = TyFamily a b c - deriving Show - diff --git a/tests/examples/ghc8/Decision.hs b/tests/examples/ghc8/Decision.hs deleted file mode 100644 --- a/tests/examples/ghc8/Decision.hs +++ /dev/null @@ -1,726 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} - -module Airship.Internal.Decision - ( flow - , appendRequestPath - ) where - -import Airship.Internal.Date (parseRfc1123Date, utcTimeToRfc1123) -import Airship.Headers (addResponseHeader) -import Airship.Types ( Response(..) - , ResponseBody(..) - , Webmachine - , etagToByteString - , getResponseBody - , getResponseHeaders - , halt - , pathInfo - , putResponseBody - , request - , requestHeaders - , requestMethod - , requestTime ) - -import Airship.Resource(Resource(..), PostResponse(..)) -import Airship.Internal.Parsers (parseEtagList) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>)) -#endif -import Control.Monad (when) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.State.Strict (StateT(..), evalStateT, - get, modify) -import Control.Monad.Writer.Class (tell) - -import Blaze.ByteString.Builder (toByteString) -import Data.Maybe (isJust) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import Data.ByteString (ByteString, intercalate) - -import Network.HTTP.Media -import qualified Network.HTTP.Types as HTTP - ------------------------------------------------------------------------------- --- HTTP Headers --- These are headers not defined for us already in --- Network.HTTP.Types ------------------------------------------------------------------------------- --- TODO this exist in http-types-0.9, see CHANGES.txt -hAcceptCharset :: HTTP.HeaderName -hAcceptCharset = "Accept-Charset" - -hAcceptEncoding :: HTTP.HeaderName -hAcceptEncoding = "Accept-Encoding" - -hIfMatch :: HTTP.HeaderName -hIfMatch = "If-Match" - -hIfUnmodifiedSince :: HTTP.HeaderName -hIfUnmodifiedSince = "If-Unmodified-Since" - -hIfNoneMatch :: HTTP.HeaderName -hIfNoneMatch = "If-None-Match" - ------------------------------------------------------------------------------- --- FlowState: StateT used for recording information as we walk the decision --- tree ------------------------------------------------------------------------------- - -data FlowState m = FlowState - { _contentType :: Maybe (MediaType, Webmachine m ResponseBody) } - -type FlowStateT m a = StateT (FlowState m) (Webmachine m) a - -type Flow m = Resource m -> FlowStateT m Response - -initFlowState :: FlowState m -initFlowState = FlowState Nothing - -flow :: Monad m => Resource m -> Webmachine m Response -flow r = evalStateT (b13 r) initFlowState - -trace :: Monad m => Text -> FlowStateT m () -trace t = lift $ tell [t] - ------------------------------------------------------------------------------ --- Header value data newtypes ------------------------------------------------------------------------------- - -newtype IfMatch = IfMatch ByteString -newtype IfNoneMatch = IfNoneMatch ByteString - ------------------------------------------------------------------------------- --- Decision Helpers ------------------------------------------------------------------------------- - -negotiateContentTypesAccepted :: Monad m => Resource m -> FlowStateT m () -negotiateContentTypesAccepted Resource{..} = do - req <- lift request - accepted <- lift contentTypesAccepted - let reqHeaders = requestHeaders req - result = do - cType <- lookup HTTP.hContentType reqHeaders - mapContentMedia accepted cType - case result of - (Just process) -> lift process - Nothing -> lift $ halt HTTP.status415 - -appendRequestPath :: Monad m => [Text] -> Webmachine m ByteString -appendRequestPath ts = do - currentPath <- pathInfo <$> request - return $ toByteString (HTTP.encodePathSegments (currentPath ++ ts)) - -requestHeaderDate :: Monad m => HTTP.HeaderName -> - Webmachine m (Maybe UTCTime) -requestHeaderDate headerName = do - req <- request - let reqHeaders = requestHeaders req - dateHeader = lookup headerName reqHeaders - parsedDate = dateHeader >>= parseRfc1123Date - return parsedDate - -writeCacheTags :: Monad m => Resource m -> FlowStateT m () -writeCacheTags Resource{..} = lift $ do - etag <- generateETag - case etag of - Nothing -> return () - Just t -> addResponseHeader ("ETag", etagToByteString t) - modified <- lastModified - case modified of - Nothing -> return () - Just d -> addResponseHeader ("Last-Modified", utcTimeToRfc1123 d) - ------------------------------------------------------------------------------- --- Type definitions for all decision nodes ------------------------------------------------------------------------------- - -b13, b12, b11, b10, b09, b08, b07, b06, b05, b04, b03 :: Monad m => Flow m -c04, c03 :: Monad m => Flow m -d05, d04 :: Monad m => Flow m -e06, e05 :: Monad m => Flow m -f07, f06 :: Monad m => Flow m -g11, g09 :: Monad m => IfMatch -> Flow m -g08, g07 :: Monad m => Flow m -h12, h11, h10, h07 :: Monad m => Flow m -i13 :: Monad m => IfNoneMatch -> Flow m -i12, i07, i04 :: Monad m => Flow m -j18 :: Monad m => Flow m -k13 :: Monad m => IfNoneMatch -> Flow m -k07, k05 :: Monad m => Flow m -l17, l15, l14, l13, l07, l05 :: Monad m => Flow m -m20, m16, m07, m05 :: Monad m => Flow m -n16, n11, n05 :: Monad m => Flow m -o20, o18, o16, o14 :: Monad m => Flow m -p11, p03 :: Monad m => Flow m - ------------------------------------------------------------------------------- --- B column ------------------------------------------------------------------------------- - -b13 r@Resource{..} = do - trace "b13" - available <- lift serviceAvailable - if available - then b12 r - else lift $ halt HTTP.status503 - -b12 r@Resource{..} = do - trace "b12" - -- known method - req <- lift request - let knownMethods = [ HTTP.methodGet - , HTTP.methodPost - , HTTP.methodHead - , HTTP.methodPut - , HTTP.methodDelete - , HTTP.methodTrace - , HTTP.methodConnect - , HTTP.methodOptions - , HTTP.methodPatch - ] - if requestMethod req `elem` knownMethods - then b11 r - else lift $ halt HTTP.status501 - -b11 r@Resource{..} = do - trace "b11" - long <- lift uriTooLong - if long - then lift $ halt HTTP.status414 - else b10 r - -b10 r@Resource{..} = do - trace "b10" - req <- lift request - allowed <- lift allowedMethods - if requestMethod req `elem` allowed - then b09 r - else do - lift $ addResponseHeader ("Allow", intercalate "," allowed) - lift $ halt HTTP.status405 - -b09 r@Resource{..} = do - trace "b09" - malformed <- lift malformedRequest - if malformed - then lift $ halt HTTP.status400 - else b08 r - -b08 r@Resource{..} = do - trace "b08" - authorized <- lift isAuthorized - if authorized - then b07 r - else lift $ halt HTTP.status401 - -b07 r@Resource{..} = do - trace "b07" - forbid <- lift forbidden - if forbid - then lift $ halt HTTP.status403 - else b06 r - -b06 r@Resource{..} = do - trace "b06" - validC <- lift validContentHeaders - if validC - then b05 r - else lift $ halt HTTP.status501 - -b05 r@Resource{..} = do - trace "b05" - known <- lift knownContentType - if known - then b04 r - else lift $ halt HTTP.status415 - -b04 r@Resource{..} = do - trace "b04" - large <- lift entityTooLarge - if large - then lift $ halt HTTP.status413 - else b03 r - -b03 r@Resource{..} = do - trace "b03" - req <- lift request - allowed <- lift allowedMethods - if requestMethod req == HTTP.methodOptions - then do - lift $ addResponseHeader ("Allow", intercalate "," allowed) - lift $ halt HTTP.status204 - else c03 r - ------------------------------------------------------------------------------- --- C column ------------------------------------------------------------------------------- - -c04 r@Resource{..} = do - trace "c04" - req <- lift request - provided <- lift contentTypesProvided - let reqHeaders = requestHeaders req - result = do - acceptStr <- lookup HTTP.hAccept reqHeaders - (acceptTyp, resource) <- mapAcceptMedia provided' acceptStr - Just (acceptTyp, resource) - where - -- this is so that in addition to getting back the resource - -- that we match, we also return the content-type provided - -- by that resource. - provided' = map dupContentType provided - dupContentType (a, b) = (a, (a, b)) - - case result of - Nothing -> lift $ halt HTTP.status406 - Just res -> do - modify (\fs -> fs { _contentType = Just res }) - d04 r - -c03 r@Resource{..} = do - trace "c03" - req <- lift request - let reqHeaders = requestHeaders req - case lookup HTTP.hAccept reqHeaders of - (Just _h) -> - c04 r - Nothing -> - d04 r - ------------------------------------------------------------------------------- --- D column ------------------------------------------------------------------------------- - -d05 r@Resource{..} = do - trace "d05" - langAvailable <- lift languageAvailable - if langAvailable - then e05 r - else lift $ halt HTTP.status406 - -d04 r@Resource{..} = do - trace "d04" - req <- lift request - let reqHeaders = requestHeaders req - case lookup HTTP.hAcceptLanguage reqHeaders of - (Just _h) -> - d05 r - Nothing -> - e05 r - ------------------------------------------------------------------------------- --- E column ------------------------------------------------------------------------------- - -e06 r@Resource{..} = do - trace "e06" - -- TODO: charset negotiation - f06 r - -e05 r@Resource{..} = do - trace "e05" - req <- lift request - let reqHeaders = requestHeaders req - case lookup hAcceptCharset reqHeaders of - (Just _h) -> - e06 r - Nothing -> - f06 r - ------------------------------------------------------------------------------- --- F column ------------------------------------------------------------------------------- - -f07 r@Resource{..} = do - trace "f07" - -- TODO: encoding negotiation - g07 r - -f06 r@Resource{..} = do - trace "f06" - req <- lift request - let reqHeaders = requestHeaders req - case lookup hAcceptEncoding reqHeaders of - (Just _h) -> - f07 r - Nothing -> - g07 r - ------------------------------------------------------------------------------- --- G column ------------------------------------------------------------------------------- - -g11 (IfMatch ifMatch) r@Resource{..} = do - trace "g11" - let etags = parseEtagList ifMatch - if null etags - then lift $ halt HTTP.status412 - else h10 r - -g09 ifMatch r@Resource{..} = do - trace "g09" - case ifMatch of - -- TODO: should we be stripping whitespace here? - (IfMatch "*") -> - h10 r - _ -> - g11 ifMatch r - -g08 r@Resource{..} = do - trace "g08" - req <- lift request - let reqHeaders = requestHeaders req - case IfMatch <$> lookup hIfMatch reqHeaders of - (Just h) -> - g09 h r - Nothing -> - h10 r - -g07 r@Resource{..} = do - trace "g07" - -- TODO: set Vary headers - exists <- lift resourceExists - if exists - then g08 r - else h07 r - ------------------------------------------------------------------------------- --- H column ------------------------------------------------------------------------------- - -h12 r@Resource{..} = do - trace "h12" - modified <- lift lastModified - parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince - let maybeGreater = do - lastM <- modified - headerDate <- parsedDate - return (lastM > headerDate) - if maybeGreater == Just True - then lift $ halt HTTP.status412 - else i12 r - -h11 r@Resource{..} = do - trace "h11" - parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince - if isJust parsedDate - then h12 r - else i12 r - -h10 r@Resource{..} = do - trace "h10" - req <- lift request - let reqHeaders = requestHeaders req - case lookup hIfUnmodifiedSince reqHeaders of - (Just _h) -> - h11 r - Nothing -> - i12 r - -h07 r@Resource {..} = do - trace "h07" - req <- lift request - let reqHeaders = requestHeaders req - case lookup hIfMatch reqHeaders of - -- TODO: should we be stripping whitespace here? - (Just "*") -> - lift $ halt HTTP.status412 - _ -> - i07 r - ------------------------------------------------------------------------------- --- I column ------------------------------------------------------------------------------- - -i13 ifNoneMatch r@Resource{..} = do - trace "i13" - case ifNoneMatch of - -- TODO: should we be stripping whitespace here? - (IfNoneMatch "*") -> - j18 r - _ -> - k13 ifNoneMatch r - -i12 r@Resource{..} = do - trace "i12" - req <- lift request - let reqHeaders = requestHeaders req - case IfNoneMatch <$> lookup hIfNoneMatch reqHeaders of - (Just h) -> - i13 h r - Nothing -> - l13 r - -i07 r = do - trace "i07" - req <- lift request - if requestMethod req == HTTP.methodPut - then i04 r - else k07 r - -i04 r@Resource{..} = do - trace "i04" - moved <- lift movedPermanently - case moved of - (Just loc) -> do - lift $ addResponseHeader ("Location", loc) - lift $ halt HTTP.status301 - Nothing -> - p03 r - ------------------------------------------------------------------------------- --- J column ------------------------------------------------------------------------------- - -j18 _ = do - trace "j18" - req <- lift request - let getOrHead = [ HTTP.methodGet - , HTTP.methodHead - ] - if requestMethod req `elem` getOrHead - then lift $ halt HTTP.status304 - else lift $ halt HTTP.status412 - ------------------------------------------------------------------------------- --- K column ------------------------------------------------------------------------------- - -k13 (IfNoneMatch ifNoneMatch) r@Resource{..} = do - trace "k13" - let etags = parseEtagList ifNoneMatch - if null etags - then l13 r - else j18 r - -k07 r@Resource{..} = do - trace "k07" - prevExisted <- lift previouslyExisted - if prevExisted - then k05 r - else l07 r - -k05 r@Resource{..} = do - trace "k05" - moved <- lift movedPermanently - case moved of - (Just loc) -> do - lift $ addResponseHeader ("Location", loc) - lift $ halt HTTP.status301 - Nothing -> - l05 r - ------------------------------------------------------------------------------- --- L column ------------------------------------------------------------------------------- - -l17 r@Resource{..} = do - trace "l17" - parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince - modified <- lift lastModified - let maybeGreater = do - lastM <- modified - ifModifiedSince <- parsedDate - return (lastM > ifModifiedSince) - if maybeGreater == Just True - then m16 r - else lift $ halt HTTP.status304 - -l15 r@Resource{..} = do - trace "l15" - parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince - now <- lift requestTime - let maybeGreater = (> now) <$> parsedDate - if maybeGreater == Just True - then m16 r - else l17 r - -l14 r@Resource{..} = do - trace "l14" - req <- lift request - let reqHeaders = requestHeaders req - dateHeader = lookup HTTP.hIfModifiedSince reqHeaders - validDate = isJust (dateHeader >>= parseRfc1123Date) - if validDate - then l15 r - else m16 r - -l13 r@Resource{..} = do - trace "l13" - req <- lift request - let reqHeaders = requestHeaders req - case lookup HTTP.hIfModifiedSince reqHeaders of - (Just _h) -> - l14 r - Nothing -> - m16 r - -l07 r = do - trace "l07" - req <- lift request - if requestMethod req == HTTP.methodPost - then m07 r - else lift $ halt HTTP.status404 - -l05 r@Resource{..} = do - trace "l05" - moved <- lift movedTemporarily - case moved of - (Just loc) -> do - lift $ addResponseHeader ("Location", loc) - lift $ halt HTTP.status307 - Nothing -> - m05 r - ------------------------------------------------------------------------------- --- M column ------------------------------------------------------------------------------- - -m20 r@Resource{..} = do - trace "m20" - deleteAccepted <- lift deleteResource - if deleteAccepted - then do - completed <- lift deleteCompleted - if completed - then o20 r - else lift $ halt HTTP.status202 - else lift $ halt HTTP.status500 - -m16 r = do - trace "m16" - req <- lift request - if requestMethod req == HTTP.methodDelete - then m20 r - else n16 r - -m07 r@Resource{..} = do - trace "m07" - allowMissing <- lift allowMissingPost - if allowMissing - then n11 r - else lift $ halt HTTP.status404 - -m05 r = do - trace "m05" - req <- lift request - if requestMethod req == HTTP.methodPost - then n05 r - else lift $ halt HTTP.status410 - ------------------------------------------------------------------------------- --- N column ------------------------------------------------------------------------------- - -n16 r = do - trace "n16" - req <- lift request - if requestMethod req == HTTP.methodPost - then n11 r - else o16 r - -n11 r@Resource{..} = trace "n11" >> lift processPost >>= flip processPostAction r - -create :: Monad m => [Text] -> Resource m -> FlowStateT m () -create ts r = do - loc <- lift (appendRequestPath ts) - lift (addResponseHeader ("Location", loc)) - negotiateContentTypesAccepted r - -processPostAction :: Monad m => PostResponse m -> Flow m -processPostAction (PostCreate ts) r = do - create ts r - p11 r -processPostAction (PostCreateRedirect ts) r = do - create ts r - lift $ halt HTTP.status303 -processPostAction (PostProcess p) r = - lift p >> p11 r -processPostAction (PostProcessRedirect ts) _r = do - locBs <- lift ts - lift $ addResponseHeader ("Location", locBs) - lift $ halt HTTP.status303 - -n05 r@Resource{..} = do - trace "n05" - allow <- lift allowMissingPost - if allow - then n11 r - else lift $ halt HTTP.status410 - ------------------------------------------------------------------------------- --- O column ------------------------------------------------------------------------------- - -o20 r = do - trace "o20" - body <- lift getResponseBody - -- ResponseBody is a little tough to make an instance of 'Eq', - -- so we just use a pattern match - case body of - Empty -> lift $ halt HTTP.status204 - _ -> o18 r - -o18 r@Resource{..} = do - trace "o18" - multiple <- lift multipleChoices - if multiple - then lift $ halt HTTP.status300 - else do - -- TODO: set etag, expiration, etc. headers - req <- lift request - let getOrHead = [ HTTP.methodGet - , HTTP.methodHead - ] - when (requestMethod req `elem` getOrHead) $ do - m <- _contentType <$> get - (cType, body) <- case m of - Nothing -> do - provided <- lift contentTypesProvided - return (head provided) - Just (cType, body) -> - return (cType, body) - b <- lift body - lift $ putResponseBody b - lift $ addResponseHeader ("Content-Type", renderHeader cType) - writeCacheTags r - lift $ halt HTTP.status200 - -o16 r = do - trace "o16" - req <- lift request - if requestMethod req == HTTP.methodPut - then o14 r - else o18 r - -o14 r@Resource{..} = do - trace "o14" - conflict <- lift isConflict - if conflict - then lift $ halt HTTP.status409 - else negotiateContentTypesAccepted r >> p11 r - ------------------------------------------------------------------------------- --- P column ------------------------------------------------------------------------------- - -p11 r = do - trace "p11" - headers <- lift getResponseHeaders - case lookup HTTP.hLocation headers of - (Just _) -> - lift $ halt HTTP.status201 - _ -> - o20 r - -p03 r@Resource{..} = do - trace "p03" - conflict <- lift isConflict - if conflict - then lift $ halt HTTP.status409 - else negotiateContentTypesAccepted r >> p11 r diff --git a/tests/examples/ghc8/Defer03.hs b/tests/examples/ghc8/Defer03.hs deleted file mode 100644 --- a/tests/examples/ghc8/Defer03.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -a :: Int -a = 'p' - -main :: IO () -main = print "No errors!" diff --git a/tests/examples/ghc8/Dep1.hs b/tests/examples/ghc8/Dep1.hs deleted file mode 100644 --- a/tests/examples/ghc8/Dep1.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module Dep1 where - -import Data.Kind - -data Proxy k (a :: k) = P - -x :: Proxy * Int -x = P - -y :: Proxy Bool True -y = P diff --git a/tests/examples/ghc8/Dep2.hs b/tests/examples/ghc8/Dep2.hs deleted file mode 100644 --- a/tests/examples/ghc8/Dep2.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PolyKinds, GADTs #-} - -module Dep2 where - -data G (a :: k) where - G1 :: G Int - G2 :: G Maybe diff --git a/tests/examples/ghc8/Dep3.hs b/tests/examples/ghc8/Dep3.hs deleted file mode 100644 --- a/tests/examples/ghc8/Dep3.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-} - -module Dep3 where - -import Data.Kind -import GHC.Exts ( Constraint ) - -type Star1 = * - -data Id1 (a :: Star1) where - Id1 :: a -> Id1 a - -data Id1' :: Star1 -> * where - Id1' :: a -> Id1' a - -type family Star2 x where - Star2 x = * - -data Id2a (a :: Star2 Constraint) = Id2a a - - -data Id2 (a :: Star2 Constraint) where - Id2 :: a -> Id2 a - -data Id2' :: Star2 Constraint -> * where - Id2' :: a -> Id2' a diff --git a/tests/examples/ghc8/DepFail1.hs b/tests/examples/ghc8/DepFail1.hs deleted file mode 100644 --- a/tests/examples/ghc8/DepFail1.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module DepFail1 where - -data Proxy k (a :: k) = P - -z :: Proxy Bool -z = P - -a :: Proxy Int Bool -a = P diff --git a/tests/examples/ghc8/DeprM.hs b/tests/examples/ghc8/DeprM.hs deleted file mode 100644 --- a/tests/examples/ghc8/DeprM.hs +++ /dev/null @@ -1,4 +0,0 @@ -module DeprM {-# DEPRECATED "Here can be your menacing deprecation warning!" #-} where - -f :: Int -f = 42 diff --git a/tests/examples/ghc8/DeprU.hs b/tests/examples/ghc8/DeprU.hs deleted file mode 100644 --- a/tests/examples/ghc8/DeprU.hs +++ /dev/null @@ -1,6 +0,0 @@ -module A where - -import DeprM -- here should be emitted deprecation warning - -g :: Int -g = f diff --git a/tests/examples/ghc8/Deprecation.hs b/tests/examples/ghc8/Deprecation.hs deleted file mode 100644 --- a/tests/examples/ghc8/Deprecation.hs +++ /dev/null @@ -1,16 +0,0 @@ - -module Deprecation -{-# Deprecated ["This is a module \"deprecation\"", - "multi-line", - "with unicode: Frère" ] #-} - ( foo ) - where - -{-# DEPRECATEd foo - ["This is a multi-line", - "deprecation message", - "for foo"] #-} -foo :: Int -foo = 4 - -{-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} diff --git a/tests/examples/ghc8/DsStrict.hs b/tests/examples/ghc8/DsStrict.hs deleted file mode 100644 --- a/tests/examples/ghc8/DsStrict.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE Strict #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -module Main where - -import Debug.Trace - -f0 a = "fun" -f0' ~a = "fun2" - -f1 ~n = - case n of - a -> "case" -f1' ~n = - case n of - ~a -> "case2" - -f2 = \a -> "lamda" -f2' = \ ~a -> "lambda2" - -newtype Age = MkAge Int - -f4, f4' :: Age -> String -f4 (MkAge a) = "newtype" -f4' ~(MkAge a) = "newtype2" - -main :: IO () -main = mapM_ (\(what,f) -> putStrLn (f (v what))) fs - where fs = - [("fun",f0 ) - ,("fun lazy",f0') - ,("case",f1) - ,("case lazy",f1') - ,("lambda",f2) - ,("lambda lazy",f2') - ,("newtype",(\ ~i -> f4 (MkAge i))) - ,("newtype lazy",(\ ~i -> f4' (MkAge i)))] - v n = trace ("evaluated in " ++ n) 1 diff --git a/tests/examples/ghc8/DsStrictData.hs b/tests/examples/ghc8/DsStrictData.hs deleted file mode 100644 --- a/tests/examples/ghc8/DsStrictData.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, StrictData, GADTs #-} - --- | Tests the StrictData LANGUAGE pragma. -module Main where - -import qualified Control.Exception as E -import System.IO.Unsafe (unsafePerformIO) - -data Strict a = S a -data Strict2 b = S2 !b -data Strict3 c where - S3 :: c -> Strict3 c - -data UStrict = US {-# UNPACK #-} Int - -data Lazy d = L ~d -data Lazy2 e where - L2 :: ~e -> Lazy2 e - -main :: IO () -main = - do print (isBottom (S bottom)) - print (isBottom (S2 bottom)) - print (isBottom (US bottom)) - print (isBottom (S3 bottom)) - putStrLn "" - print (not (isBottom (L bottom))) - print (not (isBottom (L2 bottom))) - print (not (isBottom (Just bottom))) -- sanity check - ------------------------------------------------------------------------- --- Support for testing for bottom - -bottom :: a -bottom = error "_|_" - -isBottom :: a -> Bool -isBottom f = unsafePerformIO $ - (E.evaluate f >> return False) `E.catches` - [ E.Handler (\(_ :: E.ArrayException) -> return True) - , E.Handler (\(_ :: E.ErrorCall) -> return True) - , E.Handler (\(_ :: E.NoMethodError) -> return True) - , E.Handler (\(_ :: E.NonTermination) -> return True) - , E.Handler (\(_ :: E.PatternMatchFail) -> return True) - , E.Handler (\(_ :: E.RecConError) -> return True) - , E.Handler (\(_ :: E.RecSelError) -> return True) - , E.Handler (\(_ :: E.RecUpdError) -> return True) - ] diff --git a/tests/examples/ghc8/DsStrictFail.hs b/tests/examples/ghc8/DsStrictFail.hs deleted file mode 100644 --- a/tests/examples/ghc8/DsStrictFail.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE Strict #-} -module Main where - -main = let False = True - in return () diff --git a/tests/examples/ghc8/DsStrictLet.hs b/tests/examples/ghc8/DsStrictLet.hs deleted file mode 100644 --- a/tests/examples/ghc8/DsStrictLet.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE Strict #-} -module Main where - -import Debug.Trace - -main = let False = trace "no binders" False -- evaluated - - a :: a -> a - a = trace "polymorphic" id -- evaluated - - f :: Eq a => a -> a -> Bool - f = trace "overloaded" (==) -- not evaluated - - xs :: [Int] - xs = (trace "recursive" (:) 1 xs) -- evaluated - in return () diff --git a/tests/examples/ghc8/DsStrictWarn.hs b/tests/examples/ghc8/DsStrictWarn.hs deleted file mode 100644 --- a/tests/examples/ghc8/DsStrictWarn.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-} -{-# LANGUAGE Strict #-} -module DsStrictWarn where - --- should warn about non-exhaustive pattern match -w :: String -> String -w x = let (_:_) = x in "1" diff --git a/tests/examples/ghc8/Eq.hs b/tests/examples/ghc8/Eq.hs deleted file mode 100644 --- a/tests/examples/ghc8/Eq.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, - RankNTypes, FlexibleContexts, TemplateHaskell, - UndecidableInstances, GADTs, DefaultSignatures #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Eq --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines the SEq singleton version of the Eq type class. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Prelude.Eq ( - PEq(..), SEq(..), - (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$) - ) where - -import Data.Singletons.Prelude.Bool -import Data.Singletons -import Data.Singletons.Single -import Data.Singletons.Prelude.Instances -import Data.Singletons.Util -import Data.Singletons.Promote -import Data.Type.Equality - --- NB: These must be defined by hand because of the custom handling of the --- default for (:==) to use Data.Type.Equality.== - --- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)', --- then it defaults to a use of '(==)', from @Data.Type.Equality@. -class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where - type (:==) (x :: a) (y :: a) :: Bool - type (:/=) (x :: a) (y :: a) :: Bool - - type (x :: a) :== (y :: a) = x == y - type (x :: a) :/= (y :: a) = Not (x :== y) - -infix 4 :== -infix 4 :/= - -$(genDefunSymbols [''(:==), ''(:/=)]) - --- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required --- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'. -class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where - -- | Boolean equality on singletons - (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b) - infix 4 %:== - - -- | Boolean disequality on singletons - (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b) - default (%:/=) :: forall (a :: k) (b :: k). - ((a :/= b) ~ Not (a :== b)) - => Sing a -> Sing b -> Sing (a :/= b) - a %:/= b = sNot (a %:== b) - infix 4 %:/= - -$(singEqInstances basicTypes) diff --git a/tests/examples/ghc8/ExpandSynsFail1.hs b/tests/examples/ghc8/ExpandSynsFail1.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExpandSynsFail1.hs +++ /dev/null @@ -1,4 +0,0 @@ -type Foo = Int -type Bar = Bool - -main = print $ (1 :: Foo) == (False :: Bar) diff --git a/tests/examples/ghc8/ExpandSynsFail2.hs b/tests/examples/ghc8/ExpandSynsFail2.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExpandSynsFail2.hs +++ /dev/null @@ -1,19 +0,0 @@ --- In case of types with nested type synonyms, all synonyms should be expanded - -{-# LANGUAGE RankNTypes #-} - -import Control.Monad.ST - -type Foo = Int -type Bar = Bool - -type MyFooST s = ST s Foo -type MyBarST s = ST s Bar - -fooGen :: forall s . MyFooST s -fooGen = undefined - -barGen :: forall s . MyBarST s -barGen = undefined - -main = print (runST fooGen == runST barGen) diff --git a/tests/examples/ghc8/ExpandSynsFail3.hs b/tests/examples/ghc8/ExpandSynsFail3.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExpandSynsFail3.hs +++ /dev/null @@ -1,23 +0,0 @@ --- We test two things here: --- --- 1. We expand only as much as necessary. In this case, we shouldn't expand T. --- 2. When we find a difference(T3 and T5 in this case), we do minimal expansion --- e.g. we don't expand both of them to T1, instead we expand T5 to T3. - -module Main where - -type T5 = T4 -type T4 = T3 -type T3 = T2 -type T2 = T1 -type T1 = Int - -type T a = Int -> Bool -> a -> String - -f :: T (T3, T5, Int) -> Int -f = undefined - -a :: Int -a = f (undefined :: T (T5, T3, Bool)) - -main = print a diff --git a/tests/examples/ghc8/ExpandSynsFail4.hs b/tests/examples/ghc8/ExpandSynsFail4.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExpandSynsFail4.hs +++ /dev/null @@ -1,11 +0,0 @@ --- Synonyms shouldn't be expanded since type error is visible without --- expansions. Error message should not have `Type synonyms expanded: ...` part. - -module Main where - -type T a = [a] - -f :: T Int -> String -f = undefined - -main = putStrLn $ f (undefined :: T Bool) diff --git a/tests/examples/ghc8/ExportSyntax.hs b/tests/examples/ghc8/ExportSyntax.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExportSyntax.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module ExportSyntax ( A(.., NoA), Q(F,..), G(T,..,U)) where - -data A = A | B - -pattern NoA = B - -data Q a = Q a - -pattern F a = Q a - -data G = G | H - -pattern T = G - -pattern U = H diff --git a/tests/examples/ghc8/ExportSyntaxImport.hs b/tests/examples/ghc8/ExportSyntaxImport.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExportSyntaxImport.hs +++ /dev/null @@ -1,7 +0,0 @@ -module ExportSyntaxImport where - -import ExportSyntax - -foo = NoA - -baz = A diff --git a/tests/examples/ghc8/ExprSigLocal.hs b/tests/examples/ghc8/ExprSigLocal.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExprSigLocal.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures, RankNTypes #-} - -module ExprSigLocal where - --- We expect this to compile fine, --- reporting that '_' stands 'a' - -y :: forall b. b->b -y = ((\x -> x) :: forall a. a -> _) - -g :: forall a. a -> _ -g x = x diff --git a/tests/examples/ghc8/Extends.hs b/tests/examples/ghc8/Extends.hs deleted file mode 100644 --- a/tests/examples/ghc8/Extends.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Extends where - -class BClass b where - has :: b diff --git a/tests/examples/ghc8/ExtraConstraintsWildcardInExpressionSignature.hs b/tests/examples/ghc8/ExtraConstraintsWildcardInExpressionSignature.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExtraConstraintsWildcardInExpressionSignature.hs +++ /dev/null @@ -1,3 +0,0 @@ -module ExtraConstraintsWildcardInExpressionSignature where - -foo x y = ((==) :: _ => _) x y diff --git a/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSignature.hs b/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSignature.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSignature.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module ExtraConstraintsWildcardInPatternSignature where - -foo (x :: _ => _) y = x == y diff --git a/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSplice.hs b/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSplice.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSplice.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ScopedTypeVariables #-} -module ExtraConstraintsWildcardInPatternSplice where - -foo $( [p| (x :: _) |] ) = x diff --git a/tests/examples/ghc8/ExtraConstraintsWildcardInTypeSplice.hs b/tests/examples/ghc8/ExtraConstraintsWildcardInTypeSplice.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExtraConstraintsWildcardInTypeSplice.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module ExtraConstraintsWildcardInTypeSplice where - -import Language.Haskell.TH - -metaType :: TypeQ -metaType = [t| _ => _ |] diff --git a/tests/examples/ghc8/ExtraConstraintsWildcardInTypeSplice2.hs b/tests/examples/ghc8/ExtraConstraintsWildcardInTypeSplice2.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExtraConstraintsWildcardInTypeSplice2.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module ExtraConstraintsWildcardInTypeSplice2 where - -import Language.Haskell.TH.Lib (wildCardT) - -show' :: $(wildCardT) => a -> String -show' x = show x diff --git a/tests/examples/ghc8/ExtraConstraintsWildcardInTypeSpliceUsed.hs b/tests/examples/ghc8/ExtraConstraintsWildcardInTypeSpliceUsed.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExtraConstraintsWildcardInTypeSpliceUsed.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module ExtraConstraintsWildcardInTypeSpliceUsed where - -import ExtraConstraintsWildcardInTypeSplice - --- An extra-constraints wild card is not supported in type splices -eq :: $(metaType) -eq x y = x == y diff --git a/tests/examples/ghc8/ExtraConstraintsWildcardTwice.hs b/tests/examples/ghc8/ExtraConstraintsWildcardTwice.hs deleted file mode 100644 --- a/tests/examples/ghc8/ExtraConstraintsWildcardTwice.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -module ExtraConstraintsWildcardTwice where - -foo :: ((_), _) => a -> a -foo = undefined diff --git a/tests/examples/ghc8/F.hs b/tests/examples/ghc8/F.hs deleted file mode 100644 --- a/tests/examples/ghc8/F.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | Thompson's group F. --- --- See eg. --- --- Based mainly on James Michael Belk's PhD thesis \"THOMPSON'S GROUP F\"; --- see --- - -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns, PatternSynonyms, DeriveFunctor #-} -module Math.Combinat.Groups.Thompson.F where - --- | Remove the carets with the given indices --- (throws an error if there is no caret at the given index) -removeCarets :: [Int] -> T -> T -removeCarets idxs tree = if null rem then final else error ("removeCarets: some stuff remained: " ++ show rem) where - - (_,rem,final) = go 0 idxs tree where - - go :: Int -> [Int] -> T -> (Int,[Int],T) - go !x [] t = (x + treeWidth t , [] , t) diff --git a/tests/examples/ghc8/FDsFromGivens2.hs b/tests/examples/ghc8/FDsFromGivens2.hs deleted file mode 100644 --- a/tests/examples/ghc8/FDsFromGivens2.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, GADTs #-} - -module FDsFromGivens2 where - -class C a b | a -> b where - cop :: a -> b -> () - -data KCC where - KCC :: C Char Char => () -> KCC - -f :: C Char [a] => a -> a -f = undefined - -bar (KCC _) = f diff --git a/tests/examples/ghc8/Families.hs b/tests/examples/ghc8/Families.hs deleted file mode 100644 --- a/tests/examples/ghc8/Families.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds, KindSignatures, - TypeOperators, UndecidableInstances #-} - -{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, EmptyDataDecls #-} - --- | A prelude for type-level programming with type families - -module Prelude.Type.Families where - --- >>> T :: T ((I 4) `Minus` (I 7)) --- -3 -type family (a :: k) `Minus` (b :: k) :: k -type instance a `Minus` b = a + Negate b - diff --git a/tests/examples/ghc8/FooBar.hs b/tests/examples/ghc8/FooBar.hs deleted file mode 100644 --- a/tests/examples/ghc8/FooBar.hs +++ /dev/null @@ -1,4 +0,0 @@ -module FooBar where - -import Foo -import Bar diff --git a/tests/examples/ghc8/ForFree.hs b/tests/examples/ghc8/ForFree.hs deleted file mode 100644 --- a/tests/examples/ghc8/ForFree.hs +++ /dev/null @@ -1,23 +0,0 @@ - -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} --- {-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module Control.ForFree where { - --- | Free monad from a functor -; - data Free f x = Pure x | Free (f (Free f x)); - - deriving instance (Eq (f (Free f a)), Eq a) => Eq (Free f a); - deriving instance (Ord (f (Free f a)), Ord a) => Ord (Free f a); - deriving instance (Read (f (Free f a)), Read a) => Read (Free f a); - deriving instance (Show (f (Free f a)), Show a) => Show (Free f a); -} diff --git a/tests/examples/ghc8/FromGrin2.hs b/tests/examples/ghc8/FromGrin2.hs deleted file mode 100644 --- a/tests/examples/ghc8/FromGrin2.hs +++ /dev/null @@ -1,6 +0,0 @@ - --- ./hackage-roundtrip-work/ajhc-0.8.0.10/src/C/FromGrin2.hs --- orig line 588 -convertExp :: Exp -> C (Statement,Expression) -convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do - return (mempty,e) diff --git a/tests/examples/ghc8/FrontendPlugin.hs b/tests/examples/ghc8/FrontendPlugin.hs deleted file mode 100644 --- a/tests/examples/ghc8/FrontendPlugin.hs +++ /dev/null @@ -1,52 +0,0 @@ -module FrontendPlugin where - -import GhcPlugins -import qualified GHC -import GHC ( Ghc, LoadHowMuch(..) ) - -import DriverPipeline hiding ( hsc_env ) -import DriverPhases -import System.Exit -import Control.Monad -import Data.List - -frontendPlugin :: FrontendPlugin -frontendPlugin = defaultFrontendPlugin { - frontend = doMake - } - --- Copypasted from ghc/Main.hs -doMake :: [String] -> [(String,Maybe Phase)] -> Ghc () -doMake opts srcs = do - liftIO $ print opts - let (hs_srcs, non_hs_srcs) = partition haskellish srcs - - haskellish (f,Nothing) = - looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f - haskellish (_,Just phase) = - phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm - , StopLn] - - hsc_env <- GHC.getSession - - -- if we have no haskell sources from which to do a dependency - -- analysis, then just do one-shot compilation and/or linking. - -- This means that "ghc Foo.o Bar.o -o baz" links the program as - -- we expect. - if (null hs_srcs) - then liftIO (oneShot hsc_env StopLn srcs) - else do - - o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) - non_hs_srcs - dflags <- GHC.getSessionDynFlags - let dflags' = dflags { ldInputs = map (FileOption "") o_files - ++ ldInputs dflags } - _ <- GHC.setSessionDynFlags dflags' - - targets <- mapM (uncurry GHC.guessTarget) hs_srcs - GHC.setTargets targets - ok_flag <- GHC.load LoadAllTargets - - when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) - return () diff --git a/tests/examples/ghc8/GA1r.hs b/tests/examples/ghc8/GA1r.hs deleted file mode 100644 --- a/tests/examples/ghc8/GA1r.hs +++ /dev/null @@ -1,5 +0,0 @@ -module GA1r where -import Text.ParserCombinators.Parsec - -parseStr :: CharParser () String -parseStr = char '"' *> (many1 (noneOf "\"")) <* char '"' diff --git a/tests/examples/ghc8/Generate.hs b/tests/examples/ghc8/Generate.hs deleted file mode 100644 --- a/tests/examples/ghc8/Generate.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Control.Monad (forM_) - -main :: IO () -main = forM_ [0..0xffff] $ \i -> do - putStrLn $ ".section s" ++ show i ++ ",\"\",@progbits" - putStrLn $ ".asciz \"Section " ++ show i ++ "\"" - putStrLn "" diff --git a/tests/examples/ghc8/Generic.hs b/tests/examples/ghc8/Generic.hs deleted file mode 100644 --- a/tests/examples/ghc8/Generic.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} -module Env.Generic - ( Record(..) - , type (?)(..) - ) where - -import Data.Promotion.Prelude (type (:+$), type (:*$), type (:^$), type (:-$)) -import Options.Generic (Generic, ParseRecord, type ()(..)) diff --git a/tests/examples/ghc8/IPLocation.hs b/tests/examples/ghc8/IPLocation.hs deleted file mode 100644 --- a/tests/examples/ghc8/IPLocation.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE ImplicitParams, RankNTypes #-} -{-# OPTIONS_GHC -dcore-lint #-} -module Main where - -import GHC.Exception -import GHC.Types - -f0 = putStrLn $ showCallStack ?loc - -- should just show the location of ?loc - -f1 :: (?loc :: CallStack) => IO () -f1 = putStrLn $ showCallStack ?loc - -- should show the location of ?loc *and* f1's call-site - -f2 :: (?loc :: CallStack) => IO () -f2 = do putStrLn $ showCallStack ?loc - putStrLn $ showCallStack ?loc - -- each ?loc should refer to a different location, but they should - -- share f2's call-site - -f3 :: ((?loc :: CallStack) => () -> IO ()) -> IO () -f3 x = x () - -- the call-site for the functional argument should be added to the - -- stack.. - -f4 :: (?loc :: CallStack) => ((?loc :: CallStack) => () -> IO ()) -> IO () -f4 x = x () - -- as should the call-site for f4 itself - -f5 :: (?loc1 :: CallStack) => ((?loc2 :: CallStack) => () -> IO ()) -> IO () -f5 x = x () - -- we only push new call-sites onto CallStacks with the name IP name - -f6 :: (?loc :: CallStack) => Int -> IO () -f6 0 = putStrLn $ showCallStack ?loc -f6 n = f6 (n-1) - -- recursive functions add a SrcLoc for each recursive call - -main = do f0 - f1 - f2 - f3 (\ () -> putStrLn $ showCallStack ?loc) - f4 (\ () -> putStrLn $ showCallStack ?loc) - f5 (\ () -> putStrLn $ showCallStack ?loc3) - f6 5 diff --git a/tests/examples/ghc8/Improvement.hs b/tests/examples/ghc8/Improvement.hs deleted file mode 100644 --- a/tests/examples/ghc8/Improvement.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module Foo where - -type family F a -type instance F Int = Bool - -class C a b where - -instance (b~Int) => C Bool b - -blug :: C (F a) a => a -> F a -blug = error "Urk" - -foo :: Bool -foo = blug undefined --- [W] C (F a0) a0, F a0 ~ Bool - diff --git a/tests/examples/ghc8/KindEqualities.hs b/tests/examples/ghc8/KindEqualities.hs deleted file mode 100644 --- a/tests/examples/ghc8/KindEqualities.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE PolyKinds, GADTs, ExplicitForAll #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - -module KindEqualities where - -data TyRep1 :: * -> * where - TyInt1 :: TyRep1 Int - TyBool1 :: TyRep1 Bool - -zero1 :: forall a. TyRep1 a -> a -zero1 TyInt1 = 0 -zero1 TyBool1 = False - -data Proxy (a :: k) = P - -data TyRep :: k -> * where - TyInt :: TyRep Int - TyBool :: TyRep Bool - TyMaybe :: TyRep Maybe - TyApp :: TyRep a -> TyRep b -> TyRep (a b) - -zero :: forall (a :: *). TyRep a -> a -zero TyInt = 0 -zero TyBool = False -zero (TyApp TyMaybe _) = Nothing diff --git a/tests/examples/ghc8/KindEqualities2.hs b/tests/examples/ghc8/KindEqualities2.hs deleted file mode 100644 --- a/tests/examples/ghc8/KindEqualities2.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll, - TemplateHaskell, UndecidableInstances, ScopedTypeVariables, - TypeInType #-} - -module KindEqualities2 where - -import Data.Kind -import GHC.Exts ( Any ) - -data Kind = Star | Arr Kind Kind - -data Ty :: Kind -> * where - TInt :: Ty Star - TBool :: Ty Star - TMaybe :: Ty (Arr Star Star) - TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2 - - -data TyRep (k :: Kind) (t :: Ty k) where - TyInt :: TyRep Star TInt - TyBool :: TyRep Star TBool - TyMaybe :: TyRep (Arr Star Star) TMaybe - TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b) - -type family IK (k :: Kind) -type instance IK Star = * -type instance IK (Arr k1 k2) = IK k1 -> IK k2 - -$(return []) -- necessary because the following instances depend on the - -- previous ones. - -type family I (t :: Ty k) :: IK k -type instance I TInt = Int -type instance I TBool = Bool -type instance I TMaybe = Maybe -type instance I (TApp a b) = (I a) (I b) - -zero :: forall (a :: Ty 'Star). TyRep Star a -> I a -zero TyInt = 0 -zero TyBool = False -zero (TyApp TyMaybe TyInt) = Nothing - -main = print $ zero (TyApp TyMaybe TyInt) diff --git a/tests/examples/ghc8/KindLevels.hs b/tests/examples/ghc8/KindLevels.hs deleted file mode 100644 --- a/tests/examples/ghc8/KindLevels.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DataKinds, PolyKinds #-} - -module KindLevels where - -data A -data B :: A -> * -data C :: B a -> * -data D :: C b -> * -data E :: D c -> * diff --git a/tests/examples/ghc8/ListComprehensions.hs b/tests/examples/ghc8/ListComprehensions.hs deleted file mode 100644 --- a/tests/examples/ghc8/ListComprehensions.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE ParallelListComp, - TransformListComp, - RecordWildCards #-} --- MonadComprehensions, - -module ListComprehensions where - - - -import GHC.Exts -import qualified Data.Map as M -import Data.Ord (comparing) -import Data.List (sortBy) - --- Let’s look at a simple, normal list comprehension to start: - -parallelListComp :: [Int] -parallelListComp = [ x + y * z - | x <- [0..10] - | y <- [10..20] - | z <- [20..30] - ] - -oldest :: [Int] -> [String] -oldest tbl = [ "str" - | n <- tbl - , then id - ] diff --git a/tests/examples/ghc8/LiteralsTest2.hs b/tests/examples/ghc8/LiteralsTest2.hs deleted file mode 100644 --- a/tests/examples/ghc8/LiteralsTest2.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module LiteralsTest2 where - -x,y :: Int -x = 0003 -y = 0x04 - -s :: String -s = "\x20" - -c :: Char -c = '\x20' - -d :: Double -d = 0.00 - -blah = x - where - charH = '\x41'# - intH = 0004# - wordH = 005## - floatH = 3.20# - doubleH = 04.16## - x = 1 diff --git a/tests/examples/ghc8/Main.hs b/tests/examples/ghc8/Main.hs deleted file mode 100644 --- a/tests/examples/ghc8/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ --- Copyright (C) 2015, Luke Iannini - -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ForeignFunctionInterface #-} - -module Main where -import Printf ( pr ) - -foreign import ccall "talkToCxx" talkToCxx :: IO () - -main :: IO () -main = do - putStrLn ( $(pr "Hello From Template Haskell!") ) - talkToCxx diff --git a/tests/examples/ghc8/Manipulate.hs b/tests/examples/ghc8/Manipulate.hs deleted file mode 100644 --- a/tests/examples/ghc8/Manipulate.hs +++ /dev/null @@ -1,39 +0,0 @@ -{- | -Module : Control.Comonad.Sheet.Manipulate -Description : Generic functions for manipulating multi-dimensional comonadic spreadsheets. -Copyright : Copyright (c) 2014 Kenneth Foner - -Maintainer : kenneth.foner@gmail.com -Stability : experimental -Portability : non-portable - -This module defines the 'take', 'view', 'go', and 'insert' functions generically for any dimensionality of sheet. These -constitute the preferred way of manipulating sheets, providing an interface to: take finite slices ('take'), infinite -slices ('view'), move to locations ('go'), and insert finite or infinite structures ('insert'). --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Control.Comonad.Sheet.Manipulate where - - --- | In the case of a @Nested@ structure, @asDimensionalAs@ defaults to @asNestedAs@. -instance (NestedAs x (Nested ts y), AsDimensionalAs x (Nested ts y) ~ AsNestedAs x (Nested ts y)) => DimensionalAs x (Nested ts y) where - type x `AsDimensionalAs` (Nested ts a) = x `AsNestedAs` (Nested ts a) - asDimensionalAs = asNestedAs - --- | @DimensionalAs@ also knows the dimensionality of an 'Indexed' sheet as well as regular @Nested@ structures. -instance (NestedAs x (Nested ts y)) => DimensionalAs x (Indexed ts y) where - type x `AsDimensionalAs` (Indexed ts a) = x `AsNestedAs` (Nested ts a) - x `asDimensionalAs` (Indexed i t) = x `asNestedAs` t - - -instance DepIndex (a,b) TH_0 where - type (a,b) `DepIndexResult` TH_0 = a - (a,b) # TH_0 = a diff --git a/tests/examples/ghc8/Match.hs b/tests/examples/ghc8/Match.hs deleted file mode 100644 --- a/tests/examples/ghc8/Match.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_HADDOCK hide #-} - --- Discriminate binary functions that commute, and if so return the operands in --- a stable ordering such that matching recognises expressions modulo --- commutativity. --- -commutes - :: forall acc env aenv a r. - HashAcc acc - -> PrimFun (a -> r) - -> PreOpenExp acc env aenv a - -> Maybe (PreOpenExp acc env aenv a) -commutes h f x = case f of - PrimAdd _ -> Just (swizzle x) - PrimMul _ -> Just (swizzle x) - PrimBAnd _ -> Just (swizzle x) - PrimBOr _ -> Just (swizzle x) - PrimBXor _ -> Just (swizzle x) - PrimEq _ -> Just (swizzle x) - PrimNEq _ -> Just (swizzle x) - PrimMax _ -> Just (swizzle x) - PrimMin _ -> Just (swizzle x) - PrimLAnd -> Just (swizzle x) - PrimLOr -> Just (swizzle x) - _ -> Nothing - where - swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a') - swizzle exp - | Tuple (NilTup `SnocTup` a `SnocTup` b) <- exp - , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a) - -- - | otherwise = exp diff --git a/tests/examples/ghc8/MonadFailErrors.hs b/tests/examples/ghc8/MonadFailErrors.hs deleted file mode 100644 --- a/tests/examples/ghc8/MonadFailErrors.hs +++ /dev/null @@ -1,95 +0,0 @@ --- Test purpose: --- Break properly if MonadFail is live - -{-# LANGUAGE MonadFailDesugaring #-} - -module MonadFailWarnings where - -import Control.Monad.Fail -import Control.Monad.ST -import Data.Functor.Identity - - - -general :: Monad m => m a -general = do - Just x <- undefined - undefined - - - -general' :: MonadFail m => m a -general' = do - Just x <- undefined - undefined - - - -identity :: Identity a -identity = do - Just x <- undefined - undefined - - - -io :: IO a -io = do - Just x <- undefined - undefined - - - -st :: ST s a -st = do - Just x <- undefined - undefined - - - -reader :: r -> a -reader = do - Just x <- undefined - undefined - - - -newtype Newtype a = Newtype a -newtypeMatch :: Identity a -newtypeMatch = do - Newtype x <- undefined - undefined - - - -data Data a = Data a -singleConMatch :: Identity a -singleConMatch = do - Data x <- undefined - undefined - - - -data Maybe' a = Nothing' | Just' a -instance Functor Maybe' where fmap = undefined -instance Applicative Maybe' where pure = undefined; (<*>) = undefined -instance Monad Maybe' where (>>=) = undefined -instance MonadFail Maybe' where fail = undefined -customFailable :: Maybe' a -customFailable = do - Just x <- undefined - undefined - - -wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a -wildcardx = do - x <- undefined - undefined -explicitlyIrrefutable = do - ~(x:y) <- undefined - undefined -wildcard_ = do - _ <- undefined - undefined -tuple = do - (a,b) <- undefined - undefined diff --git a/tests/examples/ghc8/MonadFailWarnings.hs b/tests/examples/ghc8/MonadFailWarnings.hs deleted file mode 100644 --- a/tests/examples/ghc8/MonadFailWarnings.hs +++ /dev/null @@ -1,107 +0,0 @@ --- Test purpose: --- Ensure that MonadFail warnings are issued correctly if the warning flag --- is enabled - -{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-} - -module MonadFailWarnings where - -import Control.Monad.Fail -import Control.Monad.ST -import Data.Functor.Identity - - - --- should warn, because the do-block gets a general Monad constraint, --- but should have MonadFail -general :: Monad m => m a -general = do - Just x <- undefined - undefined - - - --- should NOT warn, because the constraint is correct -general' :: MonadFail m => m a -general' = do - Just x <- undefined - undefined - - - --- should warn, because Identity isn't MonadFail -identity :: Identity a -identity = do - Just x <- undefined - undefined - - - --- should NOT warn, because IO is MonadFail -io :: IO a -io = do - Just x <- undefined - undefined - - - --- should warn, because (ST s) is not MonadFail -st :: ST s a -st = do - Just x <- undefined - undefined - - - --- should warn, because (r ->) is not MonadFail -reader :: r -> a -reader = do - Just x <- undefined - undefined - - - --- should NOT warn, because matching against newtype -newtype Newtype a = Newtype a -newtypeMatch :: Identity a -newtypeMatch = do - Newtype x <- undefined - undefined - - - --- should NOT warn, because Data has only one constructor -data Data a = Data a -singleConMatch :: Identity a -singleConMatch = do - Data x <- undefined - undefined - - - --- should NOT warn, because Maybe' has a MonadFail instance -data Maybe' a = Nothing' | Just' a -instance Functor Maybe' where fmap = undefined -instance Applicative Maybe' where pure = undefined; (<*>) = undefined -instance Monad Maybe' where (>>=) = undefined -instance MonadFail Maybe' where fail = undefined -customFailable :: Maybe' a -customFailable = do - Just x <- undefined - undefined - - --- should NOT warn, because patterns always match -wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a -wildcardx = do - x <- undefined - undefined -explicitlyIrrefutable = do - ~(x:y) <- undefined - undefined -wildcard_ = do - _ <- undefined - undefined -tuple = do - (a,b) <- undefined - undefined diff --git a/tests/examples/ghc8/MonadFailWarningsDisabled.hs b/tests/examples/ghc8/MonadFailWarningsDisabled.hs deleted file mode 100644 --- a/tests/examples/ghc8/MonadFailWarningsDisabled.hs +++ /dev/null @@ -1,94 +0,0 @@ --- Test purpose: --- Make sure that not enabling MonadFail warnings makes code compile just --- as it did in < 8.0 - -module MonadFailWarnings where - -import Control.Monad.Fail -import Control.Monad.ST -import Data.Functor.Identity - - - -general :: Monad m => m a -general = do - Just x <- undefined - undefined - - - -general' :: MonadFail m => m a -general' = do - Just x <- undefined - undefined - - - -identity :: Identity a -identity = do - Just x <- undefined - undefined - - - -io :: IO a -io = do - Just x <- undefined - undefined - - - -st :: ST s a -st = do - Just x <- undefined - undefined - - - -reader :: r -> a -reader = do - Just x <- undefined - undefined - - - -newtype Newtype a = Newtype a -newtypeMatch :: Identity a -newtypeMatch = do - Newtype x <- undefined - undefined - - - -data Data a = Data a -singleConMatch :: Identity a -singleConMatch = do - Data x <- undefined - undefined - - - -data Maybe' a = Nothing' | Just' a -instance Functor Maybe' where fmap = undefined -instance Applicative Maybe' where pure = undefined; (<*>) = undefined -instance Monad Maybe' where (>>=) = undefined -instance MonadFail Maybe' where fail = undefined -customFailable :: Maybe' a -customFailable = do - Just x <- undefined - undefined - - -wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a -wildcardx = do - x <- undefined - undefined -explicitlyIrrefutable = do - ~(x:y) <- undefined - undefined -wildcard_ = do - _ <- undefined - undefined -tuple = do - (a,b) <- undefined - undefined diff --git a/tests/examples/ghc8/MonadFailWarningsWithRebindableSyntax.hs b/tests/examples/ghc8/MonadFailWarningsWithRebindableSyntax.hs deleted file mode 100644 --- a/tests/examples/ghc8/MonadFailWarningsWithRebindableSyntax.hs +++ /dev/null @@ -1,14 +0,0 @@ --- Test purpose: --- RebindableSyntax does not play that well with MonadFail, so here we ensure --- that when both settings are enabled we get the proper warning. - -{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-} -{-# LANGUAGE RebindableSyntax #-} - -module MonadFailWarningsWithRebindableSyntax where - -import Prelude - -test1 f g = do - Just x <- f - g diff --git a/tests/examples/ghc8/MultiLineWarningPragma.hs b/tests/examples/ghc8/MultiLineWarningPragma.hs deleted file mode 100644 --- a/tests/examples/ghc8/MultiLineWarningPragma.hs +++ /dev/null @@ -1,18 +0,0 @@ - -{-# WARNING Logic - , mkSolver - , mkSimpleSolver - , mkSolverForLogic - , solverSetParams - , solverPush - , solverPop - , solverReset - , solverGetNumScopes - , solverAssertCnstr - , solverAssertAndTrack - , solverCheck - , solverCheckAndGetModel - , solverGetReasonUnknown - "New Z3 API support is still incomplete and fragile: \ - \you may experience segmentation faults!" - #-} diff --git a/tests/examples/ghc8/MultiQuote.hs b/tests/examples/ghc8/MultiQuote.hs deleted file mode 100644 --- a/tests/examples/ghc8/MultiQuote.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes#-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE EmptyCase #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Internal API for the store package. The functions here which are --- not re-exported by "Data.Store" are less likely to have stable APIs. --- --- This module also defines most of the included 'Store' instances, for --- types from the base package and other commonly used packages --- (bytestring, containers, text, time, etc). -module Data.Store.Internal where - ------------------------------------------------------------------------- --- Instances generated by TH - -$($(derive [d| - -- TODO - -- instance Deriving (Store ()) - instance Deriving (Store All) - instance Deriving (Store Any) - instance Deriving (Store Void) - instance Deriving (Store Bool) - |])) - diff --git a/tests/examples/ghc8/MultiWayIf.hs b/tests/examples/ghc8/MultiWayIf.hs deleted file mode 100644 --- a/tests/examples/ghc8/MultiWayIf.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -module MultiWayIf where - -foo = if | test1 -> e1 - | test2 witharg -> e2 - | otherwise -> def - -bar = if { | test1 -> if { | test2 -> e1 - | test3 -> e2 } - | test4 -> e3 - } - --- taken from GHC's test suite -x = 10 -x1 = if | x < 10 -> "< 10" | otherwise -> "" -x2 = if | x < 10 -> "< 10" - | otherwise -> "" -x3 = if | x < 10 -> "< 10" - | otherwise -> "" -x4 = if | True -> "yes" -x5 = if | True -> if | False -> 1 | True -> 2 - -x6 = if | x < 10 -> if | True -> "yes" - | False -> "no" - | otherwise -> "maybe" - -x7 = (if | True -> 0) - --- issue #98 -spam = if | () <- () -> () diff --git a/tests/examples/ghc8/NamedWildcardInDataFamilyInstanceLHS.hs b/tests/examples/ghc8/NamedWildcardInDataFamilyInstanceLHS.hs deleted file mode 100644 --- a/tests/examples/ghc8/NamedWildcardInDataFamilyInstanceLHS.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds, NamedWildCards #-} -module NamedWildcardInDataFamilyInstanceLHS where - -data MyKind = A | B - -data family Sing (a :: k) - -data instance Sing (_a :: MyKind) where - SingA :: Sing A - SingB :: Sing B diff --git a/tests/examples/ghc8/NamedWildcardInTypeFamilyInstanceLHS.hs b/tests/examples/ghc8/NamedWildcardInTypeFamilyInstanceLHS.hs deleted file mode 100644 --- a/tests/examples/ghc8/NamedWildcardInTypeFamilyInstanceLHS.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE NamedWildCards #-} -module NamedWildcardInTypeFamilyInstanceLHS where - -type family F a where - F _t = Int diff --git a/tests/examples/ghc8/NamedWildcardInTypeSplice.hs b/tests/examples/ghc8/NamedWildcardInTypeSplice.hs deleted file mode 100644 --- a/tests/examples/ghc8/NamedWildcardInTypeSplice.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NamedWildCards #-} -module NamedWildcardInTypeSplice where - -import Language.Haskell.TH - -metaType :: TypeQ -metaType = [t| _a -> _a |] diff --git a/tests/examples/ghc8/OutOfHeap.hs b/tests/examples/ghc8/OutOfHeap.hs deleted file mode 100644 --- a/tests/examples/ghc8/OutOfHeap.hs +++ /dev/null @@ -1,10 +0,0 @@ -import qualified Data.Array.Unboxed as UA -import Data.Word - -main :: IO () -main = print (UA.listArray (1, 2^(20::Int)) (repeat 0) - :: UA.UArray Int Word64) - -- this unboxed array should at least take: - -- 2^20 * 64 bits - -- = 8 * (2^20 bytes) - -- = 8 MiB (in heap) diff --git a/tests/examples/ghc8/OverloadedRecFldsFail04_A.hs b/tests/examples/ghc8/OverloadedRecFldsFail04_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/OverloadedRecFldsFail04_A.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - -module OverloadedRecFldsFail04_A (U(..), V(MkV, x), Unused(..), u) where - -data U = MkU { x :: Bool, y :: Bool } -data V = MkV { x :: Int } -data Unused = MkUnused { unused :: Bool } - -u = MkU False True diff --git a/tests/examples/ghc8/OverloadedRecFldsFail06_A.hs b/tests/examples/ghc8/OverloadedRecFldsFail06_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/OverloadedRecFldsFail06_A.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -fwarn-unused-binds #-} - -module OverloadedRecFldsFail06_A (U(..), V(..), Unused(unused), u, getX, getY, z) where - -data U = MkU { x :: Bool, y :: Bool } | MkU2 { used_locally :: Bool } - deriving Show -data V = MkV { x :: Int } | MkV2 { y :: Bool } -data Unused = MkUnused { unused :: Bool, unused2 :: Bool, used_locally :: Bool } - -u = MkU False True - -z MkU2{used_locally=used_locally} = used_locally - -getX MkU{x=x} = x -getY MkV2{y=y} = y diff --git a/tests/examples/ghc8/OverloadedRecFldsFail10_A.hs b/tests/examples/ghc8/OverloadedRecFldsFail10_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/OverloadedRecFldsFail10_A.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module OverloadedRecFldsFail10_A where - -data family F a -data instance F Int = MkFInt { foo :: Int } diff --git a/tests/examples/ghc8/OverloadedRecFldsFail10_B.hs b/tests/examples/ghc8/OverloadedRecFldsFail10_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/OverloadedRecFldsFail10_B.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module OverloadedRecFldsFail10_B (F(..)) where - -import OverloadedRecFldsFail10_A hiding (foo) - -data instance F Bool = MkFBool { foo :: Int } diff --git a/tests/examples/ghc8/OverloadedRecFldsFail10_C.hs b/tests/examples/ghc8/OverloadedRecFldsFail10_C.hs deleted file mode 100644 --- a/tests/examples/ghc8/OverloadedRecFldsFail10_C.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} -module OverloadedRecFldsFail10_C (F(..)) where - -import OverloadedRecFldsFail10_A - -data instance F Char = MkFChar { foo :: Char } diff --git a/tests/examples/ghc8/OverloadedRecFldsFail11_A.hs b/tests/examples/ghc8/OverloadedRecFldsFail11_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/OverloadedRecFldsFail11_A.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module OverloadedRecFldsFail11_A where - -{-# WARNING foo "Warning on a record field" #-} -data S = MkS { foo :: Bool } -data T = MkT { foo :: Int } diff --git a/tests/examples/ghc8/OverloadedRecFldsFail12_A.hs b/tests/examples/ghc8/OverloadedRecFldsFail12_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/OverloadedRecFldsFail12_A.hs +++ /dev/null @@ -1,5 +0,0 @@ -module OverloadedRecFldsFail12_A where - -{-# WARNING foo "Deprecated foo" #-} -{-# WARNING bar "Deprecated bar" #-} -data T = MkT { foo :: Int, bar :: Int } diff --git a/tests/examples/ghc8/OverloadedRecFldsRun02_A.hs b/tests/examples/ghc8/OverloadedRecFldsRun02_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/OverloadedRecFldsRun02_A.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - -module OverloadedRecFldsRun02_A (U(..), V(MkV, x), Unused(..), u) where - -data U = MkU { x :: Bool, y :: Bool } -data V = MkV { x :: Int } -data Unused = MkUnused { unused :: Bool } - -u = MkU False True diff --git a/tests/examples/ghc8/P.hs b/tests/examples/ghc8/P.hs deleted file mode 100644 --- a/tests/examples/ghc8/P.hs +++ /dev/null @@ -1,12 +0,0 @@ -module P where - -import qualified Map -import qualified Set - -foo = do - let x = Map.insert 0 "foo" - . Map.insert (6 :: Int) "foo" - $ Map.empty - print (Map.lookup 1 x) - print (Set.size (Map.keysSet x)) - return x diff --git a/tests/examples/ghc8/PSQ.hs b/tests/examples/ghc8/PSQ.hs deleted file mode 100644 --- a/tests/examples/ghc8/PSQ.hs +++ /dev/null @@ -1,4 +0,0 @@ - -data TourView a = Null - | Single {-# UNPACK #-} !(Elem a) - | (PSQ a) `Play` (PSQ a) diff --git a/tests/examples/ghc8/ParenFunBind.hs b/tests/examples/ghc8/ParenFunBind.hs deleted file mode 100644 --- a/tests/examples/ghc8/ParenFunBind.hs +++ /dev/null @@ -1,5 +0,0 @@ -module ParenFunBind where - -(foo x) y = x + y -((bar x)) y = x + y -((baz x)) (y) = x + y diff --git a/tests/examples/ghc8/ParenTypeSynonym.hs b/tests/examples/ghc8/ParenTypeSynonym.hs deleted file mode 100644 --- a/tests/examples/ghc8/ParenTypeSynonym.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -module ParenTypeSynonym where - -type Is = (~) diff --git a/tests/examples/ghc8/PartialClassMethodSignature2.hs b/tests/examples/ghc8/PartialClassMethodSignature2.hs deleted file mode 100644 --- a/tests/examples/ghc8/PartialClassMethodSignature2.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -module PartialClassMethodSignature2 where - -class Foo a where - foo :: (Eq a, _) => a -> a diff --git a/tests/examples/ghc8/PluralS.hs b/tests/examples/ghc8/PluralS.hs deleted file mode 100644 --- a/tests/examples/ghc8/PluralS.hs +++ /dev/null @@ -1,27 +0,0 @@ --- Test purpose: --- --- Ensure the plural "s" in warnings is only shown if there are more than --- one entries - -{-# OPTIONS_GHC -Wredundant-constraints #-} -{-# OPTIONS_GHC -Wtype-defaults #-} - -module PluralS () where - - - --- Defaulting type classes - -defaultingNum = 123 `seq` () - -defaultingNumAndShow = show 123 - - - --- Redundant constraints - -redundantNum :: (Num a, Num a) => a -redundantNum = 123 - -redundantMultiple :: (Num a, Show a, Num a, Eq a, Eq a) => a -redundantMultiple = 123 diff --git a/tests/examples/ghc8/PolyInstances.hs b/tests/examples/ghc8/PolyInstances.hs deleted file mode 100644 --- a/tests/examples/ghc8/PolyInstances.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE PolyKinds, FlexibleInstances, ScopedTypeVariables, - UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module PolyInstances where - -import GHC.Exts -import Data.Proxy - -class C (a :: k) - -instance (C a, C b) => C (a b) - -data Dict :: Constraint -> * - -instance C Dict - -foo :: C p => proxy p -> () -foo = undefined - -bar :: forall (p :: Constraint) proxy. C p => proxy p -> () -bar _ = foo (Proxy :: Proxy (Dict p)) diff --git a/tests/examples/ghc8/PopCnt.hs b/tests/examples/ghc8/PopCnt.hs deleted file mode 100644 --- a/tests/examples/ghc8/PopCnt.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-} -module Main where - -import GHC.Exts - -foreign import prim "do_popcnt32" popcnt32 :: Int# -> Int# - -main = print (I# (popcnt32 0xffff#)) - diff --git a/tests/examples/ghc8/Ppr017.hs b/tests/examples/ghc8/Ppr017.hs deleted file mode 100644 --- a/tests/examples/ghc8/Ppr017.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ExplicitNamespaces #-} -module Imports( f, type (+), pattern Single ) where - -import GHC.TypeLits - -pattern Single x = [x] - -f = undefined diff --git a/tests/examples/ghc8/Primop.hs b/tests/examples/ghc8/Primop.hs deleted file mode 100644 --- a/tests/examples/ghc8/Primop.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE GHCForeignImportPrim, MagicHash, - UnliftedFFITypes, UnboxedTuples #-} - -import GHC.Exts - -foreign import prim "dummy" - dummy :: Word# -> Word# - -foreign import prim "dummy2" - dummy2 :: Any -> State# RealWorld -> (# State# RealWorld, Word# #) diff --git a/tests/examples/ghc8/Printf.hs b/tests/examples/ghc8/Printf.hs deleted file mode 100644 --- a/tests/examples/ghc8/Printf.hs +++ /dev/null @@ -1,34 +0,0 @@ --- Copyright (C) 2015, Luke Iannini - -{-# LANGUAGE TemplateHaskell #-} -module Printf where - --- Skeletal printf from the paper: --- http://research.microsoft.com/pubs/67015/meta-haskell.pdf --- It needs to be in a separate module to the one where --- you intend to use it. - --- Import some Template Haskell syntax -import Language.Haskell.TH - --- Describe a format string -data Format = D | S | L String - --- Parse a format string. This is left largely to you --- as we are here interested in building our first ever --- Template Haskell program and not in building printf. -parse :: String -> [Format] -parse s = [ L s ] - --- Generate Haskell source code from a parsed representation --- of the format string. This code will be spliced into --- the module which calls "pr", at compile time. -gen :: [Format] -> Q Exp -gen [D] = [| \n -> show n |] -gen [S] = [| \s -> s |] -gen [L s] = stringE s - --- Here we generate the Haskell code for the splice --- from an input format string. -pr :: String -> Q Exp -pr s = gen (parse s) diff --git a/tests/examples/ghc8/PromotedClass.hs b/tests/examples/ghc8/PromotedClass.hs deleted file mode 100644 --- a/tests/examples/ghc8/PromotedClass.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeInType, GADTs #-} - -module PromotedClass where - -import Data.Proxy - -data X a where - MkX :: Show a => a -> X a - -foo :: Proxy ('MkX 'True) -foo = Proxy diff --git a/tests/examples/ghc8/Q.hs b/tests/examples/ghc8/Q.hs deleted file mode 100644 --- a/tests/examples/ghc8/Q.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Q where - -import qualified Map -import Map(Map) - -mymember :: Int -> Map Int a -> Bool -mymember k m = Map.member k m || Map.member (k + 1) m diff --git a/tests/examples/ghc8/QQ.hs b/tests/examples/ghc8/QQ.hs deleted file mode 100644 --- a/tests/examples/ghc8/QQ.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module QQ where - -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import Language.Haskell.TH - -pq = QuasiQuoter { quoteDec = \_ -> return [sig], - quoteType = \_ -> undefined, - quoteExp = \_ -> undefined, - quotePat = \_ -> undefined } - -sig = SigD (mkName "f") (ArrowT `AppT` int `AppT` int) -int = ConT (mkName "Int") diff --git a/tests/examples/ghc8/Query.hs b/tests/examples/ghc8/Query.hs deleted file mode 100644 --- a/tests/examples/ghc8/Query.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE CPP #-} - -module AWS.Lib.Query where - -requestQuery = do - if st < 400 -#ifdef DEBUG - do e -#else - then return body - else fail "not reached" -#endif - diff --git a/tests/examples/ghc8/RAE_T32a.hs b/tests/examples/ghc8/RAE_T32a.hs deleted file mode 100644 --- a/tests/examples/ghc8/RAE_T32a.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds, - PolyKinds, TypeFamilies, GADTs, TypeInType #-} - -module RAE_T32a where - -import Data.Kind - -data family Sing (k :: *) :: k -> * - -data TyArr' (a :: *) (b :: *) :: * -type TyArr (a :: *) (b :: *) = TyArr' a b -> * -type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2 -data TyPi' (a :: *) (b :: TyArr a *) :: * -type TyPi (a :: *) (b :: TyArr a *) = TyPi' a b -> * -type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b -$(return []) - -data MkStar (p :: *) (x :: TyArr' p *) -type instance MkStar p @@ x = * -$(return []) - -data Sigma (p :: *) (r :: TyPi p (MkStar p)) :: * where - Sigma :: - forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a). - Sing * p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b -> Sigma p r -$(return []) - -data instance Sing Sigma (Sigma p r) x where - SSigma :: - forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a) - (sp :: Sing * p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) (sb :: Sing (r @@@ a) b). - Sing (Sing (r @@@ a) b) sb -> - Sing (Sigma p r) ('Sigma sp sr sa sb) - --- I (RAE) believe this last definition is ill-typed. diff --git a/tests/examples/ghc8/RAE_T32b.hs b/tests/examples/ghc8/RAE_T32b.hs deleted file mode 100644 --- a/tests/examples/ghc8/RAE_T32b.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, DataKinds, PolyKinds, - RankNTypes, TypeOperators, TypeInType #-} - -module RAE_T32b where - -import Data.Kind - -data family Sing (k :: *) :: k -> * - -data TyArr (a :: *) (b :: *) :: * -type family (a :: TyArr k1 k2 -> *) @@ (b :: k1) :: k2 -$(return []) - -data Sigma (p :: *) (r :: TyArr p * -> *) :: * where - Sigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a). - Sing * p -> Sing (TyArr p * -> *) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r -$(return []) - -data instance Sing (Sigma p r) (x :: Sigma p r) :: * where - SSigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a) - (sp :: Sing * p) (sr :: Sing (TyArr p * -> *) r) (sa :: Sing p a) (sb :: Sing (r @@ a) b). - Sing (Sing (r @@ a) b) sb -> - Sing (Sigma p r) ('Sigma sp sr sa sb) diff --git a/tests/examples/ghc8/Rae31.hs b/tests/examples/ghc8/Rae31.hs deleted file mode 100644 --- a/tests/examples/ghc8/Rae31.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds, - TypeFamilies, TypeInType #-} - -module A where - -import Data.Kind - -data family Sing (k :: *) :: k -> * -type Sing' (x :: k) = Sing k x -data TyFun' (a :: *) (b :: *) :: * -type TyFun (a :: *) (b :: *) = TyFun' a b -> * -type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2 -data TyPi' (a :: *) (b :: TyFun a *) :: * -type TyPi (a :: *) (b :: TyFun a *) = TyPi' a b -> * -type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b -$(return []) - -data A (a :: *) (b :: a) (c :: TyFun' a *) -- A :: forall a -> a -> a ~> * -type instance (@@) (A a b) c = * -$(return []) -data B (a :: *) (b :: TyFun' a *) -- B :: forall a -> a ~> * -type instance (@@) (B a) b = TyPi a (A a b) -$(return []) -data C (a :: *) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) *) diff --git a/tests/examples/ghc8/RaeBlogPost.hs b/tests/examples/ghc8/RaeBlogPost.hs deleted file mode 100644 --- a/tests/examples/ghc8/RaeBlogPost.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies, - TypeInType #-} -{-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-} - -module RaeBlogPost where - -import Data.Kind - --- a Proxy type with an explicit kind -data Proxy k (a :: k) = P -prox :: Proxy * Bool -prox = P - -prox2 :: Proxy Bool 'True -prox2 = P - --- implicit kinds still work -data A -data B :: A -> * -data C :: B a -> * -data D :: C b -> * -data E :: D c -> * --- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> * - --- a kind-indexed GADT -data TypeRep (a :: k) where - TInt :: TypeRep Int - TMaybe :: TypeRep Maybe - TApp :: TypeRep a -> TypeRep b -> TypeRep (a b) - -zero :: TypeRep a -> a -zero TInt = 0 -zero (TApp TMaybe _) = Nothing - -data Nat = Zero | Succ Nat -type family a + b where - 'Zero + b = b - ('Succ a) + b = 'Succ (a + b) - -data Vec :: * -> Nat -> * where - Nil :: Vec a 'Zero - (:>) :: a -> Vec a n -> Vec a ('Succ n) -infixr 5 :> - --- promoted GADT, and using + as a "kind family": -type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where - 'Nil ++ y = y - (h ':> t) ++ y = h ':> (t ++ y) - --- datatype that mentions * -data U = Star (*) - | Bool Bool - --- kind synonym -type Monadish = * -> * -class MonadTrans (t :: Monadish -> Monadish) where - lift :: Monad m => m a -> t m a -data Free :: Monadish where - Return :: a -> Free a - Bind :: Free a -> (a -> Free b) -> Free b - --- yes, * really does have type *. -type Star = (* :: (* :: (* :: *))) diff --git a/tests/examples/ghc8/RandomPGC.hs b/tests/examples/ghc8/RandomPGC.hs deleted file mode 100644 --- a/tests/examples/ghc8/RandomPGC.hs +++ /dev/null @@ -1,597 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : System.Random --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE in the 'random' repository) --- --- Maintainer : libraries@haskell.org --- Stability : stable --- Portability : portable --- --- This library deals with the common task of pseudo-random number --- generation. The library makes it possible to generate repeatable --- results, by starting with a specified initial random number generator, --- or to get different results on each run by using the system-initialised --- generator or by supplying a seed from some other source. --- --- The library is split into two layers: --- --- * A core /random number generator/ provides a supply of bits. --- The class 'RandomGen' provides a common interface to such generators. --- The library provides one instance of 'RandomGen', the abstract --- data type 'StdGen'. Programmers may, of course, supply their own --- instances of 'RandomGen'. --- --- * The class 'Random' provides a way to extract values of a particular --- type from a random number generator. For example, the 'Float' --- instance of 'Random' allows one to generate random values of type --- 'Float'. --- --- This implementation uses the Portable Combined Generator of L'Ecuyer --- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by --- Lennart Augustsson. It has a period of roughly 2.30584e18. --- ------------------------------------------------------------------------------ - -#include "MachDeps.h" - -module RandomPGC - ( - - -- $intro - - -- * Random number generators - -#ifdef ENABLE_SPLITTABLEGEN - RandomGen(next, genRange) - , SplittableGen(split) -#else - RandomGen(next, genRange, split) -#endif - -- ** Standard random number generators - , StdGen - , mkStdGen - - -- ** The global random number generator - - -- $globalrng - - , getStdRandom - , getStdGen - , setStdGen - , newStdGen - - -- * Random values of various types - , Random ( random, randomR, - randoms, randomRs, - randomIO, randomRIO ) - - -- * References - -- $references - - ) where - -import Prelude - -import Data.Bits -import Data.Int -import Data.Word -import Foreign.C.Types - -#ifdef __NHC__ -import CPUTime ( getCPUTime ) -import Foreign.Ptr ( Ptr, nullPtr ) -import Foreign.C ( CTime, CUInt ) -#else -import System.CPUTime ( getCPUTime ) -import Data.Time ( getCurrentTime, UTCTime(..) ) -import Data.Ratio ( numerator, denominator ) -#endif -import Data.Char ( isSpace, chr, ord ) -import System.IO.Unsafe ( unsafePerformIO ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) -import Data.IORef ( atomicModifyIORef' ) -import Numeric ( readDec ) - -#ifdef __GLASGOW_HASKELL__ -import GHC.Exts ( build ) -#else --- | A dummy variant of build without fusion. -{-# INLINE build #-} -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build g = g (:) [] -#endif - --- The standard nhc98 implementation of Time.ClockTime does not match --- the extended one expected in this module, so we lash-up a quick --- replacement here. -#ifdef __NHC__ -foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime -getTime :: IO (Integer, Integer) -getTime = do CTime t <- readtime nullPtr; return (toInteger t, 0) -#else -getTime :: IO (Integer, Integer) -getTime = do - utc <- getCurrentTime - let daytime = toRational $ utctDayTime utc - return $ quotRem (numerator daytime) (denominator daytime) -#endif - --- | The class 'RandomGen' provides a common interface to random number --- generators. --- -#ifdef ENABLE_SPLITTABLEGEN --- Minimal complete definition: 'next'. -#else --- Minimal complete definition: 'next' and 'split'. -#endif - -class RandomGen g where - - -- |The 'next' operation returns an 'Int' that is uniformly distributed - -- in the range returned by 'genRange' (including both end points), - -- and a new generator. - next :: g -> (Int, g) - - -- |The 'genRange' operation yields the range of values returned by - -- the generator. - -- - -- It is required that: - -- - -- * If @(a,b) = 'genRange' g@, then @a < b@. - -- - -- * 'genRange' always returns a pair of defined 'Int's. - -- - -- The second condition ensures that 'genRange' cannot examine its - -- argument, and hence the value it returns can be determined only by the - -- instance of 'RandomGen'. That in turn allows an implementation to make - -- a single call to 'genRange' to establish a generator's range, without - -- being concerned that the generator returned by (say) 'next' might have - -- a different range to the generator passed to 'next'. - -- - -- The default definition spans the full range of 'Int'. - genRange :: g -> (Int,Int) - - -- default method - genRange _ = (minBound, maxBound) - -#ifdef ENABLE_SPLITTABLEGEN --- | The class 'SplittableGen' proivides a way to specify a random number --- generator that can be split into two new generators. -class SplittableGen g where -#endif - -- |The 'split' operation allows one to obtain two distinct random number - -- generators. This is very useful in functional programs (for example, when - -- passing a random number generator down to recursive calls), but very - -- little work has been done on statistically robust implementations of - -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"] - -- are the only examples we know of). - split :: g -> (g, g) - -{- | -The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits. - -The result of repeatedly using 'next' should be at least as statistically -robust as the /Minimal Standard Random Number Generator/ described by -["System.Random\#Park", "System.Random\#Carta"]. -Until more is known about implementations of 'split', all we require is -that 'split' deliver generators that are (a) not identical and -(b) independently robust in the sense just given. - -The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the -state of a random number generator. -It is required that @'read' ('show' g) == g@. - -In addition, 'reads' may be used to map an arbitrary string (not necessarily one -produced by 'show') onto a value of type 'StdGen'. In general, the 'Read' -instance of 'StdGen' has the following properties: - -* It guarantees to succeed on any string. - -* It guarantees to consume only a finite portion of the string. - -* Different argument strings are likely to result in different results. - --} - -data StdGen - = StdGen !Int32 !Int32 - -instance RandomGen StdGen where - next = stdNext - genRange _ = stdRange - -#ifdef ENABLE_SPLITTABLEGEN -instance SplittableGen StdGen where -#endif - split = stdSplit - -instance Show StdGen where - showsPrec p (StdGen s1 s2) = - showsPrec p s1 . - showChar ' ' . - showsPrec p s2 - -instance Read StdGen where - readsPrec _p = \ r -> - case try_read r of - r'@[_] -> r' - _ -> [stdFromString r] -- because it shouldn't ever fail. - where - try_read r = do - (s1, r1) <- readDec (dropWhile isSpace r) - (s2, r2) <- readDec (dropWhile isSpace r1) - return (StdGen s1 s2, r2) - -{- - If we cannot unravel the StdGen from a string, create - one based on the string given. --} -stdFromString :: String -> (StdGen, String) -stdFromString s = (mkStdGen num, rest) - where (cs, rest) = splitAt 6 s - num = foldl (\a x -> x + 3 * a) 1 (map ord cs) - - -{- | -The function 'mkStdGen' provides an alternative way of producing an initial -generator, by mapping an 'Int' into a generator. Again, distinct arguments -should be likely to produce distinct generators. --} -mkStdGen :: Int -> StdGen -- why not Integer ? -mkStdGen s = mkStdGen32 $ fromIntegral s - -{- -From ["System.Random\#LEcuyer"]: "The integer variables s1 and s2 ... must be -initialized to values in the range [1, 2147483562] and [1, 2147483398] -respectively." --} -mkStdGen32 :: Int32 -> StdGen -mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1) - where - -- We want a non-negative number, but we can't just take the abs - -- of sMaybeNegative as -minBound == minBound. - s = sMaybeNegative .&. maxBound - (q, s1) = s `divMod` 2147483562 - s2 = q `mod` 2147483398 - -createStdGen :: Integer -> StdGen -createStdGen s = mkStdGen32 $ fromIntegral s - -{- | -With a source of random number supply in hand, the 'Random' class allows the -programmer to extract random values of a variety of types. - -Minimal complete definition: 'randomR' and 'random'. - --} - -class Random a where - -- | Takes a range /(lo,hi)/ and a random number generator - -- /g/, and returns a random value uniformly distributed in the closed - -- interval /[lo,hi]/, together with a new generator. It is unspecified - -- what happens if /lo>hi/. For continuous types there is no requirement - -- that the values /lo/ and /hi/ are ever produced, but they may be, - -- depending on the implementation and the interval. - randomR :: RandomGen g => (a,a) -> g -> (a,g) - - -- | The same as 'randomR', but using a default range determined by the type: - -- - -- * For bounded types (instances of 'Bounded', such as 'Char'), - -- the range is normally the whole type. - -- - -- * For fractional types, the range is normally the semi-closed interval - -- @[0,1)@. - -- - -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. - random :: RandomGen g => g -> (a, g) - - -- | Plural variant of 'randomR', producing an infinite list of - -- random values instead of returning a new generator. - {-# INLINE randomRs #-} - randomRs :: RandomGen g => (a,a) -> g -> [a] - randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g) - - -- | Plural variant of 'random', producing an infinite list of - -- random values instead of returning a new generator. - {-# INLINE randoms #-} - randoms :: RandomGen g => g -> [a] - randoms g = build (\cons _nil -> buildRandoms cons random g) - - -- | A variant of 'randomR' that uses the global random number generator - -- (see "System.Random#globalrng"). - randomRIO :: (a,a) -> IO a - randomRIO range = getStdRandom (randomR range) - - -- | A variant of 'random' that uses the global random number generator - -- (see "System.Random#globalrng"). - randomIO :: IO a - randomIO = getStdRandom random - --- | Produce an infinite list-equivalent of random values. -{-# INLINE buildRandoms #-} -buildRandoms :: RandomGen g - => (a -> as -> as) -- ^ E.g. '(:)' but subject to fusion - -> (g -> (a,g)) -- ^ E.g. 'random' - -> g -- ^ A 'RandomGen' instance - -> as -buildRandoms cons rand = go - where - -- The seq fixes part of #4218 and also makes fused Core simpler. - go g = x `seq` (x `cons` go g') where (x,g') = rand g - - -instance Random Integer where - randomR ival g = randomIvalInteger ival g - random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g - -instance Random Int where randomR = randomIvalIntegral; random = randomBounded -instance Random Int8 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int16 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int32 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int64 where randomR = randomIvalIntegral; random = randomBounded - -#ifndef __NHC__ --- Word is a type synonym in nhc98. -instance Random Word where randomR = randomIvalIntegral; random = randomBounded -#endif -instance Random Word8 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word16 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word32 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word64 where randomR = randomIvalIntegral; random = randomBounded - -instance Random CChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CSChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CUChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CShort where randomR = randomIvalIntegral; random = randomBounded -instance Random CUShort where randomR = randomIvalIntegral; random = randomBounded -instance Random CInt where randomR = randomIvalIntegral; random = randomBounded -instance Random CUInt where randomR = randomIvalIntegral; random = randomBounded -instance Random CLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CULong where randomR = randomIvalIntegral; random = randomBounded -instance Random CPtrdiff where randomR = randomIvalIntegral; random = randomBounded -instance Random CSize where randomR = randomIvalIntegral; random = randomBounded -instance Random CWchar where randomR = randomIvalIntegral; random = randomBounded -instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded -instance Random CLLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CULLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CIntPtr where randomR = randomIvalIntegral; random = randomBounded -instance Random CUIntPtr where randomR = randomIvalIntegral; random = randomBounded -instance Random CIntMax where randomR = randomIvalIntegral; random = randomBounded -instance Random CUIntMax where randomR = randomIvalIntegral; random = randomBounded - -instance Random Char where - randomR (a,b) g = - case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of - (x,g') -> (chr x, g') - random g = randomR (minBound,maxBound) g - -instance Random Bool where - randomR (a,b) g = - case (randomIvalInteger (bool2Int a, bool2Int b) g) of - (x, g') -> (int2Bool x, g') - where - bool2Int :: Bool -> Integer - bool2Int False = 0 - bool2Int True = 1 - - int2Bool :: Int -> Bool - int2Bool 0 = False - int2Bool _ = True - - random g = randomR (minBound,maxBound) g - -{-# INLINE randomRFloating #-} -randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g) -randomRFloating (l,h) g - | l>h = randomRFloating (h,l) g - | otherwise = let (coef,g') = random g in - (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g') -- avoid overflow - -instance Random Double where - randomR = randomRFloating - random rng = - case random rng of - (x,rng') -> - -- We use 53 bits of randomness corresponding to the 53 bit significand: - ((fromIntegral (mask53 .&. (x::Int64)) :: Double) - / fromIntegral twoto53, rng') - where - twoto53 = (2::Int64) ^ (53::Int64) - mask53 = twoto53 - 1 - -instance Random Float where - randomR = randomRFloating - random rng = - -- TODO: Faster to just use 'next' IF it generates enough bits of randomness. - case random rng of - (x,rng') -> - -- We use 24 bits of randomness corresponding to the 24 bit significand: - ((fromIntegral (mask24 .&. (x::Int32)) :: Float) - / fromIntegral twoto24, rng') - -- Note, encodeFloat is another option, but I'm not seeing slightly - -- worse performance with the following [2011.06.25]: --- (encodeFloat rand (-24), rng') - where - mask24 = twoto24 - 1 - twoto24 = (2::Int32) ^ (24::Int32) - --- CFloat/CDouble are basically the same as a Float/Double: -instance Random CFloat where - randomR = randomRFloating - random rng = case random rng of - (x,rng') -> (realToFrac (x::Float), rng') - -instance Random CDouble where - randomR = randomRFloating - -- A MYSTERY: - -- Presently, this is showing better performance than the Double instance: - -- (And yet, if the Double instance uses randomFrac then its performance is much worse!) - random = randomFrac - -- random rng = case random rng of - -- (x,rng') -> (realToFrac (x::Double), rng') - -mkStdRNG :: Integer -> IO StdGen -mkStdRNG o = do - ct <- getCPUTime - (sec, psec) <- getTime - return (createStdGen (sec * 12345 + psec + ct + o)) - -randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g) -randomBounded = randomR (minBound, maxBound) - --- The two integer functions below take an [inclusive,inclusive] range. -randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g) -randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h) - -{-# SPECIALIZE randomIvalInteger :: (Num a) => - (Integer, Integer) -> StdGen -> (a, StdGen) #-} - -randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) -randomIvalInteger (l,h) rng - | l > h = randomIvalInteger (h,l) rng - | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') - where - (genlo, genhi) = genRange rng - b = fromIntegral genhi - fromIntegral genlo + 1 - - -- Probabilities of the most likely and least likely result - -- will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen - -- is uniform, of course - - -- On average, log q / log b more random values will be generated - -- than the minimum - q = 1000 - k = h - l + 1 - magtgt = k * q - - -- generate random values until we exceed the target magnitude - f mag v g | mag >= magtgt = (v, g) - | otherwise = v' `seq`f (mag*b) v' g' where - (x,g') = next g - v' = (v * b + (fromIntegral x - fromIntegral genlo)) - - --- The continuous functions on the other hand take an [inclusive,exclusive) range. -randomFrac :: (RandomGen g, Fractional a) => g -> (a, g) -randomFrac = randomIvalDouble (0::Double,1) realToFrac - -randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g) -randomIvalDouble (l,h) fromDouble rng - | l > h = randomIvalDouble (h,l) fromDouble rng - | otherwise = - case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of - (x, rng') -> - let - scaled_x = - fromDouble (0.5*l + 0.5*h) + -- previously (l+h)/2, overflowed - fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) * -- avoid overflow - fromIntegral (x::Int32) - in - (scaled_x, rng') - -int32Count :: Integer -int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1 -- GHC ticket #3982 - -stdRange :: (Int,Int) -stdRange = (1, 2147483562) - -stdNext :: StdGen -> (Int, StdGen) --- Returns values in the range stdRange -stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'') - where z' = if z < 1 then z + 2147483562 else z - z = s1'' - s2'' - - k = s1 `quot` 53668 - s1' = 40014 * (s1 - k * 53668) - k * 12211 - s1'' = if s1' < 0 then s1' + 2147483563 else s1' - - k' = s2 `quot` 52774 - s2' = 40692 * (s2 - k' * 52774) - k' * 3791 - s2'' = if s2' < 0 then s2' + 2147483399 else s2' - -stdSplit :: StdGen -> (StdGen, StdGen) -stdSplit std@(StdGen s1 s2) - = (left, right) - where - -- no statistical foundation for this! - left = StdGen new_s1 t2 - right = StdGen t1 new_s2 - - new_s1 | s1 == 2147483562 = 1 - | otherwise = s1 + 1 - - new_s2 | s2 == 1 = 2147483398 - | otherwise = s2 - 1 - - StdGen t1 t2 = snd (next std) - --- The global random number generator - -{- $globalrng #globalrng# - -There is a single, implicit, global random number generator of type -'StdGen', held in some global variable maintained by the 'IO' monad. It is -initialised automatically in some system-dependent fashion, for example, by -using the time of day, or Linux's kernel random number generator. To get -deterministic behaviour, use 'setStdGen'. --} - --- |Sets the global random number generator. -setStdGen :: StdGen -> IO () -setStdGen sgen = writeIORef theStdGen sgen - --- |Gets the global random number generator. -getStdGen :: IO StdGen -getStdGen = readIORef theStdGen - -theStdGen :: IORef StdGen -theStdGen = unsafePerformIO $ do - rng <- mkStdRNG 0 - newIORef rng - --- |Applies 'split' to the current global random generator, --- updates it with one of the results, and returns the other. -newStdGen :: IO StdGen -newStdGen = atomicModifyIORef' theStdGen split - -{- |Uses the supplied function to get a value from the current global -random generator, and updates the global generator with the new generator -returned by the function. For example, @rollDice@ gets a random integer -between 1 and 6: - -> rollDice :: IO Int -> rollDice = getStdRandom (randomR (1,6)) - --} - -getStdRandom :: (StdGen -> (a,StdGen)) -> IO a -getStdRandom f = atomicModifyIORef' theStdGen (swap . f) - where swap (v,g) = (g,v) - -{- $references - -1. FW #Burton# Burton and RL Page, /Distributed random number generation/, -Journal of Functional Programming, 2(2):203-212, April 1992. - -2. SK #Park# Park, and KW Miller, /Random number generators - -good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201. - -3. DG #Carta# Carta, /Two fast implementations of the minimal standard -random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88. - -4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/, -Department of Mathematics, University of Salzburg, -, 1998. - -5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random -number generators/, Comm ACM, 31(6), Jun 1988, pp742-749. - -The Web site is a great source of information. - --} diff --git a/tests/examples/ghc8/RenamingStar.hs b/tests/examples/ghc8/RenamingStar.hs deleted file mode 100644 --- a/tests/examples/ghc8/RenamingStar.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module RenamingStar where - -data Foo :: * diff --git a/tests/examples/ghc8/RepArrow.hs b/tests/examples/ghc8/RepArrow.hs deleted file mode 100644 --- a/tests/examples/ghc8/RepArrow.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module RepArrow where - -import Data.Ord ( Down ) -- convenient "Id" newtype, without its constructor -import Data.Coerce - -foo :: Coercible (Down (Int -> Int)) (Int -> Int) => Down (Int -> Int) -> Int -> Int -foo = coerce diff --git a/tests/examples/ghc8/Roles12a.hs b/tests/examples/ghc8/Roles12a.hs deleted file mode 100644 --- a/tests/examples/ghc8/Roles12a.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Roles12a where -import {-# SOURCE #-} Roles12 diff --git a/tests/examples/ghc8/RuleDefiningPlugin.hs b/tests/examples/ghc8/RuleDefiningPlugin.hs deleted file mode 100644 --- a/tests/examples/ghc8/RuleDefiningPlugin.hs +++ /dev/null @@ -1,8 +0,0 @@ -module RuleDefiningPlugin where - -import GhcPlugins - -{-# RULES "unsound" forall x. show x = "SHOWED" #-} - -plugin :: Plugin -plugin = defaultPlugin diff --git a/tests/examples/ghc8/RulePragma.hs b/tests/examples/ghc8/RulePragma.hs deleted file mode 100644 --- a/tests/examples/ghc8/RulePragma.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Data.Text.Internal.Fusion.Common where - -{-# - RULES "STREAM map/map fusion" forall f g s. - map f (map g s) = map (\x -> f (g x)) s - #-} - diff --git a/tests/examples/ghc8/SH_Overlap1.hs b/tests/examples/ghc8/SH_Overlap1.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap1.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Compilation should fail as we have overlapping instances that don't obey --- our heuristics. -module SH_Overlap1 where - -import safe SH_Overlap1_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc8/SH_Overlap10.hs b/tests/examples/ghc8/SH_Overlap10.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap10.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as `SH_Overlap6`, but now we are inferring safety. Safe since --- overlapped instance declares itself overlappable. -module SH_Overlap10 where - -import SH_Overlap10_A - -instance - {-# OVERLAPS #-} - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc8/SH_Overlap10_A.hs b/tests/examples/ghc8/SH_Overlap10_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap10_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap10_A ( - C(..) - ) where - -import SH_Overlap10_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc8/SH_Overlap10_B.hs b/tests/examples/ghc8/SH_Overlap10_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap10_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -module SH_Overlap10_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc8/SH_Overlap11.hs b/tests/examples/ghc8/SH_Overlap11.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap11.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred --- unsafe due to overlapping instances at call site `f`. --- --- Testing that we are given correct reason. -module SH_Overlap11 where - -import SH_Overlap11_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc8/SH_Overlap11_A.hs b/tests/examples/ghc8/SH_Overlap11_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap11_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap11_A ( - C(..) - ) where - -import SH_Overlap11_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc8/SH_Overlap11_B.hs b/tests/examples/ghc8/SH_Overlap11_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap11_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -module SH_Overlap11_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc8/SH_Overlap1_A.hs b/tests/examples/ghc8/SH_Overlap1_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap1_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap1_A ( - C(..) - ) where - -import SH_Overlap1_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc8/SH_Overlap1_B.hs b/tests/examples/ghc8/SH_Overlap1_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap1_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Safe #-} -module SH_Overlap1_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc8/SH_Overlap2.hs b/tests/examples/ghc8/SH_Overlap2.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap2.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as SH_Overlap1, but SH_Overlap2_A is not imported as 'safe'. --- --- Question: Should the OI-check be enforced? Y, see reasoning in --- `SH_Overlap4.hs` for why the Safe Haskell overlapping instance check should --- be tied to Safe Haskell mode only, and not to safe imports. -module SH_Overlap2 where - -import SH_Overlap2_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc8/SH_Overlap2_A.hs b/tests/examples/ghc8/SH_Overlap2_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap2_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap2_A ( - C(..) - ) where - -import SH_Overlap2_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc8/SH_Overlap2_B.hs b/tests/examples/ghc8/SH_Overlap2_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap2_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Safe #-} -module SH_Overlap2_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc8/SH_Overlap3.hs b/tests/examples/ghc8/SH_Overlap3.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap3.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE Unsafe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as SH_Overlap1, but module where overlap occurs (SH_Overlap3) is --- marked `Unsafe`. Compilation should succeed (symetry with inferring safety). -module SH_Overlap3 where - -import SH_Overlap3_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc8/SH_Overlap3_A.hs b/tests/examples/ghc8/SH_Overlap3_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap3_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap3_A ( - C(..) - ) where - -import SH_Overlap3_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc8/SH_Overlap3_B.hs b/tests/examples/ghc8/SH_Overlap3_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap3_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Safe #-} -module SH_Overlap3_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc8/SH_Overlap4.hs b/tests/examples/ghc8/SH_Overlap4.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap4.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE Unsafe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as SH_Overlap3, however, SH_Overlap4_A is imported as `safe`. --- --- Question: Should compilation now fail? N. At first it seems a nice idea to --- tie the overlap check to safe imports. However, instances are a global --- entity and can be imported by multiple import paths. How should safe imports --- interact with this? Especially when considering transitive situations... --- --- Simplest is to just enforce the overlap check in Safe and Trustworthy --- modules, but not in Unsafe ones. -module SH_Overlap4 where - -import safe SH_Overlap4_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc8/SH_Overlap4_A.hs b/tests/examples/ghc8/SH_Overlap4_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap4_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap4_A ( - C(..) - ) where - -import SH_Overlap4_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc8/SH_Overlap4_B.hs b/tests/examples/ghc8/SH_Overlap4_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap4_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Safe #-} -module SH_Overlap4_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc8/SH_Overlap5.hs b/tests/examples/ghc8/SH_Overlap5.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap5.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Compilation should fail as we have overlapping instances that don't obey --- our heuristics. -module SH_Overlap5 where - -import safe SH_Overlap5_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc8/SH_Overlap5_A.hs b/tests/examples/ghc8/SH_Overlap5_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap5_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap5_A ( - C(..) - ) where - -import SH_Overlap5_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc8/SH_Overlap5_B.hs b/tests/examples/ghc8/SH_Overlap5_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap5_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Safe #-} -module SH_Overlap5_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc8/SH_Overlap6.hs b/tests/examples/ghc8/SH_Overlap6.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap6.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as `SH_Overlap5` but dependencies are now inferred-safe, not --- explicitly marked. Compilation should still fail. -module SH_Overlap6 where - -import safe SH_Overlap6_A - -instance C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc8/SH_Overlap6_A.hs b/tests/examples/ghc8/SH_Overlap6_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap6_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap6_A ( - C(..) - ) where - -import SH_Overlap6_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc8/SH_Overlap6_B.hs b/tests/examples/ghc8/SH_Overlap6_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap6_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -module SH_Overlap6_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc8/SH_Overlap7.hs b/tests/examples/ghc8/SH_Overlap7.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap7.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred --- unsafe due to overlapping instances at call site `f`. -module SH_Overlap7 where - -import SH_Overlap7_A - -instance C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc8/SH_Overlap7_A.hs b/tests/examples/ghc8/SH_Overlap7_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap7_A.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Safe #-} -module SH_Overlap7_A ( - C(..) - ) where - -import SH_Overlap7_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc8/SH_Overlap7_B.hs b/tests/examples/ghc8/SH_Overlap7_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap7_B.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE Safe #-} -module SH_Overlap7_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc8/SH_Overlap8.hs b/tests/examples/ghc8/SH_Overlap8.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap8.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Overlapping instances, but with a single parameter type-class and no --- orphans. So `SH_Overlap8` decided to explictly depend on `SH_Overlap8_A` --- since that's where the type-class `C` with function `f` is defined. --- --- Question: Safe or Unsafe? Safe -module SH_Overlap8 where - -import safe SH_Overlap8_A - -instance C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc8/SH_Overlap8_A.hs b/tests/examples/ghc8/SH_Overlap8_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap8_A.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap8_A ( - C(..) - ) where - -class C a where - f :: a -> String - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc8/SH_Overlap9.hs b/tests/examples/ghc8/SH_Overlap9.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap9.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# OPTIONS_GHC -fwarn-safe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred --- unsafe due to overlapping instances at call site `f`. -module SH_Overlap9 where - -import SH_Overlap9_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc8/SH_Overlap9_A.hs b/tests/examples/ghc8/SH_Overlap9_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap9_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap9_A ( - C(..) - ) where - -import SH_Overlap9_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc8/SH_Overlap9_B.hs b/tests/examples/ghc8/SH_Overlap9_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/SH_Overlap9_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -module SH_Overlap9_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc8/SayAnnNames.hs b/tests/examples/ghc8/SayAnnNames.hs deleted file mode 100644 --- a/tests/examples/ghc8/SayAnnNames.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module SayAnnNames (plugin, SomeAnn(..)) where -import GhcPlugins -import Control.Monad (unless) -import Data.Data - -data SomeAnn = SomeAnn deriving (Data, Typeable) - -plugin :: Plugin -plugin = defaultPlugin { - installCoreToDos = install - } - -install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] -install _ todo = do - reinitializeGlobals - return (CoreDoPluginPass "Say name" pass : todo) - -pass :: ModGuts -> CoreM ModGuts -pass g = do - dflags <- getDynFlags - mapM_ (printAnn dflags g) (mg_binds g) >> return g - where printAnn :: DynFlags -> ModGuts -> CoreBind -> CoreM CoreBind - printAnn dflags guts bndr@(NonRec b _) = do - anns <- annotationsOn guts b :: CoreM [SomeAnn] - unless (null anns) $ putMsgS $ - "Annotated binding found: " ++ showSDoc dflags (ppr b) - return bndr - printAnn _ _ bndr = return bndr - -annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] -annotationsOn guts bndr = do - anns <- getAnnotations deserializeWithData guts - return $ lookupWithDefaultUFM anns [] (varUnique bndr) diff --git a/tests/examples/ghc8/SelfDep.hs b/tests/examples/ghc8/SelfDep.hs deleted file mode 100644 --- a/tests/examples/ghc8/SelfDep.hs +++ /dev/null @@ -1,3 +0,0 @@ -module SelfDep where - -data T :: T -> * diff --git a/tests/examples/ghc8/SemigroupWarnings.hs b/tests/examples/ghc8/SemigroupWarnings.hs deleted file mode 100644 --- a/tests/examples/ghc8/SemigroupWarnings.hs +++ /dev/null @@ -1,34 +0,0 @@ --- Test purpose: --- Ensure that missing semigroup warnings are issued --- correctly if the warning flag is enabled - -{-# OPTIONS_GHC -fwarn-semigroup #-} - -module SemigroupWarnings where - - - -import Data.Semigroup - - - --- Bad instance, should complain about missing Semigroup parent -data LacksSemigroup -instance Monoid LacksSemigroup where - mempty = undefined - mappend = undefined - - - --- Correct instance, should not warn -data HasSemigroup -instance Semigroup HasSemigroup where - (<>) = undefined -instance Monoid HasSemigroup where - mempty = undefined - mappend = undefined - - - --- Should issue a Prelude clash warning -(<>) = undefined diff --git a/tests/examples/ghc8/Setup.hs b/tests/examples/ghc8/Setup.hs deleted file mode 100644 --- a/tests/examples/ghc8/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/tests/examples/ghc8/ShouldFail.hs b/tests/examples/ghc8/ShouldFail.hs deleted file mode 100644 --- a/tests/examples/ghc8/ShouldFail.hs +++ /dev/null @@ -1,1 +0,0 @@ -import Set diff --git a/tests/examples/ghc8/SigTvKinds.hs b/tests/examples/ghc8/SigTvKinds.hs deleted file mode 100644 --- a/tests/examples/ghc8/SigTvKinds.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PolyKinds #-} - -module SigTvKinds where - -data T (a :: k1) x = MkT (S a ()) -data S (b :: k2) y = MkS (T b ()) - -- tests TcTyClsDecls.no_sig_tv diff --git a/tests/examples/ghc8/SigTvKinds2.hs b/tests/examples/ghc8/SigTvKinds2.hs deleted file mode 100644 --- a/tests/examples/ghc8/SigTvKinds2.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PolyKinds #-} - -module SigTvKinds2 where - -data SameKind :: k -> k -> * - -data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) diff --git a/tests/examples/ghc8/SpecializePhaseControl.hs b/tests/examples/ghc8/SpecializePhaseControl.hs deleted file mode 100644 --- a/tests/examples/ghc8/SpecializePhaseControl.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# SPECIALISE [1] x :: - Integer -> Integer -> Integer, - Integer -> Int -> Integer, - Int -> Int -> Int #-} -{-# INLINABLE [1] x #-} -x :: (Num a, Integral b) => a -> b -> a -x = undefined - -{-# SPECIALISE INLINE [999] y :: - Integer -> Integer -> Integer, - Integer -> Int -> Integer, - Int -> Int -> Int #-} -{-# INLINABLE [1] y #-} -y :: (Num a, Integral b) => a -> b -> a -y = undefined diff --git a/tests/examples/ghc8/Splices.hs b/tests/examples/ghc8/Splices.hs deleted file mode 100644 --- a/tests/examples/ghc8/Splices.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NamedWildCards #-} -module Splices where - -import Language.Haskell.TH -import Language.Haskell.TH.Lib (wildCardT) - -metaType1 :: TypeQ -metaType1 = wildCardT - -metaType2 :: TypeQ -metaType2 = [t| _ |] - -metaType3 :: TypeQ -metaType3 = [t| _ -> _ -> _ |] - -metaDec1 :: Q [Dec] -metaDec1 = [d| foo :: _ => _ - foo x y = x == y |] - -metaDec2 :: Q [Dec] -metaDec2 = [d| bar :: _a -> _b -> (_a, _b) - bar x y = (not x, y) |] - --- An expression with a partial type annotation -metaExp1 :: ExpQ -metaExp1 = [| Just True :: Maybe _ |] - -metaExp2 :: ExpQ -metaExp2 = [| id :: _a -> _a |] diff --git a/tests/examples/ghc8/SplicesUsed.hs b/tests/examples/ghc8/SplicesUsed.hs deleted file mode 100644 --- a/tests/examples/ghc8/SplicesUsed.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE PartialTypeSignatures #-} -module SplicesUsed where - -import Splices - -maybeBool :: $(metaType1) -maybeBool = $(metaExp2) $(metaExp1) - -charA :: a -> $(metaType2) -charA x = ('x', x) - -filter' :: $(metaType3) -filter' = filter - -$(metaDec1) - -$(metaDec2) diff --git a/tests/examples/ghc8/StackOverflow.hs b/tests/examples/ghc8/StackOverflow.hs deleted file mode 100644 --- a/tests/examples/ghc8/StackOverflow.hs +++ /dev/null @@ -1,4 +0,0 @@ -main :: IO () -main = main' () - where - main' _ = main >> main' () diff --git a/tests/examples/ghc8/Structure8.hs b/tests/examples/ghc8/Structure8.hs deleted file mode 100644 --- a/tests/examples/ghc8/Structure8.hs +++ /dev/null @@ -1,1 +0,0 @@ -foo x | otherwise = y diff --git a/tests/examples/ghc8/Structure8a.hs b/tests/examples/ghc8/Structure8a.hs deleted file mode 100644 --- a/tests/examples/ghc8/Structure8a.hs +++ /dev/null @@ -1,1 +0,0 @@ -foo x = y diff --git a/tests/examples/ghc8/T10009.hs b/tests/examples/ghc8/T10009.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10009.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module T10009 where - - -type family F a -type family UnF a - -f :: (UnF (F b) ~ b) => F b -> () -f = error "urk" - -g :: forall a. (UnF (F a) ~ a) => a -> () -g _ = f (undefined :: F a) - - -{- --------------- -[G] UnF (F b) ~ b - -[W] UnF (F beta) ~ beta -[W] F a ~ F beta - -------------------- -[G] g1: F a ~ fsk1 fsk1 := F a -[G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1 -[G] g3: fsk2 ~ a - -[W] w1: F beta ~ fmv1 -[W] w2: UnF fmv1 ~ fmv2 -[W] w3: fmv2 ~ beta -[W] w5: fsk1 ~ fmv1 -- From F a ~ F beta - -- using flat-cache - ----- No progress in solving ----- --- Unflatten: - -[W] w3: UnF (F beta) ~ beta -[W] w5: fsk1 ~ F beta - ---- Improvement - -[D] F beta ~ fmv1 -[D] UnF fmv1 ~ fmv2 -- (A) -[D] fmv2 ~ beta -[D] fmv1 ~ fsk1 -- (B) From F a ~ F beta - -- NB: put fmv on left - ---> rewrite (A) with (B), and match with g2 - -[D] F beta ~ fmv1 -[D] fmv2 ~ fsk2 -- (C) -[D] fmv2 ~ beta -- (D) -[D] fmv1 ~ fsk1 - ---> rewrite (D) with (C) and re-orient - -[D] F beta ~ fmv1 -[D] fmv2 ~ fsk2 -[D] beta ~ fsk2 -- (E) -[D] fmv1 ~ fsk1 - --- Now we can unify beta! --} - - - -{- - ------ -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - -wl: [W] F b_amr ~ F b_amt - -work item: [W] UnF (F b_amt) ~ b_amt - b_amt is the unification variable - -===> b_amt := s_amF - -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - -wl: [W] F b_amr ~ F b_amt - [W] UnF s_amD ~ s_amF - -work item: [W] F b_amt ~ s_amD - - -===> -wl: [W] F b_amr ~ F b_amt - [W] UnF s_amD ~ s_amF - -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - [W] F s_amF ~ s_amD - -===> -wl: [W] F b_amr ~ F b_amt - -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - [W] F s_amF ~ s_amD - [W] UnF s_amD ~ s_amF - -===> -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - [W] UnF s_amD ~ s_amF - [W] F s_amF ~ s_amD - -wl: - -work-item: [W] F b_amr ~ F b_amt ---> fsk_amy ~ s_amD ---> s_amD ~ fsk_amy - -===> -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - [W] UnF s_amD ~ s_amF - [W] F s_amF ~ s_amD - [W] s_amD ~ fsk_amy - -wl: - -work item: [D] UnF s_amD ~ s_amF - ---> [D] UnF fsk_amy ~ s_amF ---> [D] s_amF ~ fsk_amA - -===> -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - [W] UnF s_amD ~ s_amF - [W] F s_amF ~ s_amD - [W] s_amD ~ fsk_amy - [D] s_amF ~ fsk_amA - -wl: - -work item: [D] F s_amF ~ s_amD ---> F fsk_amA ~ s_amD ---> s_amd ~ b_amr --} diff --git a/tests/examples/ghc8/T10030.hs b/tests/examples/ghc8/T10030.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10030.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import GHC.Generics - -main = do - putStrLn $ packageName $ from $ Just True - putStrLn $ packageName $ from $ True diff --git a/tests/examples/ghc8/T10041.hs b/tests/examples/ghc8/T10041.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10041.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds #-} -{-# LANGUAGE TypeOperators, GADTs, InstanceSigs #-} - -module T10041 where - -data family Sing (a :: k) -data instance Sing (xs :: [k]) where - SNil :: Sing '[] - -class SingI (a :: ĸ) where diff --git a/tests/examples/ghc8/T10045.hs b/tests/examples/ghc8/T10045.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10045.hs +++ /dev/null @@ -1,8 +0,0 @@ -module T10045 where - -newtype Meta = Meta () - -foo (Meta ws1) = - let copy :: _ - copy w from = copy w True - in copy ws1 False diff --git a/tests/examples/ghc8/T10047.hs b/tests/examples/ghc8/T10047.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10047.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-fields #-} -module T10047 where - -import Language.Haskell.TH -import Language.Haskell.TH.Quote - -n = QuasiQuoter { quoteExp = dyn } diff --git a/tests/examples/ghc8/T10052-input.hs b/tests/examples/ghc8/T10052-input.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10052-input.hs +++ /dev/null @@ -1,1 +0,0 @@ -main = let (x :: String) = "hello" in putStrLn x diff --git a/tests/examples/ghc8/T10052.hs b/tests/examples/ghc8/T10052.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10052.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wall #-} -module Main where - -import System.Environment -import GHC - -main :: IO () -main = do - flags <- getArgs - runGhc' flags $ do - setTargets [Target (TargetFile "T10052-input.hs" Nothing) True Nothing] - _success <- load LoadAllTargets - return () - -runGhc' :: [String] -> Ghc a -> IO a -runGhc' args act = do - let libdir = head args - flags = tail args - (dynFlags, _warns) <- parseStaticFlags (map noLoc flags) - runGhc (Just libdir) $ do - dflags0 <- getSessionDynFlags - (dflags1, _leftover, _warns) <- parseDynamicFlags dflags0 dynFlags - let dflags2 = dflags1 { - hscTarget = HscInterpreted - , ghcLink = LinkInMemory - , verbosity = 1 - } - _newPkgs <- setSessionDynFlags dflags2 - act diff --git a/tests/examples/ghc8/T10083.hs b/tests/examples/ghc8/T10083.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10083.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T10083 where - import T10083a - data RSR = MkRSR SR - eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) - foo x y = not (eqRSR x y) diff --git a/tests/examples/ghc8/T10083a.hs b/tests/examples/ghc8/T10083a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10083a.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10083a where - import {-# SOURCE #-} T10083 - data SR = MkSR RSR - eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 diff --git a/tests/examples/ghc8/T10100.hs b/tests/examples/ghc8/T10100.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10100.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module T10100 where - -data Zero -data Succ a - -class Add a b ab | a b -> ab, a ab -> b -instance Add Zero b b -instance (Add a b ab) => Add (Succ a) b (Succ ab) diff --git a/tests/examples/ghc8/T10104.hs b/tests/examples/ghc8/T10104.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10104.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module Main where - -import GHC.Prim - -data P = Positives Int# Float# Double# Char# Word# deriving Show -data N = Negatives Int# Float# Double# deriving Show - -main = do - print $ Positives 42# 4.23# 4.23## '4'# 4## - print $ Negatives -4# -4.0# -4.0## diff --git a/tests/examples/ghc8/T10109.hs b/tests/examples/ghc8/T10109.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10109.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PolyKinds, MultiParamTypeClasses, FunctionalDependencies, - UndecidableInstances, FlexibleInstances #-} - -module T10109 where - -data Succ a - -class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab -instance (Add a b ab) => Add (Succ a) b (Succ ab) - diff --git a/tests/examples/ghc8/T10110A.hs b/tests/examples/ghc8/T10110A.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10110A.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10110A (a) where -{-# NOINLINE a #-} -a :: Int -a = 3 diff --git a/tests/examples/ghc8/T10110B.hs b/tests/examples/ghc8/T10110B.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10110B.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10110B (b) where -b :: Int -b = 5 diff --git a/tests/examples/ghc8/T10110C.hs b/tests/examples/ghc8/T10110C.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10110C.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T10110C (c) where -import T10110A (a) -import T10110B (b) -c :: Int -c = a+b diff --git a/tests/examples/ghc8/T10112.hs b/tests/examples/ghc8/T10112.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10112.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE RankNTypes, RebindableSyntax #-} -module T10112 where - -import qualified Prelude as P - -(>>=) :: a -> ((forall b . b) -> c) -> c -a >>= f = f P.undefined -return a = a -fail s = P.undefined - -t1 = 'd' >>= (\_ -> 'k') - -t2 = do { _ <- 'd' - ; 'k' } - -foo = P.putStrLn [t1, t2] diff --git a/tests/examples/ghc8/T10134.hs b/tests/examples/ghc8/T10134.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10134.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DataKinds, TypeOperators, ConstraintKinds, TypeFamilies, NoMonoLocalBinds, NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module T10134 where - -import GHC.TypeLits -import T10134a -import Prelude - -type Positive n = ((n-1)+1)~n - -data Dummy n d = Dummy { vec :: Vec n (Vec d Bool) } - -nextDummy :: Positive (2*(n+d)) => Dummy n d -> Dummy n d -nextDummy d = Dummy { vec = vec dFst } - where (dFst,dSnd) = nextDummy' d - -nextDummy' :: Positive (2*(n+d)) => Dummy n d -> ( Dummy n d, Bool ) -nextDummy' _ = undefined diff --git a/tests/examples/ghc8/T10134a.hs b/tests/examples/ghc8/T10134a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10134a.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -module T10134a where - -import GHC.TypeLits - -data Vec :: Nat -> * -> * where - Nil :: Vec 0 a - (:>) :: a -> Vec n a -> Vec (n + 1) a diff --git a/tests/examples/ghc8/T10139.hs b/tests/examples/ghc8/T10139.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10139.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances, - MultiParamTypeClasses, FunctionalDependencies #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module T10139 where - -import GHC.Exts -import Data.Monoid - -class Monoid v => Measured v a | a -> v where - _measure :: v -> a -data FingerTree v a = Dummy v a -singleton :: Measured v a => a -> FingerTree v a -singleton = undefined - -class DOps a where - plus :: a -> D a -> a - -type family D a :: * -type instance D (FingerTree (Size Int, v) (Sized a)) = [Diff (Normal a)] - -type family Normal a :: * - -data Diff a = Add Int a - -newtype Sized a = Sized a -newtype Size a = Size a - --- This works: -{- -instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where - plus = foldr (\(Add index val) seq -> singleton ((coerce) val)) --} - --- This hangs: -instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where - plus = foldr (flip f) - where f _seq x = case x of - Add _index val -> singleton ((coerce) val) diff --git a/tests/examples/ghc8/T10141.hs b/tests/examples/ghc8/T10141.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10141.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies, PolyKinds #-} - -module T10141 where - -type family G (a :: k) where - G Int = Bool - G Bool = Int - G a = a diff --git a/tests/examples/ghc8/T10148.hs b/tests/examples/ghc8/T10148.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10148.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Main where - -import Debug.Trace - -data Machine = Machine (Int -> Machine) Int - -main :: IO () -main = (go 7 $ Machine (gstep (Array 99)) 8) `seq` return () - where - go :: Int -> Machine -> Int - go 0 (Machine _ done) = done - go nq (Machine step _) = go (nq-1) $ step 0 - -gstep :: Array Int -> Int -> Machine -gstep m x = Machine (gstep m') (mindexA m) - where - !m' = adjustA x m - -data Array a = Array a - -adjustA :: (Show a) => Int -> Array a -> Array a -adjustA i (Array t) - | i < 0 = undefined i -- not just undefined! - | otherwise = Array $ trace ("adj " ++ show t) $ t - -mindexA :: Array a -> a -mindexA (Array v) = v diff --git a/tests/examples/ghc8/T10156.hs b/tests/examples/ghc8/T10156.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10156.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - -module T10156 where - -import Data.Coerce - -data Iso a b = Iso (a -> b) (b -> a) - -coerceIso :: Coercible a b => Iso a b -coerceIso = Iso coerce coerce - -type family F x - -f :: (Coercible a (F b), Coercible c (F b)) => a -> b -> c -f x _ = coerce x diff --git a/tests/examples/ghc8/T10180.hs b/tests/examples/ghc8/T10180.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10180.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE TypeOperators, TypeFamilies, GADTs, EmptyCase #-} -module T10180 where - -newtype Foo = Foo Int - -type family Bar a -type instance Bar Int = Int - -type family Baz a where - Baz Int = Int - Baz Char = Int - -data a :~: b where - Refl :: a :~: a - -absurd0 :: Int :~: Bool -> a -absurd0 x = case x of {} - -absurd1 :: Foo :~: Bool -> a -absurd1 x = case x of {} - -absurd2 :: Bar Int :~: Bool -> a -absurd2 x = case x of {} - -absurd3 :: Baz a :~: Bool -> a -absurd3 x = case x of {} - diff --git a/tests/examples/ghc8/T10181.hs b/tests/examples/ghc8/T10181.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10181.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10181 where - -t a = t a diff --git a/tests/examples/ghc8/T10182.hs b/tests/examples/ghc8/T10182.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10182.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10182 where -import T10182a -instance Show (a -> b) where - show _ = "" diff --git a/tests/examples/ghc8/T10182a.hs b/tests/examples/ghc8/T10182a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10182a.hs +++ /dev/null @@ -1,2 +0,0 @@ -module T10182a where -import {-# SOURCE #-} T10182 diff --git a/tests/examples/ghc8/T10184.hs b/tests/examples/ghc8/T10184.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10184.hs +++ /dev/null @@ -1,9 +0,0 @@ -module T10184 where - -import Data.Coerce - -newtype Bar a = Bar (Either a (Bar a)) -newtype Age = MkAge Int - -x :: Bar Age -x = coerce (Bar (Left (5 :: Int))) diff --git a/tests/examples/ghc8/T10185.hs b/tests/examples/ghc8/T10185.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10185.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T10185 where - -import Data.Coerce -import Data.Proxy - -foo :: (Coercible (a b) (c d), Coercible (c d) (e f)) => Proxy (c d) -> a b -> e f -foo _ = coerce diff --git a/tests/examples/ghc8/T10188.hs b/tests/examples/ghc8/T10188.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10188.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} - -module T10188 where - -data Peano = Zero | Succ Peano - -type family Length (as :: [k]) :: Peano where - Length (a : as) = Succ (Length as) - Length '[] = Zero - -type family Length' (as :: [k]) :: Peano where - Length' ((:) a as) = Succ (Length' as) - Length' '[] = Zero diff --git a/tests/examples/ghc8/T10194.hs b/tests/examples/ghc8/T10194.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10194.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module T10194 where - -type X = forall a . a - -comp :: (X -> c) -> (a -> X) -> (a -> c) -comp = (.) diff --git a/tests/examples/ghc8/T10195.hs b/tests/examples/ghc8/T10195.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10195.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, GADTs, - ConstraintKinds, DataKinds, KindSignatures, - FlexibleInstances #-} -{-# OPTIONS -fno-warn-redundant-constraints #-} - -module T10195 where - -import GHC.Exts - -data Foo m zp r'q = Foo zp -data Dict :: Constraint -> * where - Dict :: a => Dict a - -type family BarFamily a b :: Bool -class Bar m m' -instance (BarFamily m m' ~ 'True) => Bar m m' - -magic :: (Bar m m') => c m zp -> Foo m zp (c m' zq) -magic = undefined - -getDict :: a -> Dict (Num a) -getDict _ = undefined -fromScalar :: r -> c m r -fromScalar = undefined - -foo :: (Bar m m') - => c m zp -> Foo m zp (c m' zq) -> Foo m zp (c m' zq) -foo b (Foo sc) = - let scinv = fromScalar sc - in case getDict scinv of - Dict -> magic $ scinv * b diff --git a/tests/examples/ghc8/T10196.hs b/tests/examples/ghc8/T10196.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10196.hs +++ /dev/null @@ -1,13 +0,0 @@ -module T10196 where - -data X = Xᵦ | Xᵤ | Xᵩ | Xᵢ | Xᵪ | Xᵣ - -f :: Int -f = - let xᵦ = 1 - xᵤ = xᵦ - xᵩ = xᵤ - xᵢ = xᵩ - xᵪ = xᵢ - xᵣ = xᵪ - in xᵣ diff --git a/tests/examples/ghc8/T10215.hs b/tests/examples/ghc8/T10215.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10215.hs +++ /dev/null @@ -1,9 +0,0 @@ -testF :: Float -> Bool -testF x = x == 0 && not (isNegativeZero x) - -testD :: Double -> Bool -testD x = x == 0 && not (isNegativeZero x) - -main :: IO () -main = do print $ testF (-0.0) - print $ testD (-0.0) diff --git a/tests/examples/ghc8/T10218.hs b/tests/examples/ghc8/T10218.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10218.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -feager-blackholing #-} - -module Main where - -{-# NOINLINE foo #-} -foo :: Bool -> Int -> Int -> Int -foo True _ x = 1 -foo False _ x = x+1 - -{-# NOINLINE bar #-} -bar :: Int -> (Int,Int) -bar x = let y1 = x * 2 - y2 = x * 2 - in (foo False y1 y2,foo False y2 y1) - -main = print (fst p + snd p) - where - p = bar 3 diff --git a/tests/examples/ghc8/T10220B.hs b/tests/examples/ghc8/T10220B.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10220B.hs +++ /dev/null @@ -1,1 +0,0 @@ -module T10220B where diff --git a/tests/examples/ghc8/T10226.hs b/tests/examples/ghc8/T10226.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10226.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -- only necessary in 7.10 -{-# LANGUAGE FlexibleContexts #-} -- necessary for showFromF' example -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module T10226 where - -type family F a -type family FInv a - --- This definition is accepted in 7.8 without anything extra, but requires --- AllowAmbiguousTypes in 7.10 (this, by itself, is not a problem): -showFromF :: (Show a, FInv (F a) ~ a) => F a -> String -showFromF fa = undefined - --- Consider what happens when we attempt to call `showFromF` at some type b. --- In order to check that this is valid, we have to find an a such that --- --- > b ~ F a /\ Show a /\ FInv (F a) ~ a --- --- Introducing an intermediate variable `x` for the result of `F a` gives us --- --- > b ~ F a /\ Show a /\ FInv x ~ a /\ F a ~ x --- --- Simplifying --- --- > b ~ x /\ Show a /\ FInv x ~ a /\ F a ~ x --- --- Set x := b --- --- > Show a /\ FInv b ~ a /\ F a ~ b --- --- Set a := FInv b --- --- > Show (FInv b) /\ FInv b ~ FInv b /\ F (FInv b) ~ b --- --- Simplifying --- --- > Show (FInv b) /\ F (FInv b) ~ b --- --- Indeed, we can give this definition in 7.8, but not in 7.10: -showFromF' :: (Show (FInv b), F (FInv b) ~ b) => b -> String -showFromF' = showFromF - -{------------------------------------------------------------------------------- - In 7.10 the definition of showFromF' is not accepted, but it gets stranger. - In 7.10 we cannot _call_ showFromF at all, even at a concrete type. Below - we try to call it at type b ~ Int. It would need to show - - > Show (FInv Int) /\ F (FInt Int) ~ Int - - all of which should easily get resolved, but somehow don't. --------------------------------------------------------------------------------} - -type instance F Int = Int -type instance FInv Int = Int - -test :: String -test = showFromF (0 :: Int) diff --git a/tests/examples/ghc8/T10233.hs b/tests/examples/ghc8/T10233.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10233.hs +++ /dev/null @@ -1,2 +0,0 @@ -module T10233 where -import T10233a( Constraint, Int ) diff --git a/tests/examples/ghc8/T10233a.hs b/tests/examples/ghc8/T10233a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10233a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10233a ( module GHC.Exts ) where -import GHC.Exts ( Constraint, Int ) - diff --git a/tests/examples/ghc8/T10245.hs b/tests/examples/ghc8/T10245.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10245.hs +++ /dev/null @@ -1,13 +0,0 @@ -f :: Int -> String -f n = case n of - 0x8000000000000000 -> "yes" - _ -> "no" -{-# NOINLINE f #-} - -main = do - let string = "0x8000000000000000" - let i = read string :: Integer - let i' = fromIntegral i :: Int - print i - print i' - print (f i') diff --git a/tests/examples/ghc8/T10246.hs b/tests/examples/ghc8/T10246.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10246.hs +++ /dev/null @@ -1,32 +0,0 @@ -f1 :: Int -> String -f1 n = case n of - 0 -> "bar" - 0x10000000000000000 -> "foo" - _ -> "c" -{-# NOINLINE f1 #-} - -g1 :: Int -> String -g1 n = if n == 0 then "bar" else - if n == 0x10000000000000000 then "foo" else - "c" -{-# NOINLINE g1 #-} - -f2 :: Int -> String -f2 n = case n of - 0x10000000000000000 -> "foo" - 0 -> "bar" - _ -> "c" -{-# NOINLINE f2 #-} - -g2 :: Int -> String -g2 n = if n == 0x10000000000000000 then "foo" else - if n == 0 then "bar" else - "c" -{-# NOINLINE g2 #-} - -main = do - let i = read "0" :: Int - print (f1 i) - print (g1 i) - print (f2 i) - print (g2 i) diff --git a/tests/examples/ghc8/T10251.hs b/tests/examples/ghc8/T10251.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10251.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -O #-} -module T10251 where - -data D = D -data E = E - -class Storable a where - poke2 :: a -> E -instance Storable D where - poke2 = poke2 -- undefined - -class Foo a where -instance Foo D where - -class (Foo t, Storable t) => FooStorable t where - -instance FooStorable D where - {-# SPECIALIZE instance FooStorable D #-} - -{-# SPECIALIZE bug :: D -> E #-} - -bug - :: FooStorable t - => t - -> E -bug = poke2 -{- -sf 9160 # ghc -c -fforce-recomp -Wall B.hs - -ghc: panic! (the 'impossible' happened) - (GHC version 7.10.1 for x86_64-unknown-linux): - Template variable unbound in rewrite rule - $fFooStorableD_XU - [$fFooStorableD_XU] - [$fFooStorableD_XU] - [] - [] - -Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug --} diff --git a/tests/examples/ghc8/T10263.hs b/tests/examples/ghc8/T10263.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10263.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} -module T10263 where - -data Maybe a = AF -type role Maybe representational diff --git a/tests/examples/ghc8/T10267.hs b/tests/examples/ghc8/T10267.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10267.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module T10267 where - -import Language.Haskell.TH -import T10267a - -[d| i :: a -> a - i = _foo - - j :: a -> a - j x = _ |] - -$(return [ - SigD (mkName "k") - (ForallT [PlainTV (mkName "a")] - [] - (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) - , FunD (mkName "k") - [Clause [] (NormalB (UnboundVarE (mkName "_foo"))) []] - ]) - -$(return [ - SigD (mkName "l") - (ForallT [PlainTV (mkName "a")] - [] - (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) - , FunD (mkName "l") - [Clause [VarP (mkName "x")] (NormalB (UnboundVarE (mkName "_"))) []] - ]) - -foo :: a -> a -foo x = $varX diff --git a/tests/examples/ghc8/T10267a.hs b/tests/examples/ghc8/T10267a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10267a.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module T10267a where - -import Language.Haskell.TH - -varX :: Q Exp -varX = [| x |] diff --git a/tests/examples/ghc8/T10279.hs b/tests/examples/ghc8/T10279.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10279.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module T10279 where -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - --- NB: rts-1.0 is used here because it doesn't change. --- You do need to pick the right version number, otherwise the --- error message doesn't recognize it as a source package ID, --- (This is OK, since it will look obviously wrong when they --- try to find the package in their package database.) -blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A")))) diff --git a/tests/examples/ghc8/T10283.hs b/tests/examples/ghc8/T10283.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10283.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-} -{-# LANGUAGE ImpredicativeTypes #-} - -module T9834 where -import Control.Applicative -import Data.Functor.Identity - -type Nat f g = forall a. f a -> g a - -newtype Comp p q a = Comp (p (q a)) - -liftOuter :: (Functor p, Applicative q) => p a -> (Comp p q) a -liftOuter pa = Comp (pure <$> pa) - -runIdComp :: Functor p => Comp p Identity a -> p a -runIdComp (Comp p) = runIdentity <$> p - -wrapIdComp :: Applicative p => (forall q. Applicative q => Nat (Comp p q) (Comp p q)) -> p a -> p a -wrapIdComp f = runIdComp . f . liftOuter - -class Applicative p => ApplicativeFix p where - afix :: (forall q. Applicative q => (Comp p q) a -> (Comp p q) a) -> p a - afix = wrapIdComp diff --git a/tests/examples/ghc8/T10284.hs b/tests/examples/ghc8/T10284.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10284.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-} - -import Control.Exception - -a :: Int -a = 'a' - -main :: IO () -main = do - catch (evaluate a) - (\e -> do let err = show (e :: TypeError) - putStrLn ("As expected, TypeError: " ++ err) - return "") - catch (evaluate a) - (\e -> do let err = show (e :: ErrorCall) - putStrLn ("Something went horribly wrong: " ++ err) - return "") diff --git a/tests/examples/ghc8/T10285.hs b/tests/examples/ghc8/T10285.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10285.hs +++ /dev/null @@ -1,11 +0,0 @@ -module T10285 where - -import T10285a -import Data.Type.Coercion -import Data.Coerce - -oops :: Coercion (N a) (N b) -> a -> b -oops Coercion = coerce - -unsafeCoerce :: a -> b -unsafeCoerce = oops coercion diff --git a/tests/examples/ghc8/T10285a.hs b/tests/examples/ghc8/T10285a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10285a.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} - -module T10285a (N, coercion) where - -import Data.Type.Coercion - -newtype N a = MkN Int -type role N representational - -coercion :: Coercion (N a) (N b) -coercion = Coercion diff --git a/tests/examples/ghc8/T10294.hs b/tests/examples/ghc8/T10294.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10294.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T10294 where - -import SayAnnNames - -{-# ANN foo SomeAnn #-} -foo :: () -foo = () diff --git a/tests/examples/ghc8/T10294a.hs b/tests/examples/ghc8/T10294a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10294a.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T10294a where - -import SayAnnNames -import Data.Data - -baz :: Constr -baz = toConstr SomeAnn diff --git a/tests/examples/ghc8/T10306.hs b/tests/examples/ghc8/T10306.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10306.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeFamilies #-} - -module T10306 where - -import Language.Haskell.TH -import GHC.TypeLits - --- Attempting to reify a built-in type family like (+) previously --- caused a crash, because it has no equations -$(do x <- reify ''(+) - case x of - FamilyI (ClosedTypeFamilyD _ _ _ _ []) _ -> return [] - _ -> error $ show x - ) diff --git a/tests/examples/ghc8/T10318.hs b/tests/examples/ghc8/T10318.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10318.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, - FlexibleInstances, TypeFamilies, - UndecidableSuperClasses #-} - -module T10318 where - --- | Product of non-zero elements always non-zero. --- Every integral domain has a field of fractions. --- The field of fractions of any field is itself. -class (Frac (Frac a) ~ Frac a, Fractional (Frac a), IntegralDomain (Frac a)) - => IntegralDomain a where - type Frac a :: * - embed :: a -> Frac a - -instance IntegralDomain Integer where - type Frac Integer = Rational - embed = fromInteger - -instance IntegralDomain Rational where - type Frac Rational = Rational - embed = id - -g :: IntegralDomain a => a -> a -g x = g x - -h :: a -> Frac a -h x = h x - --- This is the test function - -f :: IntegralDomain a => a -> Frac a -f x = g (h (h x)) - -- Given: IntegralDomain (Frac a) - -- Wanted: IntegralDomain (Frac (Frac a)) - diff --git a/tests/examples/ghc8/T10321.hs b/tests/examples/ghc8/T10321.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10321.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -module T10321 where - -import GHC.TypeLits - -data Vec :: Nat -> * -> * where - Nil :: Vec 0 a - (:>) :: a -> Vec n a -> Vec (n + 1) a - -infixr 5 :> diff --git a/tests/examples/ghc8/T10322A.hs b/tests/examples/ghc8/T10322A.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10322A.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10322A (a) where -{-# NOINLINE a #-} -a :: Int -a = 3 diff --git a/tests/examples/ghc8/T10322B.hs b/tests/examples/ghc8/T10322B.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10322B.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10322B (b) where -import T10322A (a) -b :: Int -b = a+1 diff --git a/tests/examples/ghc8/T10322C.hs b/tests/examples/ghc8/T10322C.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10322C.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T10322C (c) where -import T10322A (a) -import T10322B (b) -c :: Int -c = a+b diff --git a/tests/examples/ghc8/T10335.hs b/tests/examples/ghc8/T10335.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10335.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-} - -module Foo where - -type X a = (Eq a, Show a) - -class Eq a => C a b - --- HEAD was unable to find the (Eq a) superclass --- for a while in March/April 2015 -instance X a => C a [b] - - - - - diff --git a/tests/examples/ghc8/T10340.hs b/tests/examples/ghc8/T10340.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10340.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -module T10340 where - -import GHC.Exts (Any) - -class MonadState s m where - get :: m s - -newtype State s a = State (s -> (s, a)) - -instance MonadState s (State s) where - get = State $ \s -> (s, s) - -foo :: State Any Any -foo = get diff --git a/tests/examples/ghc8/T10348.hs b/tests/examples/ghc8/T10348.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10348.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE AutoDeriveTypeable, GADTs, DataKinds, KindSignatures, StandaloneDeriving, TypeOperators #-} - -module T10348 where - -import GHC.TypeLits -import Data.Typeable -import Data.Proxy - -data Foo (n :: Nat) where - Hey :: KnownNat n => Foo n - -deriving instance Show (Foo n) - -data T t where - T :: (Show t, Typeable t) => t -> T t - -deriving instance Show (T n) - -hey :: KnownNat n => T (Foo n) -hey = T Hey - -ho :: T (Foo 42) -ho = T Hey - -f1 :: KnownNat a => Proxy a -> TypeRep -f1 = typeRep - -g2 :: KnownSymbol a => Proxy a -> TypeRep -g2 = typeRep - -pEqT :: (KnownSymbol a, KnownSymbol b) => Proxy a -> Proxy b -> Maybe (a :~: b) -pEqT Proxy Proxy = eqT diff --git a/tests/examples/ghc8/T10351.hs b/tests/examples/ghc8/T10351.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10351.hs +++ /dev/null @@ -1,6 +0,0 @@ -module T10351 where - -class C a where - op :: a -> () - -f x = op [x] diff --git a/tests/examples/ghc8/T10359.hs b/tests/examples/ghc8/T10359.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10359.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ConstraintKinds #-} - -module Main( main, boo ) where - -import Prelude hiding (repeat) - -boo xs f = (\x -> f x, xs) - -repeat :: Int -> (a -> a) -> a -> a -repeat 1 f x = f x -repeat n f x = n `seq` x `seq` repeat (n-1) f $ f x - ----- Buggy version ------------------- - -type Numerical a = (Fractional a, Real a) - -data Box a = Box - { func :: forall dum. (Numerical dum) => dum -> a -> a - , obj :: !a } - -do_step :: (Numerical num) => num -> Box a -> Box a -do_step number Box{..} = Box{ obj = func number obj, .. } - -start :: Box Double -start = Box { func = \x y -> realToFrac x + y - , obj = 0 } - -test :: Int -> IO () -test steps = putStrLn $ show $ obj $ repeat steps (do_step 1) start - ----- Driver ------------ - -main :: IO () -main = test 2000 -- compare test2 10000000 or test3 10000000, but test4 20000 - - -{- ----- No tuple constraint synonym is better ------------------------------------------- - -data Box2 a = Box2 - { func2 :: forall num. (Fractional num, Real num) => num -> a -> a - , obj2 :: !a } - -do_step2 :: (Fractional num, Real num) => num -> Box2 a -> Box2 a -do_step2 number Box2{..} = Box2{ obj2 = func2 number obj2, ..} - -start2 :: Box2 Double -start2 = Box2 { func2 = \x y -> realToFrac x + y - , obj2 = 0 } - -test2 :: Int -> IO () -test2 steps = putStrLn $ show $ obj2 $ repeat steps (do_step2 1) start2 - ----- Not copying the function field works too ---------------------------------------------- - -do_step3 :: (Numerical num) => num -> Box a -> Box a -do_step3 number b@Box{..} = b{ obj = func number obj } - -test3 :: Int -> IO () -test3 steps = putStrLn $ show $ obj $ repeat steps (do_step3 1) start - ----- But record wildcards are not at fault ------------------------------------------- - -do_step4 :: (Numerical num) => num -> Box a -> Box a -do_step4 number Box{func = f, obj = x} = Box{ obj = f number x, func = f } - -test4 :: Int -> IO () -test4 steps = putStrLn $ show $ obj $ repeat steps (do_step4 1) start --} - - -{- -First of all, very nice example. Thank you for making it so small and easy to work with. - -I can see what's happening. The key part is what happens here: -{{{ -do_step4 :: (Numerical num) => num -> Box a -> Box a -do_step4 number Box{ func = f, obj = x} - = Box{ func = f, obj = f number x } -}}} -After elaboration (ie making dictionaries explicit) we get this: -{{{ -do_step4 dn1 number (Box {func = f, obj = x }) - = Box { func = \dn2 -> f ( case dn2 of (f,r) -> f - , case dn2 of (f,r) -> r) - , obj = f dn1 number x } -}}} -That's odd! We expected this: -{{{ -do_step4 dn1 number (Box {func = f, obj = x }) - = Box { func = f - , obj = f dn1 number x } -}}} -And indeed, the allocation of all those `\dn2` closures is what is causing the problem. -So we are missing this optimisation: -{{{ - (case dn2 of (f,r) -> f, case dn2 of (f,r) -> r) -===> - dn2 -}}} -If we did this, then the lambda would look like `\dn2 -> f dn2` which could eta-reduce to `f`. -But there are at least three problems: - * The tuple transformation above is hard to spot - * The tuple transformation is not quite semantically right; if `dn2` was bottom, the LHS and RHS are different - * The eta-reduction isn't quite semantically right: if `f` ws bottom, the LHS and RHS are different. - -You might argue that the latter two can be ignored because dictionary arguments are special; -indeed we often toy with making them strict. - -But perhaps a better way to avoid the tuple-transformation issue would be not to construct that strange expression in the first place. Where is it coming from? It comes from the call to `f` (admittedly applied to no arguments) in `Box { ..., func = f }`. GHC needs a dictionary for `(Numerical dum)` (I changed the name of the type variable in `func`'s type in the definition of `Box`). Since it's just a pair GHC says "fine, I'll build a pair, out of `Fractional dum` and `Real dum`. How does it get those dictionaries? By selecting the components of the `Franctional dum` passed to `f`. - -If GHC said instead "I need `Numerical dum` and behold I have one in hand, it'd be much better. It doesn't because tuple constraints are treated specially. But if we adopted the idea in #10362, we would (automatically) get to re-use the `Numerical dum` constraint. That would leave us with eta reduction, which is easier. - -As to what will get you rolling, a good solution is `test3`, which saves instantiating and re-generalising `f`. The key thing is to update all the fields ''except'' the polymorphic `func` field. I'm surprised you say that it doesn't work. Can you give a (presumably more complicated) example to demonstrate? Maybe there's a separate bug! - --} - - diff --git a/tests/examples/ghc8/T10361a.hs b/tests/examples/ghc8/T10361a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10361a.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -module T10361a where - -class C1 a where - type T1 a - type instance T1 a = Char - -class C2 a where -- equivalent to C1 - type T2 a - type instance T2 a = Char - -class C3 a where -- equivalent to C1, C2 - type T3 a - type instance T3 a = Char - -data A = B - deriving C1 - -deriving instance C2 A - -instance C3 A - -test1 :: T1 A -test1 = 'x' - -test2 :: T2 A -test2 = 'x' - -test3 :: T3 A -test3 = 'x' diff --git a/tests/examples/ghc8/T10361b.hs b/tests/examples/ghc8/T10361b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10361b.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module T10361b where - -import GHC.Generics - ---------------------------------------------------------------------- -class Convert a where - type Result a - type instance Result a = GResult (Rep a) - - convert :: a -> Result a - default convert :: (Generic a, GConvert (Rep a)) => a -> GResult (Rep a) - convert x = gconvert (from x) - -instance Convert Float where - type Result Float = Float - convert = id - -instance Convert Int where - type Result Int = Int - convert = id - ---------------------------------------------------------------------- -class GConvert f where - type GResult f - gconvert :: f p -> GResult f - -instance (Convert c) => GConvert (K1 i c) where - type GResult (K1 i c) = Result c - gconvert (K1 x) = convert x - -instance (GConvert f) => GConvert (M1 i t f) where - type GResult (M1 i t f) = GResult f - gconvert (M1 x) = gconvert x - -instance (GConvert f, GConvert g) => GConvert (f :*: g) where - type GResult (f :*: g) = (GResult f, GResult g) - gconvert (x :*: y) = (gconvert x, gconvert y) - ---------------------------------------------------------------------- - -data Data1 = Data1 Int Float - deriving (Generic) - -instance Convert Data1 - -val :: (Int, Float) -val = convert $ Data1 0 0.0 - -data Data2 = Data2 Int Float - deriving (Generic, Convert) diff --git a/tests/examples/ghc8/T10370.hs b/tests/examples/ghc8/T10370.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10370.hs +++ /dev/null @@ -1,1002 +0,0 @@ -module Out where -import Control.Monad (forever) -a1 :: IO (); a1 = forever $ putStrLn "a1" -a2 :: IO (); a2 = forever $ putStrLn "a2" -a3 :: IO (); a3 = forever $ putStrLn "a3" -a4 :: IO (); a4 = forever $ putStrLn "a4" -a5 :: IO (); a5 = forever $ putStrLn "a5" -a6 :: IO (); a6 = forever $ putStrLn "a6" -a7 :: IO (); a7 = forever $ putStrLn "a7" -a8 :: IO (); a8 = forever $ putStrLn "a8" -a9 :: IO (); a9 = forever $ putStrLn "a9" -a10 :: IO (); a10 = forever $ putStrLn "a10" -a11 :: IO (); a11 = forever $ putStrLn "a11" -a12 :: IO (); a12 = forever $ putStrLn "a12" -a13 :: IO (); a13 = forever $ putStrLn "a13" -a14 :: IO (); a14 = forever $ putStrLn "a14" -a15 :: IO (); a15 = forever $ putStrLn "a15" -a16 :: IO (); a16 = forever $ putStrLn "a16" -a17 :: IO (); a17 = forever $ putStrLn "a17" -a18 :: IO (); a18 = forever $ putStrLn "a18" -a19 :: IO (); a19 = forever $ putStrLn "a19" -a20 :: IO (); a20 = forever $ putStrLn "a20" -a21 :: IO (); a21 = forever $ putStrLn "a21" -a22 :: IO (); a22 = forever $ putStrLn "a22" -a23 :: IO (); a23 = forever $ putStrLn "a23" -a24 :: IO (); a24 = forever $ putStrLn "a24" -a25 :: IO (); a25 = forever $ putStrLn "a25" -a26 :: IO (); a26 = forever $ putStrLn "a26" -a27 :: IO (); a27 = forever $ putStrLn "a27" -a28 :: IO (); a28 = forever $ putStrLn "a28" -a29 :: IO (); a29 = forever $ putStrLn "a29" -a30 :: IO (); a30 = forever $ putStrLn "a30" -a31 :: IO (); a31 = forever $ putStrLn "a31" -a32 :: IO (); a32 = forever $ putStrLn "a32" -a33 :: IO (); a33 = forever $ putStrLn "a33" -a34 :: IO (); a34 = forever $ putStrLn "a34" -a35 :: IO (); a35 = forever $ putStrLn "a35" -a36 :: IO (); a36 = forever $ putStrLn "a36" -a37 :: IO (); a37 = forever $ putStrLn "a37" -a38 :: IO (); a38 = forever $ putStrLn "a38" -a39 :: IO (); a39 = forever $ putStrLn "a39" -a40 :: IO (); a40 = forever $ putStrLn "a40" -a41 :: IO (); a41 = forever $ putStrLn "a41" -a42 :: IO (); a42 = forever $ putStrLn "a42" -a43 :: IO (); a43 = forever $ putStrLn "a43" -a44 :: IO (); a44 = forever $ putStrLn "a44" -a45 :: IO (); a45 = forever $ putStrLn "a45" -a46 :: IO (); a46 = forever $ putStrLn "a46" -a47 :: IO (); a47 = forever $ putStrLn "a47" -a48 :: IO (); a48 = forever $ putStrLn "a48" -a49 :: IO (); a49 = forever $ putStrLn "a49" -a50 :: IO (); a50 = forever $ putStrLn "a50" -a51 :: IO (); a51 = forever $ putStrLn "a51" -a52 :: IO (); a52 = forever $ putStrLn "a52" -a53 :: IO (); a53 = forever $ putStrLn "a53" -a54 :: IO (); a54 = forever $ putStrLn "a54" -a55 :: IO (); a55 = forever $ putStrLn "a55" -a56 :: IO (); a56 = forever $ putStrLn "a56" -a57 :: IO (); a57 = forever $ putStrLn "a57" -a58 :: IO (); a58 = forever $ putStrLn "a58" -a59 :: IO (); a59 = forever $ putStrLn "a59" -a60 :: IO (); a60 = forever $ putStrLn "a60" -a61 :: IO (); a61 = forever $ putStrLn "a61" -a62 :: IO (); a62 = forever $ putStrLn "a62" -a63 :: IO (); a63 = forever $ putStrLn "a63" -a64 :: IO (); a64 = forever $ putStrLn "a64" -a65 :: IO (); a65 = forever $ putStrLn "a65" -a66 :: IO (); a66 = forever $ putStrLn "a66" -a67 :: IO (); a67 = forever $ putStrLn "a67" -a68 :: IO (); a68 = forever $ putStrLn "a68" -a69 :: IO (); a69 = forever $ putStrLn "a69" -a70 :: IO (); a70 = forever $ putStrLn "a70" -a71 :: IO (); a71 = forever $ putStrLn "a71" -a72 :: IO (); a72 = forever $ putStrLn "a72" -a73 :: IO (); a73 = forever $ putStrLn "a73" -a74 :: IO (); a74 = forever $ putStrLn "a74" -a75 :: IO (); a75 = forever $ putStrLn "a75" -a76 :: IO (); a76 = forever $ putStrLn "a76" -a77 :: IO (); a77 = forever $ putStrLn "a77" -a78 :: IO (); a78 = forever $ putStrLn "a78" -a79 :: IO (); a79 = forever $ putStrLn "a79" -a80 :: IO (); a80 = forever $ putStrLn "a80" -a81 :: IO (); a81 = forever $ putStrLn "a81" -a82 :: IO (); a82 = forever $ putStrLn "a82" -a83 :: IO (); a83 = forever $ putStrLn "a83" -a84 :: IO (); a84 = forever $ putStrLn "a84" -a85 :: IO (); a85 = forever $ putStrLn "a85" -a86 :: IO (); a86 = forever $ putStrLn "a86" -a87 :: IO (); a87 = forever $ putStrLn "a87" -a88 :: IO (); a88 = forever $ putStrLn "a88" -a89 :: IO (); a89 = forever $ putStrLn "a89" -a90 :: IO (); a90 = forever $ putStrLn "a90" -a91 :: IO (); a91 = forever $ putStrLn "a91" -a92 :: IO (); a92 = forever $ putStrLn "a92" -a93 :: IO (); a93 = forever $ putStrLn "a93" -a94 :: IO (); a94 = forever $ putStrLn "a94" -a95 :: IO (); a95 = forever $ putStrLn "a95" -a96 :: IO (); a96 = forever $ putStrLn "a96" -a97 :: IO (); a97 = forever $ putStrLn "a97" -a98 :: IO (); a98 = forever $ putStrLn "a98" -a99 :: IO (); a99 = forever $ putStrLn "a99" -a100 :: IO (); a100 = forever $ putStrLn "a100" -a101 :: IO (); a101 = forever $ putStrLn "a101" -a102 :: IO (); a102 = forever $ putStrLn "a102" -a103 :: IO (); a103 = forever $ putStrLn "a103" -a104 :: IO (); a104 = forever $ putStrLn "a104" -a105 :: IO (); a105 = forever $ putStrLn "a105" -a106 :: IO (); a106 = forever $ putStrLn "a106" -a107 :: IO (); a107 = forever $ putStrLn "a107" -a108 :: IO (); a108 = forever $ putStrLn "a108" -a109 :: IO (); a109 = forever $ putStrLn "a109" -a110 :: IO (); a110 = forever $ putStrLn "a110" -a111 :: IO (); a111 = forever $ putStrLn "a111" -a112 :: IO (); a112 = forever $ putStrLn "a112" -a113 :: IO (); a113 = forever $ putStrLn "a113" -a114 :: IO (); a114 = forever $ putStrLn "a114" -a115 :: IO (); a115 = forever $ putStrLn "a115" -a116 :: IO (); a116 = forever $ putStrLn "a116" -a117 :: IO (); a117 = forever $ putStrLn "a117" -a118 :: IO (); a118 = forever $ putStrLn "a118" -a119 :: IO (); a119 = forever $ putStrLn "a119" -a120 :: IO (); a120 = forever $ putStrLn "a120" -a121 :: IO (); a121 = forever $ putStrLn "a121" -a122 :: IO (); a122 = forever $ putStrLn "a122" -a123 :: IO (); a123 = forever $ putStrLn "a123" -a124 :: IO (); a124 = forever $ putStrLn "a124" -a125 :: IO (); a125 = forever $ putStrLn "a125" -a126 :: IO (); a126 = forever $ putStrLn "a126" -a127 :: IO (); a127 = forever $ putStrLn "a127" -a128 :: IO (); a128 = forever $ putStrLn "a128" -a129 :: IO (); a129 = forever $ putStrLn "a129" -a130 :: IO (); a130 = forever $ putStrLn "a130" -a131 :: IO (); a131 = forever $ putStrLn "a131" -a132 :: IO (); a132 = forever $ putStrLn "a132" -a133 :: IO (); a133 = forever $ putStrLn "a133" -a134 :: IO (); a134 = forever $ putStrLn "a134" -a135 :: IO (); a135 = forever $ putStrLn "a135" -a136 :: IO (); a136 = forever $ putStrLn "a136" -a137 :: IO (); a137 = forever $ putStrLn "a137" -a138 :: IO (); a138 = forever $ putStrLn "a138" -a139 :: IO (); a139 = forever $ putStrLn "a139" -a140 :: IO (); a140 = forever $ putStrLn "a140" -a141 :: IO (); a141 = forever $ putStrLn "a141" -a142 :: IO (); a142 = forever $ putStrLn "a142" -a143 :: IO (); a143 = forever $ putStrLn "a143" -a144 :: IO (); a144 = forever $ putStrLn "a144" -a145 :: IO (); a145 = forever $ putStrLn "a145" -a146 :: IO (); a146 = forever $ putStrLn "a146" -a147 :: IO (); a147 = forever $ putStrLn "a147" -a148 :: IO (); a148 = forever $ putStrLn "a148" -a149 :: IO (); a149 = forever $ putStrLn "a149" -a150 :: IO (); a150 = forever $ putStrLn "a150" -a151 :: IO (); a151 = forever $ putStrLn "a151" -a152 :: IO (); a152 = forever $ putStrLn "a152" -a153 :: IO (); a153 = forever $ putStrLn "a153" -a154 :: IO (); a154 = forever $ putStrLn "a154" -a155 :: IO (); a155 = forever $ putStrLn "a155" -a156 :: IO (); a156 = forever $ putStrLn "a156" -a157 :: IO (); a157 = forever $ putStrLn "a157" -a158 :: IO (); a158 = forever $ putStrLn "a158" -a159 :: IO (); a159 = forever $ putStrLn "a159" -a160 :: IO (); a160 = forever $ putStrLn "a160" -a161 :: IO (); a161 = forever $ putStrLn "a161" -a162 :: IO (); a162 = forever $ putStrLn "a162" -a163 :: IO (); a163 = forever $ putStrLn "a163" -a164 :: IO (); a164 = forever $ putStrLn "a164" -a165 :: IO (); a165 = forever $ putStrLn "a165" -a166 :: IO (); a166 = forever $ putStrLn "a166" -a167 :: IO (); a167 = forever $ putStrLn "a167" -a168 :: IO (); a168 = forever $ putStrLn "a168" -a169 :: IO (); a169 = forever $ putStrLn "a169" -a170 :: IO (); a170 = forever $ putStrLn "a170" -a171 :: IO (); a171 = forever $ putStrLn "a171" -a172 :: IO (); a172 = forever $ putStrLn "a172" -a173 :: IO (); a173 = forever $ putStrLn "a173" -a174 :: IO (); a174 = forever $ putStrLn "a174" -a175 :: IO (); a175 = forever $ putStrLn "a175" -a176 :: IO (); a176 = forever $ putStrLn "a176" -a177 :: IO (); a177 = forever $ putStrLn "a177" -a178 :: IO (); a178 = forever $ putStrLn "a178" -a179 :: IO (); a179 = forever $ putStrLn "a179" -a180 :: IO (); a180 = forever $ putStrLn "a180" -a181 :: IO (); a181 = forever $ putStrLn "a181" -a182 :: IO (); a182 = forever $ putStrLn "a182" -a183 :: IO (); a183 = forever $ putStrLn "a183" -a184 :: IO (); a184 = forever $ putStrLn "a184" -a185 :: IO (); a185 = forever $ putStrLn "a185" -a186 :: IO (); a186 = forever $ putStrLn "a186" -a187 :: IO (); a187 = forever $ putStrLn "a187" -a188 :: IO (); a188 = forever $ putStrLn "a188" -a189 :: IO (); a189 = forever $ putStrLn "a189" -a190 :: IO (); a190 = forever $ putStrLn "a190" -a191 :: IO (); a191 = forever $ putStrLn "a191" -a192 :: IO (); a192 = forever $ putStrLn "a192" -a193 :: IO (); a193 = forever $ putStrLn "a193" -a194 :: IO (); a194 = forever $ putStrLn "a194" -a195 :: IO (); a195 = forever $ putStrLn "a195" -a196 :: IO (); a196 = forever $ putStrLn "a196" -a197 :: IO (); a197 = forever $ putStrLn "a197" -a198 :: IO (); a198 = forever $ putStrLn "a198" -a199 :: IO (); a199 = forever $ putStrLn "a199" -a200 :: IO (); a200 = forever $ putStrLn "a200" -a201 :: IO (); a201 = forever $ putStrLn "a201" -a202 :: IO (); a202 = forever $ putStrLn "a202" -a203 :: IO (); a203 = forever $ putStrLn "a203" -a204 :: IO (); a204 = forever $ putStrLn "a204" -a205 :: IO (); a205 = forever $ putStrLn "a205" -a206 :: IO (); a206 = forever $ putStrLn "a206" -a207 :: IO (); a207 = forever $ putStrLn "a207" -a208 :: IO (); a208 = forever $ putStrLn "a208" -a209 :: IO (); a209 = forever $ putStrLn "a209" -a210 :: IO (); a210 = forever $ putStrLn "a210" -a211 :: IO (); a211 = forever $ putStrLn "a211" -a212 :: IO (); a212 = forever $ putStrLn "a212" -a213 :: IO (); a213 = forever $ putStrLn "a213" -a214 :: IO (); a214 = forever $ putStrLn "a214" -a215 :: IO (); a215 = forever $ putStrLn "a215" -a216 :: IO (); a216 = forever $ putStrLn "a216" -a217 :: IO (); a217 = forever $ putStrLn "a217" -a218 :: IO (); a218 = forever $ putStrLn "a218" -a219 :: IO (); a219 = forever $ putStrLn "a219" -a220 :: IO (); a220 = forever $ putStrLn "a220" -a221 :: IO (); a221 = forever $ putStrLn "a221" -a222 :: IO (); a222 = forever $ putStrLn "a222" -a223 :: IO (); a223 = forever $ putStrLn "a223" -a224 :: IO (); a224 = forever $ putStrLn "a224" -a225 :: IO (); a225 = forever $ putStrLn "a225" -a226 :: IO (); a226 = forever $ putStrLn "a226" -a227 :: IO (); a227 = forever $ putStrLn "a227" -a228 :: IO (); a228 = forever $ putStrLn "a228" -a229 :: IO (); a229 = forever $ putStrLn "a229" -a230 :: IO (); a230 = forever $ putStrLn "a230" -a231 :: IO (); a231 = forever $ putStrLn "a231" -a232 :: IO (); a232 = forever $ putStrLn "a232" -a233 :: IO (); a233 = forever $ putStrLn "a233" -a234 :: IO (); a234 = forever $ putStrLn "a234" -a235 :: IO (); a235 = forever $ putStrLn "a235" -a236 :: IO (); a236 = forever $ putStrLn "a236" -a237 :: IO (); a237 = forever $ putStrLn "a237" -a238 :: IO (); a238 = forever $ putStrLn "a238" -a239 :: IO (); a239 = forever $ putStrLn "a239" -a240 :: IO (); a240 = forever $ putStrLn "a240" -a241 :: IO (); a241 = forever $ putStrLn "a241" -a242 :: IO (); a242 = forever $ putStrLn "a242" -a243 :: IO (); a243 = forever $ putStrLn "a243" -a244 :: IO (); a244 = forever $ putStrLn "a244" -a245 :: IO (); a245 = forever $ putStrLn "a245" -a246 :: IO (); a246 = forever $ putStrLn "a246" -a247 :: IO (); a247 = forever $ putStrLn "a247" -a248 :: IO (); a248 = forever $ putStrLn "a248" -a249 :: IO (); a249 = forever $ putStrLn "a249" -a250 :: IO (); a250 = forever $ putStrLn "a250" -a251 :: IO (); a251 = forever $ putStrLn "a251" -a252 :: IO (); a252 = forever $ putStrLn "a252" -a253 :: IO (); a253 = forever $ putStrLn "a253" -a254 :: IO (); a254 = forever $ putStrLn "a254" -a255 :: IO (); a255 = forever $ putStrLn "a255" -a256 :: IO (); a256 = forever $ putStrLn "a256" -a257 :: IO (); a257 = forever $ putStrLn "a257" -a258 :: IO (); a258 = forever $ putStrLn "a258" -a259 :: IO (); a259 = forever $ putStrLn "a259" -a260 :: IO (); a260 = forever $ putStrLn "a260" -a261 :: IO (); a261 = forever $ putStrLn "a261" -a262 :: IO (); a262 = forever $ putStrLn "a262" -a263 :: IO (); a263 = forever $ putStrLn "a263" -a264 :: IO (); a264 = forever $ putStrLn "a264" -a265 :: IO (); a265 = forever $ putStrLn "a265" -a266 :: IO (); a266 = forever $ putStrLn "a266" -a267 :: IO (); a267 = forever $ putStrLn "a267" -a268 :: IO (); a268 = forever $ putStrLn "a268" -a269 :: IO (); a269 = forever $ putStrLn "a269" -a270 :: IO (); a270 = forever $ putStrLn "a270" -a271 :: IO (); a271 = forever $ putStrLn "a271" -a272 :: IO (); a272 = forever $ putStrLn "a272" -a273 :: IO (); a273 = forever $ putStrLn "a273" -a274 :: IO (); a274 = forever $ putStrLn "a274" -a275 :: IO (); a275 = forever $ putStrLn "a275" -a276 :: IO (); a276 = forever $ putStrLn "a276" -a277 :: IO (); a277 = forever $ putStrLn "a277" -a278 :: IO (); a278 = forever $ putStrLn "a278" -a279 :: IO (); a279 = forever $ putStrLn "a279" -a280 :: IO (); a280 = forever $ putStrLn "a280" -a281 :: IO (); a281 = forever $ putStrLn "a281" -a282 :: IO (); a282 = forever $ putStrLn "a282" -a283 :: IO (); a283 = forever $ putStrLn "a283" -a284 :: IO (); a284 = forever $ putStrLn "a284" -a285 :: IO (); a285 = forever $ putStrLn "a285" -a286 :: IO (); a286 = forever $ putStrLn "a286" -a287 :: IO (); a287 = forever $ putStrLn "a287" -a288 :: IO (); a288 = forever $ putStrLn "a288" -a289 :: IO (); a289 = forever $ putStrLn "a289" -a290 :: IO (); a290 = forever $ putStrLn "a290" -a291 :: IO (); a291 = forever $ putStrLn "a291" -a292 :: IO (); a292 = forever $ putStrLn "a292" -a293 :: IO (); a293 = forever $ putStrLn "a293" -a294 :: IO (); a294 = forever $ putStrLn "a294" -a295 :: IO (); a295 = forever $ putStrLn "a295" -a296 :: IO (); a296 = forever $ putStrLn "a296" -a297 :: IO (); a297 = forever $ putStrLn "a297" -a298 :: IO (); a298 = forever $ putStrLn "a298" -a299 :: IO (); a299 = forever $ putStrLn "a299" -a300 :: IO (); a300 = forever $ putStrLn "a300" -a301 :: IO (); a301 = forever $ putStrLn "a301" -a302 :: IO (); a302 = forever $ putStrLn "a302" -a303 :: IO (); a303 = forever $ putStrLn "a303" -a304 :: IO (); a304 = forever $ putStrLn "a304" -a305 :: IO (); a305 = forever $ putStrLn "a305" -a306 :: IO (); a306 = forever $ putStrLn "a306" -a307 :: IO (); a307 = forever $ putStrLn "a307" -a308 :: IO (); a308 = forever $ putStrLn "a308" -a309 :: IO (); a309 = forever $ putStrLn "a309" -a310 :: IO (); a310 = forever $ putStrLn "a310" -a311 :: IO (); a311 = forever $ putStrLn "a311" -a312 :: IO (); a312 = forever $ putStrLn "a312" -a313 :: IO (); a313 = forever $ putStrLn "a313" -a314 :: IO (); a314 = forever $ putStrLn "a314" -a315 :: IO (); a315 = forever $ putStrLn "a315" -a316 :: IO (); a316 = forever $ putStrLn "a316" -a317 :: IO (); a317 = forever $ putStrLn "a317" -a318 :: IO (); a318 = forever $ putStrLn "a318" -a319 :: IO (); a319 = forever $ putStrLn "a319" -a320 :: IO (); a320 = forever $ putStrLn "a320" -a321 :: IO (); a321 = forever $ putStrLn "a321" -a322 :: IO (); a322 = forever $ putStrLn "a322" -a323 :: IO (); a323 = forever $ putStrLn "a323" -a324 :: IO (); a324 = forever $ putStrLn "a324" -a325 :: IO (); a325 = forever $ putStrLn "a325" -a326 :: IO (); a326 = forever $ putStrLn "a326" -a327 :: IO (); a327 = forever $ putStrLn "a327" -a328 :: IO (); a328 = forever $ putStrLn "a328" -a329 :: IO (); a329 = forever $ putStrLn "a329" -a330 :: IO (); a330 = forever $ putStrLn "a330" -a331 :: IO (); a331 = forever $ putStrLn "a331" -a332 :: IO (); a332 = forever $ putStrLn "a332" -a333 :: IO (); a333 = forever $ putStrLn "a333" -a334 :: IO (); a334 = forever $ putStrLn "a334" -a335 :: IO (); a335 = forever $ putStrLn "a335" -a336 :: IO (); a336 = forever $ putStrLn "a336" -a337 :: IO (); a337 = forever $ putStrLn "a337" -a338 :: IO (); a338 = forever $ putStrLn "a338" -a339 :: IO (); a339 = forever $ putStrLn "a339" -a340 :: IO (); a340 = forever $ putStrLn "a340" -a341 :: IO (); a341 = forever $ putStrLn "a341" -a342 :: IO (); a342 = forever $ putStrLn "a342" -a343 :: IO (); a343 = forever $ putStrLn "a343" -a344 :: IO (); a344 = forever $ putStrLn "a344" -a345 :: IO (); a345 = forever $ putStrLn "a345" -a346 :: IO (); a346 = forever $ putStrLn "a346" -a347 :: IO (); a347 = forever $ putStrLn "a347" -a348 :: IO (); a348 = forever $ putStrLn "a348" -a349 :: IO (); a349 = forever $ putStrLn "a349" -a350 :: IO (); a350 = forever $ putStrLn "a350" -a351 :: IO (); a351 = forever $ putStrLn "a351" -a352 :: IO (); a352 = forever $ putStrLn "a352" -a353 :: IO (); a353 = forever $ putStrLn "a353" -a354 :: IO (); a354 = forever $ putStrLn "a354" -a355 :: IO (); a355 = forever $ putStrLn "a355" -a356 :: IO (); a356 = forever $ putStrLn "a356" -a357 :: IO (); a357 = forever $ putStrLn "a357" -a358 :: IO (); a358 = forever $ putStrLn "a358" -a359 :: IO (); a359 = forever $ putStrLn "a359" -a360 :: IO (); a360 = forever $ putStrLn "a360" -a361 :: IO (); a361 = forever $ putStrLn "a361" -a362 :: IO (); a362 = forever $ putStrLn "a362" -a363 :: IO (); a363 = forever $ putStrLn "a363" -a364 :: IO (); a364 = forever $ putStrLn "a364" -a365 :: IO (); a365 = forever $ putStrLn "a365" -a366 :: IO (); a366 = forever $ putStrLn "a366" -a367 :: IO (); a367 = forever $ putStrLn "a367" -a368 :: IO (); a368 = forever $ putStrLn "a368" -a369 :: IO (); a369 = forever $ putStrLn "a369" -a370 :: IO (); a370 = forever $ putStrLn "a370" -a371 :: IO (); a371 = forever $ putStrLn "a371" -a372 :: IO (); a372 = forever $ putStrLn "a372" -a373 :: IO (); a373 = forever $ putStrLn "a373" -a374 :: IO (); a374 = forever $ putStrLn "a374" -a375 :: IO (); a375 = forever $ putStrLn "a375" -a376 :: IO (); a376 = forever $ putStrLn "a376" -a377 :: IO (); a377 = forever $ putStrLn "a377" -a378 :: IO (); a378 = forever $ putStrLn "a378" -a379 :: IO (); a379 = forever $ putStrLn "a379" -a380 :: IO (); a380 = forever $ putStrLn "a380" -a381 :: IO (); a381 = forever $ putStrLn "a381" -a382 :: IO (); a382 = forever $ putStrLn "a382" -a383 :: IO (); a383 = forever $ putStrLn "a383" -a384 :: IO (); a384 = forever $ putStrLn "a384" -a385 :: IO (); a385 = forever $ putStrLn "a385" -a386 :: IO (); a386 = forever $ putStrLn "a386" -a387 :: IO (); a387 = forever $ putStrLn "a387" -a388 :: IO (); a388 = forever $ putStrLn "a388" -a389 :: IO (); a389 = forever $ putStrLn "a389" -a390 :: IO (); a390 = forever $ putStrLn "a390" -a391 :: IO (); a391 = forever $ putStrLn "a391" -a392 :: IO (); a392 = forever $ putStrLn "a392" -a393 :: IO (); a393 = forever $ putStrLn "a393" -a394 :: IO (); a394 = forever $ putStrLn "a394" -a395 :: IO (); a395 = forever $ putStrLn "a395" -a396 :: IO (); a396 = forever $ putStrLn "a396" -a397 :: IO (); a397 = forever $ putStrLn "a397" -a398 :: IO (); a398 = forever $ putStrLn "a398" -a399 :: IO (); a399 = forever $ putStrLn "a399" -a400 :: IO (); a400 = forever $ putStrLn "a400" -a401 :: IO (); a401 = forever $ putStrLn "a401" -a402 :: IO (); a402 = forever $ putStrLn "a402" -a403 :: IO (); a403 = forever $ putStrLn "a403" -a404 :: IO (); a404 = forever $ putStrLn "a404" -a405 :: IO (); a405 = forever $ putStrLn "a405" -a406 :: IO (); a406 = forever $ putStrLn "a406" -a407 :: IO (); a407 = forever $ putStrLn "a407" -a408 :: IO (); a408 = forever $ putStrLn "a408" -a409 :: IO (); a409 = forever $ putStrLn "a409" -a410 :: IO (); a410 = forever $ putStrLn "a410" -a411 :: IO (); a411 = forever $ putStrLn "a411" -a412 :: IO (); a412 = forever $ putStrLn "a412" -a413 :: IO (); a413 = forever $ putStrLn "a413" -a414 :: IO (); a414 = forever $ putStrLn "a414" -a415 :: IO (); a415 = forever $ putStrLn "a415" -a416 :: IO (); a416 = forever $ putStrLn "a416" -a417 :: IO (); a417 = forever $ putStrLn "a417" -a418 :: IO (); a418 = forever $ putStrLn "a418" -a419 :: IO (); a419 = forever $ putStrLn "a419" -a420 :: IO (); a420 = forever $ putStrLn "a420" -a421 :: IO (); a421 = forever $ putStrLn "a421" -a422 :: IO (); a422 = forever $ putStrLn "a422" -a423 :: IO (); a423 = forever $ putStrLn "a423" -a424 :: IO (); a424 = forever $ putStrLn "a424" -a425 :: IO (); a425 = forever $ putStrLn "a425" -a426 :: IO (); a426 = forever $ putStrLn "a426" -a427 :: IO (); a427 = forever $ putStrLn "a427" -a428 :: IO (); a428 = forever $ putStrLn "a428" -a429 :: IO (); a429 = forever $ putStrLn "a429" -a430 :: IO (); a430 = forever $ putStrLn "a430" -a431 :: IO (); a431 = forever $ putStrLn "a431" -a432 :: IO (); a432 = forever $ putStrLn "a432" -a433 :: IO (); a433 = forever $ putStrLn "a433" -a434 :: IO (); a434 = forever $ putStrLn "a434" -a435 :: IO (); a435 = forever $ putStrLn "a435" -a436 :: IO (); a436 = forever $ putStrLn "a436" -a437 :: IO (); a437 = forever $ putStrLn "a437" -a438 :: IO (); a438 = forever $ putStrLn "a438" -a439 :: IO (); a439 = forever $ putStrLn "a439" -a440 :: IO (); a440 = forever $ putStrLn "a440" -a441 :: IO (); a441 = forever $ putStrLn "a441" -a442 :: IO (); a442 = forever $ putStrLn "a442" -a443 :: IO (); a443 = forever $ putStrLn "a443" -a444 :: IO (); a444 = forever $ putStrLn "a444" -a445 :: IO (); a445 = forever $ putStrLn "a445" -a446 :: IO (); a446 = forever $ putStrLn "a446" -a447 :: IO (); a447 = forever $ putStrLn "a447" -a448 :: IO (); a448 = forever $ putStrLn "a448" -a449 :: IO (); a449 = forever $ putStrLn "a449" -a450 :: IO (); a450 = forever $ putStrLn "a450" -a451 :: IO (); a451 = forever $ putStrLn "a451" -a452 :: IO (); a452 = forever $ putStrLn "a452" -a453 :: IO (); a453 = forever $ putStrLn "a453" -a454 :: IO (); a454 = forever $ putStrLn "a454" -a455 :: IO (); a455 = forever $ putStrLn "a455" -a456 :: IO (); a456 = forever $ putStrLn "a456" -a457 :: IO (); a457 = forever $ putStrLn "a457" -a458 :: IO (); a458 = forever $ putStrLn "a458" -a459 :: IO (); a459 = forever $ putStrLn "a459" -a460 :: IO (); a460 = forever $ putStrLn "a460" -a461 :: IO (); a461 = forever $ putStrLn "a461" -a462 :: IO (); a462 = forever $ putStrLn "a462" -a463 :: IO (); a463 = forever $ putStrLn "a463" -a464 :: IO (); a464 = forever $ putStrLn "a464" -a465 :: IO (); a465 = forever $ putStrLn "a465" -a466 :: IO (); a466 = forever $ putStrLn "a466" -a467 :: IO (); a467 = forever $ putStrLn "a467" -a468 :: IO (); a468 = forever $ putStrLn "a468" -a469 :: IO (); a469 = forever $ putStrLn "a469" -a470 :: IO (); a470 = forever $ putStrLn "a470" -a471 :: IO (); a471 = forever $ putStrLn "a471" -a472 :: IO (); a472 = forever $ putStrLn "a472" -a473 :: IO (); a473 = forever $ putStrLn "a473" -a474 :: IO (); a474 = forever $ putStrLn "a474" -a475 :: IO (); a475 = forever $ putStrLn "a475" -a476 :: IO (); a476 = forever $ putStrLn "a476" -a477 :: IO (); a477 = forever $ putStrLn "a477" -a478 :: IO (); a478 = forever $ putStrLn "a478" -a479 :: IO (); a479 = forever $ putStrLn "a479" -a480 :: IO (); a480 = forever $ putStrLn "a480" -a481 :: IO (); a481 = forever $ putStrLn "a481" -a482 :: IO (); a482 = forever $ putStrLn "a482" -a483 :: IO (); a483 = forever $ putStrLn "a483" -a484 :: IO (); a484 = forever $ putStrLn "a484" -a485 :: IO (); a485 = forever $ putStrLn "a485" -a486 :: IO (); a486 = forever $ putStrLn "a486" -a487 :: IO (); a487 = forever $ putStrLn "a487" -a488 :: IO (); a488 = forever $ putStrLn "a488" -a489 :: IO (); a489 = forever $ putStrLn "a489" -a490 :: IO (); a490 = forever $ putStrLn "a490" -a491 :: IO (); a491 = forever $ putStrLn "a491" -a492 :: IO (); a492 = forever $ putStrLn "a492" -a493 :: IO (); a493 = forever $ putStrLn "a493" -a494 :: IO (); a494 = forever $ putStrLn "a494" -a495 :: IO (); a495 = forever $ putStrLn "a495" -a496 :: IO (); a496 = forever $ putStrLn "a496" -a497 :: IO (); a497 = forever $ putStrLn "a497" -a498 :: IO (); a498 = forever $ putStrLn "a498" -a499 :: IO (); a499 = forever $ putStrLn "a499" -a500 :: IO (); a500 = forever $ putStrLn "a500" -a501 :: IO (); a501 = forever $ putStrLn "a501" -a502 :: IO (); a502 = forever $ putStrLn "a502" -a503 :: IO (); a503 = forever $ putStrLn "a503" -a504 :: IO (); a504 = forever $ putStrLn "a504" -a505 :: IO (); a505 = forever $ putStrLn "a505" -a506 :: IO (); a506 = forever $ putStrLn "a506" -a507 :: IO (); a507 = forever $ putStrLn "a507" -a508 :: IO (); a508 = forever $ putStrLn "a508" -a509 :: IO (); a509 = forever $ putStrLn "a509" -a510 :: IO (); a510 = forever $ putStrLn "a510" -a511 :: IO (); a511 = forever $ putStrLn "a511" -a512 :: IO (); a512 = forever $ putStrLn "a512" -a513 :: IO (); a513 = forever $ putStrLn "a513" -a514 :: IO (); a514 = forever $ putStrLn "a514" -a515 :: IO (); a515 = forever $ putStrLn "a515" -a516 :: IO (); a516 = forever $ putStrLn "a516" -a517 :: IO (); a517 = forever $ putStrLn "a517" -a518 :: IO (); a518 = forever $ putStrLn "a518" -a519 :: IO (); a519 = forever $ putStrLn "a519" -a520 :: IO (); a520 = forever $ putStrLn "a520" -a521 :: IO (); a521 = forever $ putStrLn "a521" -a522 :: IO (); a522 = forever $ putStrLn "a522" -a523 :: IO (); a523 = forever $ putStrLn "a523" -a524 :: IO (); a524 = forever $ putStrLn "a524" -a525 :: IO (); a525 = forever $ putStrLn "a525" -a526 :: IO (); a526 = forever $ putStrLn "a526" -a527 :: IO (); a527 = forever $ putStrLn "a527" -a528 :: IO (); a528 = forever $ putStrLn "a528" -a529 :: IO (); a529 = forever $ putStrLn "a529" -a530 :: IO (); a530 = forever $ putStrLn "a530" -a531 :: IO (); a531 = forever $ putStrLn "a531" -a532 :: IO (); a532 = forever $ putStrLn "a532" -a533 :: IO (); a533 = forever $ putStrLn "a533" -a534 :: IO (); a534 = forever $ putStrLn "a534" -a535 :: IO (); a535 = forever $ putStrLn "a535" -a536 :: IO (); a536 = forever $ putStrLn "a536" -a537 :: IO (); a537 = forever $ putStrLn "a537" -a538 :: IO (); a538 = forever $ putStrLn "a538" -a539 :: IO (); a539 = forever $ putStrLn "a539" -a540 :: IO (); a540 = forever $ putStrLn "a540" -a541 :: IO (); a541 = forever $ putStrLn "a541" -a542 :: IO (); a542 = forever $ putStrLn "a542" -a543 :: IO (); a543 = forever $ putStrLn "a543" -a544 :: IO (); a544 = forever $ putStrLn "a544" -a545 :: IO (); a545 = forever $ putStrLn "a545" -a546 :: IO (); a546 = forever $ putStrLn "a546" -a547 :: IO (); a547 = forever $ putStrLn "a547" -a548 :: IO (); a548 = forever $ putStrLn "a548" -a549 :: IO (); a549 = forever $ putStrLn "a549" -a550 :: IO (); a550 = forever $ putStrLn "a550" -a551 :: IO (); a551 = forever $ putStrLn "a551" -a552 :: IO (); a552 = forever $ putStrLn "a552" -a553 :: IO (); a553 = forever $ putStrLn "a553" -a554 :: IO (); a554 = forever $ putStrLn "a554" -a555 :: IO (); a555 = forever $ putStrLn "a555" -a556 :: IO (); a556 = forever $ putStrLn "a556" -a557 :: IO (); a557 = forever $ putStrLn "a557" -a558 :: IO (); a558 = forever $ putStrLn "a558" -a559 :: IO (); a559 = forever $ putStrLn "a559" -a560 :: IO (); a560 = forever $ putStrLn "a560" -a561 :: IO (); a561 = forever $ putStrLn "a561" -a562 :: IO (); a562 = forever $ putStrLn "a562" -a563 :: IO (); a563 = forever $ putStrLn "a563" -a564 :: IO (); a564 = forever $ putStrLn "a564" -a565 :: IO (); a565 = forever $ putStrLn "a565" -a566 :: IO (); a566 = forever $ putStrLn "a566" -a567 :: IO (); a567 = forever $ putStrLn "a567" -a568 :: IO (); a568 = forever $ putStrLn "a568" -a569 :: IO (); a569 = forever $ putStrLn "a569" -a570 :: IO (); a570 = forever $ putStrLn "a570" -a571 :: IO (); a571 = forever $ putStrLn "a571" -a572 :: IO (); a572 = forever $ putStrLn "a572" -a573 :: IO (); a573 = forever $ putStrLn "a573" -a574 :: IO (); a574 = forever $ putStrLn "a574" -a575 :: IO (); a575 = forever $ putStrLn "a575" -a576 :: IO (); a576 = forever $ putStrLn "a576" -a577 :: IO (); a577 = forever $ putStrLn "a577" -a578 :: IO (); a578 = forever $ putStrLn "a578" -a579 :: IO (); a579 = forever $ putStrLn "a579" -a580 :: IO (); a580 = forever $ putStrLn "a580" -a581 :: IO (); a581 = forever $ putStrLn "a581" -a582 :: IO (); a582 = forever $ putStrLn "a582" -a583 :: IO (); a583 = forever $ putStrLn "a583" -a584 :: IO (); a584 = forever $ putStrLn "a584" -a585 :: IO (); a585 = forever $ putStrLn "a585" -a586 :: IO (); a586 = forever $ putStrLn "a586" -a587 :: IO (); a587 = forever $ putStrLn "a587" -a588 :: IO (); a588 = forever $ putStrLn "a588" -a589 :: IO (); a589 = forever $ putStrLn "a589" -a590 :: IO (); a590 = forever $ putStrLn "a590" -a591 :: IO (); a591 = forever $ putStrLn "a591" -a592 :: IO (); a592 = forever $ putStrLn "a592" -a593 :: IO (); a593 = forever $ putStrLn "a593" -a594 :: IO (); a594 = forever $ putStrLn "a594" -a595 :: IO (); a595 = forever $ putStrLn "a595" -a596 :: IO (); a596 = forever $ putStrLn "a596" -a597 :: IO (); a597 = forever $ putStrLn "a597" -a598 :: IO (); a598 = forever $ putStrLn "a598" -a599 :: IO (); a599 = forever $ putStrLn "a599" -a600 :: IO (); a600 = forever $ putStrLn "a600" -a601 :: IO (); a601 = forever $ putStrLn "a601" -a602 :: IO (); a602 = forever $ putStrLn "a602" -a603 :: IO (); a603 = forever $ putStrLn "a603" -a604 :: IO (); a604 = forever $ putStrLn "a604" -a605 :: IO (); a605 = forever $ putStrLn "a605" -a606 :: IO (); a606 = forever $ putStrLn "a606" -a607 :: IO (); a607 = forever $ putStrLn "a607" -a608 :: IO (); a608 = forever $ putStrLn "a608" -a609 :: IO (); a609 = forever $ putStrLn "a609" -a610 :: IO (); a610 = forever $ putStrLn "a610" -a611 :: IO (); a611 = forever $ putStrLn "a611" -a612 :: IO (); a612 = forever $ putStrLn "a612" -a613 :: IO (); a613 = forever $ putStrLn "a613" -a614 :: IO (); a614 = forever $ putStrLn "a614" -a615 :: IO (); a615 = forever $ putStrLn "a615" -a616 :: IO (); a616 = forever $ putStrLn "a616" -a617 :: IO (); a617 = forever $ putStrLn "a617" -a618 :: IO (); a618 = forever $ putStrLn "a618" -a619 :: IO (); a619 = forever $ putStrLn "a619" -a620 :: IO (); a620 = forever $ putStrLn "a620" -a621 :: IO (); a621 = forever $ putStrLn "a621" -a622 :: IO (); a622 = forever $ putStrLn "a622" -a623 :: IO (); a623 = forever $ putStrLn "a623" -a624 :: IO (); a624 = forever $ putStrLn "a624" -a625 :: IO (); a625 = forever $ putStrLn "a625" -a626 :: IO (); a626 = forever $ putStrLn "a626" -a627 :: IO (); a627 = forever $ putStrLn "a627" -a628 :: IO (); a628 = forever $ putStrLn "a628" -a629 :: IO (); a629 = forever $ putStrLn "a629" -a630 :: IO (); a630 = forever $ putStrLn "a630" -a631 :: IO (); a631 = forever $ putStrLn "a631" -a632 :: IO (); a632 = forever $ putStrLn "a632" -a633 :: IO (); a633 = forever $ putStrLn "a633" -a634 :: IO (); a634 = forever $ putStrLn "a634" -a635 :: IO (); a635 = forever $ putStrLn "a635" -a636 :: IO (); a636 = forever $ putStrLn "a636" -a637 :: IO (); a637 = forever $ putStrLn "a637" -a638 :: IO (); a638 = forever $ putStrLn "a638" -a639 :: IO (); a639 = forever $ putStrLn "a639" -a640 :: IO (); a640 = forever $ putStrLn "a640" -a641 :: IO (); a641 = forever $ putStrLn "a641" -a642 :: IO (); a642 = forever $ putStrLn "a642" -a643 :: IO (); a643 = forever $ putStrLn "a643" -a644 :: IO (); a644 = forever $ putStrLn "a644" -a645 :: IO (); a645 = forever $ putStrLn "a645" -a646 :: IO (); a646 = forever $ putStrLn "a646" -a647 :: IO (); a647 = forever $ putStrLn "a647" -a648 :: IO (); a648 = forever $ putStrLn "a648" -a649 :: IO (); a649 = forever $ putStrLn "a649" -a650 :: IO (); a650 = forever $ putStrLn "a650" -a651 :: IO (); a651 = forever $ putStrLn "a651" -a652 :: IO (); a652 = forever $ putStrLn "a652" -a653 :: IO (); a653 = forever $ putStrLn "a653" -a654 :: IO (); a654 = forever $ putStrLn "a654" -a655 :: IO (); a655 = forever $ putStrLn "a655" -a656 :: IO (); a656 = forever $ putStrLn "a656" -a657 :: IO (); a657 = forever $ putStrLn "a657" -a658 :: IO (); a658 = forever $ putStrLn "a658" -a659 :: IO (); a659 = forever $ putStrLn "a659" -a660 :: IO (); a660 = forever $ putStrLn "a660" -a661 :: IO (); a661 = forever $ putStrLn "a661" -a662 :: IO (); a662 = forever $ putStrLn "a662" -a663 :: IO (); a663 = forever $ putStrLn "a663" -a664 :: IO (); a664 = forever $ putStrLn "a664" -a665 :: IO (); a665 = forever $ putStrLn "a665" -a666 :: IO (); a666 = forever $ putStrLn "a666" -a667 :: IO (); a667 = forever $ putStrLn "a667" -a668 :: IO (); a668 = forever $ putStrLn "a668" -a669 :: IO (); a669 = forever $ putStrLn "a669" -a670 :: IO (); a670 = forever $ putStrLn "a670" -a671 :: IO (); a671 = forever $ putStrLn "a671" -a672 :: IO (); a672 = forever $ putStrLn "a672" -a673 :: IO (); a673 = forever $ putStrLn "a673" -a674 :: IO (); a674 = forever $ putStrLn "a674" -a675 :: IO (); a675 = forever $ putStrLn "a675" -a676 :: IO (); a676 = forever $ putStrLn "a676" -a677 :: IO (); a677 = forever $ putStrLn "a677" -a678 :: IO (); a678 = forever $ putStrLn "a678" -a679 :: IO (); a679 = forever $ putStrLn "a679" -a680 :: IO (); a680 = forever $ putStrLn "a680" -a681 :: IO (); a681 = forever $ putStrLn "a681" -a682 :: IO (); a682 = forever $ putStrLn "a682" -a683 :: IO (); a683 = forever $ putStrLn "a683" -a684 :: IO (); a684 = forever $ putStrLn "a684" -a685 :: IO (); a685 = forever $ putStrLn "a685" -a686 :: IO (); a686 = forever $ putStrLn "a686" -a687 :: IO (); a687 = forever $ putStrLn "a687" -a688 :: IO (); a688 = forever $ putStrLn "a688" -a689 :: IO (); a689 = forever $ putStrLn "a689" -a690 :: IO (); a690 = forever $ putStrLn "a690" -a691 :: IO (); a691 = forever $ putStrLn "a691" -a692 :: IO (); a692 = forever $ putStrLn "a692" -a693 :: IO (); a693 = forever $ putStrLn "a693" -a694 :: IO (); a694 = forever $ putStrLn "a694" -a695 :: IO (); a695 = forever $ putStrLn "a695" -a696 :: IO (); a696 = forever $ putStrLn "a696" -a697 :: IO (); a697 = forever $ putStrLn "a697" -a698 :: IO (); a698 = forever $ putStrLn "a698" -a699 :: IO (); a699 = forever $ putStrLn "a699" -a700 :: IO (); a700 = forever $ putStrLn "a700" -a701 :: IO (); a701 = forever $ putStrLn "a701" -a702 :: IO (); a702 = forever $ putStrLn "a702" -a703 :: IO (); a703 = forever $ putStrLn "a703" -a704 :: IO (); a704 = forever $ putStrLn "a704" -a705 :: IO (); a705 = forever $ putStrLn "a705" -a706 :: IO (); a706 = forever $ putStrLn "a706" -a707 :: IO (); a707 = forever $ putStrLn "a707" -a708 :: IO (); a708 = forever $ putStrLn "a708" -a709 :: IO (); a709 = forever $ putStrLn "a709" -a710 :: IO (); a710 = forever $ putStrLn "a710" -a711 :: IO (); a711 = forever $ putStrLn "a711" -a712 :: IO (); a712 = forever $ putStrLn "a712" -a713 :: IO (); a713 = forever $ putStrLn "a713" -a714 :: IO (); a714 = forever $ putStrLn "a714" -a715 :: IO (); a715 = forever $ putStrLn "a715" -a716 :: IO (); a716 = forever $ putStrLn "a716" -a717 :: IO (); a717 = forever $ putStrLn "a717" -a718 :: IO (); a718 = forever $ putStrLn "a718" -a719 :: IO (); a719 = forever $ putStrLn "a719" -a720 :: IO (); a720 = forever $ putStrLn "a720" -a721 :: IO (); a721 = forever $ putStrLn "a721" -a722 :: IO (); a722 = forever $ putStrLn "a722" -a723 :: IO (); a723 = forever $ putStrLn "a723" -a724 :: IO (); a724 = forever $ putStrLn "a724" -a725 :: IO (); a725 = forever $ putStrLn "a725" -a726 :: IO (); a726 = forever $ putStrLn "a726" -a727 :: IO (); a727 = forever $ putStrLn "a727" -a728 :: IO (); a728 = forever $ putStrLn "a728" -a729 :: IO (); a729 = forever $ putStrLn "a729" -a730 :: IO (); a730 = forever $ putStrLn "a730" -a731 :: IO (); a731 = forever $ putStrLn "a731" -a732 :: IO (); a732 = forever $ putStrLn "a732" -a733 :: IO (); a733 = forever $ putStrLn "a733" -a734 :: IO (); a734 = forever $ putStrLn "a734" -a735 :: IO (); a735 = forever $ putStrLn "a735" -a736 :: IO (); a736 = forever $ putStrLn "a736" -a737 :: IO (); a737 = forever $ putStrLn "a737" -a738 :: IO (); a738 = forever $ putStrLn "a738" -a739 :: IO (); a739 = forever $ putStrLn "a739" -a740 :: IO (); a740 = forever $ putStrLn "a740" -a741 :: IO (); a741 = forever $ putStrLn "a741" -a742 :: IO (); a742 = forever $ putStrLn "a742" -a743 :: IO (); a743 = forever $ putStrLn "a743" -a744 :: IO (); a744 = forever $ putStrLn "a744" -a745 :: IO (); a745 = forever $ putStrLn "a745" -a746 :: IO (); a746 = forever $ putStrLn "a746" -a747 :: IO (); a747 = forever $ putStrLn "a747" -a748 :: IO (); a748 = forever $ putStrLn "a748" -a749 :: IO (); a749 = forever $ putStrLn "a749" -a750 :: IO (); a750 = forever $ putStrLn "a750" -a751 :: IO (); a751 = forever $ putStrLn "a751" -a752 :: IO (); a752 = forever $ putStrLn "a752" -a753 :: IO (); a753 = forever $ putStrLn "a753" -a754 :: IO (); a754 = forever $ putStrLn "a754" -a755 :: IO (); a755 = forever $ putStrLn "a755" -a756 :: IO (); a756 = forever $ putStrLn "a756" -a757 :: IO (); a757 = forever $ putStrLn "a757" -a758 :: IO (); a758 = forever $ putStrLn "a758" -a759 :: IO (); a759 = forever $ putStrLn "a759" -a760 :: IO (); a760 = forever $ putStrLn "a760" -a761 :: IO (); a761 = forever $ putStrLn "a761" -a762 :: IO (); a762 = forever $ putStrLn "a762" -a763 :: IO (); a763 = forever $ putStrLn "a763" -a764 :: IO (); a764 = forever $ putStrLn "a764" -a765 :: IO (); a765 = forever $ putStrLn "a765" -a766 :: IO (); a766 = forever $ putStrLn "a766" -a767 :: IO (); a767 = forever $ putStrLn "a767" -a768 :: IO (); a768 = forever $ putStrLn "a768" -a769 :: IO (); a769 = forever $ putStrLn "a769" -a770 :: IO (); a770 = forever $ putStrLn "a770" -a771 :: IO (); a771 = forever $ putStrLn "a771" -a772 :: IO (); a772 = forever $ putStrLn "a772" -a773 :: IO (); a773 = forever $ putStrLn "a773" -a774 :: IO (); a774 = forever $ putStrLn "a774" -a775 :: IO (); a775 = forever $ putStrLn "a775" -a776 :: IO (); a776 = forever $ putStrLn "a776" -a777 :: IO (); a777 = forever $ putStrLn "a777" -a778 :: IO (); a778 = forever $ putStrLn "a778" -a779 :: IO (); a779 = forever $ putStrLn "a779" -a780 :: IO (); a780 = forever $ putStrLn "a780" -a781 :: IO (); a781 = forever $ putStrLn "a781" -a782 :: IO (); a782 = forever $ putStrLn "a782" -a783 :: IO (); a783 = forever $ putStrLn "a783" -a784 :: IO (); a784 = forever $ putStrLn "a784" -a785 :: IO (); a785 = forever $ putStrLn "a785" -a786 :: IO (); a786 = forever $ putStrLn "a786" -a787 :: IO (); a787 = forever $ putStrLn "a787" -a788 :: IO (); a788 = forever $ putStrLn "a788" -a789 :: IO (); a789 = forever $ putStrLn "a789" -a790 :: IO (); a790 = forever $ putStrLn "a790" -a791 :: IO (); a791 = forever $ putStrLn "a791" -a792 :: IO (); a792 = forever $ putStrLn "a792" -a793 :: IO (); a793 = forever $ putStrLn "a793" -a794 :: IO (); a794 = forever $ putStrLn "a794" -a795 :: IO (); a795 = forever $ putStrLn "a795" -a796 :: IO (); a796 = forever $ putStrLn "a796" -a797 :: IO (); a797 = forever $ putStrLn "a797" -a798 :: IO (); a798 = forever $ putStrLn "a798" -a799 :: IO (); a799 = forever $ putStrLn "a799" -a800 :: IO (); a800 = forever $ putStrLn "a800" -a801 :: IO (); a801 = forever $ putStrLn "a801" -a802 :: IO (); a802 = forever $ putStrLn "a802" -a803 :: IO (); a803 = forever $ putStrLn "a803" -a804 :: IO (); a804 = forever $ putStrLn "a804" -a805 :: IO (); a805 = forever $ putStrLn "a805" -a806 :: IO (); a806 = forever $ putStrLn "a806" -a807 :: IO (); a807 = forever $ putStrLn "a807" -a808 :: IO (); a808 = forever $ putStrLn "a808" -a809 :: IO (); a809 = forever $ putStrLn "a809" -a810 :: IO (); a810 = forever $ putStrLn "a810" -a811 :: IO (); a811 = forever $ putStrLn "a811" -a812 :: IO (); a812 = forever $ putStrLn "a812" -a813 :: IO (); a813 = forever $ putStrLn "a813" -a814 :: IO (); a814 = forever $ putStrLn "a814" -a815 :: IO (); a815 = forever $ putStrLn "a815" -a816 :: IO (); a816 = forever $ putStrLn "a816" -a817 :: IO (); a817 = forever $ putStrLn "a817" -a818 :: IO (); a818 = forever $ putStrLn "a818" -a819 :: IO (); a819 = forever $ putStrLn "a819" -a820 :: IO (); a820 = forever $ putStrLn "a820" -a821 :: IO (); a821 = forever $ putStrLn "a821" -a822 :: IO (); a822 = forever $ putStrLn "a822" -a823 :: IO (); a823 = forever $ putStrLn "a823" -a824 :: IO (); a824 = forever $ putStrLn "a824" -a825 :: IO (); a825 = forever $ putStrLn "a825" -a826 :: IO (); a826 = forever $ putStrLn "a826" -a827 :: IO (); a827 = forever $ putStrLn "a827" -a828 :: IO (); a828 = forever $ putStrLn "a828" -a829 :: IO (); a829 = forever $ putStrLn "a829" -a830 :: IO (); a830 = forever $ putStrLn "a830" -a831 :: IO (); a831 = forever $ putStrLn "a831" -a832 :: IO (); a832 = forever $ putStrLn "a832" -a833 :: IO (); a833 = forever $ putStrLn "a833" -a834 :: IO (); a834 = forever $ putStrLn "a834" -a835 :: IO (); a835 = forever $ putStrLn "a835" -a836 :: IO (); a836 = forever $ putStrLn "a836" -a837 :: IO (); a837 = forever $ putStrLn "a837" -a838 :: IO (); a838 = forever $ putStrLn "a838" -a839 :: IO (); a839 = forever $ putStrLn "a839" -a840 :: IO (); a840 = forever $ putStrLn "a840" -a841 :: IO (); a841 = forever $ putStrLn "a841" -a842 :: IO (); a842 = forever $ putStrLn "a842" -a843 :: IO (); a843 = forever $ putStrLn "a843" -a844 :: IO (); a844 = forever $ putStrLn "a844" -a845 :: IO (); a845 = forever $ putStrLn "a845" -a846 :: IO (); a846 = forever $ putStrLn "a846" -a847 :: IO (); a847 = forever $ putStrLn "a847" -a848 :: IO (); a848 = forever $ putStrLn "a848" -a849 :: IO (); a849 = forever $ putStrLn "a849" -a850 :: IO (); a850 = forever $ putStrLn "a850" -a851 :: IO (); a851 = forever $ putStrLn "a851" -a852 :: IO (); a852 = forever $ putStrLn "a852" -a853 :: IO (); a853 = forever $ putStrLn "a853" -a854 :: IO (); a854 = forever $ putStrLn "a854" -a855 :: IO (); a855 = forever $ putStrLn "a855" -a856 :: IO (); a856 = forever $ putStrLn "a856" -a857 :: IO (); a857 = forever $ putStrLn "a857" -a858 :: IO (); a858 = forever $ putStrLn "a858" -a859 :: IO (); a859 = forever $ putStrLn "a859" -a860 :: IO (); a860 = forever $ putStrLn "a860" -a861 :: IO (); a861 = forever $ putStrLn "a861" -a862 :: IO (); a862 = forever $ putStrLn "a862" -a863 :: IO (); a863 = forever $ putStrLn "a863" -a864 :: IO (); a864 = forever $ putStrLn "a864" -a865 :: IO (); a865 = forever $ putStrLn "a865" -a866 :: IO (); a866 = forever $ putStrLn "a866" -a867 :: IO (); a867 = forever $ putStrLn "a867" -a868 :: IO (); a868 = forever $ putStrLn "a868" -a869 :: IO (); a869 = forever $ putStrLn "a869" -a870 :: IO (); a870 = forever $ putStrLn "a870" -a871 :: IO (); a871 = forever $ putStrLn "a871" -a872 :: IO (); a872 = forever $ putStrLn "a872" -a873 :: IO (); a873 = forever $ putStrLn "a873" -a874 :: IO (); a874 = forever $ putStrLn "a874" -a875 :: IO (); a875 = forever $ putStrLn "a875" -a876 :: IO (); a876 = forever $ putStrLn "a876" -a877 :: IO (); a877 = forever $ putStrLn "a877" -a878 :: IO (); a878 = forever $ putStrLn "a878" -a879 :: IO (); a879 = forever $ putStrLn "a879" -a880 :: IO (); a880 = forever $ putStrLn "a880" -a881 :: IO (); a881 = forever $ putStrLn "a881" -a882 :: IO (); a882 = forever $ putStrLn "a882" -a883 :: IO (); a883 = forever $ putStrLn "a883" -a884 :: IO (); a884 = forever $ putStrLn "a884" -a885 :: IO (); a885 = forever $ putStrLn "a885" -a886 :: IO (); a886 = forever $ putStrLn "a886" -a887 :: IO (); a887 = forever $ putStrLn "a887" -a888 :: IO (); a888 = forever $ putStrLn "a888" -a889 :: IO (); a889 = forever $ putStrLn "a889" -a890 :: IO (); a890 = forever $ putStrLn "a890" -a891 :: IO (); a891 = forever $ putStrLn "a891" -a892 :: IO (); a892 = forever $ putStrLn "a892" -a893 :: IO (); a893 = forever $ putStrLn "a893" -a894 :: IO (); a894 = forever $ putStrLn "a894" -a895 :: IO (); a895 = forever $ putStrLn "a895" -a896 :: IO (); a896 = forever $ putStrLn "a896" -a897 :: IO (); a897 = forever $ putStrLn "a897" -a898 :: IO (); a898 = forever $ putStrLn "a898" -a899 :: IO (); a899 = forever $ putStrLn "a899" -a900 :: IO (); a900 = forever $ putStrLn "a900" -a901 :: IO (); a901 = forever $ putStrLn "a901" -a902 :: IO (); a902 = forever $ putStrLn "a902" -a903 :: IO (); a903 = forever $ putStrLn "a903" -a904 :: IO (); a904 = forever $ putStrLn "a904" -a905 :: IO (); a905 = forever $ putStrLn "a905" -a906 :: IO (); a906 = forever $ putStrLn "a906" -a907 :: IO (); a907 = forever $ putStrLn "a907" -a908 :: IO (); a908 = forever $ putStrLn "a908" -a909 :: IO (); a909 = forever $ putStrLn "a909" -a910 :: IO (); a910 = forever $ putStrLn "a910" -a911 :: IO (); a911 = forever $ putStrLn "a911" -a912 :: IO (); a912 = forever $ putStrLn "a912" -a913 :: IO (); a913 = forever $ putStrLn "a913" -a914 :: IO (); a914 = forever $ putStrLn "a914" -a915 :: IO (); a915 = forever $ putStrLn "a915" -a916 :: IO (); a916 = forever $ putStrLn "a916" -a917 :: IO (); a917 = forever $ putStrLn "a917" -a918 :: IO (); a918 = forever $ putStrLn "a918" -a919 :: IO (); a919 = forever $ putStrLn "a919" -a920 :: IO (); a920 = forever $ putStrLn "a920" -a921 :: IO (); a921 = forever $ putStrLn "a921" -a922 :: IO (); a922 = forever $ putStrLn "a922" -a923 :: IO (); a923 = forever $ putStrLn "a923" -a924 :: IO (); a924 = forever $ putStrLn "a924" -a925 :: IO (); a925 = forever $ putStrLn "a925" -a926 :: IO (); a926 = forever $ putStrLn "a926" -a927 :: IO (); a927 = forever $ putStrLn "a927" -a928 :: IO (); a928 = forever $ putStrLn "a928" -a929 :: IO (); a929 = forever $ putStrLn "a929" -a930 :: IO (); a930 = forever $ putStrLn "a930" -a931 :: IO (); a931 = forever $ putStrLn "a931" -a932 :: IO (); a932 = forever $ putStrLn "a932" -a933 :: IO (); a933 = forever $ putStrLn "a933" -a934 :: IO (); a934 = forever $ putStrLn "a934" -a935 :: IO (); a935 = forever $ putStrLn "a935" -a936 :: IO (); a936 = forever $ putStrLn "a936" -a937 :: IO (); a937 = forever $ putStrLn "a937" -a938 :: IO (); a938 = forever $ putStrLn "a938" -a939 :: IO (); a939 = forever $ putStrLn "a939" -a940 :: IO (); a940 = forever $ putStrLn "a940" -a941 :: IO (); a941 = forever $ putStrLn "a941" -a942 :: IO (); a942 = forever $ putStrLn "a942" -a943 :: IO (); a943 = forever $ putStrLn "a943" -a944 :: IO (); a944 = forever $ putStrLn "a944" -a945 :: IO (); a945 = forever $ putStrLn "a945" -a946 :: IO (); a946 = forever $ putStrLn "a946" -a947 :: IO (); a947 = forever $ putStrLn "a947" -a948 :: IO (); a948 = forever $ putStrLn "a948" -a949 :: IO (); a949 = forever $ putStrLn "a949" -a950 :: IO (); a950 = forever $ putStrLn "a950" -a951 :: IO (); a951 = forever $ putStrLn "a951" -a952 :: IO (); a952 = forever $ putStrLn "a952" -a953 :: IO (); a953 = forever $ putStrLn "a953" -a954 :: IO (); a954 = forever $ putStrLn "a954" -a955 :: IO (); a955 = forever $ putStrLn "a955" -a956 :: IO (); a956 = forever $ putStrLn "a956" -a957 :: IO (); a957 = forever $ putStrLn "a957" -a958 :: IO (); a958 = forever $ putStrLn "a958" -a959 :: IO (); a959 = forever $ putStrLn "a959" -a960 :: IO (); a960 = forever $ putStrLn "a960" -a961 :: IO (); a961 = forever $ putStrLn "a961" -a962 :: IO (); a962 = forever $ putStrLn "a962" -a963 :: IO (); a963 = forever $ putStrLn "a963" -a964 :: IO (); a964 = forever $ putStrLn "a964" -a965 :: IO (); a965 = forever $ putStrLn "a965" -a966 :: IO (); a966 = forever $ putStrLn "a966" -a967 :: IO (); a967 = forever $ putStrLn "a967" -a968 :: IO (); a968 = forever $ putStrLn "a968" -a969 :: IO (); a969 = forever $ putStrLn "a969" -a970 :: IO (); a970 = forever $ putStrLn "a970" -a971 :: IO (); a971 = forever $ putStrLn "a971" -a972 :: IO (); a972 = forever $ putStrLn "a972" -a973 :: IO (); a973 = forever $ putStrLn "a973" -a974 :: IO (); a974 = forever $ putStrLn "a974" -a975 :: IO (); a975 = forever $ putStrLn "a975" -a976 :: IO (); a976 = forever $ putStrLn "a976" -a977 :: IO (); a977 = forever $ putStrLn "a977" -a978 :: IO (); a978 = forever $ putStrLn "a978" -a979 :: IO (); a979 = forever $ putStrLn "a979" -a980 :: IO (); a980 = forever $ putStrLn "a980" -a981 :: IO (); a981 = forever $ putStrLn "a981" -a982 :: IO (); a982 = forever $ putStrLn "a982" -a983 :: IO (); a983 = forever $ putStrLn "a983" -a984 :: IO (); a984 = forever $ putStrLn "a984" -a985 :: IO (); a985 = forever $ putStrLn "a985" -a986 :: IO (); a986 = forever $ putStrLn "a986" -a987 :: IO (); a987 = forever $ putStrLn "a987" -a988 :: IO (); a988 = forever $ putStrLn "a988" -a989 :: IO (); a989 = forever $ putStrLn "a989" -a990 :: IO (); a990 = forever $ putStrLn "a990" -a991 :: IO (); a991 = forever $ putStrLn "a991" -a992 :: IO (); a992 = forever $ putStrLn "a992" -a993 :: IO (); a993 = forever $ putStrLn "a993" -a994 :: IO (); a994 = forever $ putStrLn "a994" -a995 :: IO (); a995 = forever $ putStrLn "a995" -a996 :: IO (); a996 = forever $ putStrLn "a996" -a997 :: IO (); a997 = forever $ putStrLn "a997" -a998 :: IO (); a998 = forever $ putStrLn "a998" -a999 :: IO (); a999 = forever $ putStrLn "a999" -a1000 :: IO (); a1000 = forever $ putStrLn "a1000" diff --git a/tests/examples/ghc8/T10384.hs b/tests/examples/ghc8/T10384.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10384.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE TemplateHaskell, RankNTypes, ScopedTypeVariables #-} -module A where -x = \(y :: forall a. a -> a) -> [|| y ||] diff --git a/tests/examples/ghc8/T10390.hs b/tests/examples/ghc8/T10390.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10390.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module T10390 where - -class ApPair r where - apPair :: (forall a . (ApPair a, Num a) => Maybe a) -> Maybe r - -instance (ApPair a, ApPair b) => ApPair (a,b) where - apPair = apPair' - -apPair' :: (ApPair b, ApPair c) - => (forall a . (Num a, ApPair a) => Maybe a) -> Maybe (b,c) - -- NB constraints in a different order to apPair -apPair' f = let (Just a) = apPair f - (Just b) = apPair f - in Just $ (a, b) diff --git a/tests/examples/ghc8/T10398.hs b/tests/examples/ghc8/T10398.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10398.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Foo -( - -- The reference to chunk2 should show up in the -ddump-parsed output. - -- $chunk1 - -- $chunk2 - foo, - -- $chunk3 - bar -) -where - -{- $chunk1 -This is chunk 1. --} - -{- $chunk2 -This is chunk 2. --} - -{- $chunk3 -This is chunk 3. --} - -foo = 3 -bar = 7 diff --git a/tests/examples/ghc8/T10403.hs b/tests/examples/ghc8/T10403.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10403.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -fdefer-type-errors #-} -module T10403 where - -data I a = I a -instance Functor I where - fmap f (I a) = I (f a) - -newtype B t a = B a -instance Functor (B t) where - fmap f (B a) = B (f a) - -newtype H f = H (f ()) - -h1 :: _ => _ --- h :: Functor m => (a -> b) -> m a -> H m -h1 f b = (H . fmap (const ())) (fmap f b) - -h2 :: _ --- h2 :: Functor m => (a -> b) -> m a -> H m -h2 f b = (H . fmap (const ())) (fmap f b) - -app1 :: H (B t) -app1 = h1 (H . I) (B ()) - -app2 :: H (B t) -app2 = h2 (H . I) (B ()) diff --git a/tests/examples/ghc8/T10414.hs b/tests/examples/ghc8/T10414.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10414.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples #-} -import GHC.Exts -newtype Eval a = Eval {runEval :: State# RealWorld -> (# State# RealWorld, a #)} - --- inline sequence :: [Eval a] -> Eval [a] -well_sequenced :: [Eval a] -> Eval [a] -well_sequenced = foldr cons nil where - cons e es = Eval $ \s -> case runEval e s of - (# s', a #) -> case runEval es s' of - (# s'', as #) -> (# s'', a : as #) - nil = Eval $ \s -> (# s, [] #) - --- seemingly demonic use of spark# -ill_sequenced :: [Eval a] -> Eval [a] -ill_sequenced as = Eval $ spark# (case well_sequenced as of - Eval f -> case f realWorld# of (# _, a' #) -> a') - --- 'parallelized' version of (show >=> show >=> show >=> show >=> show) -main :: IO () -main = putStrLn ((layer . layer . layer . layer . layer) (:[]) 'y') - where - layer :: (Char -> String) -> (Char -> String) - layer f = (\(Eval x) -> case x realWorld# of (# _, as #) -> concat as) - . well_sequenced -- [Eval String] -> Eval [String] - . map ill_sequenced -- [[Eval Char]] -> [Eval String]; - -- 'map well_sequenced' is fine - . map (map (\x -> Eval $ \s -> (# s, x #))) -- wrap each Char in Eval - . chunk' -- String -> [String] - . concatMap f - . show -- add single quotes - - chunk' :: String -> [String] - chunk' [] = [] - chunk' xs = as : chunk' bs where (as,bs) = splitAt 3 xs - - -- this doesn't work: - -- chunk (a:b:c:xs) = [a,b,c]:chunk xs - -- chunk xs = [xs] diff --git a/tests/examples/ghc8/T10420.hs b/tests/examples/ghc8/T10420.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10420.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Main where - -import T10420a - -import RuleDefiningPlugin - -{-# NOINLINE x #-} -x = "foo" - -main = putStrLn (show x) diff --git a/tests/examples/ghc8/T10420a.hs b/tests/examples/ghc8/T10420a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10420a.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# OPTIONS_GHC -fplugin RuleDefiningPlugin #-} -module T10420a where diff --git a/tests/examples/ghc8/T10423.hs b/tests/examples/ghc8/T10423.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10423.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeFamilies, MultiParamTypeClasses #-} - -module T10423 where - -class Monad m => Testable m a - -newtype Prop m = MkProp (m Int) - -instance (Monad m, m ~ n) => Testable n (Prop m) diff --git a/tests/examples/ghc8/T10428.hs b/tests/examples/ghc8/T10428.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10428.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T10428 where - -import Data.Coerce -coerceNewtype :: (Coercible (o r) (n m' r)) => [o r] -> [n m' r] -coerceNewtype = coerce diff --git a/tests/examples/ghc8/T10438.hs b/tests/examples/ghc8/T10438.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10438.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TypeFamilies #-} -module T10438 where - -foo f = g - where g r = x - where x :: _ - x = r diff --git a/tests/examples/ghc8/T10447.hs b/tests/examples/ghc8/T10447.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10447.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DeriveFoldable, GADTs, StandaloneDeriving #-} -module Main where - -class (a ~ Int) => Foo a -instance Foo Int - -data A a where - A1 :: Ord a => a -> A a - A2 :: Int -> A Int - A3 :: b ~ Int => b -> A Int - A4 :: a ~ Int => Int -> A a - A5 :: a ~ Int => a -> A a - A6 :: (a ~ b, b ~ Int) => Int -> b -> A a - A7 :: Foo a => Int -> a -> A a - -deriving instance Foldable A - -data HK f a where - HK1 :: f a -> HK f (f a) - HK2 :: f a -> HK f a - -deriving instance Foldable f => Foldable (HK f) - -one :: Int -one = 1 - -main :: IO () -main = do - mapM_ (print . foldr (+) one) - [ A1 one - , A2 one - , A3 one - , A4 one - , A5 one - , A6 one one - , A7 one one - ] - mapM_ (print . foldr mappend Nothing) - [ HK1 (Just "Hello") - , HK2 (Just (Just "World")) - ] diff --git a/tests/examples/ghc8/T10451.hs b/tests/examples/ghc8/T10451.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10451.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} - -module T10451 where - -type S a = ( Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a ) - -type T a = ( Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a) - diff --git a/tests/examples/ghc8/T10460.hs b/tests/examples/ghc8/T10460.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10460.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE GHCForeignImportPrim #-} -module T10460 where -import GHC.Exts --- don't link me! -foreign import prim "f" f :: Any -> Any diff --git a/tests/examples/ghc8/T10461.hs b/tests/examples/ghc8/T10461.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10461.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE MagicHash, GHCForeignImportPrim #-} - -module T10461 where -import GHC.Exts - -foreign import prim cheneycopy :: Any -> Word# diff --git a/tests/examples/ghc8/T10463.hs b/tests/examples/ghc8/T10463.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10463.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, PartialTypeSignatures #-} - -module T10463 where - -f (x :: _) = x ++ "" diff --git a/tests/examples/ghc8/T10481.hs b/tests/examples/ghc8/T10481.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10481.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE MagicHash #-} - -import GHC.Exts -import Control.Exception - -f :: ArithException -> Int# -f x = raise# (toException x) - -main = print (I# (f Overflow)) diff --git a/tests/examples/ghc8/T10482.hs b/tests/examples/ghc8/T10482.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10482.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} -module T10482 where - -data family Foo a -data instance Foo (a, b) = FooPair !(Foo a) !(Foo b) -newtype instance Foo Int = Foo Int - -foo :: Foo ((Int, Int), Int) -> Int -> Int -foo !f k = - if k == 0 then 0 - else if even k then foo f (k-1) - else case f of - FooPair (FooPair (Foo n) _) _ -> n diff --git a/tests/examples/ghc8/T10482a.hs b/tests/examples/ghc8/T10482a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10482a.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} - -- Makes f2 a bit more challenging - --- Tests inspired by Note [CPR examples] in DmdAnal, and Trac #10482 - -module Foo where - - -h :: Int -> Int -> Bool -h 0 y = y>0 -h n y = h (n-1) y - --- The main point: all of these functions can have the CPR property - -------- f1 ----------- --- x is used strictly by h, so it'll be available --- unboxed before it is returned in the True branch - -f1 :: Int -> Int -f1 x = case h x x of - True -> x - False -> f1 (x-1) - - -------- f2 ----------- --- x is a strict field of MkT2, so we'll pass it unboxed --- to $wf2, so it's available unboxed. This depends on --- the case expression analysing (a subcomponent of) one --- of the original arguments to the function, so it's --- a bit more delicate. - -data T2 = MkT2 !Int Int - -f2 :: T2 -> Int -f2 (MkT2 x y) | y>0 = f2 (MkT2 x (y-1)) - | y>1 = 1 - | otherwise = x - - -------- f3 ----------- --- h is strict in x, so x will be unboxed before it --- is rerturned in the otherwise case. - -data T3 = MkT3 Int Int - -f3 :: T3 -> Int -f3 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) - | otherwise = x - - -------- f4 ----------- --- Just like f2, but MkT4 can't unbox its strict --- argument automatically, as f2 can - -data family Foo a -newtype instance Foo Int = Foo Int - -data T4 a = MkT4 !(Foo a) Int - -f4 :: T4 Int -> Int -f4 (MkT4 x@(Foo v) y) | y>0 = f4 (MkT4 x (y-1)) - | otherwise = v diff --git a/tests/examples/ghc8/T10487.hs b/tests/examples/ghc8/T10487.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10487.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-} - -module T10487 where - -import GHC.Generics - -import qualified T10487_M as M - -data Name = Name - -deriving instance Generic Name -deriving instance Generic M.Name diff --git a/tests/examples/ghc8/T10487_M.hs b/tests/examples/ghc8/T10487_M.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10487_M.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10487_M where - -data Name = Name diff --git a/tests/examples/ghc8/T10489.hs b/tests/examples/ghc8/T10489.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10489.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10489 where - --- Triggered an ASSERT in a debug build at some point. -convert d = let d' = case d of '0' -> '!' in d' diff --git a/tests/examples/ghc8/T10493.hs b/tests/examples/ghc8/T10493.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10493.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module T10493 where - -import Data.Coerce -import Data.Ord (Down) -- no constructor - -foo :: Coercible (Down Int) Int => Down Int -> Int -foo = coerce diff --git a/tests/examples/ghc8/T10494.hs b/tests/examples/ghc8/T10494.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10494.hs +++ /dev/null @@ -1,6 +0,0 @@ -module App where - -import Data.Coerce - -foo :: Coercible (a b) (c d) => a b -> c d -foo = coerce diff --git a/tests/examples/ghc8/T10495.hs b/tests/examples/ghc8/T10495.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10495.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T10495 where - -import Data.Coerce - -foo = coerce diff --git a/tests/examples/ghc8/T10503.hs b/tests/examples/ghc8/T10503.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10503.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE RankNTypes, PolyKinds, DataKinds, TypeFamilies #-} -module GHCBug where - -data Proxy p = Proxy - -data KProxy (a :: *) = KProxy - -h :: forall r . (Proxy ('KProxy :: KProxy k) ~ Proxy ('KProxy :: KProxy *) => r) -> r -h = undefined diff --git a/tests/examples/ghc8/T10507.hs b/tests/examples/ghc8/T10507.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10507.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module T10507 where - -import Data.Type.Equality ( (:~:)(Refl) ) -import Prelude (Maybe(..), undefined) -import GHC.TypeLits ( Nat, type (<=)) - -data V (n::Nat) - -testEq :: (m <= n) => V m -> V n -> Maybe (m :~: n) -testEq = undefined - - -uext :: (1 <= m, m <= n) => V m -> V n -> V n -uext e w = - case testEq e w of - Just Refl -> e diff --git a/tests/examples/ghc8/T10508_api.hs b/tests/examples/ghc8/T10508_api.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10508_api.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Main where - -import DynFlags -import GHC - -import Control.Monad (forM_) -import Control.Monad.IO.Class (liftIO) -import System.Environment (getArgs) - -main :: IO () -main = do - [libdir] <- getArgs - runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags $ dflags - `gopt_unset` Opt_ImplicitImportQualified - `xopt_unset` Opt_ImplicitPrelude - - forM_ exprs $ \expr -> - handleSourceError printException $ do - dyn <- dynCompileExpr expr - liftIO $ print dyn - where - exprs = - [ "" - , "(),()" - , "()" - , "\"test\"" - , unlines [ "[()]" - , " :: [()]" - ] - ] diff --git a/tests/examples/ghc8/T10516.hs b/tests/examples/ghc8/T10516.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10516.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -module T10516 where - -type App f a = f a - -newtype X f a = X (f a) - -f :: f a -> X (App f) a -f = X diff --git a/tests/examples/ghc8/T10519.hs b/tests/examples/ghc8/T10519.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10519.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE PartialTypeSignatures #-} -module T10519 where - -foo :: forall a. _ => a -> a -> Bool -foo x y = x == y diff --git a/tests/examples/ghc8/T10521.hs b/tests/examples/ghc8/T10521.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10521.hs +++ /dev/null @@ -1,11 +0,0 @@ -import Data.Word( Word8 ) - -toV :: Float -> Word8 -toV d = let coeff = significand d * 255.9999 / d - a = truncate $ d * coeff - b = exponent d - in a `seq` (b `seq` a) - -main :: IO () -main = - print $ map toV [ 3.56158e-2, 0.7415215, 0.5383201, 0.1289829, 0.45520145 ] diff --git a/tests/examples/ghc8/T10521b.hs b/tests/examples/ghc8/T10521b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10521b.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE MagicHash #-} - -import GHC.Exts - -f :: Float# -> Float# -f x = x -{-# NOINLINE f #-} - -g :: Double# -> Double# -g x = x -{-# NOINLINE g #-} - -h :: Float -> Float -h (F# x) = let a = F# (f x) - b = D# (g (2.0##)) - in a `seq` (b `seq` a) - -main = print (h 1.0) diff --git a/tests/examples/ghc8/T10524.hs b/tests/examples/ghc8/T10524.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10524.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PolyKinds #-} -module T10524 where - -import Data.Data - -newtype WrappedFunctor f a = WrapFunctor (f a) deriving (Data, Typeable) - --- WrappedFunctor :: forall k. (k -> *) -> k -> * diff --git a/tests/examples/ghc8/T10534.hs b/tests/examples/ghc8/T10534.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10534.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T10534 where - -import T10534a - -newtype instance DF a = MkDF () - -unsafeCoerce :: a -> b -unsafeCoerce = silly diff --git a/tests/examples/ghc8/T10534a.hs b/tests/examples/ghc8/T10534a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10534a.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts #-} - -module T10534a where - -import Data.Coerce - -data family DF a - -silly :: Coercible (DF a) (DF b) => a -> b -silly = coerce diff --git a/tests/examples/ghc8/T10549.hs b/tests/examples/ghc8/T10549.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10549.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS_GHC -O2 #-} - --- Verify that -O2 is rejected when this module is loaded by GHCi -module T10549 where - -import qualified Data.ByteString.Internal as Internal -import System.IO.Unsafe (unsafePerformIO) -import Data.Word (Word8) -import Foreign.Ptr (Ptr) -import Foreign.Storable (peek) - -type S = Ptr Word8 - -chr :: S -> Char -chr x = Internal.w2c $ unsafePerformIO $ peek x diff --git a/tests/examples/ghc8/T10549a.hs b/tests/examples/ghc8/T10549a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10549a.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# OPTIONS_GHC -O #-} -module Main(main) where -import GHC.Exts -main = print 1 -go (Ptr a) = a diff --git a/tests/examples/ghc8/T10561.hs b/tests/examples/ghc8/T10561.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10561.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE PolyKinds, DeriveFunctor, RankNTypes #-} - -module T10561 where - --- Ultimately this should "Just Work", --- but in GHC 7.10 it gave a Lint failure --- For now (HEAD, Jun 2015) it gives a kind error message, --- which is better than a crash - -newtype Compose f g a = Compose (f (g a)) deriving Functor - -{- -instance forall (f_ant :: k_ans -> *) - (g_anu :: * -> k_ans). - (Functor f_ant, Functor g_anu) => - Functor (Compose f_ant g_anu) where - fmap f_anv (T10561.Compose a1_anw) - = Compose (fmap (fmap f_anv) a1_anw) --} diff --git a/tests/examples/ghc8/T10562.hs b/tests/examples/ghc8/T10562.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10562.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE GADTs, TypeFamilies #-} -module T10562 where - -type family Flip a - -data QueryRep qtyp a where - QAtom :: a -> QueryRep () a - QOp :: QueryRep (Flip qtyp) a -> QueryRep qtyp a - -instance Eq (QueryRep qtyp a) where - (==) = error "urk" - -instance (Ord a) => Ord (QueryRep qtyp a) where - compare (QOp a) (QOp b) = a `compare` b diff --git a/tests/examples/ghc8/T10564.hs b/tests/examples/ghc8/T10564.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10564.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances, - DataKinds, TypeFamilies, KindSignatures, PolyKinds, FunctionalDependencies #-} - -module T10564 where - -class HasFieldM (l :: k) r (v :: Maybe *) - | l r -> v - -class HasFieldM1 (b :: Maybe [*]) (l :: k) r v - | b l r -> v - -class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) - | e1 l -> r - -data Label a -type family LabelsOf (a :: [*]) :: [*] - -instance (HMemberM (Label (l::k)) (LabelsOf xs) b, - HasFieldM1 b l (r xs) v) - => HasFieldM l (r xs) v where diff --git a/tests/examples/ghc8/T10570.hs b/tests/examples/ghc8/T10570.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10570.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE FunctionalDependencies, PolyKinds, FlexibleInstances #-} - -module T10570 where - -import Data.Proxy - -class ConsByIdx2 x a m cls | x -> m where - consByIdx2 :: x -> a -> m cls - -instance ConsByIdx2 Int a Proxy cls where - consByIdx2 _ _ = Proxy diff --git a/tests/examples/ghc8/T10590.hs b/tests/examples/ghc8/T10590.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10590.hs +++ /dev/null @@ -1,37 +0,0 @@ -import Foreign.C -import Foreign.Marshal.Array -import Foreign.Storable -import Control.Concurrent - --- The test works only on UNIX like. --- unportable bits: -import qualified System.Posix.Internals as SPI -import qualified System.Posix.Types as SPT - -pipe :: IO (CInt, CInt) -pipe = allocaArray 2 $ \fds -> do - throwErrnoIfMinus1_ "pipe" $ SPI.c_pipe fds - rd <- peekElemOff fds 0 - wr <- peekElemOff fds 1 - return (rd, wr) - -main :: IO () -main = do - (r1, w1) <- pipe - (r2, _w2) <- pipe - _ <- forkIO $ do -- thread A - threadWaitRead (SPT.Fd r1) - _ <- forkIO $ do -- thread B - threadWaitRead (SPT.Fd r2) - yield -- switch to A, then B - -- now both are blocked - _ <- SPI.c_close w1 -- unblocking thread A fd - _ <- SPI.c_close r2 -- breaking thread B fd - yield -- kick RTS IO manager - -{- - Trac #10590 exposed a bug as: - T10590: internal error: removeThreadFromDeQueue: not found - (GHC version 7.11.20150702 for x86_64_unknown_linux) - Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug - -} diff --git a/tests/examples/ghc8/T10596.hs b/tests/examples/ghc8/T10596.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10596.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module T10596 where -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import System.IO - -do - putQ (100 :: Int) - x <- (getQ :: Q (Maybe Int)) - - -- It should print "Just 100" - runIO $ print x - runIO $ hFlush stdout - return [] diff --git a/tests/examples/ghc8/T10602.hs b/tests/examples/ghc8/T10602.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10602.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# OPTIONS_GHC -O2 #-} -{-# OPTIONS_GHC -fno-warn-missing-methods #-} -{-# LANGUAGE NoImplicitPrelude #-} --- {-# OPTIONS_GHC -fno-spec-constr #-} -- Makes the problem go away. --- {-# OPTIONS_GHC -fspec-constr-count=1 #-} -- Makes the problem go away. - -module T10602 where - --- Copy-pasting T10602b.hs into the current module makes the problem go away. -import T10602b - -data PairS a = PairS a a - --- Removing the '~' makes the problem go away. -(PairS _ _) >> ~(PairS b g) = PairS b g - -class Binary t where - put :: t -> PairS () - --- Not using a newtype makes the problem go away. -newtype A a = A [a] - -instance Binary a => Binary (A a) where - put (A xs) = case splitAt 254 xs of - (_, []) -> foldr (>>) (PairS () ()) (map put xs) - (_, b) -> put (A b) diff --git a/tests/examples/ghc8/T10602b.hs b/tests/examples/ghc8/T10602b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10602b.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -O2 #-} -{-# LANGUAGE NoImplicitPrelude #-} -module T10602b (splitAt, map, foldr) where - -import GHC.Classes -import GHC.Types -import GHC.Num -import GHC.Base - -splitAt :: Int -> [a] -> ([a],[a]) -splitAt n ls - | n <= 0 = ([], ls) - | otherwise = splitAt' n ls - where - splitAt' :: Int -> [a] -> ([a], [a]) - splitAt' _ [] = ([], []) - splitAt' 1 (x:xs) = ([x], xs) - splitAt' m (x:xs) = (x:xs', xs'') - where - (xs', xs'') = splitAt' (m - 1) xs diff --git a/tests/examples/ghc8/T10615.hs b/tests/examples/ghc8/T10615.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10615.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module T10615 where - -f1 :: _ -> f -f1 = const - -f2 :: _ -> _f -f2 = const diff --git a/tests/examples/ghc8/T10618.hs b/tests/examples/ghc8/T10618.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10618.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10618 where - -foo = Just $ Nothing <> Nothing diff --git a/tests/examples/ghc8/T10620.hs b/tests/examples/ghc8/T10620.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10620.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE MagicHash, TemplateHaskell #-} -module Main where - -import Language.Haskell.TH - -main :: IO () -main = do - putStrLn $([| 'a'# |] >>= stringE . show) - putStrLn $([| "abc"# |] >>= stringE . show) diff --git a/tests/examples/ghc8/T10627.hs b/tests/examples/ghc8/T10627.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10627.hs +++ /dev/null @@ -1,17 +0,0 @@ --- Made GHC 6.10.2 go into a loop in substRecBndrs -{-# OPTIONS_GHC -w #-} - -module T10627 where - -import Data.Word - -class C a where - splitFraction :: a -> (b,a) - -roundSimple :: (C a) => a -> b -roundSimple x = error "rik" - -{-# RULES - "rs" roundSimple = (fromIntegral :: Int -> Word) . roundSimple; - #-} - diff --git a/tests/examples/ghc8/T10632.hs b/tests/examples/ghc8/T10632.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10632.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} - -f :: (?file1 :: String) => IO () -f = putStrLn $ "f2: " - -main :: IO () -main = let ?file1 = "A" in f diff --git a/tests/examples/ghc8/T10634.hs b/tests/examples/ghc8/T10634.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10634.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T10634 where - -import Data.Int (Int8, Int16, Int32) - -type family Up a -type instance Up Int8 = Int16 -type instance Up Int16 = Int32 - -class (Up (Down a) ~ a) => Convert a where - type Down a - down :: a -> Down a - -instance Convert Int16 where - type Down Int16 = Int8 - down = fromIntegral - -instance Convert Int32 where - type Down Int32 = Int16 - down = fromIntegral - -x :: Int8 -x = down 8 diff --git a/tests/examples/ghc8/T10637.hs b/tests/examples/ghc8/T10637.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10637.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10637 where - -import {-# SOURCE #-} A () -data B = B diff --git a/tests/examples/ghc8/T10638.hs b/tests/examples/ghc8/T10638.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10638.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-} - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -import GHC.Exts - -{- - the prim and javascript calling conventions do not support - headers and the static keyword. --} - --- check that quasiquoting roundtrips succesfully and that the declaration --- does not include the static keyword -test1 :: String -test1 = $(do (ds@[ForeignD (ImportF _ _ p _ _)]) <- - [d| foreign import prim "test1" cmm_test1 :: Int# -> Int# |] - addTopDecls ds - case p of - "test1" -> return (LitE . stringL $ p) - _ -> error $ "unexpected value: " ++ show p - ) - --- check that constructed prim imports with the static keyword are rejected -test2 :: String -test2 = $(do t <- [t| Int# -> Int# |] - cmm_test2 <- newName "cmm_test2" - addTopDecls - [ForeignD (ImportF Prim Safe "static test2" cmm_test2 t)] - [| test1 |] - ) diff --git a/tests/examples/ghc8/T10642.hs b/tests/examples/ghc8/T10642.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10642.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T10642 where - -import Data.Coerce - -type family F a - -newtype D a = D (F a) - --- | This works on 7.10.1, but fails on HEAD (20150711) -coerceD :: F a -> D a -coerceD = coerce diff --git a/tests/examples/ghc8/T10662.hs b/tests/examples/ghc8/T10662.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10662.hs +++ /dev/null @@ -1,4 +0,0 @@ -main :: IO () -main = do - return $ let a = "hello" in a - return () diff --git a/tests/examples/ghc8/T10667.hs b/tests/examples/ghc8/T10667.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10667.hs +++ /dev/null @@ -1,6 +0,0 @@ -module A where - --- when used with '-g' debug generation option --- '*/*' leaked into a /* comment */ and broke --- GNU as. -x */* y = 42 diff --git a/tests/examples/ghc8/T10668.hs b/tests/examples/ghc8/T10668.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10668.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10668 where - -import Data.Type.Equality(Refl) diff --git a/tests/examples/ghc8/T10670.hs b/tests/examples/ghc8/T10670.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10670.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, RankNTypes, GADTs, PolyKinds #-} - -module T10670 where - -import Unsafe.Coerce - -data TypeRepT (a::k) where - TRCon :: TypeRepT a - -data G2 c a where - G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b) - -getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a) -{-# NOINLINE getT2 #-} -getT2 c t = Nothing - -tyRepTArr :: TypeRepT (->) -{-# NOINLINE tyRepTArr #-} -tyRepTArr = TRCon - -s :: forall a x. TypeRepT (a :: *) -> Maybe x -s tf = case getT2 tyRepTArr tf :: Maybe (G2 (->) a) of - Just (G2 _ _) -> Nothing - _ -> Nothing diff --git a/tests/examples/ghc8/T10670a.hs b/tests/examples/ghc8/T10670a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10670a.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE GADTs , PolyKinds #-} - -module Bug2 where - -import Unsafe.Coerce - -data TyConT (a::k) = TyConT String - -eqTyConT :: TyConT a -> TyConT b -> Bool -eqTyConT (TyConT a) (TyConT b) = a == b - - - -tyConTArr :: TyConT (->) -tyConTArr = TyConT "(->)" - - -data TypeRepT (a::k) where - TRCon :: TyConT a -> TypeRepT a - TRApp :: TypeRepT a -> TypeRepT b -> TypeRepT (a b) - - -data GetAppT a where - GA :: TypeRepT a -> TypeRepT b -> GetAppT (a b) - -getAppT :: TypeRepT a -> Maybe (GetAppT a) -getAppT (TRApp a b) = Just $ GA a b -getAppT _ = Nothing - - - -eqTT :: TypeRepT (a::k1) -> TypeRepT (b::k2) -> Bool -eqTT (TRCon a) (TRCon b) = eqTyConT a b -eqTT (TRApp c a) (TRApp d b) = eqTT c d && eqTT a b -eqTT _ _ = False - - -data G2 c a where - G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b) - - -getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a) -getT2 c t = do GA t' b <- getAppT t - GA c' a <- getAppT t' - if eqTT c c' - then Just (unsafeCoerce $ G2 a b :: G2 c a) - else Nothing - -tyRepTArr :: TypeRepT (->) -tyRepTArr = TRCon tyConTArr - -s tf = case getT2 tyRepTArr tf - of Just (G2 _ _) -> Nothing - _ -> Nothing diff --git a/tests/examples/ghc8/T10678.hs b/tests/examples/ghc8/T10678.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10678.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE MagicHash #-} - -import GHC.Prim - -main :: IO () -main = go 1000000# 10 (2^100) - -go :: Int# -> Integer -> Integer -> IO () -go 0# _ _ = return () -go n# a b = (a + b) `seq` go (n# -# 1#) a b -{-# NOINLINE go #-} - -{- -This test is based on a strategy from rwbarton relying on the inefficiency -of `Integer` addition as defined by `integer-gmp` without `runRW#`. - - When I was testing the patch interactively, I measured allocations for, - say, a million (large Integer) + (small Integer) additions. If that - addition allocates, say, 6 words, then one can fairly reliably write the - program so that it will allocate between 6 million and 7 million words, - total. --} diff --git a/tests/examples/ghc8/T10689.hs b/tests/examples/ghc8/T10689.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10689.hs +++ /dev/null @@ -1,11 +0,0 @@ -module T10694 where - -f :: Eq a => a -> Bool -{-# NOINLINE f #-} -f x = x==x - -type Foo a b = b - -{-# RULES "foo" forall (x :: Foo a Char). f x = True #-} - -finkle = f 'c' diff --git a/tests/examples/ghc8/T10689a.hs b/tests/examples/ghc8/T10689a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10689a.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE TypeOperators - , DataKinds - , PolyKinds - , TypeFamilies - , GADTs - , UndecidableInstances - , RankNTypes - , ScopedTypeVariables - #-} - -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Werror #-} -{-# OPTIONS_GHC -O1 -fspec-constr #-} - -{- -ghc-stage2: panic! (the 'impossible' happened) - (GHC version 7.11.20150723 for x86_64-unknown-linux): - Template variable unbound in rewrite rule --} - -module List (sFoldr1) where - -data Proxy t - -data family Sing (a :: k) - -data TyFun (a :: *) (b :: *) - -type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2 - -data instance Sing (f :: TyFun k1 k2 -> *) = - SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } - -type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) - -type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) -singFun2 :: Proxy f -> SingFunction2 f -> Sing f -singFun2 _ f = SLambda (\x -> SLambda (f x)) - -data (:$$) (j :: a) (i :: TyFun [a] [a]) -type instance Apply ((:$$) j) i = (:) j i - -data (:$) (l :: TyFun a (TyFun [a] [a] -> *)) -type instance Apply (:$) l = (:$$) l -data instance Sing (z :: [a]) - = z ~ '[] => - SNil - | forall (m :: a) - (n :: [a]). z ~ (:) m n => - SCons (Sing m) (Sing n) - -data ErrorSym0 (t1 :: TyFun k1 k2) - -type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh - -type Let1627448493Xs f_afe9 - x_afea - wild_1627448474_afeb - wild_1627448476_afec = - Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec -type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) - -> *) - (t_afdZ :: [a_afdP]) = - Foldr1 t_afdY t_afdZ -data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) - -> *) - (l_afe2 :: TyFun [a_afdP] a_afdP) -type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 - -data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP - -> *) - -> *) (TyFun [a_afdP] a_afdP -> *)) -type instance Apply Foldr1Sym0 l = Foldr1Sym1 l - -type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP - -> *) - -> *) - (a_afe6 :: [a_afdP]) :: a_afdP where - Foldr1 z_afe7 '[x_afe8] = x_afe8 - Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) - Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" - -sFoldr1 :: - forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) - (y :: [a_afdP]). - Sing x - -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) -sFoldr1 _ (SCons _sX SNil) = undefined -sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) - = let - lambda_afeC :: - forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. - Sing f_afe9 - -> Sing x_afea - -> Sing wild_1627448474_afeb - -> Sing wild_1627448476_afec - -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) - lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG - = let - sXs :: - Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) - sXs - = applySing - (applySing - (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) - wild_1627448476_afeG - in - applySing - (applySing f_afeD x_afeE) - (applySing - (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) - sXs) - in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 -sFoldr1 _ SNil = undefined diff --git a/tests/examples/ghc8/T10694.hs b/tests/examples/ghc8/T10694.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10694.hs +++ /dev/null @@ -1,16 +0,0 @@ -module T10694 where - --- The point here is that 'm' should NOT have the CPR property --- Checked by grepping in the -ddump-simpl - - --- Some nonsense so that the simplifier can't see through --- to the I# constructor -pm :: Int -> Int -> (Int, Int) -pm x y = (l !! 0, l !! 1) - where l = [x+y, x-y] -{-# NOINLINE pm #-} - -m :: Int -> Int -> Int -m x y = case pm x y of - (pr, mr) -> mr diff --git a/tests/examples/ghc8/T10698.hs b/tests/examples/ghc8/T10698.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10698.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} - -module T10698 where -import Data.Coerce - -data Map k a = Map k a -type role Map nominal representational - -map1 :: (k1->k2) -> Map k1 a -> Map k2 a -map1 f (Map a b) = Map (f a) b -{-# NOINLINE [1] map1 #-} -{-# RULES -"map1/coerce" map1 coerce = coerce - #-} - - -map2 :: (a -> b) -> Map k a -> Map k b -map2 f (Map a b) = Map a (f b) -{-# NOINLINE [1] map2 #-} - -{-# RULES -"map2/coerce" map2 coerce = coerce - #-} diff --git a/tests/examples/ghc8/T10704.hs b/tests/examples/ghc8/T10704.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10704.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE MagicHash, TemplateHaskell #-} -module Main where - -import GHC.Exts -import T10704a - -main :: IO () -main = do - putStrLn $(fixityExp ''(->)) - putStrLn $(fixityExp ''Show) - putStrLn $(fixityExp 'show) - putStrLn $(fixityExp '(+)) - putStrLn $(fixityExp ''Int) - putStrLn $(fixityExp ''Item) - putStrLn $(fixityExp ''Char#) - putStrLn $(fixityExp 'Just) - putStrLn $(fixityExp 'seq) - putStrLn $(fixityExp '($)) - putStrLn $(fixityExp ''(:=>)) - putStrLn $(fixityExp ''(:+:)) - putStrLn $(fixityExp ''(:*:)) - putStrLn $(fixityExp ''(:%:)) - putStrLn $(fixityExp ''(:?:)) - putStrLn $(fixityExp ''(:@:)) diff --git a/tests/examples/ghc8/T10704a.hs b/tests/examples/ghc8/T10704a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10704a.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, TypeOperators #-} -module T10704a where - -import Language.Haskell.TH - -infixl 1 :=> -infixl 2 :+: -infix 3 :*: -infix 4 :%: -infixr 5 :?: -infixr 6 :@: - -class a :=> b -type a :+: b = Either a b -data a :*: b = a :*: b -newtype a :%: b = Percent (a, b) -data family a :?: b -type family a :@: b where a :@: b = Int - -fixityExp :: Name -> Q Exp -fixityExp n = reifyFixity n >>= stringE . show diff --git a/tests/examples/ghc8/T10713.hs b/tests/examples/ghc8/T10713.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10713.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeFamilies, PolyKinds, DataKinds #-} - -module T10713 where - -import Data.Proxy - -type family TEq t s where - TEq t t = 'True - TEq t s = 'False -data family T a - -foo :: Proxy (TEq (T Int) (T Bool)) -> Proxy 'False -foo = id diff --git a/tests/examples/ghc8/T10734.hs b/tests/examples/ghc8/T10734.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10734.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Language.Haskell.TH - -main :: IO () -main = do - pprint <$> runQ [| do { let { }; return (); } |] >>= putStrLn - pprint <$> runQ [| do { let { x = 5 }; return x; } |] >>= putStrLn - pprint <$> runQ [| do { let { x = 5; y = 3 }; return x; } |] >>= putStrLn diff --git a/tests/examples/ghc8/T10742.hs b/tests/examples/ghc8/T10742.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10742.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module T10742 where - -import GHC.TypeLits - -data T a where MkT :: T Int - -test :: ((x <=? y) ~ 'True, (y <=? z) ~ 'True) - => proxy x y z -> () -test _ = case MkT of MkT -> () diff --git a/tests/examples/ghc8/T10744.hs b/tests/examples/ghc8/T10744.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10744.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module T10744 where - -import GHC.Exts -import GHC.Magic - --- Checks if oneShot is open-kinded - -f0 :: Int -> Int -f0 = oneShot $ \n -> n - -f1 :: Int# -> Int -f1 = oneShot $ \n# -> I# n# - -f2 :: Int -> Int# -f2 = oneShot $ \(I# n#) -> n# - diff --git a/tests/examples/ghc8/T10747.hs b/tests/examples/ghc8/T10747.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10747.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module T10747 where - -pattern head `Cons` tail = head : tail diff --git a/tests/examples/ghc8/T10753.hs b/tests/examples/ghc8/T10753.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10753.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-missing-methods #-} -module T10753 where - - -class MonadState s m | m -> s where - get :: m s - -newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } -instance (Monad m) => Monad (StateT s m) where -instance (Functor m, Monad m) => Applicative (StateT s m) where -instance (Functor m) => Functor (StateT s m) where - -instance (Monad m) => MonadState s (StateT s m) where - -class HasConns (m :: * -> *) where - type Conn m - -foo :: (Monad m) => StateT (Conn m) m () -foo = - do _ <- get - return () diff --git a/tests/examples/ghc8/T10767.hs b/tests/examples/ghc8/T10767.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10767.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} - -module Main where - -{- ghc-7.8.4 and ghc-7.10.2 showed a confusing warning: - -T10767.hs:43:1: Warning: - RULE left-hand side too complicated to desugar - Optimised lhs: case cobox_aWY - of _ [Occ=Dead] { GHC.Types.Eq# cobox -> - genLength @ Int $dSpecList_aWX - } - Orig lhs: case cobox_aWY of cobox_aWY { GHC.Types.Eq# cobox -> - genLength @ Int $dSpecList_aWX - } --} - -import Data.Proxy - -class SpecList a where - type List a :: * - - slCase :: List a -> b -> (a -> List a -> b) -> b - -data IntList - = ILNil - | ILCons {-# UNPACK #-} !Int IntList - deriving (Show) - -instance SpecList Int where - type List Int = IntList - - slCase ILNil n _ = n - slCase (ILCons i t) _ c = c i t - -fromList :: [Int] -> IntList -fromList [] = ILNil -fromList (h : t) = ILCons h (fromList t) - -lst1 :: IntList -lst1 = fromList [1..10] - -{-# SPECIALIZE genLength :: Proxy Int -> List Int -> Int #-} -genLength :: forall a . SpecList a => Proxy a -> List a -> Int -genLength p lst = slCase lst 0 (\(_ :: a) tail -> 1 + genLength p tail) - -main :: IO () -main = print (genLength (Proxy :: Proxy Int) lst1) diff --git a/tests/examples/ghc8/T10781.hs b/tests/examples/ghc8/T10781.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10781.hs +++ /dev/null @@ -1,12 +0,0 @@ -module T10781 where -{- ghc-7.10.2 reported: - -T10781.hs:6:5: - Found hole ‘_name’ with type: t - Where: ‘t’ is a rigid type variable bound by - the inferred type of f :: t at T10781.hs:6:1 - Relevant bindings include f :: t (bound at T10781.hs:6:1) - In the expression: Foo._name - In an equation for ‘f’: f = Foo._name --} -f = Foo._name diff --git a/tests/examples/ghc8/T10796a.hs b/tests/examples/ghc8/T10796a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10796a.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module T10796a where - -import Data.Ratio -import Data.Set (Set, fromList) -import Language.Haskell.TH.Syntax (liftData) - --- Data instance with toConstr implemented using a variable, --- not a data constructor -splicedSet :: Set Char -splicedSet = $(liftData (fromList "test")) - --- Infix data constructor -splicedRatio :: Ratio Int -splicedRatio = $(liftData (1 % 2 :: Ratio Int)) diff --git a/tests/examples/ghc8/T10796b.hs b/tests/examples/ghc8/T10796b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10796b.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module T10796b where - -import Data.Set (Set, fromList) -import Language.Haskell.TH.Quote (dataToPatQ) - -badPattern :: Set Char -> Set Char -badPattern s@($(dataToPatQ (const Nothing) (fromList "test"))) = s diff --git a/tests/examples/ghc8/T10806.hs b/tests/examples/ghc8/T10806.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10806.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE GADTs, ExplicitNamespaces, TypeOperators, DataKinds #-} - -module T10806 where - -import GHC.TypeLits (Nat, type (<=)) - -data Q a where - Q :: (a <= b, b <= c) => proxy a -> proxy b -> Q c - -triggersLoop :: Q b -> Q b -> Bool -triggersLoop (Q _ _) (Q _ _) = print 'x' 'y' diff --git a/tests/examples/ghc8/T10815.hs b/tests/examples/ghc8/T10815.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10815.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies #-} - -module T10815 where - -import Data.Proxy - -type family Any :: k - -class kproxy ~ 'KProxy => C (kproxy :: KProxy k) where - type F (a :: k) - type G a :: k - -instance C ('KProxy :: KProxy Bool) where - type F a = Int - type G a = Any diff --git a/tests/examples/ghc8/T10819.hs b/tests/examples/ghc8/T10819.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10819.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module T10819 where - -import T10819_Lib - -import Language.Haskell.TH.Syntax - -class C a b | b -> a where - f :: b -> a - -data D = X - -instance C Int D where - f X = 2 - -$(doSomeTH "N" (mkName "D") [ConT (mkName "C") `AppT` ConT (mkName "Int")]) - -thing :: N -thing = N X - -thing1 :: Int -thing1 = f thing diff --git a/tests/examples/ghc8/T10819_Lib.hs b/tests/examples/ghc8/T10819_Lib.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10819_Lib.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T10819_Lib where - -import Language.Haskell.TH.Syntax - -doSomeTH s tp drv = return [NewtypeD [] n [] Nothing (NormalC n - [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) drv] - where n = mkName s diff --git a/tests/examples/ghc8/T10820.hs b/tests/examples/ghc8/T10820.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10820.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE LiberalTypeSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MagicHash #-} - -module Main where - -import Language.Haskell.TH.Syntax -import GHC.LanguageExtensions - -main = do - print $(isExtEnabled Cpp >>= lift) - print $(isExtEnabled LiberalTypeSynonyms >>= lift) - print $(isExtEnabled RankNTypes >>= lift) - print $(isExtEnabled TypeSynonymInstances >>= lift) - print $(isExtEnabled MagicHash >>= lift) diff --git a/tests/examples/ghc8/T10826.hs b/tests/examples/ghc8/T10826.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10826.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE Safe #-} -module Test (hook) where - -import System.IO.Unsafe - -{-# ANN hook (unsafePerformIO (putStrLn "Woops.")) #-} -hook = undefined diff --git a/tests/examples/ghc8/T10830.hs b/tests/examples/ghc8/T10830.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10830.hs +++ /dev/null @@ -1,3 +0,0 @@ -import GHC.OldList -main :: IO () -main = maximumBy compare [1..10000] `seq` return () diff --git a/tests/examples/ghc8/T10836.hs b/tests/examples/ghc8/T10836.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10836.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T10836 where - -type family Foo a = r | r -> a where - Foo Int = Int - Foo Bool = Int - -type family Bar a = r | r -> a where - Bar Int = Int - Bar Bool = Int diff --git a/tests/examples/ghc8/T10845.hs b/tests/examples/ghc8/T10845.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10845.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -{-# OPTIONS_GHC -dcore-lint #-} - -import GHC.Stack - -f1 :: (?loc :: CallStack) => CallStack --- we can infer a CallStack for let-binders -f1 = let y x = (?loc :: CallStack) - in y 0 - -f2 :: (?loc :: CallStack) => CallStack --- but only when we would infer an IP. --- i.e. the monomorphism restriction prevents us --- from inferring a CallStack. -f2 = let y = (?loc :: CallStack) - in y - -main :: IO () -main = do putStrLn $ prettyCallStack f1 - putStrLn $ prettyCallStack f2 diff --git a/tests/examples/ghc8/T10846.hs b/tests/examples/ghc8/T10846.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10846.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-} - -module Main where - -import GHC.Stack - -f1 :: (?loc :: CallStack) => String -f1 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc - -f2 :: (?loc :: CallStack) => _ -f2 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc - -f3 :: (?loc :: CallStack, _) => String -f3 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc - -main :: IO () -main = do - putStrLn f1 - putStrLn f2 - putStrLn f3 diff --git a/tests/examples/ghc8/T10870.hs b/tests/examples/ghc8/T10870.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10870.hs +++ /dev/null @@ -1,12 +0,0 @@ -import Data.Bits -import Data.Int -import Data.Word - -unsafeShift32R :: (Bits a, Num a) => a -> a -unsafeShift32R x = unsafeShiftR x 32 - -main :: IO () -main = do - print $ map unsafeShift32R [ 123456, 0x7fffffff :: Int ] - print $ map unsafeShift32R [ -123456, -0x80000000 :: Int ] - print $ map unsafeShift32R [ 123456, 0xffffffff :: Word ] diff --git a/tests/examples/ghc8/T10890.hs b/tests/examples/ghc8/T10890.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10890.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Main where - --- Previously GHC was printing this warning: --- --- Main.hs:5:1: Warning: --- The import of ‘A.has’ from module ‘A’ is redundant --- --- Main.hs:6:1: Warning: --- The import of ‘B.has’ from module ‘B’ is redundant - -import A (A (has)) -import B (B (has)) - -data Blah = Blah - -instance A Blah where - has = Blah - -instance B Blah where - has = Blah - -main :: IO () -main = return () diff --git a/tests/examples/ghc8/T10890_1.hs b/tests/examples/ghc8/T10890_1.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10890_1.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Main where - -import Base -import Extends - --- Previously GHC was giving this false positive: --- --- T10890_1.hs:4:1: Warning: --- The import of ‘Extends’ is redundant --- except perhaps to import instances from ‘Extends’ --- To import instances alone, use: import Extends() - -data Bar = Bar - -instance AClass Bar where - has = Bar - -instance BClass Bar where - has = Bar - -main :: IO () -main = return () diff --git a/tests/examples/ghc8/T10890_2.hs b/tests/examples/ghc8/T10890_2.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10890_2.hs +++ /dev/null @@ -1,17 +0,0 @@ -module T10890_2 where - --- Previously GHC was printing this warning: --- --- Main.hs:5:1: Warning: --- The import of ‘A.has’ from module ‘A’ is redundant --- --- Main.hs:6:1: Warning: --- The import of ‘B.has’ from module ‘B’ is redundant - -import T10890_2A (A (has)) -import T10890_2B (B (has)) - -data Blah = Blah - -instance A Blah where - has = Blah diff --git a/tests/examples/ghc8/T10890_2A.hs b/tests/examples/ghc8/T10890_2A.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10890_2A.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10890_2A where - -class A a where - has :: a diff --git a/tests/examples/ghc8/T10890_2B.hs b/tests/examples/ghc8/T10890_2B.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10890_2B.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10890_2B where - -class B a where - has :: a diff --git a/tests/examples/ghc8/T10891.hs b/tests/examples/ghc8/T10891.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10891.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} - -module T10891 where - -import Language.Haskell.TH -import System.IO - -class C a where - f :: a -> Int - -class C' a where - type F a :: * - type F a = a - f' :: a -> Int - -class C'' a where - data Fd a :: * - -instance C' Int where - type F Int = Bool - f' = id - -instance C'' Int where - data Fd Int = B Bool | C Char - -$(return []) - -test :: () -test = - $(let - display :: Name -> Q () - display q = do - i <- reify q - runIO (hPutStrLn stderr (pprint i) >> hFlush stderr) - in do - display ''C - display ''C' - display ''C'' - [| () |]) diff --git a/tests/examples/ghc8/T10895.hs b/tests/examples/ghc8/T10895.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10895.hs +++ /dev/null @@ -1,1 +0,0 @@ -module NotMain where diff --git a/tests/examples/ghc8/T10897a.hs b/tests/examples/ghc8/T10897a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10897a.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module T10897a where -pattern Single :: a -> a -pattern Single x = x diff --git a/tests/examples/ghc8/T10897b.hs b/tests/examples/ghc8/T10897b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10897b.hs +++ /dev/null @@ -1,4 +0,0 @@ -module B where -import T10897a - -Single y = True diff --git a/tests/examples/ghc8/T10904.hs b/tests/examples/ghc8/T10904.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10904.hs +++ /dev/null @@ -1,28 +0,0 @@ -import Control.Concurrent -import Control.Monad -import Foreign -import Foreign.C.Types -import System.Environment - - -foreign import ccall safe "finalizerlib.h init_value" - init_value :: Ptr CInt -> IO () - -foreign import ccall safe "finalizerlib.h &finalize_value" - finalize_value :: FinalizerPtr CInt - - -allocateValue :: IO () -allocateValue = do - fp <- mallocForeignPtrBytes 10000 - withForeignPtr fp init_value - addForeignPtrFinalizer finalize_value fp - - -main :: IO () -main = do - [n] <- fmap (fmap read) getArgs - _ <- forkIO (loop n) - loop n - where - loop n = replicateM_ n allocateValue diff --git a/tests/examples/ghc8/T10908.hs b/tests/examples/ghc8/T10908.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10908.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -fwarn-missing-exported-sigs #-} - -module Bug (Data.List.intercalate, x) where - -import qualified Data.List - -intercalate = True - -x :: Bool -x = intercalate diff --git a/tests/examples/ghc8/T10929.hs b/tests/examples/ghc8/T10929.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10929.hs +++ /dev/null @@ -1,31 +0,0 @@ -module T10929 where - -x1 :: [Integer] -x1 = [5 .. 3] - -x2 :: [Integer] -x2 = [3 .. 5] - -x3 :: [Integer] -x3 = [5, 3 .. 1] - -x4 :: [Integer] -x4 = [5, (3+0) .. 1] - -x5 :: [Integer] -x5 = [1, 3 .. 5] - -x6 :: [Integer] -x6 = [1, (3+0) .. 5] - -x7 :: [Integer] -x7 = [5, 7 .. 1] - -x8 :: [Integer] -x8 = [5, (7+0) .. 1] - -x9 :: [Integer] -x9 = [3, 1 .. 5] - -x10 :: [Integer] -x10 = [3, (1+0) .. 5] diff --git a/tests/examples/ghc8/T10931.hs b/tests/examples/ghc8/T10931.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10931.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} - -{-# OPTIONS_GHC -Wall #-} - -module T10931 ( BugC(..) ) where - -data IdT f a = IdC (f a) - -class ( m ~ Outer m (Inner m) ) => BugC (m :: * -> *) where - type Inner m :: * -> * - type Outer m :: (* -> *) -> * -> * - - bug :: ( forall n. ( n ~ Outer n (Inner n) - , Outer n ~ Outer m - ) - => Inner n a) - -> m a - -instance BugC (IdT m) where - type Inner (IdT m) = m - type Outer (IdT m) = IdT - - bug f = IdC f diff --git a/tests/examples/ghc8/T10934.hs b/tests/examples/ghc8/T10934.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10934.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE - ScopedTypeVariables - , DataKinds - , GADTs - , RankNTypes - , TypeOperators - , PolyKinds -- Comment out PolyKinds and the bug goes away. - #-} -{-# OPTIONS_GHC -O #-} - -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it - -module KeyValue where - -data AccValidation err a = AccFailure err | AccSuccess a - -data KeyValueError = MissingValue - -type WithKeyValueError = AccValidation [KeyValueError] - -missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs -missing = rpure missingField - where - missingField :: forall x. (WithKeyValueError :. f) x - missingField = Compose $ AccFailure [MissingValue] - -data Rec :: (u -> *) -> [u] -> * where - RNil :: Rec f '[] - (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) - -newtype Compose (f :: l -> *) (g :: k -> l) (x :: k) - = Compose { getCompose :: f (g x) } - -type (:.) f g = Compose f g - -class RecApplicative rs where - rpure - :: (forall x. f x) - -> Rec f rs diff --git a/tests/examples/ghc8/T10935.hs b/tests/examples/ghc8/T10935.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10935.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# OPTIONS_GHC -fwarn-monomorphism-restriction #-} - -module T10935 where - -f x = let y = x+1 in (y,y) diff --git a/tests/examples/ghc8/T10942.hs b/tests/examples/ghc8/T10942.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10942.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Main where - -import DynFlags -import GHC - -import Control.Monad.IO.Class (liftIO) -import System.Environment -import HeaderInfo -import Outputable -import StringBuffer - -main :: IO () -main = do - [libdir] <- getArgs - runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - let dflags' = dflags `gopt_set` Opt_KeepRawTokenStream - `gopt_set` Opt_Haddock - filename = "T10942_A.hs" - setSessionDynFlags dflags' - stringBuffer <- liftIO $ hGetStringBuffer filename - liftIO $ print (map unLoc (getOptions dflags' stringBuffer filename)) diff --git a/tests/examples/ghc8/T10942_A.hs b/tests/examples/ghc8/T10942_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10942_A.hs +++ /dev/null @@ -1,16 +0,0 @@ -{- - -A normal comment, to check if we can still pick up the CPP directive after it. - --} --- Check that we can parse a file with leading comments - --- ^ haddock --- * haddock --- | haddock --- $ haddock -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} -module T10942 where - -main = return () diff --git a/tests/examples/ghc8/T10945.hs b/tests/examples/ghc8/T10945.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10945.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module T10945 where - -import Language.Haskell.TH - -$$(return [ - SigD (mkName "m") - (ForallT [PlainTV (mkName "a")] - [] - (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) - , FunD (mkName "m") - [Clause [VarP (mkName "x")] (NormalB (VarE (mkName "x"))) []] - ]) diff --git a/tests/examples/ghc8/T10946.hs b/tests/examples/ghc8/T10946.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10946.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module T10946 where - -import Language.Haskell.TH - -m :: a -> a -m x = $$([||_||]) diff --git a/tests/examples/ghc8/T10955dyn.hs b/tests/examples/ghc8/T10955dyn.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10955dyn.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Foreign -import Foreign.C.Types -foreign import ccall "bar" dle :: IO CInt - -main = dle >>= print diff --git a/tests/examples/ghc8/T10962.hs b/tests/examples/ghc8/T10962.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10962.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} - -module Main where - -import GHC.Base - -main :: IO () -main = do - -- Overflow. - let (# w1, i1 #) = subWordC# 1## 3## - print (W# w1, I# i1) - - -- No overflow. - let (# w2, i2 #) = subWordC# 3## 1## - print (W# w2, I# i2) diff --git a/tests/examples/ghc8/T10970a.hs b/tests/examples/ghc8/T10970a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10970a.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} -main = do -#ifndef VERSION_containers - putStrLn "OK" -#endif -#ifndef MIN_VERSION_base - putStrLn "OK" -#endif diff --git a/tests/examples/ghc8/T10971a.hs b/tests/examples/ghc8/T10971a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10971a.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-} -module T10971a where - -import Data.Traversable (fmapDefault) - -f = \x -> length x -g = \f x -> fmapDefault f x -h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/ghc8/T10971b.hs b/tests/examples/ghc8/T10971b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10971b.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE MonomorphismRestriction, NoExtendedDefaultRules #-} -module T10971b where -import Data.Traversable (fmapDefault) -f = \x -> length x -g = \f x -> fmapDefault f x -h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/ghc8/T10971c.hs b/tests/examples/ghc8/T10971c.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10971c.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-} -module T10971c where - -import Data.Traversable (fmapDefault) - -f = \x -> length x -g = \f x -> fmapDefault f x -h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/ghc8/T10971d.hs b/tests/examples/ghc8/T10971d.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10971d.hs +++ /dev/null @@ -1,6 +0,0 @@ -import T10971c - -main = do - print $ f (Just 1) - print $ g (+1) (Just 5) - print $ h (const 5) Nothing diff --git a/tests/examples/ghc8/T10997.hs b/tests/examples/ghc8/T10997.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10997.hs +++ /dev/null @@ -1,6 +0,0 @@ -module T10997 where - -import T10997a - -foo :: Exp a -> String -foo Tru = "True" diff --git a/tests/examples/ghc8/T10997_1.hs b/tests/examples/ghc8/T10997_1.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10997_1.hs +++ /dev/null @@ -1,15 +0,0 @@ -module T10997_1 where - -import T10997_1a - -{- With ghc-7.10.2: - - The interface for ‘T10997a’ - Declaration for Just' - Pattern synonym Just': - Iface type variable out of scope: k - Cannot continue after interface file error --} - -bar :: (Showable a) => Maybe a -> Maybe a -bar (Just' a) = Just' a diff --git a/tests/examples/ghc8/T10997_1a.hs b/tests/examples/ghc8/T10997_1a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10997_1a.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns, ConstraintKinds, TypeFamilies, PolyKinds, KindSignatures #-} -module T10997_1a where - -import GHC.Exts - -type family Showable (a :: k) :: Constraint where - Showable (a :: *) = (Show a) - Showable a = () - -extractJust :: Maybe a -> (Bool, a) -extractJust (Just a) = (True, a) -extractJust _ = (False, undefined) - -pattern Just' :: Showable a => a -> (Maybe a) -pattern Just' a <- (extractJust -> (True, a)) where - Just' a = Just a - diff --git a/tests/examples/ghc8/T10997a.hs b/tests/examples/ghc8/T10997a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10997a.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE GADTs, PatternSynonyms #-} - -module T10997a where - -data Exp ty where - LitB :: Bool -> Exp Bool - -pattern Tru :: () => b ~ Bool => Exp b -pattern Tru = LitB True - - diff --git a/tests/examples/ghc8/T10999.hs b/tests/examples/ghc8/T10999.hs deleted file mode 100644 --- a/tests/examples/ghc8/T10999.hs +++ /dev/null @@ -1,8 +0,0 @@ -module T10999 where - -import qualified Data.Set as Set - -f :: _ => () -> _ -f _ = Set.fromList undefined - -g = map fst $ Set.toList $ f () diff --git a/tests/examples/ghc8/T11010.hs b/tests/examples/ghc8/T11010.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11010.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ExistentialQuantification, GADTSyntax #-} - -module T11010 where - -data Expr a where - Fun :: String -> (a -> b) -> (Expr a -> Expr b) - -pattern IntFun :: (a ~ Int) => String -> (a -> b) -> (Expr a -> Expr b) -pattern IntFun str f x = Fun str f x - --- Alternative syntax for pattern synonyms: --- pattern --- Suc :: () => (a ~ Int) => Expr a -> Expr Int --- Suc n <- IntFun _ _ n where --- Suc n = IntFun "suc" (+ 1) n -pattern Suc :: (a ~ Int) => Expr a -> Expr Int -pattern Suc n <- IntFun _ _ n where - Suc n = IntFun "suc" (+ 1) n diff --git a/tests/examples/ghc8/T11016.hs b/tests/examples/ghc8/T11016.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11016.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-} - -module T11016 where - -f1 :: (?x :: Int, _) => Int -f1 = ?x - -f2 :: (?x :: Int) => _ -f2 = ?x diff --git a/tests/examples/ghc8/T11039.hs b/tests/examples/ghc8/T11039.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11039.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Foo () where - -data A a = A a - -pattern Q :: () => (A ~ f) => a -> f a -pattern Q a = A a diff --git a/tests/examples/ghc8/T11053.hs b/tests/examples/ghc8/T11053.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11053.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} --- turn on with -fwarn-missing-pat-syn-sigs - -module Foo where - --- Should warn because of missing signature -pattern T = True - -pattern J a = Just a - -pattern J1 a <- Just a - -pattern J2{b} = Just b - -pattern J3{c} <- Just c - -pattern F :: Bool -pattern F = False diff --git a/tests/examples/ghc8/T11067.hs b/tests/examples/ghc8/T11067.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11067.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -module T11067 where - -import Data.Monoid -import GHC.Exts (Constraint) - -type family Skolem (p :: k -> Constraint) :: k -type family SkolemF (p :: k2 -> Constraint) (f :: k1 -> k2) :: k1 - --- | A quantified constraint -type Forall (p :: k -> Constraint) = p (Skolem p) -type ForallF (p :: k2 -> Constraint) (f :: k1 -> k2) = p (f (SkolemF p f)) - --- These work -class ForallF Monoid t => Monoid1 t -instance ForallF Monoid t => Monoid1 t - -class ForallF Monoid1 t => Monoid2 t -instance ForallF Monoid1 t => Monoid2 t - --- Changing f a ~ g a to, (Ord (f a), Ord (g a)), say, removes the error -class (f a ~ g a) => H f g a -instance (f a ~ g a) => H f g a - --- This one gives a superclass cycle error. -class Forall (H f g) => H1 f g -instance Forall (H f g) => H1 f g diff --git a/tests/examples/ghc8/T11071.hs b/tests/examples/ghc8/T11071.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11071.hs +++ /dev/null @@ -1,28 +0,0 @@ -module T11071 where - -import Data.List (lines) -import qualified Data.Map as M () -import qualified Data.IntMap as M () -import qualified Data.IntMap as M () -- just to see if this confused the code - -import qualified Data.Ord as Ord hiding (Down) - -import qualified Data.Map as M' hiding (size, filter) -import qualified Data.Map as M' hiding (size) -import qualified Data.IntMap as M' hiding (size) -import qualified System.IO as M' () -- unrelated - -ignore :: a -> IO () -ignore = const (return ()) - -main = do - ignore NoSuchModule.foo -- no such module - ignore Data.List.foobar -- does not exist (one import) - ignore M.foobar -- does not exist (two imports) - ignore M'.foobar -- does not exist (three imports) - ignore Data.List.sort -- needs import - ignore Data.List.unlines -- needs import, similar to imported - ignore M.size -- multiple modules to import from - ignore M.valid -- only one module to import from - ignore Ord.Down -- explicit hiding - ignore M'.size -- hidden and/or missing in import list diff --git a/tests/examples/ghc8/T11071a.hs b/tests/examples/ghc8/T11071a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11071a.hs +++ /dev/null @@ -1,16 +0,0 @@ -module T11071 where - -import Data.List (lines) -import Data.IntMap () -import Data.Ord hiding (Down) -import Prelude hiding (True) - -ignore :: a -> IO () -ignore = const (return ()) - -main = do - ignore intersperse -- missing in import list (one import) - ignore foldl' -- missing in import list (two imports) - ignore Down -- explicitly hidden - ignore True -- explicitly hidden from prelude (not really special) - ignore foobar -- genuinely out of scope diff --git a/tests/examples/ghc8/T11076.hs b/tests/examples/ghc8/T11076.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11076.hs +++ /dev/null @@ -1,15 +0,0 @@ -{- - Test case for a problem where GHC had incorrect strictness - information for foreign calls with lifted arguments - -} -{-# OPTIONS_GHC -O0 #-} -module Main where - -import T11076A -import Control.Exception -x :: Bool -x = error "OK: x has been forced" - -main :: IO () -main = print (testBool x) `catch` - \(ErrorCall e) -> putStrLn e -- x should be forced diff --git a/tests/examples/ghc8/T11076A.hs b/tests/examples/ghc8/T11076A.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11076A.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# OPTIONS_GHC -O #-} -{-# LANGUAGE MagicHash, - ForeignFunctionInterface, - UnliftedFFITypes, - GHCForeignImportPrim, - BangPatterns - #-} -module T11076A where - -import GHC.Exts -import Unsafe.Coerce - -{- - If the demand type for the foreign call argument is incorrectly strict, - the bang pattern can be optimized out - -} -testBool :: Bool -> Int -testBool !x = I# (cmm_testPrim (unsafeCoerce x)) -{-# INLINE testBool #-} - -foreign import prim "testPrim" cmm_testPrim :: Any -> Int# diff --git a/tests/examples/ghc8/T11077.hs b/tests/examples/ghc8/T11077.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11077.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T11077 (module X, foo) where -import Data.List as X -foo = undefined diff --git a/tests/examples/ghc8/T11103.hs b/tests/examples/ghc8/T11103.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11103.hs +++ /dev/null @@ -1,20 +0,0 @@ --- When using DuplicateRecordFields with TemplateHaskell, it is not possible to --- reify ambiguous names that are output by reifying field labels. --- See also overloadedrecflds/should_run/overloadedrecfldsrun04.hs - -{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -data R = MkR { foo :: Int, bar :: Int } -data S = MkS { foo :: Int } - -$(do info <- reify ''R - case info of - TyConI (DataD _ _ _ [RecC _ [(foo_n, _, _), (bar_n, _, _)]] _) - -> do { reify bar_n -- This is unambiguous - ; reify foo_n -- This is ambiguous - ; return [] - } - _ -> error "unexpected result of reify") diff --git a/tests/examples/ghc8/T11112.hs b/tests/examples/ghc8/T11112.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11112.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T11112 where - -sort :: Ord s -> [s] -> [s] -sort xs = xs diff --git a/tests/examples/ghc8/T11128.hs b/tests/examples/ghc8/T11128.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11128.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -fwarn-noncanonical-monad-instances #-} - --- | Test noncanonical-monad-instances warnings -module T11128 where - -import Control.Applicative as A -import Control.Monad as M - ----------------------------------------------------------------------------- --- minimal definition - -data T0 a = T0 a deriving Functor - -instance A.Applicative T0 where - pure = T0 - (<*>) = M.ap - -instance M.Monad T0 where - (>>=) = undefined - ----------------------------------------------------------------------------- --- trigger all 4 warnings - -data T1 a = T1 a deriving Functor - -instance A.Applicative T1 where - pure = return - (<*>) = M.ap - (*>) = (M.>>) - -instance M.Monad T1 where - (>>=) = undefined - return = T1 - (>>) = undefined - ----------------------------------------------------------------------------- --- backward compat canonical defintion - -data T2 a = T2 a deriving Functor - -instance Applicative T2 where - pure = T2 - (<*>) = ap - (*>) = undefined - -instance M.Monad T2 where - (>>=) = undefined - return = pure - (>>) = (*>) diff --git a/tests/examples/ghc8/T11136.hs b/tests/examples/ghc8/T11136.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11136.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T11136 where - -class C a where - type D a - type instance D a x = x diff --git a/tests/examples/ghc8/T11142.hs b/tests/examples/ghc8/T11142.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11142.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeInType, RankNTypes #-} - -module T11142 where - -import Data.Kind - -data SameKind :: k -> k -> * - -foo :: forall b. (forall k (a :: k). SameKind a b) -> () -foo = undefined diff --git a/tests/examples/ghc8/T11148.hs b/tests/examples/ghc8/T11148.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11148.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} - -module T11148 where - -data family G a b c d -data instance G Int b Float d = G deriving Functor - -data family H a b c d -data instance H [b] b d c = H deriving Functor diff --git a/tests/examples/ghc8/T11155.hs b/tests/examples/ghc8/T11155.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11155.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# OPTIONS_GHC -O -fno-full-laziness #-} -module T11155 where - -foo :: Bool -{-# NOINLINE foo #-} -foo = error "rk" - -bar x = let t :: Char - t = case foo of { True -> 'v'; False -> 'y' } - in [t] - diff --git a/tests/examples/ghc8/T11164.hs b/tests/examples/ghc8/T11164.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11164.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T11164 where - -import T11164b (T) diff --git a/tests/examples/ghc8/T11164a.hs b/tests/examples/ghc8/T11164a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11164a.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T11164a where - -data family T a diff --git a/tests/examples/ghc8/T11164b.hs b/tests/examples/ghc8/T11164b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11164b.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T11164b where - -import T11164a - -data instance T Int = MkT diff --git a/tests/examples/ghc8/T11167.hs b/tests/examples/ghc8/T11167.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11167.hs +++ /dev/null @@ -1,21 +0,0 @@ -module T11167 where - -data SomeException - -newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r} - -runContT' :: ContT r m a -> (a -> m r) -> m r -runContT' = runContT - -catch_ :: IO a -> (SomeException -> IO a) -> IO a -catch_ = undefined - -foo :: IO () -foo = (undefined :: ContT () IO a) - `runContT` (undefined :: a -> IO ()) - `catch_` (undefined :: SomeException -> IO ()) - -foo' :: IO () -foo' = (undefined :: ContT () IO a) - `runContT'` (undefined :: a -> IO ()) - `catch_` (undefined :: SomeException -> IO ()) diff --git a/tests/examples/ghc8/T11167_ambig.hs b/tests/examples/ghc8/T11167_ambig.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11167_ambig.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module T11167_ambig where - -data SomeException - -newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r} -newtype ContT' r m a = ContT' {runContT :: (a -> m r) -> m r} - -runContT' :: ContT r m a -> (a -> m r) -> m r -runContT' = runContT - -catch_ :: IO a -> (SomeException -> IO a) -> IO a -catch_ = undefined - -foo :: IO () -foo = (undefined :: ContT () IO a) - `runContT` (undefined :: a -> IO ()) - `catch_` (undefined :: SomeException -> IO ()) - -foo' :: IO () -foo' = (undefined :: ContT () IO a) - `runContT'` (undefined :: a -> IO ()) - `catch_` (undefined :: SomeException -> IO ()) diff --git a/tests/examples/ghc8/T11167_ambiguous_fixity.hs b/tests/examples/ghc8/T11167_ambiguous_fixity.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11167_ambiguous_fixity.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module T11167_ambiguous_fixity where -import T11167_ambiguous_fixity_A -import T11167_ambiguous_fixity_B - -x a = (a :: A) `foo` 0 diff --git a/tests/examples/ghc8/T11167_ambiguous_fixity_A.hs b/tests/examples/ghc8/T11167_ambiguous_fixity_A.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11167_ambiguous_fixity_A.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module T11167_ambiguous_fixity_A where -data A = MkA { foo :: Int -> Int } -data C = MkC { foo :: Int -> Int } -infixr 3 `foo` diff --git a/tests/examples/ghc8/T11167_ambiguous_fixity_B.hs b/tests/examples/ghc8/T11167_ambiguous_fixity_B.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11167_ambiguous_fixity_B.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T11167_ambiguous_fixity_B where -data B = MkB { foo :: Int -> Int } -infixl 5 `foo` diff --git a/tests/examples/ghc8/T11173.hs b/tests/examples/ghc8/T11173.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11173.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module T11173 where -import T11173a (A(..)) - --- Check that the fixity declaration applied to the field 'foo' is used -x b = b `foo` b `foo` 0 diff --git a/tests/examples/ghc8/T11173a.hs b/tests/examples/ghc8/T11173a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11173a.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module T11173a where - -data A = A { foo :: Int -> Int, bar :: Int -> Int } -newtype B = B { foo :: Int -> Int } -infixr 5 `foo` -infixr 5 `bar` - --- This is well-typed only if the fixity is correctly applied -y b = b `bar` b `bar` 0 diff --git a/tests/examples/ghc8/T11182.hs b/tests/examples/ghc8/T11182.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11182.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE Strict #-} --- | Strict should imply StrictData -module Main where - -data Lazy a = Lazy ~a - -main :: IO () -main = - case Lazy undefined of - Lazy _ -> putStrLn "Lazy" diff --git a/tests/examples/ghc8/T11187.hs b/tests/examples/ghc8/T11187.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11187.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module T11187 where -import Data.Type.Coercion - -type family X - -coercionXX :: Coercion X X -coercionXX = Coercion - -coercionXX1 :: Coercion X X -coercionXX1 = c where - c :: x ~ X => Coercion x x - c = Coercion - -coercionXX2 :: Coercion X X -coercionXX2 = c where c = Coercion diff --git a/tests/examples/ghc8/T11192.hs b/tests/examples/ghc8/T11192.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11192.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} - -module T11192 where - -fails :: a -fails = - let go :: _ - go 0 a = a - in go (0 :: Int) undefined - -succeeds :: a -succeeds = - let go :: _ - go _ a = a - in go (0 :: Int) undefined diff --git a/tests/examples/ghc8/T11193.hs b/tests/examples/ghc8/T11193.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11193.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Strict #-} - -module Main where - -main = do - ~a <- return (error "don't error here!") - b <- return (error "error here!") -- this binding should be strict - print "should never reach here" diff --git a/tests/examples/ghc8/T11208.hs b/tests/examples/ghc8/T11208.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11208.hs +++ /dev/null @@ -1,8 +0,0 @@ -module T11208 where - -import qualified Prelude as P - -f n = n P.+ 1 - -g h (P.Just x) = P.Just (h x) -g _ P.Nothing = P.Nothing diff --git a/tests/examples/ghc8/T11216.hs b/tests/examples/ghc8/T11216.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11216.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE RebindableSyntax #-} - -module Bug where - -foo :: (a, b) -> () -foo x | (_,_) <- x = () diff --git a/tests/examples/ghc8/T11224.hs b/tests/examples/ghc8/T11224.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11224.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE PatternSynonyms , ViewPatterns #-} - --- inlining a pattern synonym shouldn't change semantics - -import Text.Read - --- pattern PRead :: () => Read a => a -> String -pattern PRead a <- (readMaybe -> Just a) - -foo :: String -> Int -foo (PRead x) = (x::Int) -foo (PRead xs) = sum (xs::[Int]) -foo _ = 666 - -bar :: String -> Int -bar (readMaybe -> Just x) = (x::Int) -bar (readMaybe -> Just xs) = sum (xs::[Int]) -bar _ = 666 - -main :: IO () -main = do - print $ foo "1" -- 1 - print $ foo "[1,2,3]" -- 666 -- ??? - print $ foo "xxx" -- 666 - - print $ bar "1" -- 1 - print $ bar "[1,2,3]" -- 6 - print $ bar "xxx" -- 666 diff --git a/tests/examples/ghc8/T11232.hs b/tests/examples/ghc8/T11232.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11232.hs +++ /dev/null @@ -1,15 +0,0 @@ -module T11232 where - -import Control.Monad -import Data.Data - -mkMp :: ( MonadPlus m - , Typeable a - , Typeable b - ) - => (b -> m b) - -> a - -> m a -mkMp ext = unM (maybe (M (const mzero)) id (gcast (M ext))) - -newtype M m x = M { unM :: x -> m x } diff --git a/tests/examples/ghc8/T11237.hs b/tests/examples/ghc8/T11237.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11237.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE GADTs #-} -module TypeInTypeBug where - -import qualified Data.Kind - -data Works :: Data.Kind.Type where - WorksConstr :: Works - -type Set = Data.Kind.Type - -data ShouldWork :: Set where - ShouldWorkConstr :: ShouldWork diff --git a/tests/examples/ghc8/T1133Aa.hs b/tests/examples/ghc8/T1133Aa.hs deleted file mode 100644 --- a/tests/examples/ghc8/T1133Aa.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T1133Aa where - -import {-# SOURCE #-} T1133A diff --git a/tests/examples/ghc8/T1133a.hs b/tests/examples/ghc8/T1133a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T1133a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T1133a where - -import {-# SOURCE #-} T1133 diff --git a/tests/examples/ghc8/T11381.hs b/tests/examples/ghc8/T11381.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11381.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T11381 where - --- ensure that this code does not compile without InjectiveTypeFamilies and that --- injectivity error is not reported. -type family F a = r | r -> a -type instance F Int = Bool -type instance F Int = Char diff --git a/tests/examples/ghc8/T11959.hs b/tests/examples/ghc8/T11959.hs deleted file mode 100644 --- a/tests/examples/ghc8/T11959.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Main where - -import T11959Lib (Vec2(..), pattern (:>)) - -main = return () diff --git a/tests/examples/ghc8/T17a.hs b/tests/examples/ghc8/T17a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T17a.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unused-top-binds #-} - --- Trac #17 - -module Temp (foo, bar, quux) where - -top :: Int -top = 1 - -foo :: () -foo = let True = True in () - -bar :: Int -> Int -bar match = 1 - -quux :: Int -quux = let local = True - in 2 diff --git a/tests/examples/ghc8/T17b.hs b/tests/examples/ghc8/T17b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T17b.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unused-local-binds #-} - --- Trac #17 - -module Temp (foo, bar, quux) where - -top :: Int -top = 1 - -foo :: () -foo = let True = True in () - -bar :: Int -> Int -bar match = 1 - -quux :: Int -quux = let local = True - in 2 diff --git a/tests/examples/ghc8/T17c.hs b/tests/examples/ghc8/T17c.hs deleted file mode 100644 --- a/tests/examples/ghc8/T17c.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unused-pattern-binds #-} - --- Trac #17 - -module Temp (foo, bar, quux) where - -top :: Int -top = 1 - -foo :: () -foo = let True = True in () - -bar :: Int -> Int -bar match = 1 - -quux :: Int -quux = let local = True - in 2 diff --git a/tests/examples/ghc8/T17d.hs b/tests/examples/ghc8/T17d.hs deleted file mode 100644 --- a/tests/examples/ghc8/T17d.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unused-matches #-} - --- Trac #17 - -module Temp (foo, bar, quux) where - -top :: Int -top = 1 - -foo :: () -foo = let True = True in () - -bar :: Int -> Int -bar match = 1 - -quux :: Int -quux = let local = True - in 2 diff --git a/tests/examples/ghc8/T17e.hs b/tests/examples/ghc8/T17e.hs deleted file mode 100644 --- a/tests/examples/ghc8/T17e.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unused-binds #-} - --- Trac #17 - -module Temp (foo, bar, quux) where - -top :: Int -top = 1 - -foo :: () -foo = let True = True in () - -bar :: Int -> Int -bar match = 1 - -quux :: Int -quux = let local = True - in 2 diff --git a/tests/examples/ghc8/T1830_1.hs b/tests/examples/ghc8/T1830_1.hs deleted file mode 100644 --- a/tests/examples/ghc8/T1830_1.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T1830_1 where - -import Language.Haskell.TH.Syntax (Lift) - -data Foo a = Foo a deriving Lift diff --git a/tests/examples/ghc8/T1830_2.hs b/tests/examples/ghc8/T1830_2.hs deleted file mode 100644 --- a/tests/examples/ghc8/T1830_2.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DeriveLift #-} -module T1830_2 where - -import Language.Haskell.TH.Syntax (Lift) - -data Nothing deriving Lift diff --git a/tests/examples/ghc8/T1830_3.hs b/tests/examples/ghc8/T1830_3.hs deleted file mode 100644 --- a/tests/examples/ghc8/T1830_3.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Language.Haskell.TH.Syntax (lift) -import T1830_3a - -main :: IO () -main = do - print ($(lift algDT1) == algDT1) - print ($(lift algDT2) == algDT2) - print ($(lift algDT3) == algDT3) - print ($(lift prim) == prim) - print ($(lift df1) == df1) - print ($(lift df2) == df2) - print ($(lift df3) == df3) diff --git a/tests/examples/ghc8/T1830_3a.hs b/tests/examples/ghc8/T1830_3a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T1830_3a.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -module T1830_3a where - -import GHC.Exts -import Language.Haskell.TH.Syntax (Lift(..)) - -data AlgDT a b c = NormalCon a b - | RecCon { recCon1 :: a, recCon2 :: b} - | a :^: b - deriving (Eq, Lift) - -data Prim = Prim Char# Double# Int# Float# Word# - deriving (Eq, Lift) - --- We can't test this for equality easily due to the unstable nature of --- primitive string literal equality. We include this anyway to ensure that --- deriving Lift for datatypes with Addr# in them does in fact work. -data AddrHash = AddrHash Addr# - deriving Lift - -data Empty deriving Lift - -data family DataFam a b c - -data instance DataFam Int b c = DF1 Int | DF2 b - deriving (Eq, Lift) - -newtype instance DataFam Char b c = DF3 Char - deriving (Eq, Lift) - -algDT1, algDT2, algDT3 :: AlgDT Int String () -algDT1 = NormalCon 1 "foo" -algDT2 = RecCon 2 "bar" -algDT3 = 3 :^: "baz" - -prim :: Prim -prim = Prim 'a'# 1.0## 1# 1.0# 1## - -df1, df2 :: DataFam Int Char () -df1 = DF1 1 -df2 = DF2 'a' - -df3 :: DataFam Char () () -df3 = DF3 'b' diff --git a/tests/examples/ghc8/T2006.hs b/tests/examples/ghc8/T2006.hs deleted file mode 100644 --- a/tests/examples/ghc8/T2006.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} -{-# LANGUAGE GADTs #-} - -module T2006 where - -data Expr a vs where - EPrim :: String -> a -> Expr a vs - EVar :: Expr a (a,vs) - -interpret :: Expr a () -> a -interpret (EPrim _ a) = a --- interpret EVar = error "unreachable" - diff --git a/tests/examples/ghc8/T2204.hs b/tests/examples/ghc8/T2204.hs deleted file mode 100644 --- a/tests/examples/ghc8/T2204.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T2204 where - -f :: String -> Int -f "01" = 0 - -g :: Int -> Int -g 0 = 0 diff --git a/tests/examples/ghc8/T2632.hs b/tests/examples/ghc8/T2632.hs deleted file mode 100644 --- a/tests/examples/ghc8/T2632.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- Trac #2632 - -module MkData where - -import Language.Haskell.TH - -op :: Num v => v -> v -> v -op a b = a + b - -decl1 = [d| func = 0 `op` 3 |] - -decl2 = [d| op x y = x - func = 0 `op` 3 |] - diff --git a/tests/examples/ghc8/T2931.hs b/tests/examples/ghc8/T2931.hs deleted file mode 100644 --- a/tests/examples/ghc8/T2931.hs +++ /dev/null @@ -1,7 +0,0 @@ --- Trac #2931 - -module Foo where -a = 1 - --- NB: no newline after the 'a'! -b = 'a diff --git a/tests/examples/ghc8/T2991.hs b/tests/examples/ghc8/T2991.hs deleted file mode 100644 --- a/tests/examples/ghc8/T2991.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main where --- Test that there are actually entries in the .mix file for an imported --- literate module generated with --make. -import T2991LiterateModule -main = return () diff --git a/tests/examples/ghc8/T3078.hs b/tests/examples/ghc8/T3078.hs deleted file mode 100644 --- a/tests/examples/ghc8/T3078.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T3078 where - -data T = A Int | B Int - -funny :: T -> Int -funny t = n - where - n | A x <- t = x - | B x <- t = x diff --git a/tests/examples/ghc8/T322.hs b/tests/examples/ghc8/T322.hs deleted file mode 100644 --- a/tests/examples/ghc8/T322.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# OPTIONS -fwarn-incomplete-patterns -fwarn-overlapping-patterns -Werror #-} - -module T322 where - -instance (Num a) => Num (Maybe a) where - (Just a) + (Just b) = Just (a + b) - _ + _ = Nothing - - (Just a) - (Just b) = Just (a - b) - _ - _ = Nothing - - (Just a) * (Just b) = Just (a * b) - _ * _ = Nothing - - negate (Just a) = Just (negate a) - negate _ = Nothing - - abs (Just a) = Just (abs a) - abs _ = Nothing - - signum (Just a) = Just (signum a) - signum _ = Nothing - - fromInteger = Just . fromInteger - -f :: Maybe Int -> Int -f 1 = 1 -f Nothing = 2 -f _ = 3 diff --git a/tests/examples/ghc8/T3468a.hs b/tests/examples/ghc8/T3468a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T3468a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T3468a where - -import {-# SOURCE #-} T3468 diff --git a/tests/examples/ghc8/T3572.hs b/tests/examples/ghc8/T3572.hs deleted file mode 100644 --- a/tests/examples/ghc8/T3572.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TemplateHaskellQuotes #-} - --- Trac #3572 - -module Main where - -import Language.Haskell.TH -import Language.Haskell.TH.Ppr - -main = putStrLn . pprint =<< runQ [d| data Void |] diff --git a/tests/examples/ghc8/T365.hs b/tests/examples/ghc8/T365.hs deleted file mode 100644 --- a/tests/examples/ghc8/T365.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF ./test_preprocessor.txt #-} -module Main where - -main = print "Hello World" diff --git a/tests/examples/ghc8/T366.hs b/tests/examples/ghc8/T366.hs deleted file mode 100644 --- a/tests/examples/ghc8/T366.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -XGADTs -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T366 where - -data T a where - C1 :: T Char - C2 :: T Float - -exhaustive :: T Char -> Char -exhaustive C1 = ' ' diff --git a/tests/examples/ghc8/T3927.hs b/tests/examples/ghc8/T3927.hs deleted file mode 100644 --- a/tests/examples/ghc8/T3927.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T3927 where - -data T a where - T1 :: T Int - T2 :: T Bool - --- f1 is exhaustive -f1 :: T a -> T a -> Bool -f1 T1 T1 = True -f1 T2 T2 = False diff --git a/tests/examples/ghc8/T3927a.hs b/tests/examples/ghc8/T3927a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T3927a.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} -{-# LANGUAGE GADTs, TypeFamilies #-} - -module T3927a where - -type family F a -type instance F a = () - -data Foo a where - FooA :: Foo () - FooB :: Foo Int - -f :: a -> Foo (F a) -> () -- F a can only be () so only FooA is accepted -f _ FooA = () - diff --git a/tests/examples/ghc8/T3927b.hs b/tests/examples/ghc8/T3927b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T3927b.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T3927b where - -import Data.Proxy -import GHC.Exts - -data Message - -data SocketType = Dealer | Push | Pull - -data SocketOperation = Read | Write - -type family Restrict (a :: SocketOperation) (as :: [SocketOperation]) :: Constraint where - Restrict a (a ': as) = () - Restrict x (a ': as) = Restrict x as - Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!") - -type family Implements (t :: SocketType) :: [SocketOperation] where - Implements Dealer = ['Read, Write] - Implements Push = '[Write] - Implements Pull = '[ 'Read] - -data SockOp :: SocketType -> SocketOperation -> * where - SRead :: SockOp sock 'Read - SWrite :: SockOp sock Write - -data Socket :: SocketType -> * where - Socket :: proxy sock - -> (forall op . Restrict op (Implements sock) => SockOp sock op -> Operation op) - -> Socket sock - -type family Operation (op :: SocketOperation) :: * where - Operation 'Read = IO Message - Operation Write = Message -> IO () - -class Restrict 'Read (Implements t) => Readable t where - readSocket :: Socket t -> Operation 'Read - readSocket (Socket _ f) = f (SRead :: SockOp t 'Read) - -instance Readable Dealer - -type family Writable (t :: SocketType) :: Constraint where - Writable Dealer = () - Writable Push = () - -dealer :: Socket Dealer -dealer = Socket (Proxy :: Proxy Dealer) f - where - f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op - f SRead = undefined - f SWrite = undefined - -push :: Socket Push -push = Socket (Proxy :: Proxy Push) f - where - f :: Restrict op (Implements Push) => SockOp Push op -> Operation op - f SWrite = undefined - -pull :: Socket Pull -pull = Socket (Proxy :: Proxy Pull) f - where - f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op - f SRead = undefined - -foo :: IO Message -foo = readSocket dealer diff --git a/tests/examples/ghc8/T4056.hs b/tests/examples/ghc8/T4056.hs deleted file mode 100644 --- a/tests/examples/ghc8/T4056.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-} -{-# LANGUAGE TemplateHaskellQuotes #-} - -module T4056 where -import Language.Haskell.TH - -astTest :: Q [Dec] -astTest = [d| - class C t where - op :: [t] -> [t] - op = undefined - |] - -class D t where - bop :: [t] -> [t] - bop = undefined diff --git a/tests/examples/ghc8/T4139.hs b/tests/examples/ghc8/T4139.hs deleted file mode 100644 --- a/tests/examples/ghc8/T4139.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - -module T4139 where - -data F a where - FInt :: F Int - FBool :: F Bool - -class Baz a where - baz :: F a -> G a -instance Baz Int where - baz _ = GInt -instance Baz Bool where - baz _ = GBool - -data G a where - GInt :: G Int - GBool :: G Bool - -bar :: Baz a => F a -> () -bar a@(FInt) = - case baz a of - GInt -> () - -- GBool -> () -bar _ = () - - diff --git a/tests/examples/ghc8/T4169.hs b/tests/examples/ghc8/T4169.hs deleted file mode 100644 --- a/tests/examples/ghc8/T4169.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- Crashed GHC 6.12 - -module T4165 where - -import Language.Haskell.TH -class Numeric a where - fromIntegerNum :: a - fromIntegerNum = undefined - -ast :: Q [Dec] -ast = [d| - instance Numeric Int - |] diff --git a/tests/examples/ghc8/T4170.hs b/tests/examples/ghc8/T4170.hs deleted file mode 100644 --- a/tests/examples/ghc8/T4170.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module T4170 where - -import Language.Haskell.TH - -class LOL a - -lol :: Q [Dec] -lol = [d| - instance LOL Int - |] - -instance LOL Int diff --git a/tests/examples/ghc8/T5001b.hs b/tests/examples/ghc8/T5001b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T5001b.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -module T5001b where - -class GEnum a where - genum :: [a] - default genum :: [a] - genum = undefined - -instance GEnum Int where - {-# INLINE genum #-} diff --git a/tests/examples/ghc8/T5333.hs b/tests/examples/ghc8/T5333.hs deleted file mode 100644 --- a/tests/examples/ghc8/T5333.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE Arrows, NoMonomorphismRestriction #-} -module T5333 where - -import Prelude hiding ( id, (.) ) -import Control.Arrow - -cc1 :: a e b -> a e b -> a e b -cc1 = undefined - --- With GHC < 7.10.1, the following compile failures occured: --- --- ghc: panic! (the 'impossible' happened) --- (GHC version 7.8.4 for x86_64-unknown-linux): --- mkCmdEnv Not found: base:GHC.Desugar.>>>{v 02V} - --- 'g' fails to compile. -g = proc (x, y, z) -> - ((returnA -< x) &&& (returnA -< y) &&& (returnA -< z)) - --- 'f' compiles: --- - without an infix declaration --- - with the infixl declaration --- and fails with the infixr declaration -infixr 6 `cc1` --- infixl 6 `cc1` - -f = proc (x, y, z) -> - ((returnA -< x) `cc1` (returnA -< y) `cc1` (returnA -< z)) diff --git a/tests/examples/ghc8/T5721.hs b/tests/examples/ghc8/T5721.hs deleted file mode 100644 --- a/tests/examples/ghc8/T5721.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module T5371 where -import Language.Haskell.TH - -f :: a -> Name -f (x :: a) = ''a diff --git a/tests/examples/ghc8/T5821.hs b/tests/examples/ghc8/T5821.hs deleted file mode 100644 --- a/tests/examples/ghc8/T5821.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module T5821 where - -type family T a -type instance T Int = Bool - -foo :: Num a => a -> T a -foo = undefined - -{-# SPECIALISE foo :: Int -> Bool #-} diff --git a/tests/examples/ghc8/T5884Other.hs b/tests/examples/ghc8/T5884Other.hs deleted file mode 100644 --- a/tests/examples/ghc8/T5884Other.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T5884Other where - -data Pair a = Pair a a diff --git a/tests/examples/ghc8/T5908.hs b/tests/examples/ghc8/T5908.hs deleted file mode 100644 --- a/tests/examples/ghc8/T5908.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# LANGUAGE - ExplicitForAll - , GADTs - , RebindableSyntax #-} -module T5908 - ( Writer - , runWriter - , execWriter - , WriterT - , runWriterT - , execWriterT - , tell - ) where - -import Control.Category (Category (id), (>>>)) - -import Prelude hiding (Monad (..), id) -import qualified Prelude - -newtype Identity a = Identity { runIdentity :: a } - -class Monad m where - (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b - (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b - return :: a -> m ex ex a - fail :: String -> m e x a - - {-# INLINE (>>) #-} - m >> k = m >>= \ _ -> k - fail = error - -type Writer w = WriterT w Identity - -runWriter :: Writer w e x a -> (a, w e x) -runWriter = runIdentity . runWriterT - -execWriter :: Writer w e x a -> w e x -execWriter m = snd (runWriter m) - -newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) } - -execWriterT :: Prelude.Monad m => WriterT w m e x a -> m (w e x) -execWriterT m = do - ~(_, w) <- runWriterT m - return w - where - (>>=) = (Prelude.>>=) - return = Prelude.return - -instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where - return a = WriterT $ return (a, id) - where - return = Prelude.return - m >>= k = WriterT $ do - ~(a, w) <- runWriterT m - ~(b, w') <- runWriterT (k a) - return (b, w >>> w') - where - (>>=) = (Prelude.>>=) - return = Prelude.return - fail msg = WriterT $ fail msg - where - fail = Prelude.fail - -tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x () -tell w = WriterT $ return ((), w) - where - return = Prelude.return - - diff --git a/tests/examples/ghc8/T6018.hs b/tests/examples/ghc8/T6018.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6018.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoMonomorphismRestriction #-} - -module T6018 where - -import T6018a -- defines G, identical to F - -type family F a b c = (result :: k) | result -> a b c -type instance F Int Char Bool = Bool -type instance F Char Bool Int = Int -type instance F Bool Int Char = Char - - -type instance G Bool Int Char = Char - -type family I (a :: k) b (c :: k) = r | r -> a b -type instance I Int Char Bool = Bool -type instance I Int Char Int = Bool -type instance I Bool Int Int = Int - --- this is injective - a type variable introduced in the LHS is not mentioned on --- RHS but we don't claim injectivity in that argument. -type family J a (b :: k) = r | r -> a -type instance J Int b = Char - -type MaybeSyn a = Maybe a -newtype MaybeNew a = MaybeNew (Maybe a) - --- make sure we look through type synonyms... -type family K a = r | r -> a -type instance K a = MaybeSyn a - --- .. but not newtypes -type family M a = r | r -> a -type instance M (Maybe a) = MaybeSyn a -type instance M (MaybeNew a) = MaybeNew a - --- Closed type families - --- these are simple conversions from open type families. They should behave the --- same -type family FClosed a b c = result | result -> a b c where - FClosed Int Char Bool = Bool - FClosed Char Bool Int = Int - FClosed Bool Int Char = Char - -type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where - IClosed Int Char Bool = Bool - IClosed Int Char Int = Bool - IClosed Bool Int Int = Int - -type family JClosed a (b :: k) = r | r -> a where - JClosed Int b = Char - -type family KClosed a = r | r -> a where - KClosed a = MaybeSyn a - --- Here the last equation might return both Int and Char but we have to --- recognize that it is not possible due to equation overlap -type family Bak a = r | r -> a where - Bak Int = Char - Bak Char = Int - Bak a = a - --- This is similar, except that the last equation contains concrete type. Since --- it is overlapped it should be dropped with a warning -type family Foo a = r | r -> a where - Foo Int = Bool - Foo Bool = Int - Foo Bool = Bool - --- this one was tricky in the early implementation of injectivity. Now it is --- identical to the above but we still keep it as a regression test. -type family Bar a = r | r -> a where - Bar Int = Bool - Bar Bool = Int - Bar Bool = Char - --- Now let's use declared type families. All the below definitions should work - --- No ambiguity for any of the arguments - all are injective -f :: F a b c -> F a b c -f x = x - --- From 1st instance of F: a ~ Int, b ~ Char, c ~ Bool -fapp :: Bool -fapp = f True - --- now the closed variant of F -fc :: FClosed a b c -> FClosed a b c -fc x = x - -fcapp :: Bool -fcapp = fc True - --- The last argument is not injective so it must be instantiated -i :: I a b Int -> I a b Int -i x = x - --- From 1st instance of I: a ~ Int, b ~ Char -iapp :: Bool -iapp = i True - --- again, closed variant of I -ic :: IClosed a b Int -> IClosed a b Int -ic x = x - -icapp :: Bool -icapp = ic True - --- Now we have to test weird closed type families: -bak :: Bak a -> Bak a -bak x = x - -bakapp1 :: Char -bakapp1 = bak 'c' - -bakapp2 :: Double -bakapp2 = bak 1.0 - -bakapp3 :: () -bakapp3 = bak () - -foo :: Foo a -> Foo a -foo x = x - -fooapp1 :: Bool -fooapp1 = foo True - -bar :: Bar a -> Bar a -bar x = x - -barapp1 :: Bool -barapp1 = bar True - -barapp2 :: Int -barapp2 = bar 1 - --- Declarations below test more liberal RHSs of injectivity annotations: --- permiting variables to appear in different order than the one in which they --- were declared. -type family H a b = r | r -> b a -type family Hc a b = r | r -> b a where - Hc a b = a b -class Hcl a b where - type Ht a b = r | r -> b a - --- repeated tyvars in the RHS of injectivity annotation: no warnings or errors --- (consistent with behaviour for functional dependencies) -type family Jx a b = r | r -> a a -type family Jcx a b = r | r -> a a where - Jcx a b = a b -class Jcl a b where - type Jt a b = r | r -> a a - -type family Kx a b = r | r -> a b b -type family Kcx a b = r | r -> a b b where - Kcx a b = a b -class Kcl a b where - type Kt a b = r | r -> a b b - --- Declaring kind injectivity. Here we only claim that knowing the RHS --- determines the LHS kind but not the type. -type family L (a :: k1) = (r :: k2) | r -> k1 where - L 'True = Int - L 'False = Int - L Maybe = 3 - L IO = 3 - -data KProxy (a :: *) = KProxy -type family KP (kproxy :: KProxy k) = r | r -> k -type instance KP ('KProxy :: KProxy Bool) = Int -type instance KP ('KProxy :: KProxy *) = Char - -kproxy_id :: KP ('KProxy :: KProxy k) -> KP ('KProxy :: KProxy k) -kproxy_id x = x - -kproxy_id_use = kproxy_id 'a' - --- Now test some awkward cases from The Injectivity Paper. All should be --- accepted. -type family Gx a -type family Hx a -type family Gi a = r | r -> a -type instance Gi Int = Char -type family Hi a = r | r -> a - -type family F2 a = r | r -> a -type instance F2 [a] = [Gi a] -type instance F2 (Maybe a) = Hi a -> Int - -type family F4 a = r | r -> a -type instance F4 [a] = (Gx a, a, a, a) -type instance F4 (Maybe a) = (Hx a, a, Int, Bool) - -type family G2 a b = r | r -> a b -type instance G2 a Bool = (a, a) -type instance G2 Bool b = (b, Bool) - -type family G6 a = r | r -> a -type instance G6 [a] = [Gi a] -type instance G6 Bool = Int - -g6_id :: G6 a -> G6 a -g6_id x = x - -g6_use :: [Char] -g6_use = g6_id "foo" - --- A sole exception to "bare variables in the RHS" rule -type family Id (a :: k) = (result :: k) | result -> a -type instance Id a = a - --- This makes sure that over-saturated type family applications at the top-level --- are accepted. -type family IdProxy (a :: k) b = r | r -> a -type instance IdProxy a b = (Id a) b - --- make sure we look through type synonyms properly -type IdSyn a = Id a -type family IdProxySyn (a :: k) b = r | r -> a -type instance IdProxySyn a b = (IdSyn a) b - --- this has bare variable in the RHS but all LHS varaiables are also bare so it --- should be accepted -type family Fa (a :: k) (b :: k) = (r :: k2) | r -> k -type instance Fa a b = a - --- Taken from #9587. This exposed a bug in the solver. -type family Arr (repr :: * -> *) (a :: *) (b :: *) = (r :: *) | r -> repr a b - -class ESymantics repr where - int :: Int -> repr Int - add :: repr Int -> repr Int -> repr Int - - lam :: (repr a -> repr b) -> repr (Arr repr a b) - app :: repr (Arr repr a b) -> repr a -> repr b - -te4 = let c3 = lam (\f -> lam (\x -> f `app` (f `app` (f `app` x)))) - in (c3 `app` (lam (\x -> x `add` int 14))) `app` (int 0) - --- This used to fail during development -class Manifold' a where - type Base a = r | r -> a - project :: a -> Base a - unproject :: Base a -> a - -id' :: forall a. ( Manifold' a ) => Base a -> Base a -id' = project . unproject diff --git a/tests/examples/ghc8/T6018Afail.hs b/tests/examples/ghc8/T6018Afail.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6018Afail.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018Afail where - -type family G a b c = (result :: *) | result -> a b c -type instance G Int Char Bool = Bool -type instance G Char Bool Int = Int diff --git a/tests/examples/ghc8/T6018Bfail.hs b/tests/examples/ghc8/T6018Bfail.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6018Bfail.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018Bfail where - -type family H a b c = (result :: *) | result -> a b c diff --git a/tests/examples/ghc8/T6018Cfail.hs b/tests/examples/ghc8/T6018Cfail.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6018Cfail.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018Cfail where - -import T6018Bfail - -type instance H Int Char Bool = Bool -type instance H Char Bool Int = Int diff --git a/tests/examples/ghc8/T6018Dfail.hs b/tests/examples/ghc8/T6018Dfail.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6018Dfail.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018Dfail where - -import T6018Bfail - -type instance H Bool Int Char = Int diff --git a/tests/examples/ghc8/T6018a.hs b/tests/examples/ghc8/T6018a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6018a.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018a where - -import {-# SOURCE #-} T6018 -- test support for hs-boot files - -type family G a b c = (result :: *) | result -> a b c -type instance G Int Char Bool = Bool -type instance G Char Bool Int = Int - -type instance F Bool Int Char = Char diff --git a/tests/examples/ghc8/T6018fail.hs b/tests/examples/ghc8/T6018fail.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6018fail.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds, - MultiParamTypeClasses, FlexibleInstances #-} - -module T6018fail where - -import T6018Afail -- defines G, identical to F -import T6018Cfail -- imports H from T6018Bfail, defines some equations for H -import T6018Dfail -- imports H from T6018Bfail, defines conflicting eqns - -type family F a b c = (result :: *) | result -> a b c -type instance F Int Char Bool = Bool -type instance F Char Bool Int = Int -type instance F Bool Int Char = Int - -type instance G Bool Int Char = Int - -type family I a b c = r | r -> a b -type instance I Int Char Bool = Bool -type instance I Int Int Int = Bool -type instance I Bool Int Int = Int - --- Id is injective... -type family Id a = result | result -> a -type instance Id a = a - --- ...but despite that we disallow a call to Id -type family IdProxy a = r | r -> a -type instance IdProxy a = Id a - -data N = Z | S N - --- P is not injective, although the user declares otherwise. This --- should be rejected on the grounds of calling a type family in the --- RHS. -type family P (a :: N) (b :: N) = (r :: N) | r -> a b -type instance P Z m = m -type instance P (S n) m = S (P n m) - --- this is not injective - not all injective type variables mentioned --- on LHS are mentioned on RHS -type family J a b c = r | r -> a b -type instance J Int b c = Char - --- same as above, but tyvar is now nested inside a tycon -type family K (a :: N) (b :: N) = (r :: N) | r -> a b -type instance K (S n) m = S m - --- Make sure we look through type synonyms to catch errors -type MaybeSyn a = Id a -type family L a = r | r -> a -type instance L a = MaybeSyn a - --- These should fail because given the RHS kind there is no way to determine LHS --- kind -class PolyKindVarsC a where - type PolyKindVarsF a = (r :: k) | r -> a - -instance PolyKindVarsC '[] where - type PolyKindVarsF '[] = '[] - -type family PolyKindVars (a :: k0) = (r :: k1) | r -> a -type instance PolyKindVars '[] = '[] - --- This should fail because there is no way to determine k from the RHS -type family Fc (a :: k) (b :: k) = r | r -> k -type instance Fc a b = Int - --- This should fail because there is no way to determine a, b and k from the RHS -type family Gc (a :: k) (b :: k) = r | r -> a b -type instance Gc a b = Int - --- fails because injectivity is not compositional in this case -type family F1 a = r | r -> a -type instance F1 [a] = Maybe (GF1 a) -type instance F1 (Maybe a) = Maybe (GF2 a) - -type family GF1 a = r | r -> a -type instance GF1 Int = Bool - -type family GF2 a = r | r -> a -type instance GF2 Int = Bool - -type family HF1 a -type instance HF1 Bool = Bool - -type family W1 a = r | r -> a -type instance W1 [a] = a - -type family W2 a = r | r -> a -type instance W2 [a] = W2 a - --- not injective because of infinite types -type family Z1 a = r | r -> a -type instance Z1 [a] = (a, a) -type instance Z1 (Maybe b) = (b, [b]) - -type family G1 a = r | r -> a -type instance G1 [a] = [a] -type instance G1 (Maybe b) = [(b, b)] - -type family G3 a b = r | r -> b -type instance G3 a Int = (a, Int) -type instance G3 a Bool = (Bool, a) - -type family G4 a b = r | r -> a b -type instance G4 a b = [a] - -type family G5 a = r | r -> a -type instance G5 [a] = [GF1 a] -- GF1 injective -type instance G5 Int = [Bool] - -type family G6 a = r | r -> a -type instance G6 [a] = [HF1 a] -- HF1 not injective -type instance G6 Bool = Int - -type family G7a a b (c :: k) = r | r -> a b -type family G7 a b (c :: k) = r | r -> a b c -type instance G7 a b c = [G7a a b c] - -class C a b where - type FC a (b :: *) = r | r -> b - type instance FC a b = b - -instance C Int Char where - type FC Int Char = Bool - --- this should fail because the default instance conflicts with one of the --- earlier instances -instance C Int Bool {- where - type FC Int Bool = Bool-} - --- and this should fail because it violates "bare variable in the RHS" --- restriction -instance C Char a diff --git a/tests/examples/ghc8/T6018failclosed.hs b/tests/examples/ghc8/T6018failclosed.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6018failclosed.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds, UndecidableInstances #-} - -module T6018failclosed where - --- Id is injective... -type family IdClosed a = result | result -> a where - IdClosed a = a - --- ...but despite that we disallow a call to Id -type family IdProxyClosed (a :: *) = r | r -> a where - IdProxyClosed a = IdClosed a - -data N = Z | S N - --- PClosed is not injective, although the user declares otherwise. This --- should be rejected on the grounds of calling a type family in the --- RHS. -type family PClosed (a :: N) (b :: N) = (r :: N) | r -> a b where - PClosed Z m = m - PClosed (S n) m = S (PClosed n m) - --- this is not injective - not all injective type variables mentioned --- on LHS are mentioned on RHS -type family JClosed a b c = r | r -> a b where - JClosed Int b c = Char - --- this is not injective - not all injective type variables mentioned --- on LHS are mentioned on RHS (tyvar is now nested inside a tycon) -type family KClosed (a :: N) (b :: N) = (r :: N) | r -> a b where - KClosed (S n) m = S m - --- hiding a type family application behind a type synonym should be rejected -type MaybeSynClosed a = IdClosed a -type family LClosed a = r | r -> a where - LClosed a = MaybeSynClosed a - -type family FClosed a b c = (result :: *) | result -> a b c where - FClosed Int Char Bool = Bool - FClosed Char Bool Int = Int - FClosed Bool Int Char = Int - -type family IClosed a b c = r | r -> a b where - IClosed Int Char Bool = Bool - IClosed Int Int Int = Bool - IClosed Bool Int Int = Int - -type family E2 (a :: Bool) = r | r -> a where - E2 False = True - E2 True = False - E2 a = False - --- This exposed a subtle bug in the implementation during development. After --- unifying the RHS of (1) and (2) the LHS substitution was done only in (2) --- which made it look like an overlapped equation. This is not the case and this --- definition should be rejected. The first two equations are here to make sure --- that the internal implementation does list indexing corrcectly (this is a bit --- tricky because the list is kept in reverse order). -type family F a b = r | r -> a b where - F Float IO = Float - F Bool IO = Bool - F a IO = IO a -- (1) - F Char b = b Int -- (2) - --- This should fail because there is no way to determine a, b and k from the RHS -type family Gc (a :: k) (b :: k) = r | r -> k where - Gc a b = Int diff --git a/tests/examples/ghc8/T6018failclosed2.hs b/tests/examples/ghc8/T6018failclosed2.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6018failclosed2.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018failclosed2 where - --- this one is a strange beast. Last equation is unreachable and thus it is --- removed. It is then impossible to typecheck barapp and thus we generate an --- error -type family Bar a = r | r -> a where - Bar Int = Bool - Bar Bool = Int - Bar Bool = Char - -bar :: Bar a -> Bar a -bar x = x - -barapp :: Char -barapp = bar 'c' diff --git a/tests/examples/ghc8/T6018rnfail.hs b/tests/examples/ghc8/T6018rnfail.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6018rnfail.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE TypeFamilies, PolyKinds #-} - -module T6018rnfail where - --- IA = injectivity annotation `| foo -> bar` - --- use incorrect tyvar in LHS of IA -type family F a = r | a -> a -type family Fc a = r | a -> a where - Fc a = a -class Fcl a where - type Ft a = r | a -> a - --- declare result tyvar to be duplicate (without IA) -type family G a = a -type family Gc a = a where - Gc a = a - --- declare result tyvar to be duplicate (with IA) -type family Gb a = a | a -> a -type family Gcb a = a | a -> a where - Gcb a = a -class Gclb a where -- here we want two errors - type Gtb a = a | a -> a - --- not in-scope tyvar in RHS of IA -type family I a b = r | r -> c -type family Ic a b = r | r -> c where - Ic a b = a -class Icl a b where - type It a b = r | r -> c - --- not in-scope tyvar in LHS of IA -type family L a b = r | c -> a -type family Lc a b = r | c -> a where - Lc a b = a -class Lcl a b where - type Lt a b = r | c -> a - --- result variable shadows variable in class head -class M a b where - type Mt b = a | a -> b - --- here b is out-of-scope -class N a b where - type Nt a = r | r -> a b - --- result is out of scope. Not possible for associated types -type family O1 a | r -> a -type family Oc1 a | r -> a where - Oc1 a = a -type family O2 a :: * | r -> a -type family Oc2 a :: * | r -> a where - Oc2 a = a diff --git a/tests/examples/ghc8/T6018th.hs b/tests/examples/ghc8/T6018th.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6018th.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds #-} - -module T6018th where - -import Language.Haskell.TH - --- Test that injectivity works correct with TH. This test is not as exhaustive --- as the original T6018 test. - --- type family F a b c = (result :: k) | result -> a b c --- type instance F Int Char Bool = Bool --- type instance F Char Bool Int = Int --- type instance F Bool Int Char = Char -$( return - [ OpenTypeFamilyD - (mkName "F") - [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] - (TyVarSig (KindedTV (mkName "result") (VarT (mkName "k")))) - (Just $ InjectivityAnn (mkName "result") - [(mkName "a"), (mkName "b"), (mkName "c") ]) - , TySynInstD - (mkName "F") - (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Bool")] - ( ConT (mkName "Bool"))) - , TySynInstD - (mkName "F") - (TySynEqn [ ConT (mkName "Char"), ConT (mkName "Bool") - , ConT (mkName "Int")] - ( ConT (mkName "Int"))) - , TySynInstD - (mkName "F") - (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") - , ConT (mkName "Char")] - ( ConT (mkName "Char"))) - ] ) - --- this is injective - a type variables mentioned on LHS is not mentioned on RHS --- but we don't claim injectivity in that argument. --- --- type family J a (b :: k) = r | r -> a ----type instance J Int b = Char -$( return - [ OpenTypeFamilyD - (mkName "J") - [ PlainTV (mkName "a"), KindedTV (mkName "b") (VarT (mkName "k")) ] - (TyVarSig (PlainTV (mkName "r"))) - (Just $ InjectivityAnn (mkName "r") [mkName "a"]) - , TySynInstD - (mkName "J") - (TySynEqn [ ConT (mkName "Int"), VarT (mkName "b") ] - ( ConT (mkName "Int"))) - ] ) - --- Closed type families - --- type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where --- IClosed Int Char Bool = Bool --- IClosed Int Char Int = Bool --- IClosed Bool Int Int = Int - -$( return - [ ClosedTypeFamilyD - (mkName "I") - [ KindedTV (mkName "a") StarT, KindedTV (mkName "b") StarT - , KindedTV (mkName "c") StarT ] - (TyVarSig (PlainTV (mkName "r"))) - (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")]) - [ TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Bool")] - ( ConT (mkName "Bool")) - , TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Int")] - ( ConT (mkName "Bool")) - , TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") - , ConT (mkName "Int")] - ( ConT (mkName "Int")) - ] - ] ) - --- reification test -$( do { decl@([ClosedTypeFamilyD _ _ _ (Just inj) _]) <- - [d| type family Bak a = r | r -> a where - Bak Int = Char - Bak Char = Int - Bak a = a |] - ; return decl - } - ) - --- Check whether incorrect injectivity declarations are caught - --- type family I a b c = r | r -> a b --- type instance I Int Char Bool = Bool --- type instance I Int Int Int = Bool --- type instance I Bool Int Int = Int -$( return - [ OpenTypeFamilyD - (mkName "H") - [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] - (TyVarSig (PlainTV (mkName "r"))) - (Just $ InjectivityAnn (mkName "r") - [(mkName "a"), (mkName "b") ]) - , TySynInstD - (mkName "H") - (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Bool")] - ( ConT (mkName "Bool"))) - , TySynInstD - (mkName "H") - (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Int") - , ConT (mkName "Int")] - ( ConT (mkName "Bool"))) - , TySynInstD - (mkName "H") - (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") - , ConT (mkName "Int")] - ( ConT (mkName "Int"))) - ] ) diff --git a/tests/examples/ghc8/T6062.hs b/tests/examples/ghc8/T6062.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6062.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module T6062 where -x = [| False True |] diff --git a/tests/examples/ghc8/T6124.hs b/tests/examples/ghc8/T6124.hs deleted file mode 100644 --- a/tests/examples/ghc8/T6124.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - -module T6124 where - -newtype A = MkA Int -newtype B = MkB Char - -data T a where - A :: T A - B :: T B - -f :: T A -> A -f A = undefined diff --git a/tests/examples/ghc8/T7411.hs b/tests/examples/ghc8/T7411.hs deleted file mode 100644 --- a/tests/examples/ghc8/T7411.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Control.Exception -import Control.DeepSeq -main = evaluate (('a' : undefined) `deepseq` return () :: IO ()) diff --git a/tests/examples/ghc8/T7669a.hs b/tests/examples/ghc8/T7669a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T7669a.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE EmptyCase #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - -module T7669 where - -data Void - -foo :: Void -> () -foo x = case x of {} diff --git a/tests/examples/ghc8/T7672.hs b/tests/examples/ghc8/T7672.hs deleted file mode 100644 --- a/tests/examples/ghc8/T7672.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T7672 where -import qualified T7672a as XX -data T = S XX.T diff --git a/tests/examples/ghc8/T7672a.hs b/tests/examples/ghc8/T7672a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T7672a.hs +++ /dev/null @@ -1,2 +0,0 @@ -module T7672a(Decl.T) where -import {-# SOURCE #-} qualified T7672 as Decl diff --git a/tests/examples/ghc8/T7765.hs b/tests/examples/ghc8/T7765.hs deleted file mode 100644 --- a/tests/examples/ghc8/T7765.hs +++ /dev/null @@ -1,1 +0,0 @@ -module Main where diff --git a/tests/examples/ghc8/T7788.hs b/tests/examples/ghc8/T7788.hs deleted file mode 100644 --- a/tests/examples/ghc8/T7788.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module T7788 where - -data Proxy a = Proxy - -foo :: Proxy (F (Fix Id)) -> () -foo = undefined - -newtype Fix a = Fix (a (Fix a)) -newtype Id a = Id a - -type family F a -type instance F (Fix a) = F (a (Fix a)) -type instance F (Id a) = F a - -main :: IO () -main = print $ foo Proxy diff --git a/tests/examples/ghc8/T8030.hs b/tests/examples/ghc8/T8030.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8030.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PolyKinds, FlexibleContexts, TypeFamilies #-} -module T8030 where - --- The types of op1 and op2 are both ambiguous --- and should be reported as such - -class C (a :: k) where - type Pr a :: * - op1 :: Pr a - op2 :: Pr a -> Pr a -> Pr a - diff --git a/tests/examples/ghc8/T8034.hs b/tests/examples/ghc8/T8034.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8034.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T8034 where - -class C a where - type F a - foo :: F a -> F a diff --git a/tests/examples/ghc8/T8101b.hs b/tests/examples/ghc8/T8101b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8101b.hs +++ /dev/null @@ -1,8 +0,0 @@ - -module A where - -data ABC = A | B | C - -abc :: ABC -> Int -abc x = case x of - A -> 1 diff --git a/tests/examples/ghc8/T8131b.hs b/tests/examples/ghc8/T8131b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8131b.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples #-} -import GHC.Prim -import GHC.IO - -main = IO $ \s -> - let (# s1, p0 #) = newByteArray# 10# s - (# s2, p #) = unsafeFreezeByteArray# p0 s1 - (# s3, q #) = newByteArray# 10# s2 - in (# copyByteArray# p 0# q 0# 10# s, () #) diff --git a/tests/examples/ghc8/T8274.hs b/tests/examples/ghc8/T8274.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8274.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module T8274 where - -import GHC.Prim - -data P = Positives Int# Float# Double# Char# Word# -data N = Negatives Int# Float# Double# - -p = Positives 42# 4.23# 4.23## '4'# 4## -n = Negatives -4# -4.0# -4.0## diff --git a/tests/examples/ghc8/T8455.hs b/tests/examples/ghc8/T8455.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8455.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE DataKinds #-} - -module T8455 where - -ty = [t| 5 |] diff --git a/tests/examples/ghc8/T8550.hs b/tests/examples/ghc8/T8550.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8550.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE TypeFamilies, GADTs, UndecidableInstances #-} - -module T8550 where - -type family F a -type instance F () = F () -data A where - A :: F () ~ () => A -x :: A -x = A - -main :: IO () -main = seq A (return ()) - --- Note: This worked in GHC 7.8, but I (Richard E) think this regression --- is acceptable. diff --git a/tests/examples/ghc8/T8555.hs b/tests/examples/ghc8/T8555.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8555.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module T8555 where -import Data.Coerce - -foo :: Coercible [a] [b] => a -> b -foo = coerce diff --git a/tests/examples/ghc8/T8633.hs b/tests/examples/ghc8/T8633.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8633.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Main where -import Language.Haskell.TH.Syntax - -t1 = case mkName "^.." of - Name (OccName ".") (NameQ (ModName "^")) -> error "bug0" - Name (OccName "^..") NameS -> return () - -t2 = case mkName "Control.Lens.^.." of - Name (OccName ".") (NameQ (ModName "Control.Lens.^")) -> error "bug1" - Name (OccName "^..") (NameQ (ModName "Control.Lens")) -> return () - -t3 = case mkName "Data.Bits..&." of - Name (OccName ".&.") (NameQ (ModName "Data.Bits")) -> return () - -t4 = case mkName "abcde" of - Name (OccName "abcde") NameS -> return () - -main :: IO () -main = do t1; t2; t3; t4 diff --git a/tests/examples/ghc8/T8743a.hs b/tests/examples/ghc8/T8743a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8743a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T8743a where - -import {-# SOURCE #-} T8743 () diff --git a/tests/examples/ghc8/T8759a.hs b/tests/examples/ghc8/T8759a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8759a.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE PatternSynonyms #-} - -module T8759a where - -foo = [d| pattern Q = False |] diff --git a/tests/examples/ghc8/T8799.hs b/tests/examples/ghc8/T8799.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8799.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module T8555 where -import Data.Coerce - -foo :: Coercible a b => b -> a -foo = coerce - -bar :: (Coercible a b, Coercible b c) => b -> c -> a -bar b c = coerce c diff --git a/tests/examples/ghc8/T8970.hs b/tests/examples/ghc8/T8970.hs deleted file mode 100644 --- a/tests/examples/ghc8/T8970.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T8970 where - -data K = Foo - | Bar - -data D1 :: K -> * where - F1 :: D1 Foo - B1 :: D1 Bar - -class C (a :: K -> *) where - data D2 a :: K -> * - foo :: a k -> D2 a k -> Bool - -instance C D1 where - data D2 D1 k where - F2 :: D2 D1 Foo - B2 :: D2 D1 Bar - foo F1 F2 = True - foo B1 B2 = True diff --git a/tests/examples/ghc8/T9015.hs b/tests/examples/ghc8/T9015.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9015.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Main where - -import GHC -import DynFlags -import System.Environment -import GhcMonad - -testStrings = [ - "import Data.Maybe" - , "import qualified Data.Maybe" - , "import Data.Maybe (isJust)" - - , "add a b = a+b" - , "data Foo = Foo String" - , "deriving instance Show Foo" - , "{-# NOVECTORISE foo #-}" - , "{-# WARNING Foo \"Just a warning\" #-}" - , "{-# ANN foo (Just \"Hello\") #-}" - , "{-# RULES \"map/map\" forall f g xs. map f (map g xs) = map (f.g) xs #-}" - , "class HasString a where\n\ - \ update :: a -> (String -> String) -> a\n\ - \ upcase :: a -> a\n\ - \ upcase x = update x (fmap toUpper)\n\ - \ content :: a -> String\n\ - \ default content :: Show a => a -> String\n\ - \ content = show" - , "instance HasString Foo where\n\ - \ update (Foo s) f = Foo (f s)\n\ - \ content (Foo s) = s" - - , "add a b" - , "let foo = add a b" - , "x <- foo y" - , "5 + 8" - - , "a <-" - , "2 +" - , "@#" - ] - -main = do - [libdir] <- getArgs - runGhc (Just libdir) $ do - liftIO (putStrLn "Is import:") - testWithParser isImport - - liftIO (putStrLn "Is declaration:") - testWithParser isDecl - - liftIO (putStrLn "Is statement:") - testWithParser isStmt - - where - testWithParser parser = do - dflags <- getSessionDynFlags - liftIO . putStrLn . unlines $ map (testExpr (parser dflags)) testStrings - - testExpr parser expr = do - expr ++ ": " ++ show (parser expr) diff --git a/tests/examples/ghc8/T9017.hs b/tests/examples/ghc8/T9017.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9017.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PolyKinds #-} - -module T9017 where - -import Control.Arrow - -foo :: a b (m b) -foo = arr return diff --git a/tests/examples/ghc8/T9177a.hs b/tests/examples/ghc8/T9177a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9177a.hs +++ /dev/null @@ -1,6 +0,0 @@ -module T9177a where - -foo3 = bar -foo4 = Fun - - diff --git a/tests/examples/ghc8/T9204a.hs b/tests/examples/ghc8/T9204a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9204a.hs +++ /dev/null @@ -1,2 +0,0 @@ -module T9204a where -import {-# SOURCE #-} T9204 diff --git a/tests/examples/ghc8/T9204b.hs b/tests/examples/ghc8/T9204b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9204b.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T9204b where - -import T9204b2 - -data P a = P diff --git a/tests/examples/ghc8/T9204b2.hs b/tests/examples/ghc8/T9204b2.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9204b2.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T9204b2 where - -import {-# SOURCE #-} T9204b diff --git a/tests/examples/ghc8/T9233.hs b/tests/examples/ghc8/T9233.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9233.hs +++ /dev/null @@ -1,12 +0,0 @@ -module T9233 where - -import T9233a -import Data.Functor.Identity - -upds :: (Monad m) => [String -> Options -> m Options] -upds = [ - \a o -> return o { flags = (flags o) { f1 = splitComma a ++ " " ++ f1 (flags o) } } - ] - -setAll :: Options -> Options -setAll _ = (getOpt upds :: Identity ()) `seq` undefined diff --git a/tests/examples/ghc8/T9233a.hs b/tests/examples/ghc8/T9233a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9233a.hs +++ /dev/null @@ -1,128 +0,0 @@ -module T9233a where - - -data X = X { - f1 :: String, - f2 :: !Bool, - f3 :: !Bool, - f4 :: !Bool, - f5 :: !Bool, - f6 :: !Bool, - f7 :: !Bool, - f8 :: !Bool, - f9 :: !Bool, - f10 :: !Bool, - f11 :: !Bool, - f12 :: !Bool, - f13 :: !Bool, - f14 :: !Bool, - f15 :: !Bool, - f16 :: !Bool, - f17 :: !Bool, - f18 :: !Bool, - f19 :: !Bool, - f20 :: !Bool, - f21 :: !Bool, - f22 :: !Bool, - f23 :: !Bool, - f24 :: !Bool, - f25 :: !Bool, - f26 :: !Bool, - f27 :: !Bool, - f28 :: !Bool, - f29 :: !Bool, - f30 :: !Bool, - f31 :: !Bool, - f32 :: !Bool, - f33 :: !Bool, - f34 :: !Bool, - f35 :: !Bool, - f36 :: !Bool, - f37 :: !Bool, - f38 :: !Bool, - f39 :: !Bool, - f40 :: !Bool, - f41 :: !Bool, - f42 :: !Bool, - f43 :: !Bool, - f44 :: !Bool, - f45 :: !Bool, - f46 :: !Bool, - f47 :: !Bool, - f48 :: !Bool, - f49 :: !Bool, - f50 :: !Bool, - f51 :: !Bool, - f52 :: !Bool, - f53 :: !Bool, - f54 :: !Bool, - f55 :: !Bool, - f56 :: !Bool, - f57 :: !Bool, - f58 :: !Bool, - f59 :: !Bool, - f60 :: !Bool, - f61 :: !Bool, - f62 :: !Bool, - f63 :: !Bool, - f64 :: !Bool, - f65 :: !Bool, - f66 :: !Bool, - f67 :: !Bool, - f68 :: !Bool, - f69 :: !Bool, - f70 :: !Bool, - f71 :: !Bool, - f72 :: !Bool, - f73 :: !Bool, - f74 :: !Bool, - f75 :: !Bool, - f76 :: !Bool, - f77 :: !Bool, - f78 :: !Bool, - f79 :: !Bool, - f80 :: !Bool, - f81 :: !Bool, - f82 :: !Bool, - f83 :: !Bool, - f84 :: !Bool, - f85 :: !Bool, - f86 :: !Bool, - f87 :: !Bool, - f88 :: !Bool, - f89 :: !Bool, - f90 :: !Bool, - f91 :: !Bool, - f92 :: !Bool, - f93 :: !Bool, - f94 :: !Bool, - f95 :: !Bool, - f96 :: !Bool, - f97 :: !Bool, - f98 :: !Bool, - f99 :: !Bool, - f100 :: !Bool - } - -data Options = Options { - flags :: !X, - o2 :: !Bool, - o3 :: !Bool, - o4 :: !Bool, - o5 :: !Bool, - o6 :: !Bool, - o7 :: !Bool, - o8 :: !Bool, - o9 :: !Bool, - o10 :: !Bool, - o11 :: !Bool, - o12 :: !Bool - } - -splitComma :: String -> String -splitComma _ = "a" -{-# NOINLINE splitComma #-} - -getOpt :: Monad m => [String -> Options -> m Options] -> m () -getOpt _ = return () -{-# NOINLINE getOpt #-} diff --git a/tests/examples/ghc8/T9238.hs b/tests/examples/ghc8/T9238.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9238.hs +++ /dev/null @@ -1,16 +0,0 @@ -compareDouble :: Double -> Double -> Ordering -compareDouble x y = - case (isNaN x, isNaN y) of - (True, True) -> EQ - (True, False) -> LT - (False, True) -> GT - (False, False) -> - -- Make -0 less than 0 - case (x == 0, y == 0, isNegativeZero x, isNegativeZero y) of - (True, True, True, False) -> LT - (True, True, False, True) -> GT - _ -> x `compare` y - -main = do - let l = [-0, 0] - print [ (x, y, compareDouble x y) | x <- l, y <- l ] diff --git a/tests/examples/ghc8/T9260.hs b/tests/examples/ghc8/T9260.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9260.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DataKinds, TypeOperators, GADTs #-} - -module T9260 where - -import GHC.TypeLits - -data Fin n where - Fzero :: Fin (n + 1) - Fsucc :: Fin n -> Fin (n + 1) - -test :: Fin 1 -test = Fsucc Fzero - -{- Only the second error is legitimate. - -% ghc --version -The Glorious Glasgow Haskell Compilation System, version 7.8.2 -% ghc -ignore-dot-ghci /tmp/Error.hs -[1 of 1] Compiling Error ( /tmp/Error.hs, /tmp/Error.o ) - -/tmp/Error.hs:12:8: - Couldn't match type ‘0’ with ‘1’ - Expected type: Fin 1 - Actual type: Fin (0 + 1) - In the expression: Fsucc Fzero - In an equation for ‘test’: test = Fsucc Fzero - -/tmp/Error.hs:12:14: - Couldn't match type ‘1’ with ‘0’ - Expected type: Fin 0 - Actual type: Fin (0 + 1) - In the first argument of ‘Fsucc’, namely ‘Fzero’ - In the expression: Fsucc Fzero --} diff --git a/tests/examples/ghc8/T9430.hs b/tests/examples/ghc8/T9430.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9430.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} - -module Main where - -import GHC.Exts - -checkI - :: (Int, Int) -- ^ expected results - -> (Int# -> Int# -> (# Int#, Int# #)) -- ^ primop - -> Int -- ^ first argument - -> Int -- ^ second argument - -> Maybe String -- ^ maybe error -checkI (expX, expY) op (I# a) (I# b) = - case op a b of - (# x, y #) - | I# x == expX && I# y == expY -> Nothing - | otherwise -> - Just $ - "Expected " ++ show expX ++ " and " ++ show expY - ++ " but got " ++ show (I# x) ++ " and " ++ show (I# y) -checkW - :: (Word, Word) -- ^ expected results - -> (Word# -> Word# -> (# Word#, Word# #)) -- ^ primop - -> Word -- ^ first argument - -> Word -- ^ second argument - -> Maybe String -- ^ maybe error -checkW (expX, expY) op (W# a) (W# b) = - case op a b of - (# x, y #) - | W# x == expX && W# y == expY -> Nothing - | otherwise -> - Just $ - "Expected " ++ show expX ++ " and " ++ show expY - ++ " but got " ++ show (W# x) ++ " and " ++ show (W# y) - -checkW2 - :: (Word, Word) -- ^ expected results - -> (Word# -> Word# -> Word# -> (# Word#, Word# #)) - -- ^ primop - -> Word -- ^ first argument - -> Word -- ^ second argument - -> Word -- ^ third argument - -> Maybe String -- ^ maybe error -checkW2 (expX, expY) op (W# a) (W# b) (W# c) = - case op a b c of - (# x, y #) - | W# x == expX && W# y == expY -> Nothing - | otherwise -> - Just $ - "Expected " ++ show expX ++ " and " ++ show expY - ++ " but got " ++ show (W# x) ++ " and " ++ show (W# y) - -check :: String -> Maybe String -> IO () -check s (Just err) = error $ "Error for " ++ s ++ ": " ++ err -check _ Nothing = return () - -main :: IO () -main = do - -- First something trivial - check "addIntC# maxBound 0" $ checkI (maxBound, 0) addIntC# maxBound 0 - check "addIntC# 0 maxBound" $ checkI (maxBound, 0) addIntC# 0 maxBound - -- Overflows - check "addIntC# maxBound 1" $ checkI (minBound, 1) addIntC# maxBound 1 - check "addIntC# 1 maxBound" $ checkI (minBound, 1) addIntC# 1 maxBound - check "addIntC# maxBound 2" $ checkI (minBound + 1, 1) addIntC# maxBound 2 - check "addIntC# 2 maxBound" $ checkI (minBound + 1, 1) addIntC# 2 maxBound - check "addIntC# minBound minBound" $ - checkI (0, 1) addIntC# minBound minBound - - -- First something trivial - check "subIntC# minBound 0" $ checkI (minBound, 0) subIntC# minBound 0 - -- Overflows - check "subIntC# minBound 1" $ checkI (maxBound, 1) subIntC# minBound 1 - check "subIntC# minBound 1" $ checkI (maxBound - 1, 1) subIntC# minBound 2 - check "subIntC# 0 minBound" $ checkI (minBound, 1) subIntC# 0 minBound - check "subIntC# -1 minBound" $ checkI (maxBound, 0) subIntC# (-1) minBound - check "subIntC# minBound -1" $ - checkI (minBound + 1, 0) subIntC# minBound (-1) - - -- First something trivial (note that the order of results is different!) - check "plusWord2# maxBound 0" $ checkW (0, maxBound) plusWord2# maxBound 0 - check "plusWord2# 0 maxBound" $ checkW (0, maxBound) plusWord2# 0 maxBound - -- Overflows - check "plusWord2# maxBound 1" $ - checkW (1, minBound) plusWord2# maxBound 1 - check "plusWord2# 1 maxBound" $ - checkW (1, minBound) plusWord2# 1 maxBound - check "plusWord2# maxBound 2" $ - checkW (1, minBound + 1) plusWord2# maxBound 2 - check "plusWord2# 2 maxBound" $ - checkW (1, minBound + 1) plusWord2# 2 maxBound - - check "timesWord2# maxBound 0" $ checkW (0, 0) timesWord2# maxBound 0 - check "timesWord2# 0 maxBound" $ checkW (0, 0) timesWord2# 0 maxBound - check "timesWord2# maxBound 1" $ checkW (0, maxBound) timesWord2# maxBound 1 - check "timesWord2# 1 maxBound" $ checkW (0, maxBound) timesWord2# 1 maxBound - -- Overflows - check "timesWord2# " $ checkW (1, 0) timesWord2# (2 ^ 63) 2 - check "timesWord2# " $ checkW (2, 0) timesWord2# (2 ^ 63) (2 ^ 2) - check "timesWord2# " $ checkW (4, 0) timesWord2# (2 ^ 63) (2 ^ 3) - check "timesWord2# " $ checkW (8, 0) timesWord2# (2 ^ 63) (2 ^ 4) - check "timesWord2# maxBound 2" $ - checkW (1, maxBound - 1) timesWord2# maxBound 2 - check "timesWord2# 2 maxBound" $ - checkW (1, maxBound - 1) timesWord2# 2 maxBound - check "timesWord2# maxBound 3" $ - checkW (2, maxBound - 2) timesWord2# maxBound 3 - check "timesWord2# 3 maxBound" $ - checkW (2, maxBound - 2) timesWord2# 3 maxBound - - check "quotRemWord2# 0 0 1" $ checkW2 (0, 0) quotRemWord2# 0 0 1 - check "quotRemWord2# 0 4 2" $ checkW2 (2, 0) quotRemWord2# 0 4 2 - check "quotRemWord2# 0 7 3" $ checkW2 (2, 1) quotRemWord2# 0 7 3 - check "quotRemWord2# 1 0 (2 ^ 63)" $ - checkW2 (2, 0) quotRemWord2# 1 0 (2 ^ 63) - check "quotRemWord2# 1 1 (2 ^ 63)" $ - checkW2 (2, 1) quotRemWord2# 1 1 (2 ^ 63) - check "quotRemWord2# 1 0 maxBound" $ - checkW2 (1, 1) quotRemWord2# 1 0 maxBound - check "quotRemWord2# 2 0 maxBound" $ - checkW2 (2, 2) quotRemWord2# 2 0 maxBound - check "quotRemWord2# 1 maxBound maxBound" $ - checkW2 (2, 1) quotRemWord2# 1 maxBound maxBound - check "quotRemWord2# (2 ^ 63) 0 maxBound" $ - checkW2 (2 ^ 63, 2 ^ 63) quotRemWord2# (2 ^ 63) 0 maxBound - check "quotRemWord2# (2 ^ 63) maxBound maxBound" $ - checkW2 (2 ^ 63 + 1, 2 ^ 63) quotRemWord2# (2 ^ 63) maxBound maxBound diff --git a/tests/examples/ghc8/T9554.hs b/tests/examples/ghc8/T9554.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9554.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeFamilies, UndecidableInstances #-} - -module T9554 where - -import Data.Proxy - -type family F a where - F a = F (F a) - -foo :: Proxy (F Bool) -> Proxy (F Int) -foo x = x - -main = case foo Proxy of Proxy -> putStrLn "Made it!" diff --git a/tests/examples/ghc8/T9600-1.hs b/tests/examples/ghc8/T9600-1.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9600-1.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -import Control.Applicative - -newtype Foo a = Foo (a -> a) deriving Applicative diff --git a/tests/examples/ghc8/T9600.hs b/tests/examples/ghc8/T9600.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9600.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Control.Applicative - -newtype Foo a = Foo (a -> a) deriving Applicative diff --git a/tests/examples/ghc8/T9632.hs b/tests/examples/ghc8/T9632.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9632.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module T9632 where - -import Data.Kind - -data B = T | F -data P :: B -> * - -type B' = B -data P' :: B' -> * diff --git a/tests/examples/ghc8/T9824.hs b/tests/examples/ghc8/T9824.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9824.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# OPTIONS_GHC -fwarn-unused-matches #-} - -module T9824 where - -foo = [p| (x, y) |] diff --git a/tests/examples/ghc8/T9839_02.hs b/tests/examples/ghc8/T9839_02.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9839_02.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = return () diff --git a/tests/examples/ghc8/T9839_03.hs b/tests/examples/ghc8/T9839_03.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9839_03.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = return () diff --git a/tests/examples/ghc8/T9839_04.hs b/tests/examples/ghc8/T9839_04.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9839_04.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = return () diff --git a/tests/examples/ghc8/T9839_05.hs b/tests/examples/ghc8/T9839_05.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9839_05.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = return () diff --git a/tests/examples/ghc8/T9839_06.hs b/tests/examples/ghc8/T9839_06.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9839_06.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = return () diff --git a/tests/examples/ghc8/T9840.hs b/tests/examples/ghc8/T9840.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9840.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T9840 where - -import T9840a - -type family X :: * -> * where - -type family F (a :: * -> *) where - -foo :: G (F X) -> G (F X) -foo x = x diff --git a/tests/examples/ghc8/T9840a.hs b/tests/examples/ghc8/T9840a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9840a.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T9840a where - -import {-# SOURCE #-} T9840 - -type family G a where - -bar :: X a -> X a -bar = id diff --git a/tests/examples/ghc8/T9858a.hs b/tests/examples/ghc8/T9858a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9858a.hs +++ /dev/null @@ -1,35 +0,0 @@ --- From comment:76 in Trac #9858 --- This exploit still works in GHC 7.10.1. --- By Shachaf Ben-Kiki, Ørjan Johansen and Nathan van Doorn - -{-# LANGUAGE Safe #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ImpredicativeTypes #-} - -module T9858a where - -import Data.Typeable - -type E = (:~:) -type PX = Proxy (((),()) => ()) -type PY = Proxy (() -> () -> ()) - -data family F p a b - -newtype instance F a b PX = ID (a -> a) -newtype instance F a b PY = UC (a -> b) - -{-# NOINLINE ecast #-} -ecast :: E p q -> f p -> f q -ecast Refl = id - -supercast :: F a b PX -> F a b PY -supercast = case cast e of - Just e' -> ecast e' - where - e = Refl - e :: E PX PX - -uc :: a -> b -uc = case supercast (ID id) of UC f -> f diff --git a/tests/examples/ghc8/T9858b.hs b/tests/examples/ghc8/T9858b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9858b.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE FlexibleContexts #-} - -module T9858b where -import Data.Typeable - -test = typeRep (Proxy :: Proxy (Eq Int => Int)) - - - diff --git a/tests/examples/ghc8/T9858c.hs b/tests/examples/ghc8/T9858c.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9858c.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -module Main(main) where - -import Data.Typeable -import GHC.Exts - -test1 :: Bool -test1 = typeRep (Proxy :: Proxy (() :: *)) == - typeRep (Proxy :: Proxy (() :: Constraint)) - -test2 :: Bool -test2 = typeRepTyCon (typeRep (Proxy :: Proxy (Int,Int))) == - typeRepTyCon (typeRep (Proxy :: Proxy (Eq Int, Eq Int))) - -main :: IO () -main = print (test1,test2) - - - diff --git a/tests/examples/ghc8/T9858d.hs b/tests/examples/ghc8/T9858d.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9858d.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module Main where - -import Data.Typeable - -data A = A - -main = print $ typeRep (Proxy :: Proxy A) == typeRep (Proxy :: Proxy 'A) diff --git a/tests/examples/ghc8/T9858e.hs b/tests/examples/ghc8/T9858e.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9858e.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE ImpredicativeTypes, FlexibleContexts #-} - -module T9858e where -import Data.Typeable - -i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep -i p = typeRep p - -j = i (Proxy :: Proxy (Eq Int => Int)) diff --git a/tests/examples/ghc8/T9867.hs b/tests/examples/ghc8/T9867.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9867.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-} - -module T9867 where - -pattern Nil = [] :: [a] diff --git a/tests/examples/ghc8/T9878b.hs b/tests/examples/ghc8/T9878b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9878b.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE StaticPointers #-} -module T9878b where - -import GHC.StaticPtr - -f = deRefStaticPtr (static True) diff --git a/tests/examples/ghc8/T9938.hs b/tests/examples/ghc8/T9938.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9938.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -import Control.Monad -import Control.Monad.Trans.State - -solve :: Int -> StateT () [] () -solve carry | carry > 0 = - do guard (0 == carry) - solve (carry -1) -solve 0 = mzero - -main :: IO () -main = return () diff --git a/tests/examples/ghc8/T9938B.hs b/tests/examples/ghc8/T9938B.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9938B.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -import Control.Monad -import Control.Monad.Trans.State - -solve :: Int -> StateT () [] () -solve 0 = mzero -solve carry | carry > 0 = - do guard (0 == carry) - solve (carry -1) - -main :: IO () -main = return () diff --git a/tests/examples/ghc8/T9939.hs b/tests/examples/ghc8/T9939.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9939.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE GADTs #-} - -module T9939 where - -f1 :: (Eq a, Ord a) => a -> a -> Bool --- Eq a redundant -f1 x y = (x == y) && (x > y) - -f2 :: (Eq a, Ord a) => a -> a -> Bool --- Ord a redundant, but Eq a is reported -f2 x y = (x == y) - -f3 :: (Eq a, a ~ b, Eq b) => a -> b -> Bool --- Eq b redundant -f3 x y = x==y - -data Equal a b where - EQUAL :: Equal a a - -f4 :: (Eq a, Eq b) => a -> b -> Equal a b -> Bool --- Eq b redundant -f4 x y EQUAL = y==y - diff --git a/tests/examples/ghc8/T9951.hs b/tests/examples/ghc8/T9951.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9951.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T9951 where - -f :: [a] -> () -f x = case x of - [] -> () - (_:_) -> () - diff --git a/tests/examples/ghc8/T9951b.hs b/tests/examples/ghc8/T9951b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9951b.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T9951b where - -f :: String -> Bool -f "ab" = True diff --git a/tests/examples/ghc8/T9964.hs b/tests/examples/ghc8/T9964.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9964.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE UnboxedTuples #-} -module T9964 where - -import GHC.Base - -crash :: IO () -crash = IO (\s -> - let - {-# NOINLINE s' #-} - s' = s - in (# s', () #)) diff --git a/tests/examples/ghc8/T9968.hs b/tests/examples/ghc8/T9968.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9968.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-} - -module T9968 where - -class C a b -data X = X deriving (C Int) - diff --git a/tests/examples/ghc8/T9968a.hs b/tests/examples/ghc8/T9968a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9968a.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} - -module T9968 where - -import Data.Bifunctor - -data Blah a b = A a | B b - deriving (Bifunctor) diff --git a/tests/examples/ghc8/T9973.hs b/tests/examples/ghc8/T9973.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9973.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# OPTIONS_GHC -fwarn-redundant-constraints #-} - -module T9973 where - -duplicateDecl :: (Eq t) => t -> IO () --- Trac #9973 was a bogus "redundant constraint" here -duplicateDecl sigs - = do { newSpan <- return typeSig - - -- **** commenting out the next three lines causes the original warning to disappear - ; let rowOffset = case typeSig of { _ -> 1 } - - ; undefined } - where - typeSig = definingSigsNames sigs - - -definingSigsNames :: (Eq t) => t -> () -definingSigsNames x = undefined - where - _ = x == x -- Suppress the complaint on this - diff --git a/tests/examples/ghc8/T9975a.hs b/tests/examples/ghc8/T9975a.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9975a.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternSynonyms #-} -module T9975a where - -data Test = Test { x :: Int } -pattern Test wat = Test { x = wat } - diff --git a/tests/examples/ghc8/T9975b.hs b/tests/examples/ghc8/T9975b.hs deleted file mode 100644 --- a/tests/examples/ghc8/T9975b.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternSynonyms #-} -module T9975b where - -data Test = Test { x :: Int } -pattern PTest wat = Test { x = wat } - diff --git a/tests/examples/ghc8/TH_abstractFamily.hs b/tests/examples/ghc8/TH_abstractFamily.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_abstractFamily.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module TH_abstractFamily where - -import Language.Haskell.TH - --- Empty closed type families are okay... -ds1 :: Q [Dec] -ds1 = [d| type family F a where |] - --- ...but abstract ones should result in a type error -ds2 :: Q [Dec] -ds2 = [d| type family G a where .. |] diff --git a/tests/examples/ghc8/TH_bracket1.hs b/tests/examples/ghc8/TH_bracket1.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_bracket1.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- Check that declarations in a bracket shadow the top-level --- declarations, rather than clashing with them. - -module TH_bracket1 where - -foo = 1 -bar = [d| foo = 1 |] diff --git a/tests/examples/ghc8/TH_bracket2.hs b/tests/examples/ghc8/TH_bracket2.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_bracket2.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module TH_bracket2 where - -d_show = [d| data A = A - - instance Show A where - show _ = "A" - |] diff --git a/tests/examples/ghc8/TH_bracket3.hs b/tests/examples/ghc8/TH_bracket3.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_bracket3.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskellQuotes #-} - -module TH_bracket3 where - -d_class = [d| class Classy a b where - f :: a -> b - - instance Classy Int Bool where - f x = if x == 0 then True else False - |] diff --git a/tests/examples/ghc8/TH_finalizer.hs b/tests/examples/ghc8/TH_finalizer.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_finalizer.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module ShouldCompile where - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -$( do - addModFinalizer (do b <- getQ; reportWarning (show (b::Maybe Bool))) - return [] ) -$( putQ True >> return [] ) diff --git a/tests/examples/ghc8/TH_localname.hs b/tests/examples/ghc8/TH_localname.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_localname.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module TH_localname where - -x = \y -> [| y |] diff --git a/tests/examples/ghc8/TH_namePackage.hs b/tests/examples/ghc8/TH_namePackage.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_namePackage.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Language.Haskell.TH - -eitherName, fooName, moduleFooName :: Name -eitherName = ''Either -fooName = mkName "foo" -moduleFooName = mkName "Module.foo" - -main :: IO () -main = do - print $ nameBase eitherName - print $ nameBase fooName - print $ nameBase moduleFooName - - print $ nameModule eitherName - print $ nameModule fooName - print $ nameModule moduleFooName - - print $ namePackage eitherName - print $ namePackage fooName - print $ namePackage moduleFooName diff --git a/tests/examples/ghc8/TH_nameSpace.hs b/tests/examples/ghc8/TH_nameSpace.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_nameSpace.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Data.Maybe (Maybe(..)) -import Data.Ord (Ord) -import Language.Haskell.TH (mkName, nameSpace) - -main :: IO () -main = mapM_ (print . nameSpace) - [ 'Prelude.id - , mkName "id" - , 'Data.Maybe.Just - , ''Data.Maybe.Maybe - , ''Data.Ord.Ord - ] diff --git a/tests/examples/ghc8/TH_ppr1.hs b/tests/examples/ghc8/TH_ppr1.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_ppr1.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Main (main) where - -import Language.Haskell.TH - -u1 :: a -u1 = undefined - -u2 :: a -u2 = undefined - -f :: a -f = undefined - -(.+.) :: a -(.+.) = undefined - -main :: IO () -main = do runQ [| f u1 u2 |] >>= p - runQ [| u1 `f` u2 |] >>= p - runQ [| (.+.) u1 u2 |] >>= p - runQ [| u1 .+. u2 |] >>= p - runQ [| (:) u1 u2 |] >>= p - runQ [| u1 : u2 |] >>= p - runQ [| \((:) x xs) -> x |] >>= p - runQ [| \(x : xs) -> x |] >>= p - runQ [d| class Foo a b where - foo :: a -> b |] >>= p - runQ [| \x -> (x, 1 `x` 2) |] >>= p - runQ [| \(+) -> ((+), 1 + 2) |] >>= p - runQ [| (f, 1 `f` 2) |] >>= p - runQ [| ((.+.), 1 .+. 2) |] >>= p - -p :: Ppr a => a -> IO () -p = putStrLn . pprint - diff --git a/tests/examples/ghc8/TH_reifyType1.hs b/tests/examples/ghc8/TH_reifyType1.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_reifyType1.hs +++ /dev/null @@ -1,13 +0,0 @@ --- test reification of monomorphic types - -module TH_reifyType1 -where - -import Language.Haskell.TH - -foo :: Int -> Int -foo x = x + 1 - -type_foo :: InfoQ -type_foo = reify 'foo - diff --git a/tests/examples/ghc8/TH_reifyType2.hs b/tests/examples/ghc8/TH_reifyType2.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_reifyType2.hs +++ /dev/null @@ -1,9 +0,0 @@ --- test reification of polymorphic types - -module TH_reifyType1 -where - -import Language.Haskell.TH - -type_length :: InfoQ -type_length = reify 'length diff --git a/tests/examples/ghc8/TH_repE1.hs b/tests/examples/ghc8/TH_repE1.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_repE1.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- test the representation of literals and also explicit type annotations - -module TH_repE1 -where - -import Language.Haskell.TH - -integralExpr :: ExpQ -integralExpr = [| 42 |] - -intExpr :: ExpQ -intExpr = [| 42 :: Int |] - -integerExpr :: ExpQ -integerExpr = [| 42 :: Integer |] - -charExpr :: ExpQ -charExpr = [| 'x' |] - -stringExpr :: ExpQ -stringExpr = [| "A String" |] - -fractionalExpr :: ExpQ -fractionalExpr = [| 1.2 |] - -floatExpr :: ExpQ -floatExpr = [| 1.2 :: Float |] - -doubleExpr :: ExpQ -doubleExpr = [| 1.2 :: Double |] diff --git a/tests/examples/ghc8/TH_repE3.hs b/tests/examples/ghc8/TH_repE3.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_repE3.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- test the representation of literals and also explicit type annotations - -module TH_repE1 -where - -import Language.Haskell.TH - -emptyListExpr :: ExpQ -emptyListExpr = [| [] |] - -singletonListExpr :: ExpQ -singletonListExpr = [| [4] |] - -listExpr :: ExpQ -listExpr = [| [4,5,6] |] - -consExpr :: ExpQ -consExpr = [| 4:5:6:[] |] - diff --git a/tests/examples/ghc8/TH_scope.hs b/tests/examples/ghc8/TH_scope.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_scope.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- Test for Trac #2188 - -module TH_scope where - -f g = [d| f :: Int - f = g - g :: Int - g = 4 |] diff --git a/tests/examples/ghc8/TH_spliceE5_prof_ext.hs b/tests/examples/ghc8/TH_spliceE5_prof_ext.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_spliceE5_prof_ext.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module Main where - -import TH_spliceE5_prof_ext_Lib - -v1 = "foo" - -main = putStrLn $(expandVars ["v1","v2"]) --- The splice expands to refer to both v1 and v2, --- and the test checks that we don't dependency-analyse --- the program so that one or the other isn't in scope --- to the type checker - - -v2 = "bar" diff --git a/tests/examples/ghc8/TH_spliceE5_prof_ext_Lib.hs b/tests/examples/ghc8/TH_spliceE5_prof_ext_Lib.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_spliceE5_prof_ext_Lib.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module TH_spliceE5_prof_ext_Lib where - -import Language.Haskell.TH - -expandVars :: [String] -> Q Exp -expandVars s = [| concat $(return (ListE (map f s))) |] - where - f x = VarE (mkName x) diff --git a/tests/examples/ghc8/TH_tf2.hs b/tests/examples/ghc8/TH_tf2.hs deleted file mode 100644 --- a/tests/examples/ghc8/TH_tf2.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -- 'bar' is ambiguous - -module TH_tf2 where - -{- -$( [d| class C a where - data T a - foo :: Bool -> T a |] ) - -$( [d| instance C Int where - data T Int = TInt Bool - foo b = TInt (b && b) |] ) - -$( [d| instance C Float where - data T Float = TFloat {flag :: Bool} - foo b = TFloat {flag = b && b} |] ) --} - -class D a where - type S a - bar :: S a -> Int - -instance D Int where - type S Int = Bool - bar c = if c then 1 else 2 diff --git a/tests/examples/ghc8/TcCustomSolverSuper.hs b/tests/examples/ghc8/TcCustomSolverSuper.hs deleted file mode 100644 --- a/tests/examples/ghc8/TcCustomSolverSuper.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -module TcCustomSolverSuper where - -import GHC.TypeLits -import Data.Typeable - -{- - -When solving super-class instances, GHC solves the evidence without -using the solver (see `tcSuperClasses` in `TcInstDecls`). - -However, some classes need to be excepted from this behavior, -as they have custom solving rules, and this test checks that -we got this right. --} - - -class (Typeable x, KnownNat x) => C x -class (Typeable x, KnownSymbol x) => D x - -instance C 2 -instance D "2" - diff --git a/tests/examples/ghc8/Templates.hs b/tests/examples/ghc8/Templates.hs deleted file mode 100644 --- a/tests/examples/ghc8/Templates.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeFamilies, FlexibleInstances, OverlappingInstances, TypeOperators, PatternGuards #-} -module Object.Templates( - makeName, - makeObject, - makeObjectFlexible - ) where - -import Object.Letters -import Object.Types - -import Prelude hiding ((.)) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Data.Char -import Data.Maybe - --- | --- implements 'makeObject' or 'makeObjectFlexible' depending on the first argument -makeObject' :: Bool -> Name -> Q [Dec] -makeObject' flexible name = go name where - go :: Name -> Q [Dec] - go obj = do - (name, vars, fields) <- reify name >>= getInfo - let objType = foldl AppT (ConT name) (VarT<*vars) - outputDecls <- if flexible - then return [] - else [d| - type instance Output $(return objType) (Method m) = - MethodOutput $(return objType) (Method m) - type instance Output $(return objType) (Method m := input) = - MethodOutput $(return objType) (Method m := input) - |] - fieldDecls <- (sequence $ makeField name vars <* fields) *> concat - return $ outputDecls ++ fieldDecls --- "(Object.Example.Foo,[x_1627454179],[(Object.Example._bar,NotStrict,ConT GHC.Types.Int),(Object.Example._baz,NotStrict,ConT GHC.Types.Char),(Object.Example._blub,NotStrict,VarT x_1627454179)])" - makeField :: Name -> [Name] -> VarStrictType -> Q [Dec] - makeField _ _ (name,_,_) | '_' /= head (nameBase name) = fail $ show name ++ " did not start with underscore" - makeField name vars (fName, _, fType) = do - (decs1,(typeName,dataName)) <- makeName' (tail $ nameBase fName) - methodOutput <- lookupTypeName "Object.Types.MethodOutput" *> fromMaybe (error "no MethodOutput in scope") - let objType = foldl AppT (ConT name) (VarT<*vars) - - let methodOutInst = TySynInstD methodOutput $ TySynEqn [objType, ConT typeName] fType - actionInst <- [d| - instance Action $(return objType) $(return $ ConT typeName) where - object . _ = $(return $ VarE fName) object - |] - - matchType <- [t| $(return $ ConT typeName) := $(return $ VarT $ mkName "value") |] - let methodSetOutInst = TySynInstD methodOutput $ TySynEqn [objType, matchType] objType - actionSetInst <- [d| - instance (value ~ $(return fType)) => Action $(return objType) $(return matchType) where - object . ( _ := v) = $(recUpdE [e|object|] [return (fName, VarE $ mkName "v")]) - |] - - return $ [methodOutInst,methodSetOutInst] ++ actionInst ++ actionSetInst ++ decs1 - diff --git a/tests/examples/ghc8/Test.hs b/tests/examples/ghc8/Test.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Test where - -import QQ - -f' = f . (+ 1) - -[pq| foo |] -- Expands to f :: Int -> Int -f x = x + 1 diff --git a/tests/examples/ghc8/Test10255.hs b/tests/examples/ghc8/Test10255.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10255.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Test10255 where - -import Data.Maybe - -fob (f :: (Maybe t -> Int)) = - undefined diff --git a/tests/examples/ghc8/Test10268.hs b/tests/examples/ghc8/Test10268.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10268.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TemplateHaskell,TypeOperators,DataKinds #-} - -module Test10268 where - -th = $footemplate - -give :: b -> Pattern '[b] a -give = undefined - -pfail :: Pattern '[] a -pfail = undefined diff --git a/tests/examples/ghc8/Test10269.hs b/tests/examples/ghc8/Test10269.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10269.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Test10269 where - - -(f =*= g) sa i = undefined diff --git a/tests/examples/ghc8/Test10276.hs b/tests/examples/ghc8/Test10276.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10276.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} - -module Test10276 where - -f1 = [| bar |] -f2 = [e| bar |] - -class QQExp a b where - qqExp x = [||fst $ runState $$(qqExpM x) - ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] - -class QQExp2 a b where - qqExp x = [e||fst $ runState $$(qqExpM x) - ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] diff --git a/tests/examples/ghc8/Test10278.hs b/tests/examples/ghc8/Test10278.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10278.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables,GADTs #-} -module Test10278 where - -extremumNewton :: forall tag. forall tag1. tag -> tag1 -> Int -extremumNewton = undefined - -extremumNewton1 :: (Eq a, Fractional a) => - (forall tag. forall tag1. - Tower tag1 (Tower tag a) - -> Tower tag1 (Tower tag a)) - -> a -> [a] -extremumNewton1 f x0 = zeroNewton (diffUU f) x0 - -data MaybeDefault v where - SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v - SetTo2:: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v - SetTo3 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v - {- - SetTo4 :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a]) - -} diff --git a/tests/examples/ghc8/Test10280.hs b/tests/examples/ghc8/Test10280.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10280.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TupleSections #-} -module Test10280 where - -foo2 = atomicModifyIORef ciTokens ((,()) . f) diff --git a/tests/examples/ghc8/Test10307.hs b/tests/examples/ghc8/Test10307.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10307.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Test10307 where - -class Foldable t where - type FoldableConstraint t x :: * - type FoldableConstraint t x = () diff --git a/tests/examples/ghc8/Test10309.hs b/tests/examples/ghc8/Test10309.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10309.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE GADTs #-} -module Test10309 where - -data H1 a b where - C3 :: (Num a) => { field :: a -- ^ hello docs - } -> H1 Int Int diff --git a/tests/examples/ghc8/Test10312.hs b/tests/examples/ghc8/Test10312.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10312.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE ParallelListComp, - TransformListComp, - RecordWildCards #-} -module Test10312 where --- From --- https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html - -import GHC.Exts -import qualified Data.Map as M -import Data.Ord (comparing) -import Data.List (sortBy) - --- Let’s look at a simple, normal list comprehension to start: - -regularListComp :: [Int] -regularListComp = [ x + y * z - | x <- [0..10] - , y <- [10..20] - , z <- [20..30] - ] - -parallelListComp :: [Int] -parallelListComp = [ x + y * z - | x <- [0..10] - | y <- [10..20] - | z <- [20..30] - ] - --- fibs :: [Int] --- fibs = 0 : 1 : zipWith (+) fibs (tail fibs) - -fibs :: [Int] -fibs = 0 : 1 : [ x + y - | x <- fibs - | y <- tail fibs - ] - -fiblikes :: [Int] -fiblikes = 0 : 1 : [ x + y + z - | x <- fibs - | y <- tail fibs - | z <- tail (tail fibs) - ] - --- TransformListComp -data Character = Character - { firstName :: String - , lastName :: String - , birthYear :: Int - } deriving (Show, Eq) - -friends :: [Character] -friends = [ Character "Phoebe" "Buffay" 1963 - , Character "Chandler" "Bing" 1969 - , Character "Rachel" "Green" 1969 - , Character "Joey" "Tribbiani" 1967 - , Character "Monica" "Geller" 1964 - , Character "Ross" "Geller" 1966 - ] - -oldest :: Int -> [Character] -> [String] -oldest k tbl = [ firstName ++ " " ++ lastName - | Character{..} <- tbl - , then sortWith by birthYear - , then take k - ] - -groupByLargest :: Ord b => (a -> b) -> [a] -> [[a]] -groupByLargest f = sortBy (comparing (negate . length)) . groupWith f - -bestBirthYears :: [Character] -> [(Int, [String])] -bestBirthYears tbl = [ (the birthYear, firstName) - | Character{..} <- tbl - , then group by birthYear using groupByLargest - ] - -uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs - , let d' = ppDir d - , then group by Down (p,d') using groupWith ] diff --git a/tests/examples/ghc8/Test10313.hs b/tests/examples/ghc8/Test10313.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10313.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE MagicHash, UnliftedFFITypes #-} -{-# LANGUAGE ForeignFunctionInterface #-} - -module Test10313 where - -import "b\x61se" Data.List - -{-# WARNING Logic - , solverCheckAndGetModel - "New Z3 API support is still incomplete and fragile: \ - \you may experience segmentation faults!" - #-} - -{-# Deprecated Logic - , solverCheckAndGetModel - "Deprecation: \ - \you may experience segmentation faults!" - #-} - -data {-# Ctype "foo\x63" "b\x61r" #-} Logic = Logic - --- Should warn -foo1 x = x -{-# RULES "foo1\x67" [ 1] forall x. foo1 x = x #-} - -foreign import prim unsafe "a\x62" a :: IO Int - -{-# INLINE strictStream #-} -strictStream (Bitstream l v) - = {-# CORE "Strict Bitstream stre\x61m" #-} - S.concatMap stream (GV.stream v) - `S.sized` - Exact l - -b = {-# SCC "foo\x64" #-} 006 - -c = {-# GENERATED "foob\x61r" 1 : 2 - 3 : 4 #-} 0.00 diff --git a/tests/examples/ghc8/Test10354.hs b/tests/examples/ghc8/Test10354.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10354.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -module Test10354 where - -f :: ((Eq a, _)) => a -> a -> Bool -f x y = x == y - -bar :: ( ) => a-> Bool -bar = undefined - -baz :: _ => a -> String -baz = undefined - -foo :: ForceError -foo = undefined diff --git a/tests/examples/ghc8/Test10357.hs b/tests/examples/ghc8/Test10357.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10357.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} -module Test10357 where - -legendres = one : x : - [ multPoly - (poly LE [recip (n' + 1)]) - (addPoly (poly LE [0, 2 * n' + 1] `multPoly` p_n) - (poly LE [-n'] `multPoly` p_nm1) - ) - | n <- [1..], let n' = fromInteger n - | p_n <- tail legendres - | p_nm1 <- legendres - ] diff --git a/tests/examples/ghc8/Test10358.hs b/tests/examples/ghc8/Test10358.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10358.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Test10358 where - -mtGamma x v d = - let !x_2 = x*x; !x_4 = x_2*x_2 - v3 = v*v*v - dv = d * v3 - in 5 diff --git a/tests/examples/ghc8/Test10396.hs b/tests/examples/ghc8/Test10396.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10396.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Test10396 where - -errors :: IO () -errors= do - let ls :: Int = undefined - return () diff --git a/tests/examples/ghc8/Test10399.hs b/tests/examples/ghc8/Test10399.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test10399.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -module Test10399 where - -type MPI = ?mpi_secret :: MPISecret - -mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) - -data MaybeDefault v where - SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v - SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v - -> a -> MaybeDefault [a]) - -[t| Map.Map T.Text $tc |] - -bar $( [p| x |] ) = x diff --git a/tests/examples/ghc8/Test11018.hs b/tests/examples/ghc8/Test11018.hs deleted file mode 100644 --- a/tests/examples/ghc8/Test11018.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -module Test11018 where - -nonUnicode :: forall a . a -> IO Int -nonUnicode _ = do - x <- readChar - return 4 - --- ^ An opaque ESD handle for recording data from the soundcard via ESD. -data Recorder fr ch (r ∷ * -> *) - = Recorder { - reCloseH :: !(FinalizerHandle r) - } - -f :: Arrow a => a (Int,Int,Int) Int -f = proc (x,y,z) -> returnA -< x+y - -f2 :: Arrow a => a (Int,Int,Int) Int -f2 = proc (x,y,z) -> returnA >- x+y - -g :: ArrowApply a => Int -> a (a Int Int,Int) Int -g y = proc (x,z) -> x -<< 2+y - -g2 :: ArrowApply a => Int -> a (a Int Int,Int) Int -g2 y = proc (x,z) -> x >>- 2+y - --- ------------------------------------- - -unicode ∷ ∀ a . a → IO Int -unicode _ = do - x ← readChar - return 4 - --- ^ An opaque ESD handle for recording data from the soundcard via ESD. -data RecorderU fr ch (r ∷ ★ → ★) - = RecorderU { - reCloseHU ∷ !(FinalizerHandle r) - } - -fU :: Arrow a ⇒ a (Int,Int,Int) Int -fU = proc (x,y,z) -> returnA ⤙ x+y - -f2U :: Arrow a ⇒ a (Int,Int,Int) Int -f2U = proc (x,y,z) -> returnA ⤚ x+y - -gU :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int -gU y = proc (x,z) -> x ⤛ 2+y - -g2U :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int -g2U y = proc (x,z) -> x ⤜ 2+y diff --git a/tests/examples/ghc8/TestBoolFormula.hs b/tests/examples/ghc8/TestBoolFormula.hs deleted file mode 100644 --- a/tests/examples/ghc8/TestBoolFormula.hs +++ /dev/null @@ -1,36 +0,0 @@ -module TestBoolFormula where - -class ManyOps a where - aOp :: a -> a -> Bool - aOp = undefined - bOp :: a -> a -> Bool - bOp = undefined - cOp :: a -> a -> Bool - cOp = undefined - dOp :: a -> a -> Bool - dOp = undefined - eOp :: a -> a -> Bool - eOp = undefined - fOp :: a -> a -> Bool - fOp = undefined - {-# MINIMAL ( aOp) - | ( bOp , cOp) - | ((dOp | eOp) , fOp) - #-} - -class Foo a where - bar :: a -> a -> Bool - foo :: a -> a -> Bool - baq :: a -> a -> Bool - baq = undefined - baz :: a -> a -> Bool - baz = undefined - quux :: a -> a -> Bool - quux = undefined - {-# MINIMAL bar, (foo, baq | foo, quux) #-} - -instance Foo Int where - bar = undefined - baz = undefined - quux = undefined - foo = undefined diff --git a/tests/examples/ghc8/TestUtils.hs b/tests/examples/ghc8/TestUtils.hs deleted file mode 100644 --- a/tests/examples/ghc8/TestUtils.hs +++ /dev/null @@ -1,5 +0,0 @@ - -module Math.NumberTheory.TestUtils where - -class (f `Compose` g) x - diff --git a/tests/examples/ghc8/Trac10045.hs b/tests/examples/ghc8/Trac10045.hs deleted file mode 100644 --- a/tests/examples/ghc8/Trac10045.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Trac10045 where - -newtype Meta = Meta () - -foo (Meta ws1) = - let copy :: _ - copy w from = copy w 1 - in copy ws1 1 diff --git a/tests/examples/ghc8/TransAssociated.hs b/tests/examples/ghc8/TransAssociated.hs deleted file mode 100644 --- a/tests/examples/ghc8/TransAssociated.hs +++ /dev/null @@ -1,9 +0,0 @@ -module TransAssociated(A(..)) where - -import Associated (A(..)) - -foo = MkA 5 -baz = NoA - -qux (MkA x) = x -qux NoA = 0 diff --git a/tests/examples/ghc8/TransBundle.hs b/tests/examples/ghc8/TransBundle.hs deleted file mode 100644 --- a/tests/examples/ghc8/TransBundle.hs +++ /dev/null @@ -1,9 +0,0 @@ -module TransAssociated(A(..)) where - -import Bundle (A(..)) - -foo = MkA 5 -baz = NoA - -qux (MkA x) = x -qux NoA = 0 diff --git a/tests/examples/ghc8/TypeFamilyInstanceLHS.hs b/tests/examples/ghc8/TypeFamilyInstanceLHS.hs deleted file mode 100644 --- a/tests/examples/ghc8/TypeFamilyInstanceLHS.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module TypeFamilyInstanceLHS where - -type family F (a :: *) (b :: *) :: * -type instance F Int _ = Int -type instance F Bool _ = Bool - -foo :: F Int Char -> Int -foo = id diff --git a/tests/examples/ghc8/TypeLevelVec.hs b/tests/examples/ghc8/TypeLevelVec.hs deleted file mode 100644 --- a/tests/examples/ghc8/TypeLevelVec.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TypeInType, UnicodeSyntax, GADTs, NoImplicitPrelude, - TypeOperators, TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} - -module TypeLevelVec where - -import Data.Kind - -data ℕ ∷ Type where - O ∷ ℕ - S ∷ ℕ → ℕ - -type family x + y where - O + n = n - S m + n = S (m + n) -infixl 5 + - -data Vec ∷ ℕ → Type → Type where - Nil ∷ Vec O a - (:>) ∷ a → Vec n a → Vec (S n) a -infixr 8 :> - -type family (x ∷ Vec n a) ++ (y ∷ Vec m a) ∷ Vec (n + m) a where - Nil ++ y = y - (x :> xs) ++ y = x :> (xs ++ y) -infixl 5 ++ diff --git a/tests/examples/ghc8/TypeSkolEscape.hs b/tests/examples/ghc8/TypeSkolEscape.hs deleted file mode 100644 --- a/tests/examples/ghc8/TypeSkolEscape.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes, PolyKinds, TypeInType #-} - -module TypeSkolEscape where - -import GHC.Types -import GHC.Exts - -type Bad = forall (v :: Levity) (a :: TYPE v). a diff --git a/tests/examples/ghc8/TypedSplice.hs b/tests/examples/ghc8/TypedSplice.hs deleted file mode 100644 --- a/tests/examples/ghc8/TypedSplice.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NamedWildCards #-} -{-# LANGUAGE PartialTypeSignatures #-} -module TypedSplice where - -import Language.Haskell.TH - -metaExp :: Q (TExp (Bool -> Bool)) -metaExp = [|| not :: _ -> _b ||] diff --git a/tests/examples/ghc8/UnicodeRules.hs b/tests/examples/ghc8/UnicodeRules.hs deleted file mode 100644 --- a/tests/examples/ghc8/UnicodeRules.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE - BangPatterns - , FlexibleContexts - , FlexibleInstances - , ScopedTypeVariables - , UnboxedTuples - , UndecidableInstances - , UnicodeSyntax - #-} - -strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool -{-# RULES "head → strictHead" [1] - ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). - head v = strictHead v #-} -{-# INLINE strictHead #-} -strictHead (Bitstream _ v) = head (SV.head v) diff --git a/tests/examples/ghc8/UnicodeSyntax.hs b/tests/examples/ghc8/UnicodeSyntax.hs deleted file mode 100644 --- a/tests/examples/ghc8/UnicodeSyntax.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE Arrows #-} - -module Tutorial where - --- import Abt.Class --- import Abt.Types --- import Abt.Concrete.LocallyNameless - -import Control.Applicative -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Except --- import Data.Vinyl -import Prelude hiding (pi) - --- | We'll start off with a monad in which to manipulate ABTs; we'll need some --- state for fresh variable generation. --- -newtype M α - = M - { _M ∷ State Int α - } deriving (Functor, Applicative, Monad) - --- | We'll run an ABT computation by starting the variable counter at @0@. --- -runM ∷ M α → α -runM (M m) = evalState m 0 - --- | Check out the source to see fresh variable generation. --- -instance MonadVar Var M where - fresh = M $ do - n ← get - let n' = n + 1 - put n' - return $ Var Nothing n' - - named a = do - v ← fresh - return $ v { _varName = Just a } - --- | Next, we'll define the operators for a tiny lambda calculus as a datatype --- indexed by arities. --- -data Lang ns where - LAM ∷ Lang '[S Z] - APP ∷ Lang '[Z, Z] - PI ∷ Lang '[Z, S Z] - UNIT ∷ Lang '[] - AX ∷ Lang '[] - -instance Show1 Lang where - show1 = \case - LAM → "lam" - APP → "ap" - PI → "pi" - UNIT → "unit" - AX → "<>" - -instance HEq1 Lang where - heq1 LAM LAM = Just Refl - heq1 APP APP = Just Refl - heq1 PI PI = Just Refl - heq1 UNIT UNIT = Just Refl - heq1 AX AX = Just Refl - heq1 _ _ = Nothing - -lam ∷ Tm Lang (S Z) → Tm0 Lang -lam e = LAM $$ e :& RNil - -app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang -app m n = APP $$ m :& n :& RNil - -ax ∷ Tm0 Lang -ax = AX $$ RNil - -unit ∷ Tm0 Lang -unit = UNIT $$ RNil - -pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang -pi α xβ = PI $$ α :& xβ :& RNil - --- | A monad transformer for small step operational semantics. --- -newtype StepT m α - = StepT - { runStepT ∷ MaybeT m α - } deriving (Monad, Functor, Applicative, Alternative) - --- | To indicate that a term is in normal form. --- -stepsExhausted - ∷ Applicative m - ⇒ StepT m α -stepsExhausted = StepT . MaybeT $ pure Nothing - -instance MonadVar Var m ⇒ MonadVar Var (StepT m) where - fresh = StepT . MaybeT $ Just <$> fresh - named str = StepT . MaybeT $ Just <$> named str - --- | A single evaluation step. --- -step - ∷ Tm0 Lang - → StepT M (Tm0 Lang) -step tm = - out tm >>= \case - APP :$ m :& n :& RNil → - out m >>= \case - LAM :$ xe :& RNil → xe // n - _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n - PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ - _ → stepsExhausted - --- | The reflexive-transitive closure of a small-step operational semantics. --- -star - ∷ Monad m - ⇒ (α → StepT m α) - → (α → m α) -star f a = - runMaybeT (runStepT $ f a) >>= - return a `maybe` star f - --- | Evaluate a term to normal form --- -eval ∷ Tm0 Lang → Tm0 Lang -eval = runM . star step - -newtype JudgeT m α - = JudgeT - { runJudgeT ∷ ExceptT String m α - } deriving (Monad, Functor, Applicative, Alternative) - -instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where - fresh = JudgeT . ExceptT $ Right <$> fresh - named str = JudgeT . ExceptT $ Right <$> named str - -type Ctx = [(Var, Tm0 Lang)] - -raise ∷ Monad m ⇒ String → JudgeT m α -raise = JudgeT . ExceptT . return . Left - -checkTy - ∷ Ctx - → Tm0 Lang - → Tm0 Lang - → JudgeT M () -checkTy g tm ty = do - let ntm = eval tm - nty = eval ty - (,) <$> out ntm <*> out nty >>= \case - (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do - z ← fresh - ez ← xe // var z - βz ← yβ // var z - checkTy ((z,α):g) ez βz - (AX :$ RNil, UNIT :$ RNil) → return () - _ → do - ty' ← inferTy g tm - if ty' === nty - then return () - else raise "Type error" - -inferTy - ∷ Ctx - → Tm0 Lang - → JudgeT M (Tm0 Lang) -inferTy g tm = do - out (eval tm) >>= \case - V v | Just (eval → ty) ← lookup v g → return ty - | otherwise → raise "Ill-scoped variable" - APP :$ m :& n :& RNil → do - inferTy g m >>= out >>= \case - PI :$ α :& xβ :& RNil → do - checkTy g n α - eval <$> xβ // n - _ → raise "Expected pi type for lambda abstraction" - _ → raise "Only infer neutral terms" - --- | @λx.x@ --- -identityTm ∷ M (Tm0 Lang) -identityTm = do - x ← fresh - return $ lam (x \\ var x) - --- | @(λx.x)(λx.x)@ --- -appTm ∷ M (Tm0 Lang) -appTm = do - tm ← identityTm - return $ app tm tm - --- | A demonstration of evaluating (and pretty-printing). Output: --- --- @ --- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4] --- @ --- -main ∷ IO () -main = do - -- Try out the type checker - either fail print . runM . runExceptT . runJudgeT $ do - x ← fresh - checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit)) - - print . runM $ do - mm ← appTm - mmStr ← toString mm - mmStr' ← toString $ eval mm - return $ mmStr ++ " ~>* " ++ mmStr' - -doMap ∷ FilePath → IOSArrow XmlTree TiledMap -doMap mapPath = proc m → do - mapWidth ← getAttrR "width" ⤙ m - returnA -< baz - --- ^ An opaque ESD handle for recording data from the soundcard via ESD. -data Recorder fr ch (r ∷ ★ → ★) - = Recorder { - reRate ∷ !Int - , reHandle ∷ !Handle - , reCloseH ∷ !(FinalizerHandle r) - } - --- from ghc-prim - --- | A backward-compatible (pre-GHC 8.0) synonym for 'Type' -type * = TYPE 'PtrRepLifted - --- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type' -type ★ = TYPE 'PtrRepLifted diff --git a/tests/examples/ghc8/Vta1.hs b/tests/examples/ghc8/Vta1.hs deleted file mode 100644 --- a/tests/examples/ghc8/Vta1.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE TypeApplications, ScopedTypeVariables, PolyKinds, - TypeFamilies, RankNTypes, - FlexibleContexts #-} --- tests about visible type application - -module Vta1 where - -quad :: a -> b -> c -> d -> (a, b, c, d) -quad = (,,,) - -silly = quad @_ @Bool @Char @_ 5 True 'a' "Hello" - -pairup_nosig x y = (x, y) - -pairup_sig :: a -> b -> (a,b) -pairup_sig u w = (u, w) - -answer_sig = pairup_sig @Bool @Int False 7 -- --- (False, 7) :: (Bool, Int) - -answer_read = show (read @Int "3") -- "3" :: String -answer_show = show @Integer (read "5") -- "5" :: String -answer_showread = show @Int (read @Int "7") -- "7" :: String - -intcons a = (:) @Int a - -intpair x y = pairup_sig @Int x y - -answer_pairup = pairup_sig @Int 5 True -- (5, True) :: (Int, Bool) -answer_intpair = intpair 1 "hello" -- (1, "hello") :: (Int, String) -answer_intcons = intcons 7 [] -- [7] :: [Int] - -type family F a -type instance F Char = Bool - -g :: F a -> a -g _ = undefined - -f :: Char -f = g True - -answer = g @Char False - -mapSame :: forall b. (forall a. a -> a) -> [b] -> [b] -mapSame _ [] = [] -mapSame fun (x:xs) = fun @b x : (mapSame @b fun xs) - -pair :: forall a. a-> (forall b. b -> (a, b)) -pair x y = (x, y) - -b = pair @Int 3 @Bool True -c = mapSame id [1,2,3] -d = pair 3 @Bool True - -pairnum :: forall a. Num a => forall b. b -> (a, b) -pairnum = pair 3 - -e = (pair 3 :: forall a. Num a => forall b. b -> (a, b)) @Int @Bool True -h = pairnum @Int @Bool True - -data First (a :: * -> *) = F -data Proxy (a :: k) = P -- This expands to P (kind variable) (type variable) -data Three (a :: * -> k -> *) = T - -foo :: Proxy a -> Int -foo _ = 0 - -first :: First a -> Int -first _ = 0 - -fTest = first F -fMaybe = first @Maybe F - -test = foo P -bar = foo @Bool P -- should work - -too :: Three a -> Int -too _ = 3 - -threeBase = too T -threeOk = too @Either T - -blah = Nothing @Int - -newtype N = MkN { unMkN :: forall a. Show a => a -> String } - -n = MkN show - -boo = unMkN n @Bool - -boo2 :: forall (a :: * -> *) . Proxy a -> Bool -boo2 _ = False - -base = boo2 P -bar'= boo2 @Maybe P -- should work diff --git a/tests/examples/ghc8/Vta2.hs b/tests/examples/ghc8/Vta2.hs deleted file mode 100644 --- a/tests/examples/ghc8/Vta2.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE RankNTypes, TypeApplications #-} - - -module Vta2 where - -checkIf :: Bool -> (forall a. a -> a) -> (Bool, Int) -checkIf _ = if True - then \f -> (f True, f 5) - else \f -> (f False, f @Int 3) - -checkCase :: Bool -> (forall a. a -> a) -> (Bool, Int) -checkCase _ = case True of - True -> \f -> (f True, f 5) - False -> \f -> (f False, f @Int 3) diff --git a/tests/examples/ghc8/WCompatWarningsNotOn.hs b/tests/examples/ghc8/WCompatWarningsNotOn.hs deleted file mode 100644 --- a/tests/examples/ghc8/WCompatWarningsNotOn.hs +++ /dev/null @@ -1,26 +0,0 @@ --- Test purpose: --- Ensure that not using -Wcompat does not enable its warnings - --- {-# OPTIONS_GHC -Wcompat #-} --- {-# OPTIONS_GHC -Wno-compat #-} - -module WCompatWarningsNotOn where - -import qualified Data.Semigroup as Semi - -monadFail :: Monad m => m a -monadFail = do - Just _ <- undefined - undefined - -(<>) = undefined -- Semigroup warnings - --- -fwarn-noncanonical-monoid-instances -newtype S = S Int - -instance Semi.Semigroup S where - (<>) = mappend - -instance Semi.Monoid S where - S a `mappend` S b = S (a+b) - mempty = S 0 diff --git a/tests/examples/ghc8/WCompatWarningsOff.hs b/tests/examples/ghc8/WCompatWarningsOff.hs deleted file mode 100644 --- a/tests/examples/ghc8/WCompatWarningsOff.hs +++ /dev/null @@ -1,26 +0,0 @@ --- Test purpose: --- Ensure that using -Wno-compat does not switch on warnings - --- {-# OPTIONS_GHC -Wcompat #-} -{-# OPTIONS_GHC -Wno-compat #-} - -module WCompatWarningsOff where - -import qualified Data.Semigroup as Semi - -monadFail :: Monad m => m a -monadFail = do - Just _ <- undefined - undefined - -(<>) = undefined -- Semigroup warnings - --- -fwarn-noncanonical-monoid-instances -newtype S = S Int - -instance Semi.Semigroup S where - (<>) = mappend - -instance Semi.Monoid S where - S a `mappend` S b = S (a+b) - mempty = S 0 diff --git a/tests/examples/ghc8/WCompatWarningsOn.hs b/tests/examples/ghc8/WCompatWarningsOn.hs deleted file mode 100644 --- a/tests/examples/ghc8/WCompatWarningsOn.hs +++ /dev/null @@ -1,26 +0,0 @@ --- Test purpose: --- Ensure that -Wcompat switches on the right warnings - -{-# OPTIONS_GHC -Wcompat #-} --- {-# OPTIONS_GHC -Wno-compat #-} - -module WCompatWarningsOn where - -import qualified Data.Semigroup as Semi - -monadFail :: Monad m => m a -monadFail = do - Just _ <- undefined - undefined - -(<>) = undefined -- Semigroup warnings - --- -fwarn-noncanonical-monoid-instances -newtype S = S Int - -instance Semi.Semigroup S where - (<>) = mappend - -instance Semi.Monoid S where - S a `mappend` S b = S (a+b) - mempty = S 0 diff --git a/tests/examples/ghc8/WCompatWarningsOnOff.hs b/tests/examples/ghc8/WCompatWarningsOnOff.hs deleted file mode 100644 --- a/tests/examples/ghc8/WCompatWarningsOnOff.hs +++ /dev/null @@ -1,26 +0,0 @@ --- Test purpose: --- Ensure that -Wno-compat disables a previously set -Wcompat - -{-# OPTIONS_GHC -Wcompat #-} -{-# OPTIONS_GHC -Wno-compat #-} - -module WCompatWarningsOnOff where - -import qualified Data.Semigroup as Semi - -monadFail :: Monad m => m a -monadFail = do - Just _ <- undefined - undefined - -(<>) = undefined -- Semigroup warnings - --- -fwarn-noncanonical-monoid-instances -newtype S = S Int - -instance Semi.Semigroup S where - (<>) = mappend - -instance Semi.Monoid S where - S a `mappend` S b = S (a+b) - mempty = S 0 diff --git a/tests/examples/ghc8/Webhook.hs b/tests/examples/ghc8/Webhook.hs deleted file mode 100644 --- a/tests/examples/ghc8/Webhook.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-| -Module : Servant.GitHub.Webhook -Description : Easily write safe GitHub webhook handlers with Servant -Copyright : (c) Jacob Thomas Errington, 2016 -License : MIT -Maintainer : servant-github-webhook@mail.jerrington.me -Stability : experimental - -The GitHub webhook machinery will attach three headers to the HTTP requests -that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@. -The former two headers correspond with the 'GitHubEvent' and -'GitHubSignedReqBody''' routing combinators. This library ignores the -@X-Github-Delivery@ header; if you would like to access its value, then use the -builtin 'Header' combinator from Servant. - -Usage of the library is straightforward: protect routes with the 'GitHubEvent' -combinator to ensure that the route is only reached for specific -'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write -under that route with 'GitHubSignedReqBody'. It is advised to always include a -'GitHubSignedReqBody''', as this is the only way you can be sure that it is -GitHub who is sending the request, and not a malicious user. If you don't care -about the request body, then simply use Aeson\'s 'Object' type as the -deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and -ignore the @Object@ in the handler. - -The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in -order to extract the signing key. This is the same key that must be entered in -the configuration of the webhook on GitHub. See 'GitHubKey'' for more details. - -In order to support multiple keys on a per-route basis, the basic combinator -@GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this, -create a datatype, e.g. @KeyIndex@ whose constructors identify the different -keys you will be using. Generally, this means one constructor per repository. -Use the @DataKinds@ extension to promote this datatype to a kind, and write an -instance of 'Reflect' for each promoted constructor of your datatype. Finally, -create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is -the datatype you've built up. Thus, your function can determine which key to -retrieve. --} - -{-# LANGUAGE CPP #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - --- GHC 8 seems to have improved its decidability check for type family --- instances and class instances. In particular, without UndecidableInstances --- enabled, the Demote' instance for lists, which we need, will not compile. --- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol, --- won't compile on GHC < 8 because the instance head is no smaller than the --- instance head. -#if __GLASGOW_HASKELL__ < 800 -{-# LANGUAGE UndecidableInstances #-} -#endif - -module Servant.GitHub.Webhook -( -- * Servant combinators - GitHubSignedReqBody'' -, GitHubSignedReqBody' -, GitHubSignedReqBody -, GitHubEvent - - -- ** Security -, GitHubKey'(..) -, GitHubKey -, gitHubKey - - -- * Reexports - -- - -- | We reexport a few datatypes that are typically needed to use the - -- library. -, RepoWebhookEvent(..) -, KProxy(..) - - -- * Implementation details - - -- ** Type-level programming machinery -, Demote -, Demote' -, Reflect(..) - - -- ** Stringy stuff -, parseHeaderMaybe -, matchEvent - - -- * Examples - -- - -- $example1 - -- - -- $example2 -) where - -import Control.Monad.IO.Class ( liftIO ) -import Data.Aeson ( decode', encode ) -import qualified Data.ByteString as BS -import Data.ByteString.Lazy ( fromStrict, toStrict ) -import qualified Data.ByteString.Base16 as B16 -import Data.HMAC ( hmac_sha1 ) -import Data.List ( intercalate ) -import Data.Maybe ( catMaybes, fromMaybe ) -import Data.Monoid ( (<>) ) -import Data.Proxy -import Data.String.Conversions ( cs ) -import qualified Data.Text.Encoding as E -import GHC.TypeLits -import GitHub.Data.Webhooks -import Network.HTTP.Types hiding (Header, ResponseHeaders) -import Network.Wai ( requestHeaders, strictRequestBody ) -import Servant -import Servant.API.ContentTypes ( AllCTUnrender(..) ) -import Servant.Server.Internal - - --- | A clone of Servant's 'ReqBody' combinator, except that it will also --- verify the signature provided by GitHub in the @X-Hub-Signature@ header by --- computing the SHA1 HMAC of the request body and comparing. --- --- The use of this combinator will require that the router context contain an --- appropriate 'GitHubKey'' entry. Specifically, the type parameter of --- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the --- index @key@ used here. Consequently, it will be necessary to use --- 'serveWithContext' instead of 'serve'. --- --- Other routes are not tried upon the failure of this combinator, and a 401 --- response is generated. --- --- Use of this datatype directly is discouraged, since the choice of the index --- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use --- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just --- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for --- the implementation of the 'HasServer' instance for the datatype. -data GitHubSignedReqBody'' - (proxy :: KProxy k) - (key :: k) - (list :: [*]) - (result :: *) where - --- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first --- type argument given just the second one. --- --- Use this type synonym if you are creating a webhook server to handle --- webhooks from multiple repositories, with different secret keys. -type GitHubSignedReqBody' (key :: k) - = GitHubSignedReqBody'' ('KProxy :: KProxy k) key - --- | A convenient alias for a trivial key index. --- --- USe this type synonym if you are creating a webhook server to handle only --- webhooks from a single repository, or for mutliple repositories using the --- same secret key. -type GitHubSignedReqBody = GitHubSignedReqBody' '() - --- | A routing combinator that succeeds only for a webhook request that matches --- one of the given 'RepoWebhookEvent' given in the type-level list @events@. --- --- If the list contains 'WebhookWildcardEvent', then all events will be --- matched. --- --- The combinator will require that its associated handler take a --- 'RepoWebhookEvent' parameter, and the matched event will be passed to the --- handler. This allows the handler to determine which event triggered it from --- the list. --- --- Other routes are tried if there is a mismatch. -data GitHubEvent (events :: [RepoWebhookEvent]) where - diff --git a/tests/examples/ghc8/ado001.hs b/tests/examples/ghc8/ado001.hs deleted file mode 100644 --- a/tests/examples/ghc8/ado001.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo #-} -module Main where - -import Control.Applicative -import Text.PrettyPrint - -(a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..] - --- a | b -test1 :: M () -test1 = do - x1 <- a - x2 <- b - const (return ()) (x1,x2) - --- no parallelism -test2 :: M () -test2 = do - x1 <- a - x2 <- const g x1 - const (return ()) (x1,x2) - --- a | (b;g) | e -test3 :: M () -test3 = do - x1 <- a - x2 <- b - x3 <- const g x2 - x4 <- e - return () `const` (x1,x2,x3,x4) - --- (a ; (b | g)) | c --- or --- ((a | b); g) | c -test4 :: M () -test4 = do - x1 <- a - x2 <- b - x3 <- const g x1 - x4 <- c - return () `const` (x2,x3,x4) - --- (a | b | c); (g | h) -test5 :: M () -test5 = do - x1 <- a - x2 <- b - x3 <- c - x4 <- const g x1 - x5 <- const h x3 - return () `const` (x3,x4,x5) - --- b/c in parallel, e/f in parallel --- a; (b | (c; (d; (e | (f; g))))) -test6 :: M () -test6 = do - x1 <- a - x2 <- const b x1 - x3 <- const c x1 - x4 <- const d x3 - x5 <- const e x4 - x6 <- const f x4 - x7 <- const g x6 - return () `const` (x1,x2,x3,x4,x5,x6,x7) - --- (a | b); (c | d) -test7 :: M () -test7 = do - x1 <- a - x2 <- b - x3 <- const c x1 - x4 <- const d x2 - return () `const` (x3,x4) - --- a; (b | c | d) --- --- alternative (but less good): --- ((a;b) | c); d -test8 :: M () -test8 = do - x1 <- a - x2 <- const b x1 - x3 <- c - x4 <- const d x1 - return () `const` (x2,x3,x4) - --- test that Lets don't get in the way --- ((a | (b; c)) | d) | e -test9 :: M () -test9 = do - x1 <- a - let x = doc "x" -- this shouldn't get in the way of grouping a/b - x2 <- b - x3 <- const c x2 - x4 <- d - x5 <- e - let y = doc "y" - return () - --- ((a | b) ; (c | d)) | e -test10 :: M () -test10 = do - x1 <- a - x2 <- b - let z1 = (x1,x2) - x3 <- const c x1 - let z2 = (x1,x2) - x4 <- const d z1 - x5 <- e - return (const () (x3,x4,x5)) - -main = mapM_ run - [ test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - , test10 - ] - --- Testing code, prints out the structure of a monad/applicative expression - -newtype M a = M (Bool -> (Maybe Doc, a)) - -maybeParen True d = parens d -maybeParen _ d = d - -run :: M a -> IO () -run (M m) = print d where (Just d,_) = m False - -instance Functor M where - fmap f m = m >>= return . f - -instance Applicative M where - pure a = M $ \_ -> (Nothing, a) - M f <*> M a = M $ \p -> - let (Just d1, f') = f True - (Just d2, a') = a True - in - (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a') - -instance Monad M where - return = pure - M m >>= k = M $ \p -> - let (d1, a) = m True - (d2, b) = case k a of M f -> f True - in - case (d1,d2) of - (Nothing,Nothing) -> (Nothing, b) - (Just d, Nothing) -> (Just d, b) - (Nothing, Just d) -> (Just d, b) - (Just d1, Just d2) -> (Just (maybeParen p (d1 <> semi <+> d2)), b) - -doc :: String -> M () -doc d = M $ \_ -> (Just (text d), ()) diff --git a/tests/examples/ghc8/ado002.hs b/tests/examples/ghc8/ado002.hs deleted file mode 100644 --- a/tests/examples/ghc8/ado002.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ApplicativeDo,ScopedTypeVariables #-} -module Test where - --- Test that type errors aren't affected by ApplicativeDo -f :: IO Int -f = do - x <- getChar - y <- getChar 'a' -- type error - print (x,y) - -g :: IO (Int,Int) -g = do - x <- getChar - y <- getChar - return (y,x) - -h :: IO (Int,Int) -h = do - x1 <- getChar - x2 <- getChar - x3 <- const (return ()) x1 - x4 <- getChar - x5 <- getChar x4 - return (x2,x4) diff --git a/tests/examples/ghc8/ado003.hs b/tests/examples/ghc8/ado003.hs deleted file mode 100644 --- a/tests/examples/ghc8/ado003.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -module ShouldFail where - -g :: IO () -g = do - x <- getChar - 'a' <- return (3::Int) -- type error - return () diff --git a/tests/examples/ghc8/ado004.hs b/tests/examples/ghc8/ado004.hs deleted file mode 100644 --- a/tests/examples/ghc8/ado004.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# OPTIONS_GHC -ddump-types #-} -module Test where - --- This is a do expression that typechecks with only an Applicative constraint -test1 :: Applicative f => (Int -> f Int) -> f Int -test1 f = do - x <- f 3 - y <- f 4 - return (x + y) - --- Test we can also infer the Applicative version of the type -test2 f = do - x <- f 3 - y <- f 4 - return (x + y) - --- This one will use join -test3 f g = do - x <- f 3 - y <- f 4 - g y x - --- This one needs a tuple -test4 f g = do - x <- f 3 - y <- f 4 - let r = g y x - r - --- This one used to need a big tuple, now it compiles to ApplicativeLastStmt -test5 f g = do - x01 <- f 01 - x02 <- f 02 - x03 <- f 03 - x04 <- f 04 - x05 <- f 05 - x06 <- f 06 - x07 <- f 07 - x08 <- f 08 - x09 <- f 09 - x11 <- f 11 - x12 <- f 12 - x13 <- f 13 - x14 <- f 14 - x15 <- f 15 - x16 <- f 16 - x17 <- f 17 - x18 <- f 18 - x19 <- f 19 - x20 <- f 20 - x21 <- f 21 - x22 <- f 22 - x23 <- f 23 - x24 <- f 24 - x25 <- f 25 - x26 <- f 26 - x27 <- f 27 - x28 <- f 28 - x29 <- f 29 - x30 <- f 30 - x31 <- f 31 - x32 <- f 32 - x33 <- f 33 - x34 <- f 34 - x35 <- f 35 - x36 <- f 36 - x37 <- f 37 - x38 <- f 38 - x39 <- f 39 - x40 <- f 40 - x41 <- f 41 - x42 <- f 42 - x43 <- f 43 - x44 <- f 44 - x45 <- f 45 - x46 <- f 46 - x47 <- f 47 - x48 <- f 48 - x49 <- f 49 - x50 <- f 50 - x51 <- f 51 - x52 <- f 52 - x53 <- f 53 - x54 <- f 54 - x55 <- f 55 - x56 <- f 56 - x57 <- f 57 - x58 <- f 58 - x59 <- f 59 - x60 <- f 60 - x61 <- f 61 - x62 <- f 62 - x63 <- f 63 - x64 <- f 64 - x65 <- f 65 - x66 <- f 66 - x67 <- f 67 - x68 <- f 68 - x69 <- f 69 - x70 <- f 70 - let r = g x70 x01 - r - --- This one needs a big tuple -test6 f g = do - x01 <- f 01 - x02 <- f 02 - x03 <- f 03 - x04 <- f 04 - x05 <- f 05 - x06 <- f 06 - x07 <- f 07 - x08 <- f 08 - x09 <- f 09 - x11 <- f 11 - x12 <- f 12 - x13 <- f 13 - x14 <- f 14 - x15 <- f 15 - x16 <- f 16 - x17 <- f 17 - x18 <- f 18 - x19 <- f 19 - x20 <- f 20 - x21 <- f 21 - x22 <- f 22 - x23 <- f 23 - x24 <- f 24 - x25 <- f 25 - x26 <- f 26 - x27 <- f 27 - x28 <- f 28 - x29 <- f 29 - x30 <- f 30 - x31 <- f 31 - x32 <- f 32 - x33 <- f 33 - x34 <- f 34 - x35 <- f 35 - x36 <- f 36 - x37 <- f 37 - x38 <- f 38 - x39 <- f 39 - x40 <- f 40 - x41 <- f 41 - x42 <- f 42 - x43 <- f 43 - x44 <- f 44 - x45 <- f 45 - x46 <- f 46 - x47 <- f 47 - x48 <- f 48 - x49 <- f 49 - x50 <- f 50 - x51 <- f 51 - x52 <- f 52 - x53 <- f 53 - x54 <- f 54 - x55 <- f 55 - x56 <- f 56 - x57 <- f 57 - x58 <- f 58 - x59 <- f 59 - x60 <- f 60 - x61 <- f 61 - x62 <- f 62 - x63 <- f 63 - x64 <- f 64 - x65 <- f 65 - x66 <- f 66 - x67 <- f 67 - x68 <- f 68 - x69 <- f 69 - x70 <- f x01 - x71 <- f 70 - x71 `const` - [ x01 - , x02 - , x03 - , x04 - , x05 - , x06 - , x07 - , x08 - , x09 - , x11 - , x12 - , x13 - , x14 - , x15 - , x16 - , x17 - , x18 - , x19 - , x20 - , x21 - , x22 - , x23 - , x24 - , x25 - , x26 - , x27 - , x28 - , x29 - , x30 - , x31 - , x32 - , x33 - , x34 - , x35 - , x36 - , x37 - , x38 - , x39 - , x40 - , x41 - , x42 - , x43 - , x44 - , x45 - , x46 - , x47 - , x48 - , x49 - , x50 - , x51 - , x52 - , x53 - , x54 - , x55 - , x56 - , x57 - , x58 - , x59 - , x60 - , x61 - , x62 - , x63 - , x64 - , x65 - , x66 - , x67 - , x68 - , x69 - , x70 - , x71 ] diff --git a/tests/examples/ghc8/ado005.hs b/tests/examples/ghc8/ado005.hs deleted file mode 100644 --- a/tests/examples/ghc8/ado005.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# OPTIONS_GHC -ddump-types #-} -module Test where - --- This should fail to typecheck because it needs Monad -test :: Applicative f => (Int -> f Int) -> f Int -test f = do - x <- f 3 - y <- f x - return (x + y) diff --git a/tests/examples/ghc8/ado006.hs b/tests/examples/ghc8/ado006.hs deleted file mode 100644 --- a/tests/examples/ghc8/ado006.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -module Test where - --- This exposed a bug in zonking ApplicativeLastStmt -test :: IO Int -test - = do - x <- return () - h <- return (\_ -> 3) - return (h ()) diff --git a/tests/examples/ghc8/ado007.hs b/tests/examples/ghc8/ado007.hs deleted file mode 100644 --- a/tests/examples/ghc8/ado007.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE RebindableSyntax #-} -module Test where - -import Control.Applicative -import Control.Monad -import Prelude - --- Caused a -dcore-lint failure with an earlier version of --- ApplicativeDo due to the polymorphic let binding. -test :: IO [Char] -test = do - x <- return 'a' - y <- return 'b' - let f | y == 'c' = id | otherwise = id - return (map f []) diff --git a/tests/examples/ghc8/boolFormula.hs b/tests/examples/ghc8/boolFormula.hs deleted file mode 100644 --- a/tests/examples/ghc8/boolFormula.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/determ004.hs b/tests/examples/ghc8/determ004.hs deleted file mode 100644 --- a/tests/examples/ghc8/determ004.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# LANGUAGE TypeOperators - , DataKinds - , PolyKinds - , TypeFamilies - , GADTs - , UndecidableInstances - , RankNTypes - , ScopedTypeVariables - #-} - -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Werror #-} -{-# OPTIONS_GHC -O1 -fspec-constr #-} - -{- - -With reversed order of allocated uniques the type variables would be in -wrong order: - -*** Core Lint errors : in result of SpecConstr *** -determ004.hs:88:12: warning: - [in body of lambda with binder m_azbFg :: a_afdP_azbON] - @ (a_afdP_azbON :: BOX) is out of scope -*** Offending Program *** - -... - -Rec { -$s$wsFoldr1_szbtK - :: forall (m_azbFg :: a_afdP_azbON) - (x_azbOM :: TyFun - a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *) - -> *) - (a_afdP_azbON :: BOX) - (ipv_szbwN :: a_afdP_azbON) - (ipv_szbwO :: [a_afdP_azbON]). - R:Sing[]z (ipv_szbwN : ipv_szbwO) - ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO) - -> Sing ipv_szbwO - -> Sing ipv_szbwN - -> (forall (t_azbNM :: a_afdP_azbON). - Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) - -> Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) -[LclId, - Arity=4, - Str=DmdType ] -$s$wsFoldr1_szbtK = - \ (@ (m_azbFg :: a_afdP_azbON)) - (@ (x_azbOM :: TyFun - a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *) - -> *)) - (@ (a_afdP_azbON :: BOX)) - (@ (ipv_szbwN :: a_afdP_azbON)) - (@ (ipv_szbwO :: [a_afdP_azbON])) - (sg_szbtL - :: R:Sing[]z (ipv_szbwN : ipv_szbwO) - ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO)) - (sc_szbtM :: Sing ipv_szbwO) - (sc_szbtN :: Sing ipv_szbwN) - (sc_szbtP - :: forall (t_azbNM :: a_afdP_azbON). - Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) -> - case (SCons - @ a_afdP_azbON - @ (ipv_szbwN : ipv_szbwO) - @ ipv_szbwO - @ ipv_szbwN - @~ (_N - :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO)) - sc_szbtN - sc_szbtM) - `cast` (sg_szbtL - ; TFCo:R:Sing[]z[0] _N _N - :: R:Sing[]z (ipv_szbwN : ipv_szbwO) - ~R# R:Sing[]z - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) - of wild_XD { - SNil dt_dzbxX -> - (lvl_szbwi @ a_afdP_azbON) - `cast` ((Sing - (Sym (TFCo:R:Foldr1[2] _N _N) - ; Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N <'[]>_N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) - (Sym dt_dzbxX))_N))_R - :: Sing (Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list") - ~R# Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); - SCons @ n_azbFh @ m_XzbGe dt_dzbxK _sX_azbOH - ds_dzbyu [Dmd=] -> - case ds_dzbyu - `cast` (TFCo:R:Sing[]z[0] _N _N - :: Sing n_azbFh ~R# R:Sing[]z n_azbFh) - of wild_Xo { - SNil dt_dzbxk -> - (lvl_szbw1 @ a_afdP_azbON @ m_XzbGe) - `cast` ((Sing - (Sym (TFCo:R:Foldr1[0] _N _N _N) - ; Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N <'[m_XzbGe]>_N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) - ((_N ': Sym dt_dzbxk)_N ; Sym dt_dzbxK))_N))_R - :: Sing m_XzbGe - ~R# Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); - SCons @ ipv_XzbxR @ ipv_XzbyV ipv_szbwM ipv_szbwL ipv_szbwK -> - case (sc_szbtP @ m_XzbGe _sX_azbOH) - `cast` (TFCo:R:Sing(->)f[0] - _N _N _N - :: Sing (Apply x_azbOM m_XzbGe) - ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe)) - of wild_X3X { SLambda ds_XzbBr [Dmd=] -> - (ds_XzbBr - @ (Foldr1 x_azbOM (ipv_XzbyV : ipv_XzbxR)) - (($wsFoldr1_szbuc - @ a_afdP_azbON - @ x_azbOM - @ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR) - sc_szbtP - ((SCons - @ a_afdP_azbON - @ (ipv_XzbyV : ipv_XzbxR) - @ ipv_XzbxR - @ ipv_XzbyV - @~ (_N - :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR)) - ipv_szbwL - ipv_szbwK) - `cast` (Sym (TFCo:R:Sing[]z[0] _N) (Sym - (TFCo:R:Apply[][]:$$i[0] - _N - _N - _N) - ; (Apply - (Sym - (TFCo:R:Applyk(->):$l[0] - _N - _N)) - _N)_N) - :: R:Sing[]z (ipv_XzbyV : ipv_XzbxR) - ~R# Sing (Apply (Apply (:$) ipv_XzbyV) ipv_XzbxR)))) - `cast` ((Sing - ((Apply - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N) - _N)_N - ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N - ((Apply - (TFCo:R:Applyk(->):$l[0] _N _N) - _N)_N - ; TFCo:R:Apply[][]:$$i[0] - _N _N _N) - _N))_R - :: Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR)) - ~R# Sing (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))))) - `cast` ((Sing - ((Apply - _N - (Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N _N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] - _N _N)) - (Sym - (TFCo:R:Apply[][]:$$i[0] - _N _N _N) - ; (Apply - (Sym - (TFCo:R:Applyk(->):$l[0] _N _N)) - _N)_N))_N))_N - ; Sym - (TFCo:R:Foldr1[1] - _N - _N - _N - _N - _N) - ; Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N _N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) - ((_N ': Sym ipv_szbwM)_N ; Sym dt_dzbxK))_N))_R - :: Sing - (Apply - (Apply x_azbOM m_XzbGe) - (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))) - ~R# Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))) - } - } - } -... --} - -module List (sFoldr1) where - -data Proxy t - -data family Sing (a :: k) - -data TyFun (a :: *) (b :: *) - -type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2 - -data instance Sing (f :: TyFun k1 k2 -> *) = - SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } - -type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) - -type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) -singFun2 :: Proxy f -> SingFunction2 f -> Sing f -singFun2 _ f = SLambda (\x -> SLambda (f x)) - -data (:$$) (j :: a) (i :: TyFun [a] [a]) -type instance Apply ((:$$) j) i = (:) j i - -data (:$) (l :: TyFun a (TyFun [a] [a] -> *)) -type instance Apply (:$) l = (:$$) l -data instance Sing (z :: [a]) - = z ~ '[] => - SNil - | forall (m :: a) - (n :: [a]). z ~ (:) m n => - SCons (Sing m) (Sing n) - -data ErrorSym0 (t1 :: TyFun k1 k2) - -type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh - -type Let1627448493Xs f_afe9 - x_afea - wild_1627448474_afeb - wild_1627448476_afec = - Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec -type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) - -> *) - (t_afdZ :: [a_afdP]) = - Foldr1 t_afdY t_afdZ -data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) - -> *) - (l_afe2 :: TyFun [a_afdP] a_afdP) -type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 - -data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP - -> *) - -> *) (TyFun [a_afdP] a_afdP -> *)) -type instance Apply Foldr1Sym0 l = Foldr1Sym1 l - -type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP - -> *) - -> *) - (a_afe6 :: [a_afdP]) :: a_afdP where - Foldr1 z_afe7 '[x_afe8] = x_afe8 - Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) - Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" - -sFoldr1 :: - forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) - (y :: [a_afdP]). - Sing x - -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) -sFoldr1 _ (SCons _sX SNil) = undefined -sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) - = let - lambda_afeC :: - forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. - Sing f_afe9 - -> Sing x_afea - -> Sing wild_1627448474_afeb - -> Sing wild_1627448476_afec - -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) - lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG - = let - sXs :: - Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) - sXs - = applySing - (applySing - (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) - wild_1627448476_afeG - in - applySing - (applySing f_afeD x_afeE) - (applySing - (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) - sXs) - in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 -sFoldr1 _ SNil = undefined diff --git a/tests/examples/ghc8/determinism001.hs b/tests/examples/ghc8/determinism001.hs deleted file mode 100644 --- a/tests/examples/ghc8/determinism001.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Main where - -import Digraph - -main = mapM_ print - [ test001 - , test002 - , test003 - , test004 - ] - --- These check that the result of SCCs doesn't depend on the order of the key --- type (Int here). - -test001 = testSCC [("a", 1, []), ("b", 2, []), ("c", 3, [])] - -test002 = testSCC [("a", 2, []), ("b", 3, []), ("c", 1, [])] - -test003 = testSCC [("b", 1, []), ("c", 2, []), ("a", 3, [])] - -test004 = testSCC [("b", 2, []), ("c", 3, []), ("a", 1, [])] - -testSCC = flattenSCCs . stronglyConnCompFromEdgedVertices diff --git a/tests/examples/ghc8/dynamic-paper.hs b/tests/examples/ghc8/dynamic-paper.hs deleted file mode 100644 --- a/tests/examples/ghc8/dynamic-paper.hs +++ /dev/null @@ -1,341 +0,0 @@ -{- This is the code extracted from "A reflection on types", by Simon PJ, -Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -} - -{-# LANGUAGE RankNTypes, PolyKinds, TypeOperators, - ScopedTypeVariables, GADTs, FlexibleInstances, - UndecidableInstances, RebindableSyntax, - DataKinds, MagicHash, AutoDeriveTypeable, TypeInType #-} -{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-redundant-constraints #-} - -module Dynamic where - -import Data.Map ( Map ) -import qualified Data.Map as Map -import Unsafe.Coerce ( unsafeCoerce ) -import Control.Monad ( (<=<) ) -import Prelude hiding ( lookup, fromInteger, replicate ) -import qualified Prelude -import qualified Data.Typeable -import qualified Data.Data -import Data.Kind - -lookupMap = Map.lookup -insertMap = Map.insert - --- let's ignore overloaded numbers -fromInteger :: Integer -> Int -fromInteger = Prelude.fromInteger - -insertStore = undefined -schema = undefined -withTypeable = undefined -throw# = undefined - -toDynamicST = undefined -fromDynamicST = undefined - -extendStore :: Typeable a => STRef s a -> a -> Store -> Store -lookupStore :: Typeable a => STRef s a -> Store -> Maybe a - -type Key = Int -data STRef s a = STR Key -type Store = Map Key Dynamic - -extendStore (STR k) v s = insertMap k (toDynamicST v) s -lookupStore (STR k) s = case lookupMap k s of - Just d -> fromDynamicST d - Nothing -> Nothing - -toDynamicST :: Typeable a => a -> Dynamic -fromDynamicST :: Typeable a => Dynamic -> Maybe a - -eval = undefined -data Term - -data DynamicSilly = DIntSilly Int - | DBoolSilly Bool - | DCharSilly Char - | DPairSilly DynamicSilly DynamicSilly - - -toDynInt :: Int -> DynamicSilly -toDynInt = DIntSilly - -fromDynInt :: DynamicSilly -> Maybe Int -fromDynInt (DIntSilly n) = Just n -fromDynInt _ = Nothing - -toDynPair :: DynamicSilly -> DynamicSilly -> DynamicSilly -toDynPair = DPairSilly - -dynFstSilly :: DynamicSilly -> Maybe DynamicSilly -dynFstSilly (DPairSilly x1 x2) = Just x1 -dynFstSilly _ = Nothing - -eval :: Term -> DynamicSilly - -eqT = undefined - -instance Typeable (->) -instance Typeable Maybe -instance Typeable Bool -instance Typeable Int -instance (Typeable a, Typeable b) => Typeable (a b) -instance Typeable (,) - -instance Eq TypeRepX - -data Dynamic where - Dyn :: TypeRep a -> a -> Dynamic - -toDynamic :: Typeable a => a -> Dynamic -toDynamic x = Dyn typeRep x - -eqTNoKind = undefined - -eqTNoKind :: TypeRep a -> TypeRep b -> Maybe (a :***: b) - -- Primitive; implemented by compiler - -data a :***: b where - ReflNoKind :: a :***: a - -fromDynamic :: forall d. Typeable d => Dynamic -> Maybe d -fromDynamic (Dyn (ra :: TypeRep a) (x :: a)) - = case eqT ra (typeRep :: TypeRep d) of - Nothing -> Nothing - Just Refl -> Just x - -fromDynamicMonad :: forall d. Typeable d => Dynamic -> Maybe d - -fromDynamicMonad (Dyn ra x) - = do Refl <- eqT ra (typeRep :: TypeRep d) - return x - -cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b -cast x = do Refl <- eqT (typeRep :: TypeRep a) - (typeRep :: TypeRep b) - return x - -gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b) -gcast x = do Refl <- eqT (typeRep :: TypeRep a) - (typeRep :: TypeRep b) - return x - -data SameKind :: k -> k -> * -type CheckAppResult = SameKind AppResult AppResultNoKind - -- not the most thorough check -foo :: AppResult x -> AppResultNoKind x -foo (App y z) = AppNoKind y z - -splitApp :: TypeRep a -> Maybe (AppResult a) -splitApp = undefined -splitAppNoKind = undefined -splitAppNoKind :: TypeRep a -> Maybe (AppResultNoKind a) - -- Primitive; implemented by compiler - -data AppResultNoKind t where - AppNoKind :: TypeRep a -> TypeRep b -> AppResultNoKind (a b) - -dynFstNoKind :: Dynamic -> Maybe Dynamic -dynFstNoKind (Dyn rpab x) - = do AppNoKind rpa rb <- splitAppNoKind rpab - AppNoKind rp ra <- splitAppNoKind rpa - Refl <- eqT rp (typeRep :: TypeRep (,)) - return (Dyn ra (fst x)) - -dynApply :: Dynamic -> Dynamic -> Maybe Dynamic -dynApply (Dyn rf f) (Dyn rx x) = do - App ra rt2 <- splitApp rf - App rtc rt1 <- splitApp ra - Refl <- eqT rtc (typeRep :: TypeRep (->)) - Refl <- eqT rt1 rx - return (Dyn rt2 (f x)) - -data TypeRepAbstract (a :: k) -- primitive, indexed by type and kind - -class Typeable (a :: k) where - typeRep :: TypeRep a - -data AppResult (t :: k) where - App :: forall k1 k (a :: k1 -> k) (b :: k1). - TypeRep a -> TypeRep b -> AppResult (a b) - -dynFst :: Dynamic -> Maybe Dynamic -dynFst (Dyn (rpab :: TypeRep pab) (x :: pab)) - - = do App (rpa :: TypeRep pa ) (rb :: TypeRep b) <- splitApp rpab - -- introduces kind |k2|, and types |pa :: k2 -> *|, |b :: k2| - - App (rp :: TypeRep p ) (ra :: TypeRep a) <- splitApp rpa - -- introduces kind |k1|, and types |p :: k1 -> k2 -> *|, |a :: k1| - - Refl <- eqT rp (typeRep :: TypeRep (,)) - -- introduces |p ~ (,)| and |(k1 -> k2 -> *) ~ (* -> * -> *)| - - return (Dyn ra (fst x)) - -eqT :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~: b) - -data (a :: k1) :~: (b :: k2) where - Refl :: forall k (a :: k). a :~: a - -castDance :: (Typeable a, Typeable b) => a -> Maybe b -castDance = castR typeRep typeRep - -withTypeable :: TypeRep a -> (Typeable a => r) -> r - -castR :: TypeRep a -> TypeRep b -> a -> Maybe b -castR ta tb = withTypeable ta (withTypeable tb castDance) - -cmpT = undefined -compareTypeRep = undefined - -data TypeRepX where - TypeRepX :: TypeRep a -> TypeRepX - -type TyMapLessTyped = Map TypeRepX Dynamic - -insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped -insertLessTyped x = Map.insert (TypeRepX (typeRep :: TypeRep a)) (toDynamic x) - -lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a -lookupLessTyped = fromDynamic <=< Map.lookup (TypeRepX (typeRep :: TypeRep a)) - -instance Ord TypeRepX where - compare (TypeRepX tr1) (TypeRepX tr2) = compareTypeRep tr1 tr2 - -compareTypeRep :: TypeRep a -> TypeRep b -> Ordering -- primitive - -data TyMap = Empty | Node Dynamic TyMap TyMap - -lookup :: TypeRep a -> TyMap -> Maybe a -lookup tr1 (Node (Dyn tr2 v) left right) = - case compareTypeRep tr1 tr2 of - LT -> lookup tr1 left - EQ -> castR tr2 tr1 v -- know this cast will succeed - GT -> lookup tr1 right -lookup tr1 Empty = Nothing - -cmpT :: TypeRep a -> TypeRep b -> OrderingT a b - -- definition is primitive - -data OrderingT a b where - LTT :: OrderingT a b - EQT :: OrderingT t t - GTT :: OrderingT a b - -data TypeRep (a :: k) where - TrApp :: TypeRep a -> TypeRep b -> TypeRep (a b) - TrTyCon :: TyCon -> TypeRep k -> TypeRep (a :: k) - -data TyCon = TyCon { tc_module :: Module, tc_name :: String } -data Module = Module { mod_pkg :: String, mod_name :: String } - -tcMaybe :: TyCon -tcMaybe = TyCon { tc_module = Module { mod_pkg = "base" - , mod_name = "Data.Maybe" } - , tc_name = "Maybe" } - -rt = undefined - -delta1 :: Dynamic -> Dynamic -delta1 dn = case fromDynamic dn of - Just f -> f dn - Nothing -> dn -loop1 = delta1 (toDynamic delta1) - -data Rid = MkT (forall a. TypeRep a -> a -> a) -rt :: TypeRep Rid -delta :: forall a. TypeRep a -> a -> a -delta ra x = case (eqT ra rt) of - Just Refl -> case x of MkT y -> y rt x - Nothing -> x -loop = delta rt (MkT delta) - -throw# :: SomeException -> a - -data SomeException where - SomeException :: Exception e => e -> SomeException - -class (Typeable e, Show e) => Exception e where { } - -data Company -data Salary -incS :: Float -> Salary -> Salary -incS = undefined - --- some impedance matching with SYB -instance Data.Data.Data Company -instance {-# INCOHERENT #-} Data.Typeable.Typeable a => Typeable a - -mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a -mkT f x = case (cast f) of - Just g -> g x - Nothing -> x - -data Expr a -frontEnd = undefined - -data DynExp where - DE :: TypeRep a -> Expr a -> DynExp - -frontEnd :: String -> DynExp - -data TyConOld - -typeOf = undefined -eqTOld = undefined -funTcOld = undefined :: TyConOld -splitTyConApp = undefined -mkTyCon3 = undefined -boolTcOld = undefined -tupleTc = undefined -mkTyConApp = undefined -instance Eq TypeRepOld -instance Eq TyConOld - -data TypeRepOld -- Abstract - -class TypeableOld a where - typeRepOld :: proxy a -> TypeRepOld - -data DynamicOld where - DynOld :: TypeRepOld -> a -> DynamicOld - -data Proxy a = Proxy - -fromDynamicOld :: forall d. TypeableOld d => DynamicOld -> Maybe d -fromDynamicOld (DynOld trx x) - | typeRepOld (Proxy :: Proxy d) == trx = Just (unsafeCoerce x) - | otherwise = Nothing - -dynApplyOld :: DynamicOld -> DynamicOld -> Maybe DynamicOld -dynApplyOld (DynOld trf f) (DynOld trx x) = - case splitTyConApp trf of - (tc, [t1,t2]) | tc == funTcOld && t1 == trx -> - Just (DynOld t2 ((unsafeCoerce f) x)) - _ -> Nothing - -data DynamicClosed where - DynClosed :: TypeRepClosed a -> a -> DynamicClosed - -data TypeRepClosed (a :: *) where - TBool :: TypeRepClosed Bool - TFun :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a -> b) - TProd :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a, b) - - -lookupPil = undefined - -lookupPil :: Typeable a => [Dynamic] -> Maybe a - -data Dyn1 = Dyn1 Int - | DynFun (Dyn1 -> Dyn1) - | DynPair (Dyn1, Dyn1) - -data TypeEnum = IntType | FloatType | BoolType | DateType | StringType -data Schema = Object [Schema] | - Field TypeEnum | - Array Schema - -schema :: Typeable a => a -> Schema diff --git a/tests/examples/ghc8/export-class.hs b/tests/examples/ghc8/export-class.hs deleted file mode 100644 --- a/tests/examples/ghc8/export-class.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Foo (MyClass(.., P)) where - -pattern P = Nothing - -class MyClass a where - foo :: a -> Int diff --git a/tests/examples/ghc8/export-ps-rec-sel.hs b/tests/examples/ghc8/export-ps-rec-sel.hs deleted file mode 100644 --- a/tests/examples/ghc8/export-ps-rec-sel.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Foo( R(P,x)) where - -data Q = Q Int - -data R = R - -pattern P{x} = Q x diff --git a/tests/examples/ghc8/export-record-selector.hs b/tests/examples/ghc8/export-record-selector.hs deleted file mode 100644 --- a/tests/examples/ghc8/export-record-selector.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Foo ( A(foo) ) where - -data A a = A a - -pattern P :: Int -> A Int -pattern P{foo} = A foo diff --git a/tests/examples/ghc8/export-super-class-fail.hs b/tests/examples/ghc8/export-super-class-fail.hs deleted file mode 100644 --- a/tests/examples/ghc8/export-super-class-fail.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ViewPatterns #-} - -module Foo ( B(P) ) where - -class (f ~ A) => C f a where - build :: a -> f a - destruct :: f a -> a - -data A a = A a - -data B a = B a - -instance C A Int where - build n = A n - destruct (A n) = n - - -pattern P :: C f a => a -> f a -pattern P x <- (destruct -> x) - where - P x = build x diff --git a/tests/examples/ghc8/export-super-class.hs b/tests/examples/ghc8/export-super-class.hs deleted file mode 100644 --- a/tests/examples/ghc8/export-super-class.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ViewPatterns #-} - -module Foo ( A(P) ) where - -class (f ~ A) => C f a where - build :: a -> f a - destruct :: f a -> a - -data A a = A a - -instance C A Int where - build n = A n - destruct (A n) = n - - -pattern P :: C f a => a -> f a -pattern P x <- (destruct -> x) - where - P x = build x diff --git a/tests/examples/ghc8/export-syntax.hs b/tests/examples/ghc8/export-syntax.hs deleted file mode 100644 --- a/tests/examples/ghc8/export-syntax.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Foo(A(.., B)) where - -data A = A | B diff --git a/tests/examples/ghc8/export-type-synonym.hs b/tests/examples/ghc8/export-type-synonym.hs deleted file mode 100644 --- a/tests/examples/ghc8/export-type-synonym.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Foo ( A(P) ) where - -data A = A -data B = B - -type C = B - -pattern P :: C -pattern P = B diff --git a/tests/examples/ghc8/export-type.hs b/tests/examples/ghc8/export-type.hs deleted file mode 100644 --- a/tests/examples/ghc8/export-type.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Export (A(..,MyB), B(MyA), C(MyC)) where - -data A = A - -data B = B - -pattern MyB = B - -pattern MyA = A - -data C a = C - -pattern MyC = B diff --git a/tests/examples/ghc8/frontend01.hs b/tests/examples/ghc8/frontend01.hs deleted file mode 100644 --- a/tests/examples/ghc8/frontend01.hs +++ /dev/null @@ -1,1 +0,0 @@ -main = putStrLn "hello world" diff --git a/tests/examples/ghc8/haddockA034.hs b/tests/examples/ghc8/haddockA034.hs deleted file mode 100644 --- a/tests/examples/ghc8/haddockA034.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -module Hi where - --- | This is a GADT. -data Hi where - -- | This is a GADT constructor. - Hi :: () -> Hi diff --git a/tests/examples/ghc8/listcomps.hs b/tests/examples/ghc8/listcomps.hs deleted file mode 100644 --- a/tests/examples/ghc8/listcomps.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - --- This program must be called with GHC's libdir as the single command line --- argument. -module Main where - --- import Data.Generics -import Data.Data -import Data.List -import System.IO -import GHC -import BasicTypes -import DynFlags -import MonadUtils -import Outputable -import ApiAnnotation -import Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import System.Exit -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Dynamic ( fromDynamic,Dynamic ) - -main::IO() -main = do - [libdir] <- getArgs - testOneFile libdir "ListComprehensions" - exitSuccess - -testOneFile libdir fileName = do - ((anns,cs),p) <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - t <- typecheckModule p - d <- desugarModule t - l <- loadModule d - let ts=typecheckedSource l - r =renamedSource l - return (pm_annotations p,p) - - let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p) - - putStrLn (pp spans) - putStrLn "--------------------------------" - putStrLn (intercalate "\n" [showAnns anns]) - - where - getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))] - getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns - - getAllSrcSpans :: (Data t) => t -> [SrcSpan] - getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast - where - getSrcSpan :: SrcSpan -> [SrcSpan] - getSrcSpan ss = [ss] - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPpr unsafeGlobalDynFlags a - - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/tests/examples/ghc8/mixed-pat-syn-record-sels.hs b/tests/examples/ghc8/mixed-pat-syn-record-sels.hs deleted file mode 100644 --- a/tests/examples/ghc8/mixed-pat-syn-record-sels.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Foo where - - -pattern A { a } = Just a -pattern B { b } = Just b - -foo :: Maybe a -> Maybe Bool -foo x = x { a = True, b = False } diff --git a/tests/examples/ghc8/mkGADTVars.hs b/tests/examples/ghc8/mkGADTVars.hs deleted file mode 100644 --- a/tests/examples/ghc8/mkGADTVars.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE GADTs, TypeInType #-} - -module GADTVars where - -import Data.Kind -import Data.Proxy - -data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where - MkT :: T x1 * (Proxy (y :: x1), z) z diff --git a/tests/examples/ghc8/multi-export.hs b/tests/examples/ghc8/multi-export.hs deleted file mode 100644 --- a/tests/examples/ghc8/multi-export.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Foo (A(B, C)) where - -data A a = A - -pattern B :: A Int -pattern B = A - -pattern C :: A String -pattern C = A diff --git a/tests/examples/ghc8/overloadedlabelsfail01.hs b/tests/examples/ghc8/overloadedlabelsfail01.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedlabelsfail01.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedLabels, DataKinds, FlexibleContexts #-} - -import GHC.OverloadedLabels - --- No instance for (OverloadedLabel "x" t0) -a = #x - --- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0) -b = #x #y - --- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t) -c :: IsLabel "x" t => t -c = #y - -main = return () diff --git a/tests/examples/ghc8/overloadedlabelsrun01.hs b/tests/examples/ghc8/overloadedlabelsrun01.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedlabelsrun01.hs +++ /dev/null @@ -1,29 +0,0 @@ --- Basic tests of overloaded labels - -{-# LANGUAGE OverloadedLabels - , DataKinds - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , NoMonomorphismRestriction - #-} - -import GHC.OverloadedLabels - -instance IsLabel "true" Bool where - fromLabel _ = True - -instance IsLabel "false" Bool where - fromLabel _ = False - -a :: IsLabel "true" t => t -a = #true - -b = #false - -c :: Bool -c = #true - -main = do print (a :: Bool) - print (b :: Bool) - print c diff --git a/tests/examples/ghc8/overloadedlabelsrun02.hs b/tests/examples/ghc8/overloadedlabelsrun02.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedlabelsrun02.hs +++ /dev/null @@ -1,61 +0,0 @@ --- Using overloaded labels to provide nice syntactic sugar for a --- term representation using de Bruijn indices - -{-# LANGUAGE OverloadedLabels - , DataKinds - , FlexibleContexts - , FlexibleInstances - , GADTs - , KindSignatures - , MultiParamTypeClasses - , NoMonomorphismRestriction - , OverlappingInstances - , ScopedTypeVariables - , StandaloneDeriving - , TypeOperators - #-} - -import GHC.OverloadedLabels -import Data.Proxy ( Proxy(..) ) -import GHC.TypeLits ( Symbol ) - -instance x ~ y => IsLabel x (Proxy y) where - fromLabel _ = Proxy - -data Elem (x :: Symbol) g where - Top :: Elem x (x ': g) - Pop :: Elem x g -> Elem x (y ': g) -deriving instance Show (Elem x g) - - -class IsElem x g where - which :: Elem x g - -instance IsElem x (x ': g) where - which = Top - -instance IsElem x g => IsElem x (y ': g) where - which = Pop which - - -data Tm g where - Var :: Elem x g -> Tm g - App :: Tm g -> Tm g -> Tm g - Lam :: Tm (x ': g) -> Tm g -deriving instance Show (Tm g) - -instance IsElem x g => IsLabel x (Tm g) where - fromLabel _ = Var (which :: Elem x g) - -lam :: Proxy x -> Tm (x ': g) -> Tm g -lam _ = Lam - -s = lam #x #x -t = lam #x (lam #y (#x `App` #y)) - -u :: IsElem "z" g => Tm g -u = #z `App` #z - -main = do print s - print t - print (u :: Tm '["z"]) diff --git a/tests/examples/ghc8/overloadedlabelsrun03.hs b/tests/examples/ghc8/overloadedlabelsrun03.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedlabelsrun03.hs +++ /dev/null @@ -1,21 +0,0 @@ --- Using overloaded labels as strings, slightly pointlessly - -{-# LANGUAGE OverloadedLabels - , DataKinds - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , ScopedTypeVariables - , TypeFamilies - , TypeSynonymInstances - #-} - -import GHC.OverloadedLabels -import Data.Proxy ( Proxy(..) ) -import GHC.TypeLits ( KnownSymbol, symbolVal ) - -instance (KnownSymbol x, c ~ Char) => IsLabel x [c] where - fromLabel _ = symbolVal (Proxy :: Proxy x) - -main = do putStrLn #x - print $ #x ++ #y diff --git a/tests/examples/ghc8/overloadedrecflds_generics.hs b/tests/examples/ghc8/overloadedrecflds_generics.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecflds_generics.hs +++ /dev/null @@ -1,50 +0,0 @@ --- Test that DuplicateRecordFields doesn't affect the metadata --- generated by GHC.Generics or Data.Data - --- Based on a Stack Overflow post by bennofs --- (http://stackoverflow.com/questions/24474581) --- licensed under cc by-sa 3.0 - -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} - -import GHC.Generics -import Data.Data -import Data.Proxy - -type family FirstSelector (f :: * -> *) :: Meta -type instance FirstSelector (M1 D x f) = FirstSelector f -type instance FirstSelector (M1 C x f) = FirstSelector f -type instance FirstSelector (a :*: b) = FirstSelector a -type instance FirstSelector (M1 S s f) = s - -data SelectorProxy (s :: Meta) (f :: * -> *) a = SelectorProxy -type SelectorProxy' (s :: Meta) = SelectorProxy s Proxy () - --- Extract the first selector name using GHC.Generics -firstSelectorName :: forall a. Selector (FirstSelector (Rep a)) - => Proxy a -> String -firstSelectorName _ = - selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a))) - --- Extract the list of selector names for a constructor using Data.Data -selectorNames :: Data a => a -> [String] -selectorNames = constrFields . toConstr - -data T = MkT { foo :: Int } deriving (Data, Generic) -data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic) - -main = do -- This should yield "foo", not "$sel:foo:MkT" - print (firstSelectorName (Proxy :: Proxy T)) - -- Similarly this should yield "foo" - print (firstSelectorName (Proxy :: Proxy U)) - -- This should yield ["foo"] - print (selectorNames (MkT 3)) - -- And this should yield ["foo","bar"] - print (selectorNames (MkU 3 True)) diff --git a/tests/examples/ghc8/overloadedrecfldsfail01.hs b/tests/examples/ghc8/overloadedrecfldsfail01.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail01.hs +++ /dev/null @@ -1,19 +0,0 @@ --- Test ambiguous updates are rejected with appropriate error messages - -{-# LANGUAGE DuplicateRecordFields #-} - -data R = MkR { w :: Bool, x :: Int, y :: Bool } -data S = MkS { w :: Bool, x :: Int, y :: Bool } -data T = MkT { x :: Int, z :: Bool } -data U = MkU { y :: Bool } - --- Straightforward ambiguous update -upd1 r = r { x = 3 } - --- No type has all these fields -upd2 r = r { x = 3, y = True, z = False } - --- User-specified type does not have these fields -upd3 r = r { w = True, x = 3, y = True } :: U - -main = return () diff --git a/tests/examples/ghc8/overloadedrecfldsfail02.hs b/tests/examples/ghc8/overloadedrecfldsfail02.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail02.hs +++ /dev/null @@ -1,9 +0,0 @@ --- Test selectors cannot be used ambiguously - -{-# LANGUAGE DuplicateRecordFields #-} - -data R = MkR { x :: Int, y :: Bool } -data S = MkS { x :: Int } - -main = do print (x (MkS 42)) - print (y (MkR 42 42)) diff --git a/tests/examples/ghc8/overloadedrecfldsfail03.hs b/tests/examples/ghc8/overloadedrecfldsfail03.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail03.hs +++ /dev/null @@ -1,10 +0,0 @@ --- Test that a top-level definition with the same name as a record --- field is rejected - -{-# LANGUAGE DuplicateRecordFields #-} - -foo = True - -data T = MkT { foo :: Int } - -main = print foo diff --git a/tests/examples/ghc8/overloadedrecfldsfail04.hs b/tests/examples/ghc8/overloadedrecfldsfail04.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail04.hs +++ /dev/null @@ -1,14 +0,0 @@ --- Test that importing an overloaded field and using it as a selector --- leads to a suitable error - -{-# LANGUAGE DuplicateRecordFields #-} - -import OverloadedRecFldsFail04_A as I - --- Qualified overloaded fields are not allowed here -x' = I.x - --- But this is okay -f e = e { I.x = True, I.y = False } - -main = return () diff --git a/tests/examples/ghc8/overloadedrecfldsfail05.hs b/tests/examples/ghc8/overloadedrecfldsfail05.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail05.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -fwarn-unused-binds -Werror #-} - -module Main (main, T(MkT)) where - -data S = MkS { foo :: Int } -data T = MkT { foo :: Int } - --- This should count as a use of S(foo) but not T(foo) -main = print ((\ MkS{foo=foo} -> foo) (MkS 3)) diff --git a/tests/examples/ghc8/overloadedrecfldsfail06.hs b/tests/examples/ghc8/overloadedrecfldsfail06.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail06.hs +++ /dev/null @@ -1,18 +0,0 @@ --- Check that unused imports are reported correctly in the presence of --- DuplicateRecordFields - -{-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -Werror -fwarn-unused-imports #-} - -import OverloadedRecFldsFail06_A (U(x, y), V(MkV, MkV2, x, y), Unused(unused), u, getY) -import qualified OverloadedRecFldsFail06_A as M (U(x)) -import qualified OverloadedRecFldsFail06_A as N (V(x, y)) -import qualified OverloadedRecFldsFail06_A as P (U(x), V(x)) - -v = MkV2 True - --- Check that this counts a use of U(x) and V(y) but not U(y) or V(x)... -main = do print (u { x = True } :: U) - print ((\ MkV2{y=y} -> y) v) - print (N.x v) - print (getY (v { P.x = 3 })) diff --git a/tests/examples/ghc8/overloadedrecfldsfail07.hs b/tests/examples/ghc8/overloadedrecfldsfail07.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail07.hs +++ /dev/null @@ -1,9 +0,0 @@ --- Test type errors contain field names, not selector names - -{-# LANGUAGE DuplicateRecordFields #-} - -data T = MkT { x :: Int } - -y = x x - -main = return () diff --git a/tests/examples/ghc8/overloadedrecfldsfail08.hs b/tests/examples/ghc8/overloadedrecfldsfail08.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail08.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} - -data family F a -data instance F Int = MkFInt { x :: Int } -data instance F Bool = MkFBool { y :: Bool } - --- No data type has both these fields, but they belong to the same --- lexical parent (F). This used to confuse DuplicateRecordFields. -foo e = e { x = 3, y = True } - -main = return () diff --git a/tests/examples/ghc8/overloadedrecfldsfail09.hs b/tests/examples/ghc8/overloadedrecfldsfail09.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail09.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} - -data S = MkS { x :: Int } -data T = MkT { x :: Int } - --- This tests what happens when an ambiguous record update is used in --- a splice: since it can't be represented in TH, it should error --- cleanly, rather than panicking or silently using one field. -foo = [e| (MkS 3) { x = 3 } |] - -main = return () diff --git a/tests/examples/ghc8/overloadedrecfldsfail10.hs b/tests/examples/ghc8/overloadedrecfldsfail10.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail10.hs +++ /dev/null @@ -1,11 +0,0 @@ --- Modules A and B both declare F(foo) --- Module C declares F($sel:foo:MkFChar) but exports A.F(foo) as well --- Thus we can't export F(..) even with DuplicateRecordFields enabled - -{-# LANGUAGE DuplicateRecordFields #-} -module Main (main, F(..)) where - -import OverloadedRecFldsFail10_B -import OverloadedRecFldsFail10_C - -main = return () diff --git a/tests/examples/ghc8/overloadedrecfldsfail11.hs b/tests/examples/ghc8/overloadedrecfldsfail11.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail11.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -Werror #-} -import OverloadedRecFldsFail11_A - -main = print (foo (MkS True :: S)) diff --git a/tests/examples/ghc8/overloadedrecfldsfail12.hs b/tests/examples/ghc8/overloadedrecfldsfail12.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail12.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -Werror #-} - -import OverloadedRecFldsFail12_A - -data S = MkS { foo :: Bool } - --- Use of foo and bar should give deprecation warnings -f :: T -> T -f e = e { foo = 3, bar = 3 } - -s :: T -> Int -s = foo - -main = return () diff --git a/tests/examples/ghc8/overloadedrecfldsfail13.hs b/tests/examples/ghc8/overloadedrecfldsfail13.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail13.hs +++ /dev/null @@ -1,20 +0,0 @@ --- Test that giving a stupid type annotation to an ambiguous field --- yields a sensible error message - -{-# LANGUAGE DuplicateRecordFields #-} - -data S = MkS { x :: Int } -data T = MkT { x :: Bool } -data U = MkU - -a = x (MkU :: U) - -b = x (MkU :: a) - -c :: U -> Int -c = x - -d :: a -> Int -d = x - -main = return () diff --git a/tests/examples/ghc8/overloadedrecfldsfail14.hs b/tests/examples/ghc8/overloadedrecfldsfail14.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsfail14.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - --- Test that we deal gracefully with non-fields in updates - -data S = MkS { x :: Int } -data T = MkT { x :: Int } - -y :: Bool -y = True - --- y isn't a field -f r = r { x = 3, y = False } - -main = return () diff --git a/tests/examples/ghc8/overloadedrecfldsrun01.hs b/tests/examples/ghc8/overloadedrecfldsrun01.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsrun01.hs +++ /dev/null @@ -1,28 +0,0 @@ --- Test that unambiguous constructions remain valid when --- DuplicateRecordFields is enabled - -{-# LANGUAGE DuplicateRecordFields #-} - -data S = MkS { x :: Int } - deriving Show - -data T = MkT { x :: Bool, y :: Bool -> Bool, tField :: Bool } - -data U a = MkU { x :: a, y :: a } - --- Construction is unambiguous -s = MkS { x = 42 } -t = MkT { x = True, y = id, tField = False } - --- Pattern matching is unambiguous -get_x MkS{x=x} = x - --- Resolving ambiguous monomorphic updates -a = t { x = False, y = not, tField = True } -- only T has all these fields -b = s { x = 3 } :: S -- type being pushed in -c = (t :: T) { x = False } -- type signature on record expression - --- Unambiguous selectors are in scope normally -z = tField t - -main = print (get_x b) diff --git a/tests/examples/ghc8/overloadedrecfldsrun02.hs b/tests/examples/ghc8/overloadedrecfldsrun02.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsrun02.hs +++ /dev/null @@ -1,6 +0,0 @@ --- This module does not enable -XDuplicateRecordFields, but it should --- still be able to refer to non-overloaded fields like `y` - -import OverloadedRecFldsRun02_A - -main = print (y u) diff --git a/tests/examples/ghc8/overloadedrecfldsrun03.hs b/tests/examples/ghc8/overloadedrecfldsrun03.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsrun03.hs +++ /dev/null @@ -1,25 +0,0 @@ --- Test that DuplicateRecordFields can be used along with --- TypeFamilies (with selectors only if unambiguous) - -{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} - -data family F a - -data instance F Int = MkFInt { foo :: Int } -data instance F Bool = MkFBool { bar :: Bool, baz :: Bool } - - -data family G a - -data instance G Int = MkGInt { foo :: Int } -data instance G Bool = MkGBool { bar :: Bool } - -x = MkFBool { bar = False, baz = True } - -y :: F Bool -y = x { bar = True } - -get_bar MkFBool{bar=bar} = bar - -main = do print (baz y) - print (get_bar y) diff --git a/tests/examples/ghc8/overloadedrecfldsrun04.hs b/tests/examples/ghc8/overloadedrecfldsrun04.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsrun04.hs +++ /dev/null @@ -1,30 +0,0 @@ --- Test that DuplicateRecordFields works with TemplateHaskell - -{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - --- Splice in a datatype with field... -$(return [DataD [] (mkName "R") [] [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []]) - --- New TH story means reify only sees R if we do this: -$(return []) - --- ... and check that we can inspect it -main = do putStrLn $(do { info <- reify ''R - ; case info of - TyConI (DataD _ _ _ [RecC _ [(n, _, _)]] _) -> - do { info' <- reify n - ; lift (pprint info ++ "\n" ++ pprint info') - } - _ -> error "unexpected result of reify" - }) - putStrLn $(do { info <- reify 'foo - ; case info of - VarI n _ _ -> - do { info' <- reify n - ; lift (pprint info ++ "\n" ++ pprint info') - } - }) - print (foo (MkR { foo = 42 })) diff --git a/tests/examples/ghc8/overloadedrecfldsrun05.hs b/tests/examples/ghc8/overloadedrecfldsrun05.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsrun05.hs +++ /dev/null @@ -1,27 +0,0 @@ --- Test that DuplicateRecordFields works with NamedFieldPuns and --- RecordWildCards - -{-# LANGUAGE DuplicateRecordFields, NamedFieldPuns, RecordWildCards #-} - -data S = MkS { foo :: Int } - deriving Show -data T = MkT { foo :: Int } - deriving Show - -f MkS{foo} = MkT{foo} - -g MkT{..} = MkS{..} - -h e = let foo = 6 in e { foo } :: S - -main = do print a - print b - print c - print d - where - foo = 42 - - a = MkS{foo} - b = f a - c = g b - d = h c diff --git a/tests/examples/ghc8/overloadedrecfldsrun06.hs b/tests/examples/ghc8/overloadedrecfldsrun06.hs deleted file mode 100644 --- a/tests/examples/ghc8/overloadedrecfldsrun06.hs +++ /dev/null @@ -1,21 +0,0 @@ --- Test that ambiguous selectors can be disambiguated by providing --- type signatures in various places - -{-# LANGUAGE DuplicateRecordFields #-} - -data S = MkS { x :: Int } -data T = MkT { x :: Bool } -data U a = MkU { x :: a } - -x_for_s :: S -> Int -x_for_s = x - -x_for_t = x :: T -> Bool - -x_for_u u = x (u :: U Int) - -k :: (T -> Bool) -> Bool -k f = f (MkT True) - -main = do print (x_for_s (MkS 42)) - print (k x) diff --git a/tests/examples/ghc8/performGC.hs b/tests/examples/ghc8/performGC.hs deleted file mode 100644 --- a/tests/examples/ghc8/performGC.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Main (main) where - --- Test for #10545 - -import System.Environment -import Control.Concurrent -import Control.Exception -import Control.Monad -import RandomPGC -import System.Mem -import qualified Data.Set as Set - -main = do - [n] <- getArgs - forkIO $ doSomeWork - forM [1..read n] $ \n -> do print n; threadDelay 1000; performMinorGC - -doSomeWork :: IO () -doSomeWork = forever $ do - ns <- replicateM 10000 randomIO :: IO [Int] - ms <- replicateM 1000 randomIO - let set = Set.fromList ns - elems = filter (`Set.member` set) ms - evaluate $ sum elems diff --git a/tests/examples/ghc8/plugins07.hs b/tests/examples/ghc8/plugins07.hs deleted file mode 100644 --- a/tests/examples/ghc8/plugins07.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -{-# NOINLINE x #-} -x = "foo" - -main = putStrLn (show x) diff --git a/tests/examples/ghc8/pmc001.hs b/tests/examples/ghc8/pmc001.hs deleted file mode 100644 --- a/tests/examples/ghc8/pmc001.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE TypeFamilies, GADTs #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module PMC001 where - -data family T a - -data instance T [a] where - MkT1 :: T [Int] - MkT2 :: Char -> T [Char] - MkT3 :: T [a] - -f :: T [a] -> T [a] -> Bool -f MkT1 MkT1 = True -f (MkT2 _) (MkT2 _) = True -f MkT3 MkT3 = True - -g :: T [a] -> T [a] -> Bool -g x y - | MkT1 <- x, MkT1 <- y = True - | (MkT2 _) <- x, (MkT2 _) <- y = True - | MkT3 <- x, MkT3 <- y = True diff --git a/tests/examples/ghc8/pmc002.hs b/tests/examples/ghc8/pmc002.hs deleted file mode 100644 --- a/tests/examples/ghc8/pmc002.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module PMC002 where - -f :: [a] -> Bool -f [] = True -f x | (_:_) <- x = False -- exhaustive diff --git a/tests/examples/ghc8/pmc003.hs b/tests/examples/ghc8/pmc003.hs deleted file mode 100644 --- a/tests/examples/ghc8/pmc003.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module PMC003 where - -f :: Bool -> Bool -> () -f _ False = () -f True False = () -f _ _ = () - diff --git a/tests/examples/ghc8/pmc004.hs b/tests/examples/ghc8/pmc004.hs deleted file mode 100644 --- a/tests/examples/ghc8/pmc004.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} -{-# LANGUAGE GADTs #-} - -module PMC004 where - -data F a where - F1 :: F Int - F2 :: F Bool - -data G a where - G1 :: G Int - G2 :: G Char - -h :: F a -> G a -> () -h F1 G1 = () -h _ G1 = () diff --git a/tests/examples/ghc8/pmc005.hs b/tests/examples/ghc8/pmc005.hs deleted file mode 100644 --- a/tests/examples/ghc8/pmc005.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} -{-# LANGUAGE GADTs #-} - -module PMC005 where - -data T a where - TList :: T [a] - TBool :: T Bool - -foo :: T c -> T c -> () -foo TList _ = () -foo _ TList = () diff --git a/tests/examples/ghc8/pmc006.hs b/tests/examples/ghc8/pmc006.hs deleted file mode 100644 --- a/tests/examples/ghc8/pmc006.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module PMC006 where - -len :: [a] -> Int -len xs = case xs of - [] -> 0 - (_:ys) -> case () of - () | (_:_) <- xs -> 1 + len ys - --- -- we would like these to work too but they don't yet --- --- len :: [a] -> Int --- len [] = 0 --- len xs = case xs of --- (_:ys) -> 1 + len ys --- --- len :: [a] -> Int --- len xs = case xs of --- [] -> 0 --- ys -> case ys of --- (_:zs) -> 1 + len zs diff --git a/tests/examples/ghc8/pmc007.hs b/tests/examples/ghc8/pmc007.hs deleted file mode 100644 --- a/tests/examples/ghc8/pmc007.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module PMC007 where - --- overloaded -f "ab" = () -f "ac" = () - --- non-overloaded -g :: String -> () -g "ab" = () -g "ac" = () - --- non-overloaded due to type inference -h :: String -> () -h s = let s' = s - in case s' of - "ab" -> () - "ac" -> () diff --git a/tests/examples/ghc8/poly-export-fail2.hs b/tests/examples/ghc8/poly-export-fail2.hs deleted file mode 100644 --- a/tests/examples/ghc8/poly-export-fail2.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Foo (A(P)) where - -data A = A - -data B = B - -pattern P :: () => (f ~ B) => f -pattern P = B diff --git a/tests/examples/ghc8/poly-export.hs b/tests/examples/ghc8/poly-export.hs deleted file mode 100644 --- a/tests/examples/ghc8/poly-export.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} -module Foo (Foo(P)) where - -data Foo a = Foo a - -instance C Foo where - build a = Foo a - destruct (Foo a) = a - -class C f where - build :: a -> f a - destruct :: f a -> a - -pattern P :: C f => a -> f a -pattern P x <- (destruct -> x) - where - P x = build x diff --git a/tests/examples/ghc8/poly-export2.hs b/tests/examples/ghc8/poly-export2.hs deleted file mode 100644 --- a/tests/examples/ghc8/poly-export2.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE FlexibleInstances #-} -module Foo (A(P,Q)) where - -data A a = A a - -pattern P :: Show a => a -> A a -pattern P a = A a - -pattern Q :: (A ~ f) => a -> f a -pattern Q a = A a diff --git a/tests/examples/ghc8/poly-export3.hs b/tests/examples/ghc8/poly-export3.hs deleted file mode 100644 --- a/tests/examples/ghc8/poly-export3.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} - --- Testing polykindedness - -module Foo ( A(P) ) where - -data A a = A - -pattern P = A diff --git a/tests/examples/ghc8/records-check-sels.hs b/tests/examples/ghc8/records-check-sels.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-check-sels.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Qux where - --- Make sure selectors aren't generated for normal synonyms - -pattern Uni a = Just a - -pattern a :+: b = (a, b) - -qux = a (Just True) diff --git a/tests/examples/ghc8/records-compile.hs b/tests/examples/ghc8/records-compile.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-compile.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module ShouldCompile where - -pattern Single{x} = [x] - --- Selector -selector :: Int -selector = x [5] - -update :: [String] -update = ["String"] { x = "updated" } diff --git a/tests/examples/ghc8/records-exquant.hs b/tests/examples/ghc8/records-exquant.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-exquant.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ExistentialQuantification #-} -module ExQuant where - -data Showable = forall a . Show a => Showable a - -pattern Nasty{a} = Showable a - -qux = a (Showable True) - -foo = (Showable ()) { a = True } diff --git a/tests/examples/ghc8/records-mixing-fields.hs b/tests/examples/ghc8/records-mixing-fields.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-mixing-fields.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -data MyRec = MyRec { foo :: Int, qux :: String } - -pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} - -updater,updater1, updater2 :: MyRec -> MyRec -updater a = a {f1 = 1 } - -updater1 a = a {f1 = 1, qux = "two" } - -updater2 a = a {f1 = 1, foo = 2 } diff --git a/tests/examples/ghc8/records-no-uni-update.hs b/tests/examples/ghc8/records-no-uni-update.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-no-uni-update.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module RecordPats where - --- No updates -pattern Uni{a,b} <- (a, b) - -foo = ("a","b") { a = "b" } diff --git a/tests/examples/ghc8/records-no-uni-update2.hs b/tests/examples/ghc8/records-no-uni-update2.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-no-uni-update2.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module RecordPats where - --- No updates -pattern Uni{a} <- Just a - -qux = a (Just True) - -qux2 (Uni b) = b - -foo = Uni { a = "b" } diff --git a/tests/examples/ghc8/records-poly-update.hs b/tests/examples/ghc8/records-poly-update.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-poly-update.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Main where - -pattern ReqNoProv :: Show a => a -> Maybe a -pattern ReqNoProv{j} = Just j - -data A = A deriving Show - -p1 = Just True - -p6 = p1 {j = A} - -main = print p6 diff --git a/tests/examples/ghc8/records-poly.hs b/tests/examples/ghc8/records-poly.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-poly.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module PolyPat where - --- Testing whether type changing updates work correctly. - -pattern MyTuple :: a -> b -> (a, b) -pattern MyTuple{mfst, msnd} = (mfst, msnd) - - -expr1 :: (Int, String) -> (Int, Int) -expr1 a = a { msnd = 2} - -expr3 a = a { msnd = 2} - -expr2 :: (a, b) -> a -expr2 a = mfst a diff --git a/tests/examples/ghc8/records-prov-req.hs b/tests/examples/ghc8/records-prov-req.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-prov-req.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns, GADTs, RankNTypes, - StandaloneDeriving, FlexibleInstances #-} -module ShouldCompile where - --- Testing that selectors work properly with prov and req thetas - -data T a b where - MkT :: (Show b) => a -> b -> T a b - -deriving instance Show (T Int A) - -data G a b = MkG { care :: a, y :: (Show b => b) } - -pattern ExNumPat :: (Eq b) => (Show b) => b -> T Int b -pattern ExNumPat{x} = MkT 42 x - -data A = A | B deriving (Show, Eq) - -f3 :: T Int A -f3 = (MkT 42 A) { x = B } - -f5 :: T Int A -f5 = (ExNumPat A) { x = B } - - -f4 = (MkG 42 True) { y = False } diff --git a/tests/examples/ghc8/records-req-only.hs b/tests/examples/ghc8/records-req-only.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-req-only.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Main where - -import Prelude (Maybe(..), Show(..), String, Bool(..), print) - -pattern ReqNoProv :: Show a => a -> Maybe a -pattern ReqNoProv{j} = Just j - -p1 = ReqNoProv True - -p7 (ReqNoProv _) = ReqNoProv False - -p6 = p1 {j = False} - -main = print p6 diff --git a/tests/examples/ghc8/records-req.hs b/tests/examples/ghc8/records-req.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-req.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-} - --- Pattern synonyms - -module ShouldCompile where - -data T a where - MkT :: (Eq b) => a -> b -> T a - -f :: (Show a) => a -> Bool -f = undefined - -pattern P{x} <- MkT (f -> True) x diff --git a/tests/examples/ghc8/records-run.hs b/tests/examples/ghc8/records-run.hs deleted file mode 100644 --- a/tests/examples/ghc8/records-run.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Main where - -pattern Bi{a, b} = (a, b) - -foo = ("a","b") - -main = do - print foo - print (a foo) - print (b foo) - print (foo {a = "c"}) - print (foo {a = "fst", b = "snd"}) diff --git a/tests/examples/ghc8/spec-inline-determ.hs b/tests/examples/ghc8/spec-inline-determ.hs deleted file mode 100644 --- a/tests/examples/ghc8/spec-inline-determ.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Roman where - --- This is a simplified version of simplCore/should_compile/spec-inline.hs --- --- It reproduces a problem where workers get specialized in different ways --- depending on the values of uniques. --- --- Compare: --- --- $s$wgo_s1CN :: Int# -> Int -> Int# --- [LclId, Arity=2, Str=DmdType ] --- $s$wgo_s1CN = --- \ (sc_s1CI :: Int#) (sc_s1CJ :: Int) -> --- case tagToEnum# @ Bool (<=# sc_s1CI 0#) of _ [Occ=Dead] { --- False -> --- $wgo_s1BU (Just @ Int (I# (-# sc_s1CI 1#))) (Just @ Int sc_s1CJ); --- True -> 0# --- } --- --- vs --- --- $s$wgo_s18mTj :: Int -> Int# -> Int# --- [LclId, Arity=2, Str=DmdType ] --- $s$wgo_s18mTj = --- \ (sc_s18mTn :: Int) (sc_s18mTo :: Int#) -> --- case tagToEnum# @ Bool (<=# sc_s18mTo 0#) of _ [Occ=Dead] { --- False -> --- $wgo_s18mUc --- (Just @ Int (I# (-# sc_s18mTo 1#))) (Just @ Int sc_s18mTn); --- True -> 0# --- } - -foo :: Int -> Int -foo n = - go (Just n) (Just (6::Int)) - where - go Nothing (Just x) = go (Just 10) (Just x) - go (Just n) (Just x) - | n <= 0 = 0 - | otherwise = go (Just (n-1)) (Just x) diff --git a/tests/examples/ghc8/stringSource.hs b/tests/examples/ghc8/stringSource.hs deleted file mode 100644 --- a/tests/examples/ghc8/stringSource.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - --- This program must be called with GHC's libdir as the single command line --- argument. -module Main where - --- import Data.Generics -import Data.Data -import Data.List -import System.IO -import GHC -import BasicTypes -import DynFlags -import FastString -import ForeignCall -import MonadUtils -import Outputable -import HsDecls -import Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import qualified Data.Map as Map -import Data.Dynamic ( fromDynamic,Dynamic ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName - -testOneFile libdir fileName = do - ((anns,cs),p) <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - return (pm_annotations p,p) - - let tupArgs = gq (pm_parsed_source p) - - putStrLn (pp tupArgs) - -- putStrLn (intercalate "\n" [showAnns anns]) - - where - gq ast = everything (++) ([] `mkQ` doWarningTxt - `extQ` doImportDecl - `extQ` doCType - `extQ` doRuleDecl - `extQ` doCCallTarget - `extQ` doHsExpr - ) ast - - doWarningTxt :: WarningTxt -> [(String,[Located (SourceText,FastString)])] - doWarningTxt ((WarningTxt _ ss)) = [("w",map conv ss)] - doWarningTxt ((DeprecatedTxt _ ss)) = [("d",map conv ss)] - - doImportDecl :: ImportDecl RdrName - -> [(String,[Located (SourceText,FastString)])] - doImportDecl (ImportDecl _ _ Nothing _ _ _ _ _ _) = [] - doImportDecl (ImportDecl _ _ (Just ss) _ _ _ _ _ _) - = [("i",[conv (noLoc ss)])] - - doCType :: CType -> [(String,[Located (SourceText,FastString)])] - doCType (CType src (Just (Header hs hf)) c) - = [("c",[noLoc (hs,hf),noLoc c])] - doCType (CType src Nothing c) = [("c",[noLoc c])] - - doRuleDecl :: RuleDecl RdrName - -> [(String,[Located (SourceText,FastString)])] - doRuleDecl (HsRule ss _ _ _ _ _ _) = [("r",[ss])] - - doCCallTarget :: CCallTarget - -> [(String,[Located (SourceText,FastString)])] - doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])] - - doHsExpr :: HsExpr RdrName -> [(String,[Located (SourceText,FastString)])] - doHsExpr (HsCoreAnn src ss _) = [("co",[conv (noLoc ss)])] - doHsExpr (HsSCC src ss _) = [("sc",[conv (noLoc ss)])] - doHsExpr (HsTickPragma src (ss,_,_) _) = [("tp",[conv (noLoc ss)])] - doHsExpr _ = [] - - conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs) - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPpr unsafeGlobalDynFlags a - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - --- | Extend a generic query by a type-specific case -extQ :: ( Typeable a - , Typeable b - ) - => (a -> q) - -> (b -> q) - -> a - -> q -extQ f g a = maybe (f a) g (cast a) - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/tests/examples/ghc8/t10255.hs b/tests/examples/ghc8/t10255.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10255.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10268.hs b/tests/examples/ghc8/t10268.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10268.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10269.hs b/tests/examples/ghc8/t10269.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10269.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10278.hs b/tests/examples/ghc8/t10278.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10278.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10280.hs b/tests/examples/ghc8/t10280.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10280.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10307.hs b/tests/examples/ghc8/t10307.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10307.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10309.hs b/tests/examples/ghc8/t10309.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10309.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10312.hs b/tests/examples/ghc8/t10312.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10312.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10354.hs b/tests/examples/ghc8/t10354.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10354.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10357.hs b/tests/examples/ghc8/t10357.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10357.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10358.hs b/tests/examples/ghc8/t10358.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10358.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10396.hs b/tests/examples/ghc8/t10396.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10396.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/t10399.hs b/tests/examples/ghc8/t10399.hs deleted file mode 100644 --- a/tests/examples/ghc8/t10399.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc8/tc265.hs b/tests/examples/ghc8/tc265.hs deleted file mode 100644 --- a/tests/examples/ghc8/tc265.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module Tc265 where - -data T a = MkT (F a) -type family F a where - F (T a) = a - F (T Int) = Bool diff --git a/tests/examples/ghc8/tcfail223.hs b/tests/examples/ghc8/tcfail223.hs deleted file mode 100644 --- a/tests/examples/ghc8/tcfail223.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} -module ShouldFail where - -class Class1 a -class Class1 a => Class2 a -class Class2 a => Class3 a - --- This was wrongfully accepted by ghc-7.0 to ghc-7.10. --- It is missing a `Class1 a` constraint. -instance Class3 a => Class2 a diff --git a/tests/examples/ghc8/update-existential.hs b/tests/examples/ghc8/update-existential.hs deleted file mode 100644 --- a/tests/examples/ghc8/update-existential.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE - NoImplicitPrelude - , ExistentialQuantification - #-} - -module Test where - -hGetContents handle_ = handle_{ haType=SemiClosedHandle} - -data HandleType = SemiClosedHandle - -class Show a where - show :: a -> a - --- they have to check whether the handle has indeed been closed. -data Handle__ - = forall dev . (Show dev) => - Handle__ { - haDevice :: !dev, - haType :: HandleType -- type (read/write/append etc.) -} diff --git a/tests/examples/ghc80/A.hs b/tests/examples/ghc80/A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/A.hs @@ -0,0 +1,4 @@ +module A where + +class A a where + has :: a diff --git a/tests/examples/ghc80/AddParams2.hs b/tests/examples/ghc80/AddParams2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/AddParams2.hs @@ -0,0 +1,9 @@ +module AddParams2 where + +collapse rightInner rightOuter = right + where + right = (rightInner, rightOuter) + righ2 = (rightInner, (rightOuter baz bar)) + +baz = undefined +bar = undefined diff --git a/tests/examples/ghc80/Associated.hs b/tests/examples/ghc80/Associated.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Associated.hs @@ -0,0 +1,9 @@ +module Associated(A(..)) where + +import AssociatedInternal (A(..)) + +foo = MkA 5 +baz = NoA + +qux (MkA x) = x +qux NoA = 0 diff --git a/tests/examples/ghc80/AssociatedInternal.hs b/tests/examples/ghc80/AssociatedInternal.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/AssociatedInternal.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} +module AssociatedInternal (A(NewA,MkA, NoA)) where + +newtype A = NewA (Maybe Int) + +pattern MkA n = NewA (Just n) + +pattern NoA = NewA Nothing diff --git a/tests/examples/ghc80/B.hs b/tests/examples/ghc80/B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/B.hs @@ -0,0 +1,4 @@ +module B where + +class B a where + has :: a diff --git a/tests/examples/ghc80/BadTelescope.hs b/tests/examples/ghc80/BadTelescope.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/BadTelescope.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeInType #-} + +module BadTelescope where + +import Data.Kind + +data SameKind :: k -> k -> * + +data X a k (b :: k) (c :: SameKind a b) diff --git a/tests/examples/ghc80/BadTelescope2.hs b/tests/examples/ghc80/BadTelescope2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/BadTelescope2.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeInType, ExplicitForAll #-} + +module BadTelescope2 where + +import Data.Kind +import Data.Proxy + +data SameKind :: k -> k -> * + +foo :: forall a k (b :: k). SameKind a b +foo = undefined + +bar :: forall a (c :: Proxy b) (d :: Proxy a). Proxy c -> SameKind b d +bar = undefined diff --git a/tests/examples/ghc80/BadTelescope3.hs b/tests/examples/ghc80/BadTelescope3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/BadTelescope3.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeInType, ExplicitForAll #-} + +module BadTelescope3 where + +import Data.Kind + +data SameKind :: k -> k -> * + +type S a k (b :: k) = SameKind a b diff --git a/tests/examples/ghc80/BadTelescope4.hs b/tests/examples/ghc80/BadTelescope4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/BadTelescope4.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ExistentialQuantification, TypeInType #-} +module BadTelescope4 where + +import Data.Proxy +import Data.Kind + +data SameKind :: k -> k -> * + +data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +data Borked a (b :: k) = forall (c :: k). B (Proxy c) + -- this last one is OK. But there was a bug involving renaming + -- that failed here, so the test case remains. diff --git a/tests/examples/ghc80/Base.hs b/tests/examples/ghc80/Base.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Base.hs @@ -0,0 +1,6 @@ +module Base (AClass(..), BClass()) where + +import Extends (BClass ()) + +class AClass a where + has :: a diff --git a/tests/examples/ghc80/Bundle.hs b/tests/examples/ghc80/Bundle.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Bundle.hs @@ -0,0 +1,9 @@ +module Bundle(A(..)) where + +import BundleInternal (A(..)) + +foo = MkA 5 +baz = NoA + +qux (MkA x) = x +qux NoA = 0 diff --git a/tests/examples/ghc80/Bundle1.hs b/tests/examples/ghc80/Bundle1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Bundle1.hs @@ -0,0 +1,9 @@ +module Associated1(A(..)) where + +import BundleInternal1 (A(..)) + +foo = MkA 5 +baz = NoA + +qux (MkA x) = x +qux NoA = 0 diff --git a/tests/examples/ghc80/BundleExport.hs b/tests/examples/ghc80/BundleExport.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/BundleExport.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +module BundleExport(P(.., A), Q(B)) where + +data P = P + +data Q = Q + +pattern A = P +pattern B = Q diff --git a/tests/examples/ghc80/BundleInternal.hs b/tests/examples/ghc80/BundleInternal.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/BundleInternal.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} +module BundleInternal (A(NewA,MkA, NoA)) where + +newtype A = NewA (Maybe Int) + +pattern MkA n = NewA (Just n) + +pattern NoA = NewA Nothing diff --git a/tests/examples/ghc80/BundleInternal1.hs b/tests/examples/ghc80/BundleInternal1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/BundleInternal1.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} +module BundleInternal1 (A(NewA,MkA, NoA)) where + +newtype A = NewA (Maybe Int) + +pattern MkA n = NewA (Just n) + +pattern NoA = NewA Nothing diff --git a/tests/examples/ghc80/C.hs b/tests/examples/ghc80/C.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/C.hs @@ -0,0 +1,3 @@ +module C (oops) where + +import {-# SOURCE #-} B diff --git a/tests/examples/ghc80/CheckUtils.hs b/tests/examples/ghc80/CheckUtils.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/CheckUtils.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE RankNTypes #-} + +-- This program must be called with GHC's libdir and the file to be checked as +-- the command line arguments. +module CheckUtils where + +import Data.Data +import Data.List +import System.IO +import GHC +import BasicTypes +import DynFlags +import MonadUtils +import Outputable +import ApiAnnotation +import Bag (filterBag,isEmptyBag) +import System.Directory (removeFile) +import System.Environment( getArgs ) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Dynamic ( fromDynamic,Dynamic ) + +_main::IO() +_main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName + +testOneFile libdir fileName = do + ((anns,cs),p) <- runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags + let mn =mkModuleName fileName + addTarget Target { targetId = TargetModule mn + , targetAllowObjCode = True + , targetContents = Nothing } + load LoadAllTargets + modSum <- getModSummary mn + p <- parseModule modSum + return (pm_annotations p,p) + + let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p) + + problems = filter (\(s,a) -> not (Set.member s spans)) + $ getAnnSrcSpans (anns,cs) + + exploded = [((kw,ss),[anchor]) + | ((anchor,kw),sss) <- Map.toList anns,ss <- sss] + + exploded' = Map.toList $ Map.fromListWith (++) exploded + + problems' = filter (\(_,anchors) + -> not (any (\a -> Set.member a spans) anchors)) + exploded' + + putStrLn "---Problems---------------------" + putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems]) + putStrLn "---Problems'--------------------" + putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems']) + putStrLn "--------------------------------" + putStrLn (intercalate "\n" [showAnns anns]) + + where + getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))] + getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns + + getAllSrcSpans :: (Data t) => t -> [SrcSpan] + getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast + where + getSrcSpan :: SrcSpan -> [SrcSpan] + getSrcSpan ss = [ss] + + +showAnns anns = "[\n" ++ (intercalate "\n" + $ map (\((s,k),v) + -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) + $ Map.toList anns) + ++ "]\n" + +pp a = showPpr unsafeGlobalDynFlags a + + +-- --------------------------------------------------------------------- + +-- Copied from syb for the test + + +-- | Generic queries of type \"r\", +-- i.e., take any \"a\" and return an \"r\" +-- +type GenericQ r = forall a. Data a => a -> r + + +-- | Make a generic query; +-- start from a type-specific case; +-- return a constant otherwise +-- +mkQ :: ( Typeable a + , Typeable b + ) + => r + -> (b -> r) + -> a + -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + + + +-- | Summarise all nodes in top-down, left-to-right order +everything :: (r -> r -> r) -> GenericQ r -> GenericQ r + +-- Apply f to x to summarise top-level node; +-- use gmapQ to recurse into immediate subterms; +-- use ordinary foldl to reduce list of intermediate results + +everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/tests/examples/ghc80/Class.hs b/tests/examples/ghc80/Class.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Class.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE UndecidableInstances #-} +module Servant.Auth.Server.Internal.Class where + +import Servant.Auth +import Data.Monoid +import Servant hiding (BasicAuth) + +import Servant.Auth.Server.Internal.Types +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.BasicAuth +import Servant.Auth.Server.Internal.Cookie +import Servant.Auth.Server.Internal.JWT + +-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all +-- elements of @ctx@ to be the in the Context and whose authentication check +-- returns an @AuthCheck v@. +class IsAuth a v where + type family AuthArgs a :: [*] + runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v) + diff --git a/tests/examples/ghc80/ClosedFam1a.hs b/tests/examples/ghc80/ClosedFam1a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ClosedFam1a.hs @@ -0,0 +1,3 @@ +module ClosedFam1a where + +import {-# SOURCE #-} ClosedFam1 diff --git a/tests/examples/ghc80/ClosedFam2a.hs b/tests/examples/ghc80/ClosedFam2a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ClosedFam2a.hs @@ -0,0 +1,2 @@ +module ClosedFam2a where +import {-# SOURCE #-} ClosedFam2 diff --git a/tests/examples/ghc80/ClosedFam3a.hs b/tests/examples/ghc80/ClosedFam3a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ClosedFam3a.hs @@ -0,0 +1,3 @@ +module ClosedFam3a where + +import {-# SOURCE #-} ClosedFam3 diff --git a/tests/examples/ghc80/CmmSwitchTest.hs b/tests/examples/ghc80/CmmSwitchTest.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/CmmSwitchTest.hs @@ -0,0 +1,505 @@ +{-# LANGUAGE MagicHash #-} +import Control.Monad (unless, forM_) +import GHC.Exts +{-# NOINLINE aa #-} +aa :: Int# -> Int# +aa 1# = 42# +aa 2# = 43# +aa 3# = 43# +aa 4# = 44# +aa 5# = 44# +aa 6# = 45# +aa 7# = 45# +aa 8# = 46# +aa 9# = 46# +aa 10# = 47# +aa _ = 1337# + +{-# NOINLINE ab #-} +ab :: Int# -> Int# +ab 0# = 42# +ab 1# = 42# +ab 2# = 43# +ab 3# = 43# +ab 4# = 44# +ab 5# = 44# +ab 6# = 45# +ab 7# = 45# +ab 8# = 46# +ab 9# = 46# +ab 10# = 47# +ab _ = 1337# + +{-# NOINLINE ac #-} +ac :: Int# -> Int# +ac 1# = 42# +ac 2# = 43# +ac 3# = 43# +ac _ = 1337# + +{-# NOINLINE ad #-} +ad :: Int# -> Int# +ad 1# = 42# +ad 2# = 43# +ad 3# = 43# +ad 4# = 44# +ad _ = 1337# + +{-# NOINLINE ae #-} +ae :: Int# -> Int# +ae 1# = 42# +ae 2# = 43# +ae 3# = 43# +ae 4# = 44# +ae 5# = 44# +ae _ = 1337# + +{-# NOINLINE af #-} +af :: Int# -> Int# +af -1# = 41# +af 0# = 42# +af 1# = 42# +af 2# = 43# +af 3# = 43# +af 4# = 44# +af 5# = 44# +af 6# = 45# +af 7# = 45# +af 8# = 46# +af 9# = 46# +af 10# = 47# +af _ = 1337# + +{-# NOINLINE ag #-} +ag :: Int# -> Int# +ag -10# = 37# +ag -9# = 37# +ag -8# = 38# +ag -7# = 38# +ag -6# = 39# +ag -5# = 39# +ag -4# = 40# +ag -3# = 40# +ag -2# = 41# +ag -1# = 41# +ag 0# = 42# +ag 1# = 42# +ag 2# = 43# +ag 3# = 43# +ag 4# = 44# +ag 5# = 44# +ag 6# = 45# +ag 7# = 45# +ag 8# = 46# +ag 9# = 46# +ag 10# = 47# +ag _ = 1337# + +{-# NOINLINE ah #-} +ah :: Int# -> Int# +ah -20# = 32# +ah -19# = 32# +ah -18# = 33# +ah -17# = 33# +ah -16# = 34# +ah -15# = 34# +ah -14# = 35# +ah -13# = 35# +ah -12# = 36# +ah -11# = 36# +ah -10# = 37# +ah 0# = 42# +ah 1# = 42# +ah 2# = 43# +ah 3# = 43# +ah 4# = 44# +ah 5# = 44# +ah 6# = 45# +ah 7# = 45# +ah 8# = 46# +ah 9# = 46# +ah 10# = 47# +ah _ = 1337# + +{-# NOINLINE ai #-} +ai :: Int# -> Int# +ai -20# = 32# +ai -19# = 32# +ai -18# = 33# +ai -17# = 33# +ai -16# = 34# +ai -15# = 34# +ai -14# = 35# +ai -13# = 35# +ai -12# = 36# +ai -11# = 36# +ai -10# = 37# +ai 1# = 42# +ai 2# = 43# +ai 3# = 43# +ai 4# = 44# +ai 5# = 44# +ai 6# = 45# +ai 7# = 45# +ai 8# = 46# +ai 9# = 46# +ai 10# = 47# +ai _ = 1337# + +{-# NOINLINE aj #-} +aj :: Int# -> Int# +aj -9223372036854775808# = -4611686018427387862# +aj 0# = 42# +aj 9223372036854775807# = 4611686018427387945# +aj _ = 1337# + +{-# NOINLINE ak #-} +ak :: Int# -> Int# +ak 9223372036854775797# = 4611686018427387940# +ak 9223372036854775798# = 4611686018427387941# +ak 9223372036854775799# = 4611686018427387941# +ak 9223372036854775800# = 4611686018427387942# +ak 9223372036854775801# = 4611686018427387942# +ak 9223372036854775802# = 4611686018427387943# +ak 9223372036854775803# = 4611686018427387943# +ak 9223372036854775804# = 4611686018427387944# +ak 9223372036854775805# = 4611686018427387944# +ak 9223372036854775806# = 4611686018427387945# +ak 9223372036854775807# = 4611686018427387945# +ak _ = 1337# + +{-# NOINLINE al #-} +al :: Int# -> Int# +al -9223372036854775808# = -4611686018427387862# +al -9223372036854775807# = -4611686018427387862# +al -9223372036854775806# = -4611686018427387861# +al -9223372036854775805# = -4611686018427387861# +al -9223372036854775804# = -4611686018427387860# +al -9223372036854775803# = -4611686018427387860# +al -9223372036854775802# = -4611686018427387859# +al -9223372036854775801# = -4611686018427387859# +al -9223372036854775800# = -4611686018427387858# +al -9223372036854775799# = -4611686018427387858# +al -9223372036854775798# = -4611686018427387857# +al 9223372036854775797# = 4611686018427387940# +al 9223372036854775798# = 4611686018427387941# +al 9223372036854775799# = 4611686018427387941# +al 9223372036854775800# = 4611686018427387942# +al 9223372036854775801# = 4611686018427387942# +al 9223372036854775802# = 4611686018427387943# +al 9223372036854775803# = 4611686018427387943# +al 9223372036854775804# = 4611686018427387944# +al 9223372036854775805# = 4611686018427387944# +al 9223372036854775806# = 4611686018427387945# +al 9223372036854775807# = 4611686018427387945# +al _ = 1337# + +{-# NOINLINE am #-} +am :: Word# -> Word# +am 0## = 42## +am 1## = 42## +am 2## = 43## +am 3## = 43## +am 4## = 44## +am 5## = 44## +am 6## = 45## +am 7## = 45## +am 8## = 46## +am 9## = 46## +am 10## = 47## +am _ = 1337## + +{-# NOINLINE an #-} +an :: Word# -> Word# +an 1## = 42## +an 2## = 43## +an 3## = 43## +an 4## = 44## +an 5## = 44## +an 6## = 45## +an 7## = 45## +an 8## = 46## +an 9## = 46## +an 10## = 47## +an _ = 1337## + +{-# NOINLINE ao #-} +ao :: Word# -> Word# +ao 0## = 42## +ao _ = 1337## + +{-# NOINLINE ap #-} +ap :: Word# -> Word# +ap 0## = 42## +ap 1## = 42## +ap _ = 1337## + +{-# NOINLINE aq #-} +aq :: Word# -> Word# +aq 0## = 42## +aq 1## = 42## +aq 2## = 43## +aq _ = 1337## + +{-# NOINLINE ar #-} +ar :: Word# -> Word# +ar 0## = 42## +ar 1## = 42## +ar 2## = 43## +ar 3## = 43## +ar _ = 1337## + +{-# NOINLINE as #-} +as :: Word# -> Word# +as 0## = 42## +as 1## = 42## +as 2## = 43## +as 3## = 43## +as 4## = 44## +as _ = 1337## + +{-# NOINLINE at #-} +at :: Word# -> Word# +at 1## = 42## +at _ = 1337## + +{-# NOINLINE au #-} +au :: Word# -> Word# +au 1## = 42## +au 2## = 43## +au _ = 1337## + +{-# NOINLINE av #-} +av :: Word# -> Word# +av 1## = 42## +av 2## = 43## +av 3## = 43## +av _ = 1337## + +{-# NOINLINE aw #-} +aw :: Word# -> Word# +aw 1## = 42## +aw 2## = 43## +aw 3## = 43## +aw 4## = 44## +aw _ = 1337## + +{-# NOINLINE ax #-} +ax :: Word# -> Word# +ax 1## = 42## +ax 2## = 43## +ax 3## = 43## +ax 4## = 44## +ax 5## = 44## +ax _ = 1337## + +{-# NOINLINE ay #-} +ay :: Word# -> Word# +ay 0## = 42## +ay 18446744073709551615## = 9223372036854775849## +ay _ = 1337## + +{-# NOINLINE az #-} +az :: Word# -> Word# +az 18446744073709551605## = 9223372036854775844## +az 18446744073709551606## = 9223372036854775845## +az 18446744073709551607## = 9223372036854775845## +az 18446744073709551608## = 9223372036854775846## +az 18446744073709551609## = 9223372036854775846## +az 18446744073709551610## = 9223372036854775847## +az 18446744073709551611## = 9223372036854775847## +az 18446744073709551612## = 9223372036854775848## +az 18446744073709551613## = 9223372036854775848## +az 18446744073709551614## = 9223372036854775849## +az 18446744073709551615## = 9223372036854775849## +az _ = 1337## + +{-# NOINLINE ba #-} +ba :: Word# -> Word# +ba 0## = 42## +ba 1## = 42## +ba 2## = 43## +ba 3## = 43## +ba 4## = 44## +ba 5## = 44## +ba 6## = 45## +ba 7## = 45## +ba 8## = 46## +ba 9## = 46## +ba 10## = 47## +ba 18446744073709551605## = 9223372036854775844## +ba 18446744073709551606## = 9223372036854775845## +ba 18446744073709551607## = 9223372036854775845## +ba 18446744073709551608## = 9223372036854775846## +ba 18446744073709551609## = 9223372036854775846## +ba 18446744073709551610## = 9223372036854775847## +ba 18446744073709551611## = 9223372036854775847## +ba 18446744073709551612## = 9223372036854775848## +ba 18446744073709551613## = 9223372036854775848## +ba 18446744073709551614## = 9223372036854775849## +ba 18446744073709551615## = 9223372036854775849## +ba _ = 1337## + +aa_check :: IO () +aa_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (aa i) + unless (r == o) $ putStrLn $ "ERR: aa (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ab_check :: IO () +ab_check = forM_ [(-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (ab i) + unless (r == o) $ putStrLn $ "ERR: ab (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ac_check :: IO () +ac_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(I# i,o) -> do + let r = I# (ac i) + unless (r == o) $ putStrLn $ "ERR: ac (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ad_check :: IO () +ad_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(I# i,o) -> do + let r = I# (ad i) + unless (r == o) $ putStrLn $ "ERR: ad (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ae_check :: IO () +ae_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(I# i,o) -> do + let r = I# (ae i) + unless (r == o) $ putStrLn $ "ERR: ae (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +af_check :: IO () +af_check = forM_ [(-2,1337), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (af i) + unless (r == o) $ putStrLn $ "ERR: af (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ag_check :: IO () +ag_check = forM_ [(-11,1337), (-10,37), (-9,37), (-8,38), (-7,38), (-6,39), (-5,39), (-4,40), (-3,40), (-2,41), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (ag i) + unless (r == o) $ putStrLn $ "ERR: ag (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ah_check :: IO () +ah_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (ah i) + unless (r == o) $ putStrLn $ "ERR: ah (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ai_check :: IO () +ai_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do + let r = I# (ai i) + unless (r == o) $ putStrLn $ "ERR: ai (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +aj_check :: IO () +aj_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,1337), (-1,1337), (0,42), (1,1337), (9223372036854775806,1337), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do + let r = I# (aj i) + unless (r == o) $ putStrLn $ "ERR: aj (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ak_check :: IO () +ak_check = forM_ [(9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do + let r = I# (ak i) + unless (r == o) $ putStrLn $ "ERR: ak (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +al_check :: IO () +al_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,-4611686018427387862), (-9223372036854775806,-4611686018427387861), (-9223372036854775805,-4611686018427387861), (-9223372036854775804,-4611686018427387860), (-9223372036854775803,-4611686018427387860), (-9223372036854775802,-4611686018427387859), (-9223372036854775801,-4611686018427387859), (-9223372036854775800,-4611686018427387858), (-9223372036854775799,-4611686018427387858), (-9223372036854775798,-4611686018427387857), (-9223372036854775797,1337), (9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do + let r = I# (al i) + unless (r == o) $ putStrLn $ "ERR: al (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +am_check :: IO () +am_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do + let r = W# (am i) + unless (r == o) $ putStrLn $ "ERR: am (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +an_check :: IO () +an_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do + let r = W# (an i) + unless (r == o) $ putStrLn $ "ERR: an (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ao_check :: IO () +ao_check = forM_ [(0,42), (1,1337)] $ \(W# i,o) -> do + let r = W# (ao i) + unless (r == o) $ putStrLn $ "ERR: ao (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ap_check :: IO () +ap_check = forM_ [(0,42), (1,42), (2,1337)] $ \(W# i,o) -> do + let r = W# (ap i) + unless (r == o) $ putStrLn $ "ERR: ap (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +aq_check :: IO () +aq_check = forM_ [(0,42), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do + let r = W# (aq i) + unless (r == o) $ putStrLn $ "ERR: aq (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ar_check :: IO () +ar_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do + let r = W# (ar i) + unless (r == o) $ putStrLn $ "ERR: ar (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +as_check :: IO () +as_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do + let r = W# (as i) + unless (r == o) $ putStrLn $ "ERR: as (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +at_check :: IO () +at_check = forM_ [(0,1337), (1,42), (2,1337)] $ \(W# i,o) -> do + let r = W# (at i) + unless (r == o) $ putStrLn $ "ERR: at (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +au_check :: IO () +au_check = forM_ [(0,1337), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do + let r = W# (au i) + unless (r == o) $ putStrLn $ "ERR: au (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +av_check :: IO () +av_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do + let r = W# (av i) + unless (r == o) $ putStrLn $ "ERR: av (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +aw_check :: IO () +aw_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do + let r = W# (aw i) + unless (r == o) $ putStrLn $ "ERR: aw (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ax_check :: IO () +ax_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(W# i,o) -> do + let r = W# (ax i) + unless (r == o) $ putStrLn $ "ERR: ax (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ay_check :: IO () +ay_check = forM_ [(0,42), (1,1337), (18446744073709551614,1337), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do + let r = W# (ay i) + unless (r == o) $ putStrLn $ "ERR: ay (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +az_check :: IO () +az_check = forM_ [(18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do + let r = W# (az i) + unless (r == o) $ putStrLn $ "ERR: az (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +ba_check :: IO () +ba_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337), (18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do + let r = W# (ba i) + unless (r == o) $ putStrLn $ "ERR: ba (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." + +main = do + aa_check + ab_check + ac_check + ad_check + ae_check + af_check + ag_check + ah_check + ai_check + aj_check + ak_check + al_check + am_check + an_check + ao_check + ap_check + aq_check + ar_check + as_check + at_check + au_check + av_check + aw_check + ax_check + ay_check + az_check + ba_check diff --git a/tests/examples/ghc80/CmmSwitchTestGen.hs b/tests/examples/ghc80/CmmSwitchTestGen.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/CmmSwitchTestGen.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE TupleSections #-} + +-- Generates CmmSwitch.hs + +import qualified Data.Set as S +import Data.Word +import Data.List + +output :: Integer -> Integer +output n = n`div`2 + 42 + +def :: Integer +def = 1337 + +type Spec = (String, Bool, [Integer]) + +primtyp True = "Int#" +primtyp False = "Word#" + +con True = "I#" +con False = "W#" + +hash True = "#" +hash False = "##" + +primLit s v = show v ++ hash s + +genSwitch :: Spec -> String +genSwitch (name, signed, values) = unlines $ + [ "{-# NOINLINE " ++ name ++ " #-}" ] ++ + [ name ++ " :: " ++ primtyp signed ++ " -> " ++ primtyp signed ] ++ + [ name ++ " " ++ primLit signed v ++ " = " ++ primLit signed (output v) + | v <- values] ++ + [ name ++ " _ = " ++ primLit signed def ] + +genCheck :: Spec -> String +genCheck (name, signed, values) = unlines $ + [ checkName name ++ " :: IO ()" + , checkName name ++ " = forM_ [" ++ pairs ++ "] $ \\(" ++ con signed ++ " i,o) -> do" + , " let r = " ++ con signed ++ " (" ++ name ++ " i)" + , " unless (r == o) $ putStrLn $ \"ERR: " ++ name ++ " (\" ++ show (" ++ con signed ++ " i)++ \") is \" ++ show r ++ \" and not \" ++ show o ++\".\"" + ] + where + f x | x `S.member` range = output x + | otherwise = def + range = S.fromList values + checkValues = S.toList $ S.fromList $ + [ v' | v <- values, v' <- [v-1,v,v+1], + if signed then v' >= minS && v' <= maxS else v' >= minU && v' <= maxU ] + pairs = intercalate ", " ["(" ++ show v ++ "," ++ show (f v) ++ ")" | v <- checkValues ] + +checkName :: String -> String +checkName f = f ++ "_check" + +genMain :: [Spec] -> String +genMain specs = unlines $ "main = do" : [ " " ++ checkName n | (n,_,_) <- specs ] + +genMod :: [Spec] -> String +genMod specs = unlines $ + "-- This file is generated from CmmSwitchGen!" : + "{-# LANGUAGE MagicHash, NegativeLiterals #-}" : + "import Control.Monad (unless, forM_)" : + "import GHC.Exts" : + map genSwitch specs ++ + map genCheck specs ++ + [ genMain specs ] + +main = putStrLn $ + genMod $ zipWith (\n (s,v) -> (n,s,v)) names $ signedChecks ++ unsignedChecks + + +signedChecks :: [(Bool, [Integer])] +signedChecks = map (True,) + [ [1..10] + , [0..10] + , [1..3] + , [1..4] + , [1..5] + , [-1..10] + , [-10..10] + , [-20.. -10]++[0..10] + , [-20.. -10]++[1..10] + , [minS,0,maxS] + , [maxS-10 .. maxS] + , [minS..minS+10]++[maxS-10 .. maxS] + ] + +minU, maxU, minS, maxS :: Integer +minU = 0 +maxU = fromIntegral (maxBound :: Word) +minS = fromIntegral (minBound :: Int) +maxS = fromIntegral (maxBound :: Int) + + +unsignedChecks :: [(Bool, [Integer])] +unsignedChecks = map (False,) + [ [0..10] + , [1..10] + , [0] + , [0..1] + , [0..2] + , [0..3] + , [0..4] + , [1] + , [1..2] + , [1..3] + , [1..4] + , [1..5] + , [minU,maxU] + , [maxU-10 .. maxU] + , [minU..minU+10]++[maxU-10 .. maxU] + ] + +names :: [String] +names = [ c1:c2:[] | c1 <- ['a'..'z'], c2 <- ['a'..'z']] diff --git a/tests/examples/ghc80/Collapse1.hs b/tests/examples/ghc80/Collapse1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Collapse1.hs @@ -0,0 +1,16 @@ +module LiftToTop3evel.Collapse1 where + +collapse' _ _ [] = [] +collapse' left space (t:ts) = new : collapse' right space rest + where + (_, leftInner) = left + rightInner = leftInner + symbolSize t + right = (rightInner, (rightOuter rightInner rights)) + (rights, rest) = span space ts + new = (t, Bounds left right) + +rightOuter rightInner rights = rightInner + symbolSize rights + +data Bounds = Bounds (Int,Int) (Int,Int) +symbolSize t = 4 + diff --git a/tests/examples/ghc80/Compare.hs b/tests/examples/ghc80/Compare.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Compare.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Trustworthy, + TypeOperators, + PolyKinds, DataKinds, + TypeFamilies, + UndecidableInstances #-} + + +module Type.Compare where + +import Data.Ord +import GHC.TypeLits + +type family (a :: Ordering) $$ (b :: Ordering) :: Ordering where + LT $$ b = LT + GT $$ b = GT + EQ $$ b = b +infixl 0 $$ + +-- | Compare two types of any (possibly different) kinds. +-- Since `Compare` itself is a closed type family, add instances to `CompareUser` if you want to compare other types. +type family Compare (a :: k) (b :: k') :: Ordering where + + Compare '() '() = EQ diff --git a/tests/examples/ghc80/CustomTypeErrors01.hs b/tests/examples/ghc80/CustomTypeErrors01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/CustomTypeErrors01.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds, UndecidableInstances #-} +module T1 where +import GHC.TypeLits + + +data MyType = MyType + +instance + TypeError (Text "Values of type 'MyType' cannot be compared for equality.") + => Eq MyType where (==) = undefined + +err x = x == MyType + + diff --git a/tests/examples/ghc80/CustomTypeErrors02.hs b/tests/examples/ghc80/CustomTypeErrors02.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/CustomTypeErrors02.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds, UndecidableInstances #-} +{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts #-} +module T2 where + +import GHC.TypeLits + +type family IntRep a where + IntRep Int = Integer + IntRep Integer = Integer + IntRep Bool = Integer + IntRep a = TypeError (Text "The type '" :<>: ShowType a :<>: + Text "' cannot be represented as an integer.") + +convert :: Num (IntRep a) => a -> IntRep a +convert _ = 5 + +err = convert id + + diff --git a/tests/examples/ghc80/CustomTypeErrors03.hs b/tests/examples/ghc80/CustomTypeErrors03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/CustomTypeErrors03.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DataKinds #-} +module T3 where + +import GHC.TypeLits + +f :: TypeError (Text "This is a type error") +f = undefined diff --git a/tests/examples/ghc80/D.hs b/tests/examples/ghc80/D.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/D.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} + +module D where + +import A +import C + +type instance F a b = a + +unsafeCoerce :: a -> b +unsafeCoerce x = oops x x diff --git a/tests/examples/ghc80/DataFamilyInstanceLHS.hs b/tests/examples/ghc80/DataFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/DataFamilyInstanceLHS.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds #-} +module DataFamilyInstanceLHS where +-- Test case from #10586 +data MyKind = A | B + +data family Sing (a :: k) + +data instance Sing (_ :: MyKind) where + SingA :: Sing A + SingB :: Sing B + +foo :: Sing A +foo = SingA diff --git a/tests/examples/ghc80/DatatypeContexts.hs b/tests/examples/ghc80/DatatypeContexts.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/DatatypeContexts.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DatatypeContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- I don't know how to silence the -XDatatypeContexts warnings otherwise... +{-# OPTIONS_GHC -w #-} + +{-| +Module: Derived.DatatypeContexts +Copyright: (C) 2014-2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +Defines data types with DatatypeContexts (which are gross, but still possible). +-} +module Derived.DatatypeContexts where + + +data family TyFamily x y z :: * + +data instance Ord a => TyFamily a b c = TyFamily a b c + deriving Show + diff --git a/tests/examples/ghc80/Decision.hs b/tests/examples/ghc80/Decision.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Decision.hs @@ -0,0 +1,726 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Airship.Internal.Decision + ( flow + , appendRequestPath + ) where + +import Airship.Internal.Date (parseRfc1123Date, utcTimeToRfc1123) +import Airship.Headers (addResponseHeader) +import Airship.Types ( Response(..) + , ResponseBody(..) + , Webmachine + , etagToByteString + , getResponseBody + , getResponseHeaders + , halt + , pathInfo + , putResponseBody + , request + , requestHeaders + , requestMethod + , requestTime ) + +import Airship.Resource(Resource(..), PostResponse(..)) +import Airship.Internal.Parsers (parseEtagList) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import Control.Monad (when) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.State.Strict (StateT(..), evalStateT, + get, modify) +import Control.Monad.Writer.Class (tell) + +import Blaze.ByteString.Builder (toByteString) +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.ByteString (ByteString, intercalate) + +import Network.HTTP.Media +import qualified Network.HTTP.Types as HTTP + +------------------------------------------------------------------------------ +-- HTTP Headers +-- These are headers not defined for us already in +-- Network.HTTP.Types +------------------------------------------------------------------------------ +-- TODO this exist in http-types-0.9, see CHANGES.txt +hAcceptCharset :: HTTP.HeaderName +hAcceptCharset = "Accept-Charset" + +hAcceptEncoding :: HTTP.HeaderName +hAcceptEncoding = "Accept-Encoding" + +hIfMatch :: HTTP.HeaderName +hIfMatch = "If-Match" + +hIfUnmodifiedSince :: HTTP.HeaderName +hIfUnmodifiedSince = "If-Unmodified-Since" + +hIfNoneMatch :: HTTP.HeaderName +hIfNoneMatch = "If-None-Match" + +------------------------------------------------------------------------------ +-- FlowState: StateT used for recording information as we walk the decision +-- tree +------------------------------------------------------------------------------ + +data FlowState m = FlowState + { _contentType :: Maybe (MediaType, Webmachine m ResponseBody) } + +type FlowStateT m a = StateT (FlowState m) (Webmachine m) a + +type Flow m = Resource m -> FlowStateT m Response + +initFlowState :: FlowState m +initFlowState = FlowState Nothing + +flow :: Monad m => Resource m -> Webmachine m Response +flow r = evalStateT (b13 r) initFlowState + +trace :: Monad m => Text -> FlowStateT m () +trace t = lift $ tell [t] + +----------------------------------------------------------------------------- +-- Header value data newtypes +------------------------------------------------------------------------------ + +newtype IfMatch = IfMatch ByteString +newtype IfNoneMatch = IfNoneMatch ByteString + +------------------------------------------------------------------------------ +-- Decision Helpers +------------------------------------------------------------------------------ + +negotiateContentTypesAccepted :: Monad m => Resource m -> FlowStateT m () +negotiateContentTypesAccepted Resource{..} = do + req <- lift request + accepted <- lift contentTypesAccepted + let reqHeaders = requestHeaders req + result = do + cType <- lookup HTTP.hContentType reqHeaders + mapContentMedia accepted cType + case result of + (Just process) -> lift process + Nothing -> lift $ halt HTTP.status415 + +appendRequestPath :: Monad m => [Text] -> Webmachine m ByteString +appendRequestPath ts = do + currentPath <- pathInfo <$> request + return $ toByteString (HTTP.encodePathSegments (currentPath ++ ts)) + +requestHeaderDate :: Monad m => HTTP.HeaderName -> + Webmachine m (Maybe UTCTime) +requestHeaderDate headerName = do + req <- request + let reqHeaders = requestHeaders req + dateHeader = lookup headerName reqHeaders + parsedDate = dateHeader >>= parseRfc1123Date + return parsedDate + +writeCacheTags :: Monad m => Resource m -> FlowStateT m () +writeCacheTags Resource{..} = lift $ do + etag <- generateETag + case etag of + Nothing -> return () + Just t -> addResponseHeader ("ETag", etagToByteString t) + modified <- lastModified + case modified of + Nothing -> return () + Just d -> addResponseHeader ("Last-Modified", utcTimeToRfc1123 d) + +------------------------------------------------------------------------------ +-- Type definitions for all decision nodes +------------------------------------------------------------------------------ + +b13, b12, b11, b10, b09, b08, b07, b06, b05, b04, b03 :: Monad m => Flow m +c04, c03 :: Monad m => Flow m +d05, d04 :: Monad m => Flow m +e06, e05 :: Monad m => Flow m +f07, f06 :: Monad m => Flow m +g11, g09 :: Monad m => IfMatch -> Flow m +g08, g07 :: Monad m => Flow m +h12, h11, h10, h07 :: Monad m => Flow m +i13 :: Monad m => IfNoneMatch -> Flow m +i12, i07, i04 :: Monad m => Flow m +j18 :: Monad m => Flow m +k13 :: Monad m => IfNoneMatch -> Flow m +k07, k05 :: Monad m => Flow m +l17, l15, l14, l13, l07, l05 :: Monad m => Flow m +m20, m16, m07, m05 :: Monad m => Flow m +n16, n11, n05 :: Monad m => Flow m +o20, o18, o16, o14 :: Monad m => Flow m +p11, p03 :: Monad m => Flow m + +------------------------------------------------------------------------------ +-- B column +------------------------------------------------------------------------------ + +b13 r@Resource{..} = do + trace "b13" + available <- lift serviceAvailable + if available + then b12 r + else lift $ halt HTTP.status503 + +b12 r@Resource{..} = do + trace "b12" + -- known method + req <- lift request + let knownMethods = [ HTTP.methodGet + , HTTP.methodPost + , HTTP.methodHead + , HTTP.methodPut + , HTTP.methodDelete + , HTTP.methodTrace + , HTTP.methodConnect + , HTTP.methodOptions + , HTTP.methodPatch + ] + if requestMethod req `elem` knownMethods + then b11 r + else lift $ halt HTTP.status501 + +b11 r@Resource{..} = do + trace "b11" + long <- lift uriTooLong + if long + then lift $ halt HTTP.status414 + else b10 r + +b10 r@Resource{..} = do + trace "b10" + req <- lift request + allowed <- lift allowedMethods + if requestMethod req `elem` allowed + then b09 r + else do + lift $ addResponseHeader ("Allow", intercalate "," allowed) + lift $ halt HTTP.status405 + +b09 r@Resource{..} = do + trace "b09" + malformed <- lift malformedRequest + if malformed + then lift $ halt HTTP.status400 + else b08 r + +b08 r@Resource{..} = do + trace "b08" + authorized <- lift isAuthorized + if authorized + then b07 r + else lift $ halt HTTP.status401 + +b07 r@Resource{..} = do + trace "b07" + forbid <- lift forbidden + if forbid + then lift $ halt HTTP.status403 + else b06 r + +b06 r@Resource{..} = do + trace "b06" + validC <- lift validContentHeaders + if validC + then b05 r + else lift $ halt HTTP.status501 + +b05 r@Resource{..} = do + trace "b05" + known <- lift knownContentType + if known + then b04 r + else lift $ halt HTTP.status415 + +b04 r@Resource{..} = do + trace "b04" + large <- lift entityTooLarge + if large + then lift $ halt HTTP.status413 + else b03 r + +b03 r@Resource{..} = do + trace "b03" + req <- lift request + allowed <- lift allowedMethods + if requestMethod req == HTTP.methodOptions + then do + lift $ addResponseHeader ("Allow", intercalate "," allowed) + lift $ halt HTTP.status204 + else c03 r + +------------------------------------------------------------------------------ +-- C column +------------------------------------------------------------------------------ + +c04 r@Resource{..} = do + trace "c04" + req <- lift request + provided <- lift contentTypesProvided + let reqHeaders = requestHeaders req + result = do + acceptStr <- lookup HTTP.hAccept reqHeaders + (acceptTyp, resource) <- mapAcceptMedia provided' acceptStr + Just (acceptTyp, resource) + where + -- this is so that in addition to getting back the resource + -- that we match, we also return the content-type provided + -- by that resource. + provided' = map dupContentType provided + dupContentType (a, b) = (a, (a, b)) + + case result of + Nothing -> lift $ halt HTTP.status406 + Just res -> do + modify (\fs -> fs { _contentType = Just res }) + d04 r + +c03 r@Resource{..} = do + trace "c03" + req <- lift request + let reqHeaders = requestHeaders req + case lookup HTTP.hAccept reqHeaders of + (Just _h) -> + c04 r + Nothing -> + d04 r + +------------------------------------------------------------------------------ +-- D column +------------------------------------------------------------------------------ + +d05 r@Resource{..} = do + trace "d05" + langAvailable <- lift languageAvailable + if langAvailable + then e05 r + else lift $ halt HTTP.status406 + +d04 r@Resource{..} = do + trace "d04" + req <- lift request + let reqHeaders = requestHeaders req + case lookup HTTP.hAcceptLanguage reqHeaders of + (Just _h) -> + d05 r + Nothing -> + e05 r + +------------------------------------------------------------------------------ +-- E column +------------------------------------------------------------------------------ + +e06 r@Resource{..} = do + trace "e06" + -- TODO: charset negotiation + f06 r + +e05 r@Resource{..} = do + trace "e05" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hAcceptCharset reqHeaders of + (Just _h) -> + e06 r + Nothing -> + f06 r + +------------------------------------------------------------------------------ +-- F column +------------------------------------------------------------------------------ + +f07 r@Resource{..} = do + trace "f07" + -- TODO: encoding negotiation + g07 r + +f06 r@Resource{..} = do + trace "f06" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hAcceptEncoding reqHeaders of + (Just _h) -> + f07 r + Nothing -> + g07 r + +------------------------------------------------------------------------------ +-- G column +------------------------------------------------------------------------------ + +g11 (IfMatch ifMatch) r@Resource{..} = do + trace "g11" + let etags = parseEtagList ifMatch + if null etags + then lift $ halt HTTP.status412 + else h10 r + +g09 ifMatch r@Resource{..} = do + trace "g09" + case ifMatch of + -- TODO: should we be stripping whitespace here? + (IfMatch "*") -> + h10 r + _ -> + g11 ifMatch r + +g08 r@Resource{..} = do + trace "g08" + req <- lift request + let reqHeaders = requestHeaders req + case IfMatch <$> lookup hIfMatch reqHeaders of + (Just h) -> + g09 h r + Nothing -> + h10 r + +g07 r@Resource{..} = do + trace "g07" + -- TODO: set Vary headers + exists <- lift resourceExists + if exists + then g08 r + else h07 r + +------------------------------------------------------------------------------ +-- H column +------------------------------------------------------------------------------ + +h12 r@Resource{..} = do + trace "h12" + modified <- lift lastModified + parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince + let maybeGreater = do + lastM <- modified + headerDate <- parsedDate + return (lastM > headerDate) + if maybeGreater == Just True + then lift $ halt HTTP.status412 + else i12 r + +h11 r@Resource{..} = do + trace "h11" + parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince + if isJust parsedDate + then h12 r + else i12 r + +h10 r@Resource{..} = do + trace "h10" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hIfUnmodifiedSince reqHeaders of + (Just _h) -> + h11 r + Nothing -> + i12 r + +h07 r@Resource {..} = do + trace "h07" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hIfMatch reqHeaders of + -- TODO: should we be stripping whitespace here? + (Just "*") -> + lift $ halt HTTP.status412 + _ -> + i07 r + +------------------------------------------------------------------------------ +-- I column +------------------------------------------------------------------------------ + +i13 ifNoneMatch r@Resource{..} = do + trace "i13" + case ifNoneMatch of + -- TODO: should we be stripping whitespace here? + (IfNoneMatch "*") -> + j18 r + _ -> + k13 ifNoneMatch r + +i12 r@Resource{..} = do + trace "i12" + req <- lift request + let reqHeaders = requestHeaders req + case IfNoneMatch <$> lookup hIfNoneMatch reqHeaders of + (Just h) -> + i13 h r + Nothing -> + l13 r + +i07 r = do + trace "i07" + req <- lift request + if requestMethod req == HTTP.methodPut + then i04 r + else k07 r + +i04 r@Resource{..} = do + trace "i04" + moved <- lift movedPermanently + case moved of + (Just loc) -> do + lift $ addResponseHeader ("Location", loc) + lift $ halt HTTP.status301 + Nothing -> + p03 r + +------------------------------------------------------------------------------ +-- J column +------------------------------------------------------------------------------ + +j18 _ = do + trace "j18" + req <- lift request + let getOrHead = [ HTTP.methodGet + , HTTP.methodHead + ] + if requestMethod req `elem` getOrHead + then lift $ halt HTTP.status304 + else lift $ halt HTTP.status412 + +------------------------------------------------------------------------------ +-- K column +------------------------------------------------------------------------------ + +k13 (IfNoneMatch ifNoneMatch) r@Resource{..} = do + trace "k13" + let etags = parseEtagList ifNoneMatch + if null etags + then l13 r + else j18 r + +k07 r@Resource{..} = do + trace "k07" + prevExisted <- lift previouslyExisted + if prevExisted + then k05 r + else l07 r + +k05 r@Resource{..} = do + trace "k05" + moved <- lift movedPermanently + case moved of + (Just loc) -> do + lift $ addResponseHeader ("Location", loc) + lift $ halt HTTP.status301 + Nothing -> + l05 r + +------------------------------------------------------------------------------ +-- L column +------------------------------------------------------------------------------ + +l17 r@Resource{..} = do + trace "l17" + parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince + modified <- lift lastModified + let maybeGreater = do + lastM <- modified + ifModifiedSince <- parsedDate + return (lastM > ifModifiedSince) + if maybeGreater == Just True + then m16 r + else lift $ halt HTTP.status304 + +l15 r@Resource{..} = do + trace "l15" + parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince + now <- lift requestTime + let maybeGreater = (> now) <$> parsedDate + if maybeGreater == Just True + then m16 r + else l17 r + +l14 r@Resource{..} = do + trace "l14" + req <- lift request + let reqHeaders = requestHeaders req + dateHeader = lookup HTTP.hIfModifiedSince reqHeaders + validDate = isJust (dateHeader >>= parseRfc1123Date) + if validDate + then l15 r + else m16 r + +l13 r@Resource{..} = do + trace "l13" + req <- lift request + let reqHeaders = requestHeaders req + case lookup HTTP.hIfModifiedSince reqHeaders of + (Just _h) -> + l14 r + Nothing -> + m16 r + +l07 r = do + trace "l07" + req <- lift request + if requestMethod req == HTTP.methodPost + then m07 r + else lift $ halt HTTP.status404 + +l05 r@Resource{..} = do + trace "l05" + moved <- lift movedTemporarily + case moved of + (Just loc) -> do + lift $ addResponseHeader ("Location", loc) + lift $ halt HTTP.status307 + Nothing -> + m05 r + +------------------------------------------------------------------------------ +-- M column +------------------------------------------------------------------------------ + +m20 r@Resource{..} = do + trace "m20" + deleteAccepted <- lift deleteResource + if deleteAccepted + then do + completed <- lift deleteCompleted + if completed + then o20 r + else lift $ halt HTTP.status202 + else lift $ halt HTTP.status500 + +m16 r = do + trace "m16" + req <- lift request + if requestMethod req == HTTP.methodDelete + then m20 r + else n16 r + +m07 r@Resource{..} = do + trace "m07" + allowMissing <- lift allowMissingPost + if allowMissing + then n11 r + else lift $ halt HTTP.status404 + +m05 r = do + trace "m05" + req <- lift request + if requestMethod req == HTTP.methodPost + then n05 r + else lift $ halt HTTP.status410 + +------------------------------------------------------------------------------ +-- N column +------------------------------------------------------------------------------ + +n16 r = do + trace "n16" + req <- lift request + if requestMethod req == HTTP.methodPost + then n11 r + else o16 r + +n11 r@Resource{..} = trace "n11" >> lift processPost >>= flip processPostAction r + +create :: Monad m => [Text] -> Resource m -> FlowStateT m () +create ts r = do + loc <- lift (appendRequestPath ts) + lift (addResponseHeader ("Location", loc)) + negotiateContentTypesAccepted r + +processPostAction :: Monad m => PostResponse m -> Flow m +processPostAction (PostCreate ts) r = do + create ts r + p11 r +processPostAction (PostCreateRedirect ts) r = do + create ts r + lift $ halt HTTP.status303 +processPostAction (PostProcess p) r = + lift p >> p11 r +processPostAction (PostProcessRedirect ts) _r = do + locBs <- lift ts + lift $ addResponseHeader ("Location", locBs) + lift $ halt HTTP.status303 + +n05 r@Resource{..} = do + trace "n05" + allow <- lift allowMissingPost + if allow + then n11 r + else lift $ halt HTTP.status410 + +------------------------------------------------------------------------------ +-- O column +------------------------------------------------------------------------------ + +o20 r = do + trace "o20" + body <- lift getResponseBody + -- ResponseBody is a little tough to make an instance of 'Eq', + -- so we just use a pattern match + case body of + Empty -> lift $ halt HTTP.status204 + _ -> o18 r + +o18 r@Resource{..} = do + trace "o18" + multiple <- lift multipleChoices + if multiple + then lift $ halt HTTP.status300 + else do + -- TODO: set etag, expiration, etc. headers + req <- lift request + let getOrHead = [ HTTP.methodGet + , HTTP.methodHead + ] + when (requestMethod req `elem` getOrHead) $ do + m <- _contentType <$> get + (cType, body) <- case m of + Nothing -> do + provided <- lift contentTypesProvided + return (head provided) + Just (cType, body) -> + return (cType, body) + b <- lift body + lift $ putResponseBody b + lift $ addResponseHeader ("Content-Type", renderHeader cType) + writeCacheTags r + lift $ halt HTTP.status200 + +o16 r = do + trace "o16" + req <- lift request + if requestMethod req == HTTP.methodPut + then o14 r + else o18 r + +o14 r@Resource{..} = do + trace "o14" + conflict <- lift isConflict + if conflict + then lift $ halt HTTP.status409 + else negotiateContentTypesAccepted r >> p11 r + +------------------------------------------------------------------------------ +-- P column +------------------------------------------------------------------------------ + +p11 r = do + trace "p11" + headers <- lift getResponseHeaders + case lookup HTTP.hLocation headers of + (Just _) -> + lift $ halt HTTP.status201 + _ -> + o20 r + +p03 r@Resource{..} = do + trace "p03" + conflict <- lift isConflict + if conflict + then lift $ halt HTTP.status409 + else negotiateContentTypesAccepted r >> p11 r diff --git a/tests/examples/ghc80/Defer03.hs b/tests/examples/ghc80/Defer03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Defer03.hs @@ -0,0 +1,7 @@ +module Main where + +a :: Int +a = 'p' + +main :: IO () +main = print "No errors!" diff --git a/tests/examples/ghc80/Dep1.hs b/tests/examples/ghc80/Dep1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Dep1.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeInType #-} + +module Dep1 where + +import Data.Kind + +data Proxy k (a :: k) = P + +x :: Proxy * Int +x = P + +y :: Proxy Bool True +y = P diff --git a/tests/examples/ghc80/Dep2.hs b/tests/examples/ghc80/Dep2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Dep2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PolyKinds, GADTs #-} + +module Dep2 where + +data G (a :: k) where + G1 :: G Int + G2 :: G Maybe diff --git a/tests/examples/ghc80/Dep3.hs b/tests/examples/ghc80/Dep3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Dep3.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-} + +module Dep3 where + +import Data.Kind +import GHC.Exts ( Constraint ) + +type Star1 = * + +data Id1 (a :: Star1) where + Id1 :: a -> Id1 a + +data Id1' :: Star1 -> * where + Id1' :: a -> Id1' a + +type family Star2 x where + Star2 x = * + +data Id2a (a :: Star2 Constraint) = Id2a a + + +data Id2 (a :: Star2 Constraint) where + Id2 :: a -> Id2 a + +data Id2' :: Star2 Constraint -> * where + Id2' :: a -> Id2' a diff --git a/tests/examples/ghc80/DepFail1.hs b/tests/examples/ghc80/DepFail1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/DepFail1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeInType #-} + +module DepFail1 where + +data Proxy k (a :: k) = P + +z :: Proxy Bool +z = P + +a :: Proxy Int Bool +a = P diff --git a/tests/examples/ghc80/DeprM.hs b/tests/examples/ghc80/DeprM.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/DeprM.hs @@ -0,0 +1,4 @@ +module DeprM {-# DEPRECATED "Here can be your menacing deprecation warning!" #-} where + +f :: Int +f = 42 diff --git a/tests/examples/ghc80/DeprU.hs b/tests/examples/ghc80/DeprU.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/DeprU.hs @@ -0,0 +1,6 @@ +module A where + +import DeprM -- here should be emitted deprecation warning + +g :: Int +g = f diff --git a/tests/examples/ghc80/Deprecation.hs b/tests/examples/ghc80/Deprecation.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Deprecation.hs @@ -0,0 +1,16 @@ + +module Deprecation +{-# Deprecated ["This is a module \"deprecation\"", + "multi-line", + "with unicode: Frère" ] #-} + ( foo ) + where + +{-# DEPRECATEd foo + ["This is a multi-line", + "deprecation message", + "for foo"] #-} +foo :: Int +foo = 4 + +{-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} diff --git a/tests/examples/ghc80/DsStrict.hs b/tests/examples/ghc80/DsStrict.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/DsStrict.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE Strict #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +module Main where + +import Debug.Trace + +f0 a = "fun" +f0' ~a = "fun2" + +f1 ~n = + case n of + a -> "case" +f1' ~n = + case n of + ~a -> "case2" + +f2 = \a -> "lamda" +f2' = \ ~a -> "lambda2" + +newtype Age = MkAge Int + +f4, f4' :: Age -> String +f4 (MkAge a) = "newtype" +f4' ~(MkAge a) = "newtype2" + +main :: IO () +main = mapM_ (\(what,f) -> putStrLn (f (v what))) fs + where fs = + [("fun",f0 ) + ,("fun lazy",f0') + ,("case",f1) + ,("case lazy",f1') + ,("lambda",f2) + ,("lambda lazy",f2') + ,("newtype",(\ ~i -> f4 (MkAge i))) + ,("newtype lazy",(\ ~i -> f4' (MkAge i)))] + v n = trace ("evaluated in " ++ n) 1 diff --git a/tests/examples/ghc80/DsStrictData.hs b/tests/examples/ghc80/DsStrictData.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/DsStrictData.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ScopedTypeVariables, StrictData, GADTs #-} + +-- | Tests the StrictData LANGUAGE pragma. +module Main where + +import qualified Control.Exception as E +import System.IO.Unsafe (unsafePerformIO) + +data Strict a = S a +data Strict2 b = S2 !b +data Strict3 c where + S3 :: c -> Strict3 c + +data UStrict = US {-# UNPACK #-} Int + +data Lazy d = L ~d +data Lazy2 e where + L2 :: ~e -> Lazy2 e + +main :: IO () +main = + do print (isBottom (S bottom)) + print (isBottom (S2 bottom)) + print (isBottom (US bottom)) + print (isBottom (S3 bottom)) + putStrLn "" + print (not (isBottom (L bottom))) + print (not (isBottom (L2 bottom))) + print (not (isBottom (Just bottom))) -- sanity check + +------------------------------------------------------------------------ +-- Support for testing for bottom + +bottom :: a +bottom = error "_|_" + +isBottom :: a -> Bool +isBottom f = unsafePerformIO $ + (E.evaluate f >> return False) `E.catches` + [ E.Handler (\(_ :: E.ArrayException) -> return True) + , E.Handler (\(_ :: E.ErrorCall) -> return True) + , E.Handler (\(_ :: E.NoMethodError) -> return True) + , E.Handler (\(_ :: E.NonTermination) -> return True) + , E.Handler (\(_ :: E.PatternMatchFail) -> return True) + , E.Handler (\(_ :: E.RecConError) -> return True) + , E.Handler (\(_ :: E.RecSelError) -> return True) + , E.Handler (\(_ :: E.RecUpdError) -> return True) + ] diff --git a/tests/examples/ghc80/DsStrictFail.hs b/tests/examples/ghc80/DsStrictFail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/DsStrictFail.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE Strict #-} +module Main where + +main = let False = True + in return () diff --git a/tests/examples/ghc80/DsStrictLet.hs b/tests/examples/ghc80/DsStrictLet.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/DsStrictLet.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Strict #-} +module Main where + +import Debug.Trace + +main = let False = trace "no binders" False -- evaluated + + a :: a -> a + a = trace "polymorphic" id -- evaluated + + f :: Eq a => a -> a -> Bool + f = trace "overloaded" (==) -- not evaluated + + xs :: [Int] + xs = (trace "recursive" (:) 1 xs) -- evaluated + in return () diff --git a/tests/examples/ghc80/DsStrictWarn.hs b/tests/examples/ghc80/DsStrictWarn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/DsStrictWarn.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-} +{-# LANGUAGE Strict #-} +module DsStrictWarn where + +-- should warn about non-exhaustive pattern match +w :: String -> String +w x = let (_:_) = x in "1" diff --git a/tests/examples/ghc80/Eq.hs b/tests/examples/ghc80/Eq.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Eq.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, + RankNTypes, FlexibleContexts, TemplateHaskell, + UndecidableInstances, GADTs, DefaultSignatures #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Prelude.Eq +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines the SEq singleton version of the Eq type class. +-- +----------------------------------------------------------------------------- + +module Data.Singletons.Prelude.Eq ( + PEq(..), SEq(..), + (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$) + ) where + +import Data.Singletons.Prelude.Bool +import Data.Singletons +import Data.Singletons.Single +import Data.Singletons.Prelude.Instances +import Data.Singletons.Util +import Data.Singletons.Promote +import Data.Type.Equality + +-- NB: These must be defined by hand because of the custom handling of the +-- default for (:==) to use Data.Type.Equality.== + +-- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)', +-- then it defaults to a use of '(==)', from @Data.Type.Equality@. +class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where + type (:==) (x :: a) (y :: a) :: Bool + type (:/=) (x :: a) (y :: a) :: Bool + + type (x :: a) :== (y :: a) = x == y + type (x :: a) :/= (y :: a) = Not (x :== y) + +infix 4 :== +infix 4 :/= + +$(genDefunSymbols [''(:==), ''(:/=)]) + +-- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required +-- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'. +class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where + -- | Boolean equality on singletons + (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b) + infix 4 %:== + + -- | Boolean disequality on singletons + (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b) + default (%:/=) :: forall (a :: k) (b :: k). + ((a :/= b) ~ Not (a :== b)) + => Sing a -> Sing b -> Sing (a :/= b) + a %:/= b = sNot (a %:== b) + infix 4 %:/= + +$(singEqInstances basicTypes) diff --git a/tests/examples/ghc80/ExpandSynsFail1.hs b/tests/examples/ghc80/ExpandSynsFail1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExpandSynsFail1.hs @@ -0,0 +1,4 @@ +type Foo = Int +type Bar = Bool + +main = print $ (1 :: Foo) == (False :: Bar) diff --git a/tests/examples/ghc80/ExpandSynsFail2.hs b/tests/examples/ghc80/ExpandSynsFail2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExpandSynsFail2.hs @@ -0,0 +1,19 @@ +-- In case of types with nested type synonyms, all synonyms should be expanded + +{-# LANGUAGE RankNTypes #-} + +import Control.Monad.ST + +type Foo = Int +type Bar = Bool + +type MyFooST s = ST s Foo +type MyBarST s = ST s Bar + +fooGen :: forall s . MyFooST s +fooGen = undefined + +barGen :: forall s . MyBarST s +barGen = undefined + +main = print (runST fooGen == runST barGen) diff --git a/tests/examples/ghc80/ExpandSynsFail3.hs b/tests/examples/ghc80/ExpandSynsFail3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExpandSynsFail3.hs @@ -0,0 +1,23 @@ +-- We test two things here: +-- +-- 1. We expand only as much as necessary. In this case, we shouldn't expand T. +-- 2. When we find a difference(T3 and T5 in this case), we do minimal expansion +-- e.g. we don't expand both of them to T1, instead we expand T5 to T3. + +module Main where + +type T5 = T4 +type T4 = T3 +type T3 = T2 +type T2 = T1 +type T1 = Int + +type T a = Int -> Bool -> a -> String + +f :: T (T3, T5, Int) -> Int +f = undefined + +a :: Int +a = f (undefined :: T (T5, T3, Bool)) + +main = print a diff --git a/tests/examples/ghc80/ExpandSynsFail4.hs b/tests/examples/ghc80/ExpandSynsFail4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExpandSynsFail4.hs @@ -0,0 +1,11 @@ +-- Synonyms shouldn't be expanded since type error is visible without +-- expansions. Error message should not have `Type synonyms expanded: ...` part. + +module Main where + +type T a = [a] + +f :: T Int -> String +f = undefined + +main = putStrLn $ f (undefined :: T Bool) diff --git a/tests/examples/ghc80/ExportSyntax.hs b/tests/examples/ghc80/ExportSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExportSyntax.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PatternSynonyms #-} + +module ExportSyntax ( A(.., NoA), Q(F,..), G(T,..,U)) where + +data A = A | B + +pattern NoA = B + +data Q a = Q a + +pattern F a = Q a + +data G = G | H + +pattern T = G + +pattern U = H diff --git a/tests/examples/ghc80/ExportSyntaxImport.hs b/tests/examples/ghc80/ExportSyntaxImport.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExportSyntaxImport.hs @@ -0,0 +1,7 @@ +module ExportSyntaxImport where + +import ExportSyntax + +foo = NoA + +baz = A diff --git a/tests/examples/ghc80/ExprSigLocal.hs b/tests/examples/ghc80/ExprSigLocal.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExprSigLocal.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PartialTypeSignatures, RankNTypes #-} + +module ExprSigLocal where + +-- We expect this to compile fine, +-- reporting that '_' stands 'a' + +y :: forall b. b->b +y = ((\x -> x) :: forall a. a -> _) + +g :: forall a. a -> _ +g x = x diff --git a/tests/examples/ghc80/Extends.hs b/tests/examples/ghc80/Extends.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Extends.hs @@ -0,0 +1,4 @@ +module Extends where + +class BClass b where + has :: b diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInExpressionSignature.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInExpressionSignature.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExtraConstraintsWildcardInExpressionSignature.hs @@ -0,0 +1,3 @@ +module ExtraConstraintsWildcardInExpressionSignature where + +foo x y = ((==) :: _ => _) x y diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSignature.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSignature.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSignature.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module ExtraConstraintsWildcardInPatternSignature where + +foo (x :: _ => _) y = x == y diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSplice.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSplice.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +module ExtraConstraintsWildcardInPatternSplice where + +foo $( [p| (x :: _) |] ) = x diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module ExtraConstraintsWildcardInTypeSplice where + +import Language.Haskell.TH + +metaType :: TypeQ +metaType = [t| _ => _ |] diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice2.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module ExtraConstraintsWildcardInTypeSplice2 where + +import Language.Haskell.TH.Lib (wildCardT) + +show' :: $(wildCardT) => a -> String +show' x = show x diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSpliceUsed.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSpliceUsed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSpliceUsed.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module ExtraConstraintsWildcardInTypeSpliceUsed where + +import ExtraConstraintsWildcardInTypeSplice + +-- An extra-constraints wild card is not supported in type splices +eq :: $(metaType) +eq x y = x == y diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardTwice.hs b/tests/examples/ghc80/ExtraConstraintsWildcardTwice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ExtraConstraintsWildcardTwice.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ExtraConstraintsWildcardTwice where + +foo :: ((_), _) => a -> a +foo = undefined diff --git a/tests/examples/ghc80/F.hs b/tests/examples/ghc80/F.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/F.hs @@ -0,0 +1,20 @@ +-- | Thompson's group F. +-- +-- See eg. +-- +-- Based mainly on James Michael Belk's PhD thesis \"THOMPSON'S GROUP F\"; +-- see +-- + +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns, PatternSynonyms, DeriveFunctor #-} +module Math.Combinat.Groups.Thompson.F where + +-- | Remove the carets with the given indices +-- (throws an error if there is no caret at the given index) +removeCarets :: [Int] -> T -> T +removeCarets idxs tree = if null rem then final else error ("removeCarets: some stuff remained: " ++ show rem) where + + (_,rem,final) = go 0 idxs tree where + + go :: Int -> [Int] -> T -> (Int,[Int],T) + go !x [] t = (x + treeWidth t , [] , t) diff --git a/tests/examples/ghc80/FDsFromGivens2.hs b/tests/examples/ghc80/FDsFromGivens2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/FDsFromGivens2.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, GADTs #-} + +module FDsFromGivens2 where + +class C a b | a -> b where + cop :: a -> b -> () + +data KCC where + KCC :: C Char Char => () -> KCC + +f :: C Char [a] => a -> a +f = undefined + +bar (KCC _) = f diff --git a/tests/examples/ghc80/Families.hs b/tests/examples/ghc80/Families.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Families.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds, KindSignatures, + TypeOperators, UndecidableInstances #-} + +{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, EmptyDataDecls #-} + +-- | A prelude for type-level programming with type families + +module Prelude.Type.Families where + +-- >>> T :: T ((I 4) `Minus` (I 7)) +-- -3 +type family (a :: k) `Minus` (b :: k) :: k +type instance a `Minus` b = a + Negate b + diff --git a/tests/examples/ghc80/FooBar.hs b/tests/examples/ghc80/FooBar.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/FooBar.hs @@ -0,0 +1,4 @@ +module FooBar where + +import Foo +import Bar diff --git a/tests/examples/ghc80/ForFree.hs b/tests/examples/ghc80/ForFree.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ForFree.hs @@ -0,0 +1,23 @@ + +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Control.ForFree where { + +-- | Free monad from a functor +; + data Free f x = Pure x | Free (f (Free f x)); + + deriving instance (Eq (f (Free f a)), Eq a) => Eq (Free f a); + deriving instance (Ord (f (Free f a)), Ord a) => Ord (Free f a); + deriving instance (Read (f (Free f a)), Read a) => Read (Free f a); + deriving instance (Show (f (Free f a)), Show a) => Show (Free f a); +} diff --git a/tests/examples/ghc80/FromGrin2.hs b/tests/examples/ghc80/FromGrin2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/FromGrin2.hs @@ -0,0 +1,6 @@ + +-- ./hackage-roundtrip-work/ajhc-0.8.0.10/src/C/FromGrin2.hs +-- orig line 588 +convertExp :: Exp -> C (Statement,Expression) +convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do + return (mempty,e) diff --git a/tests/examples/ghc80/FrontendPlugin.hs b/tests/examples/ghc80/FrontendPlugin.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/FrontendPlugin.hs @@ -0,0 +1,52 @@ +module FrontendPlugin where + +import GhcPlugins +import qualified GHC +import GHC ( Ghc, LoadHowMuch(..) ) + +import DriverPipeline hiding ( hsc_env ) +import DriverPhases +import System.Exit +import Control.Monad +import Data.List + +frontendPlugin :: FrontendPlugin +frontendPlugin = defaultFrontendPlugin { + frontend = doMake + } + +-- Copypasted from ghc/Main.hs +doMake :: [String] -> [(String,Maybe Phase)] -> Ghc () +doMake opts srcs = do + liftIO $ print opts + let (hs_srcs, non_hs_srcs) = partition haskellish srcs + + haskellish (f,Nothing) = + looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f + haskellish (_,Just phase) = + phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm + , StopLn] + + hsc_env <- GHC.getSession + + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then liftIO (oneShot hsc_env StopLn srcs) + else do + + o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) + non_hs_srcs + dflags <- GHC.getSessionDynFlags + let dflags' = dflags { ldInputs = map (FileOption "") o_files + ++ ldInputs dflags } + _ <- GHC.setSessionDynFlags dflags' + + targets <- mapM (uncurry GHC.guessTarget) hs_srcs + GHC.setTargets targets + ok_flag <- GHC.load LoadAllTargets + + when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) + return () diff --git a/tests/examples/ghc80/GA1r.hs b/tests/examples/ghc80/GA1r.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/GA1r.hs @@ -0,0 +1,5 @@ +module GA1r where +import Text.ParserCombinators.Parsec + +parseStr :: CharParser () String +parseStr = char '"' *> (many1 (noneOf "\"")) <* char '"' diff --git a/tests/examples/ghc80/Generate.hs b/tests/examples/ghc80/Generate.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Generate.hs @@ -0,0 +1,7 @@ +import Control.Monad (forM_) + +main :: IO () +main = forM_ [0..0xffff] $ \i -> do + putStrLn $ ".section s" ++ show i ++ ",\"\",@progbits" + putStrLn $ ".asciz \"Section " ++ show i ++ "\"" + putStrLn "" diff --git a/tests/examples/ghc80/Generic.hs b/tests/examples/ghc80/Generic.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Generic.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +module Env.Generic + ( Record(..) + , type (?)(..) + ) where + +import Data.Promotion.Prelude (type (:+$), type (:*$), type (:^$), type (:-$)) +import Options.Generic (Generic, ParseRecord, type ()(..)) diff --git a/tests/examples/ghc80/IPLocation.hs b/tests/examples/ghc80/IPLocation.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/IPLocation.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE ImplicitParams, RankNTypes #-} +{-# OPTIONS_GHC -dcore-lint #-} +module Main where + +import GHC.Exception +import GHC.Types + +f0 = putStrLn $ showCallStack ?loc + -- should just show the location of ?loc + +f1 :: (?loc :: CallStack) => IO () +f1 = putStrLn $ showCallStack ?loc + -- should show the location of ?loc *and* f1's call-site + +f2 :: (?loc :: CallStack) => IO () +f2 = do putStrLn $ showCallStack ?loc + putStrLn $ showCallStack ?loc + -- each ?loc should refer to a different location, but they should + -- share f2's call-site + +f3 :: ((?loc :: CallStack) => () -> IO ()) -> IO () +f3 x = x () + -- the call-site for the functional argument should be added to the + -- stack.. + +f4 :: (?loc :: CallStack) => ((?loc :: CallStack) => () -> IO ()) -> IO () +f4 x = x () + -- as should the call-site for f4 itself + +f5 :: (?loc1 :: CallStack) => ((?loc2 :: CallStack) => () -> IO ()) -> IO () +f5 x = x () + -- we only push new call-sites onto CallStacks with the name IP name + +f6 :: (?loc :: CallStack) => Int -> IO () +f6 0 = putStrLn $ showCallStack ?loc +f6 n = f6 (n-1) + -- recursive functions add a SrcLoc for each recursive call + +main = do f0 + f1 + f2 + f3 (\ () -> putStrLn $ showCallStack ?loc) + f4 (\ () -> putStrLn $ showCallStack ?loc) + f5 (\ () -> putStrLn $ showCallStack ?loc3) + f6 5 diff --git a/tests/examples/ghc80/Improvement.hs b/tests/examples/ghc80/Improvement.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Improvement.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +module Foo where + +type family F a +type instance F Int = Bool + +class C a b where + +instance (b~Int) => C Bool b + +blug :: C (F a) a => a -> F a +blug = error "Urk" + +foo :: Bool +foo = blug undefined +-- [W] C (F a0) a0, F a0 ~ Bool + diff --git a/tests/examples/ghc80/KindEqualities.hs b/tests/examples/ghc80/KindEqualities.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/KindEqualities.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE PolyKinds, GADTs, ExplicitForAll #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module KindEqualities where + +data TyRep1 :: * -> * where + TyInt1 :: TyRep1 Int + TyBool1 :: TyRep1 Bool + +zero1 :: forall a. TyRep1 a -> a +zero1 TyInt1 = 0 +zero1 TyBool1 = False + +data Proxy (a :: k) = P + +data TyRep :: k -> * where + TyInt :: TyRep Int + TyBool :: TyRep Bool + TyMaybe :: TyRep Maybe + TyApp :: TyRep a -> TyRep b -> TyRep (a b) + +zero :: forall (a :: *). TyRep a -> a +zero TyInt = 0 +zero TyBool = False +zero (TyApp TyMaybe _) = Nothing diff --git a/tests/examples/ghc80/KindEqualities2.hs b/tests/examples/ghc80/KindEqualities2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/KindEqualities2.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll, + TemplateHaskell, UndecidableInstances, ScopedTypeVariables, + TypeInType #-} + +module KindEqualities2 where + +import Data.Kind +import GHC.Exts ( Any ) + +data Kind = Star | Arr Kind Kind + +data Ty :: Kind -> * where + TInt :: Ty Star + TBool :: Ty Star + TMaybe :: Ty (Arr Star Star) + TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2 + + +data TyRep (k :: Kind) (t :: Ty k) where + TyInt :: TyRep Star TInt + TyBool :: TyRep Star TBool + TyMaybe :: TyRep (Arr Star Star) TMaybe + TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b) + +type family IK (k :: Kind) +type instance IK Star = * +type instance IK (Arr k1 k2) = IK k1 -> IK k2 + +$(return []) -- necessary because the following instances depend on the + -- previous ones. + +type family I (t :: Ty k) :: IK k +type instance I TInt = Int +type instance I TBool = Bool +type instance I TMaybe = Maybe +type instance I (TApp a b) = (I a) (I b) + +zero :: forall (a :: Ty 'Star). TyRep Star a -> I a +zero TyInt = 0 +zero TyBool = False +zero (TyApp TyMaybe TyInt) = Nothing + +main = print $ zero (TyApp TyMaybe TyInt) diff --git a/tests/examples/ghc80/KindLevels.hs b/tests/examples/ghc80/KindLevels.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/KindLevels.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, PolyKinds #-} + +module KindLevels where + +data A +data B :: A -> * +data C :: B a -> * +data D :: C b -> * +data E :: D c -> * diff --git a/tests/examples/ghc80/ListComprehensions.hs b/tests/examples/ghc80/ListComprehensions.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ListComprehensions.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ParallelListComp, + TransformListComp, + RecordWildCards #-} +-- MonadComprehensions, + +module ListComprehensions where + + + +import GHC.Exts +import qualified Data.Map as M +import Data.Ord (comparing) +import Data.List (sortBy) + +-- Let’s look at a simple, normal list comprehension to start: + +parallelListComp :: [Int] +parallelListComp = [ x + y * z + | x <- [0..10] + | y <- [10..20] + | z <- [20..30] + ] + +oldest :: [Int] -> [String] +oldest tbl = [ "str" + | n <- tbl + , then id + ] diff --git a/tests/examples/ghc80/LiteralsTest2.hs b/tests/examples/ghc80/LiteralsTest2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/LiteralsTest2.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE MagicHash #-} +module LiteralsTest2 where + +x,y :: Int +x = 0003 +y = 0x04 + +s :: String +s = "\x20" + +c :: Char +c = '\x20' + +d :: Double +d = 0.00 + +blah = x + where + charH = '\x41'# + intH = 0004# + wordH = 005## + floatH = 3.20# + doubleH = 04.16## + x = 1 diff --git a/tests/examples/ghc80/Main.hs b/tests/examples/ghc80/Main.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Main.hs @@ -0,0 +1,14 @@ +-- Copyright (C) 2015, Luke Iannini + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main where +import Printf ( pr ) + +foreign import ccall "talkToCxx" talkToCxx :: IO () + +main :: IO () +main = do + putStrLn ( $(pr "Hello From Template Haskell!") ) + talkToCxx diff --git a/tests/examples/ghc80/Manipulate.hs b/tests/examples/ghc80/Manipulate.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Manipulate.hs @@ -0,0 +1,39 @@ +{- | +Module : Control.Comonad.Sheet.Manipulate +Description : Generic functions for manipulating multi-dimensional comonadic spreadsheets. +Copyright : Copyright (c) 2014 Kenneth Foner + +Maintainer : kenneth.foner@gmail.com +Stability : experimental +Portability : non-portable + +This module defines the 'take', 'view', 'go', and 'insert' functions generically for any dimensionality of sheet. These +constitute the preferred way of manipulating sheets, providing an interface to: take finite slices ('take'), infinite +slices ('view'), move to locations ('go'), and insert finite or infinite structures ('insert'). +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Control.Comonad.Sheet.Manipulate where + + +-- | In the case of a @Nested@ structure, @asDimensionalAs@ defaults to @asNestedAs@. +instance (NestedAs x (Nested ts y), AsDimensionalAs x (Nested ts y) ~ AsNestedAs x (Nested ts y)) => DimensionalAs x (Nested ts y) where + type x `AsDimensionalAs` (Nested ts a) = x `AsNestedAs` (Nested ts a) + asDimensionalAs = asNestedAs + +-- | @DimensionalAs@ also knows the dimensionality of an 'Indexed' sheet as well as regular @Nested@ structures. +instance (NestedAs x (Nested ts y)) => DimensionalAs x (Indexed ts y) where + type x `AsDimensionalAs` (Indexed ts a) = x `AsNestedAs` (Nested ts a) + x `asDimensionalAs` (Indexed i t) = x `asNestedAs` t + + +instance DepIndex (a,b) TH_0 where + type (a,b) `DepIndexResult` TH_0 = a + (a,b) # TH_0 = a diff --git a/tests/examples/ghc80/Match.hs b/tests/examples/ghc80/Match.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Match.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK hide #-} + +-- Discriminate binary functions that commute, and if so return the operands in +-- a stable ordering such that matching recognises expressions modulo +-- commutativity. +-- +commutes + :: forall acc env aenv a r. + HashAcc acc + -> PrimFun (a -> r) + -> PreOpenExp acc env aenv a + -> Maybe (PreOpenExp acc env aenv a) +commutes h f x = case f of + PrimAdd _ -> Just (swizzle x) + PrimMul _ -> Just (swizzle x) + PrimBAnd _ -> Just (swizzle x) + PrimBOr _ -> Just (swizzle x) + PrimBXor _ -> Just (swizzle x) + PrimEq _ -> Just (swizzle x) + PrimNEq _ -> Just (swizzle x) + PrimMax _ -> Just (swizzle x) + PrimMin _ -> Just (swizzle x) + PrimLAnd -> Just (swizzle x) + PrimLOr -> Just (swizzle x) + _ -> Nothing + where + swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a') + swizzle exp + | Tuple (NilTup `SnocTup` a `SnocTup` b) <- exp + , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a) + -- + | otherwise = exp diff --git a/tests/examples/ghc80/MonadFailErrors.hs b/tests/examples/ghc80/MonadFailErrors.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/MonadFailErrors.hs @@ -0,0 +1,95 @@ +-- Test purpose: +-- Break properly if MonadFail is live + +{-# LANGUAGE MonadFailDesugaring #-} + +module MonadFailWarnings where + +import Control.Monad.Fail +import Control.Monad.ST +import Data.Functor.Identity + + + +general :: Monad m => m a +general = do + Just x <- undefined + undefined + + + +general' :: MonadFail m => m a +general' = do + Just x <- undefined + undefined + + + +identity :: Identity a +identity = do + Just x <- undefined + undefined + + + +io :: IO a +io = do + Just x <- undefined + undefined + + + +st :: ST s a +st = do + Just x <- undefined + undefined + + + +reader :: r -> a +reader = do + Just x <- undefined + undefined + + + +newtype Newtype a = Newtype a +newtypeMatch :: Identity a +newtypeMatch = do + Newtype x <- undefined + undefined + + + +data Data a = Data a +singleConMatch :: Identity a +singleConMatch = do + Data x <- undefined + undefined + + + +data Maybe' a = Nothing' | Just' a +instance Functor Maybe' where fmap = undefined +instance Applicative Maybe' where pure = undefined; (<*>) = undefined +instance Monad Maybe' where (>>=) = undefined +instance MonadFail Maybe' where fail = undefined +customFailable :: Maybe' a +customFailable = do + Just x <- undefined + undefined + + +wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a +wildcardx = do + x <- undefined + undefined +explicitlyIrrefutable = do + ~(x:y) <- undefined + undefined +wildcard_ = do + _ <- undefined + undefined +tuple = do + (a,b) <- undefined + undefined diff --git a/tests/examples/ghc80/MonadFailWarnings.hs b/tests/examples/ghc80/MonadFailWarnings.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/MonadFailWarnings.hs @@ -0,0 +1,107 @@ +-- Test purpose: +-- Ensure that MonadFail warnings are issued correctly if the warning flag +-- is enabled + +{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-} + +module MonadFailWarnings where + +import Control.Monad.Fail +import Control.Monad.ST +import Data.Functor.Identity + + + +-- should warn, because the do-block gets a general Monad constraint, +-- but should have MonadFail +general :: Monad m => m a +general = do + Just x <- undefined + undefined + + + +-- should NOT warn, because the constraint is correct +general' :: MonadFail m => m a +general' = do + Just x <- undefined + undefined + + + +-- should warn, because Identity isn't MonadFail +identity :: Identity a +identity = do + Just x <- undefined + undefined + + + +-- should NOT warn, because IO is MonadFail +io :: IO a +io = do + Just x <- undefined + undefined + + + +-- should warn, because (ST s) is not MonadFail +st :: ST s a +st = do + Just x <- undefined + undefined + + + +-- should warn, because (r ->) is not MonadFail +reader :: r -> a +reader = do + Just x <- undefined + undefined + + + +-- should NOT warn, because matching against newtype +newtype Newtype a = Newtype a +newtypeMatch :: Identity a +newtypeMatch = do + Newtype x <- undefined + undefined + + + +-- should NOT warn, because Data has only one constructor +data Data a = Data a +singleConMatch :: Identity a +singleConMatch = do + Data x <- undefined + undefined + + + +-- should NOT warn, because Maybe' has a MonadFail instance +data Maybe' a = Nothing' | Just' a +instance Functor Maybe' where fmap = undefined +instance Applicative Maybe' where pure = undefined; (<*>) = undefined +instance Monad Maybe' where (>>=) = undefined +instance MonadFail Maybe' where fail = undefined +customFailable :: Maybe' a +customFailable = do + Just x <- undefined + undefined + + +-- should NOT warn, because patterns always match +wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a +wildcardx = do + x <- undefined + undefined +explicitlyIrrefutable = do + ~(x:y) <- undefined + undefined +wildcard_ = do + _ <- undefined + undefined +tuple = do + (a,b) <- undefined + undefined diff --git a/tests/examples/ghc80/MonadFailWarningsDisabled.hs b/tests/examples/ghc80/MonadFailWarningsDisabled.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/MonadFailWarningsDisabled.hs @@ -0,0 +1,94 @@ +-- Test purpose: +-- Make sure that not enabling MonadFail warnings makes code compile just +-- as it did in < 8.0 + +module MonadFailWarnings where + +import Control.Monad.Fail +import Control.Monad.ST +import Data.Functor.Identity + + + +general :: Monad m => m a +general = do + Just x <- undefined + undefined + + + +general' :: MonadFail m => m a +general' = do + Just x <- undefined + undefined + + + +identity :: Identity a +identity = do + Just x <- undefined + undefined + + + +io :: IO a +io = do + Just x <- undefined + undefined + + + +st :: ST s a +st = do + Just x <- undefined + undefined + + + +reader :: r -> a +reader = do + Just x <- undefined + undefined + + + +newtype Newtype a = Newtype a +newtypeMatch :: Identity a +newtypeMatch = do + Newtype x <- undefined + undefined + + + +data Data a = Data a +singleConMatch :: Identity a +singleConMatch = do + Data x <- undefined + undefined + + + +data Maybe' a = Nothing' | Just' a +instance Functor Maybe' where fmap = undefined +instance Applicative Maybe' where pure = undefined; (<*>) = undefined +instance Monad Maybe' where (>>=) = undefined +instance MonadFail Maybe' where fail = undefined +customFailable :: Maybe' a +customFailable = do + Just x <- undefined + undefined + + +wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a +wildcardx = do + x <- undefined + undefined +explicitlyIrrefutable = do + ~(x:y) <- undefined + undefined +wildcard_ = do + _ <- undefined + undefined +tuple = do + (a,b) <- undefined + undefined diff --git a/tests/examples/ghc80/MonadFailWarningsWithRebindableSyntax.hs b/tests/examples/ghc80/MonadFailWarningsWithRebindableSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/MonadFailWarningsWithRebindableSyntax.hs @@ -0,0 +1,14 @@ +-- Test purpose: +-- RebindableSyntax does not play that well with MonadFail, so here we ensure +-- that when both settings are enabled we get the proper warning. + +{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-} +{-# LANGUAGE RebindableSyntax #-} + +module MonadFailWarningsWithRebindableSyntax where + +import Prelude + +test1 f g = do + Just x <- f + g diff --git a/tests/examples/ghc80/MultiLineWarningPragma.hs b/tests/examples/ghc80/MultiLineWarningPragma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/MultiLineWarningPragma.hs @@ -0,0 +1,18 @@ + +{-# WARNING Logic + , mkSolver + , mkSimpleSolver + , mkSolverForLogic + , solverSetParams + , solverPush + , solverPop + , solverReset + , solverGetNumScopes + , solverAssertCnstr + , solverAssertAndTrack + , solverCheck + , solverCheckAndGetModel + , solverGetReasonUnknown + "New Z3 API support is still incomplete and fragile: \ + \you may experience segmentation faults!" + #-} diff --git a/tests/examples/ghc80/MultiQuote.hs b/tests/examples/ghc80/MultiQuote.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/MultiQuote.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes#-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Internal API for the store package. The functions here which are +-- not re-exported by "Data.Store" are less likely to have stable APIs. +-- +-- This module also defines most of the included 'Store' instances, for +-- types from the base package and other commonly used packages +-- (bytestring, containers, text, time, etc). +module Data.Store.Internal where + +------------------------------------------------------------------------ +-- Instances generated by TH + +$($(derive [d| + -- TODO + -- instance Deriving (Store ()) + instance Deriving (Store All) + instance Deriving (Store Any) + instance Deriving (Store Void) + instance Deriving (Store Bool) + |])) + diff --git a/tests/examples/ghc80/MultiWayIf.hs b/tests/examples/ghc80/MultiWayIf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/MultiWayIf.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultiWayIf #-} +module MultiWayIf where + +foo = if | test1 -> e1 + | test2 witharg -> e2 + | otherwise -> def + +bar = if { | test1 -> if { | test2 -> e1 + | test3 -> e2 } + | test4 -> e3 + } + +-- taken from GHC's test suite +x = 10 +x1 = if | x < 10 -> "< 10" | otherwise -> "" +x2 = if | x < 10 -> "< 10" + | otherwise -> "" +x3 = if | x < 10 -> "< 10" + | otherwise -> "" +x4 = if | True -> "yes" +x5 = if | True -> if | False -> 1 | True -> 2 + +x6 = if | x < 10 -> if | True -> "yes" + | False -> "no" + | otherwise -> "maybe" + +x7 = (if | True -> 0) + +-- issue #98 +spam = if | () <- () -> () diff --git a/tests/examples/ghc80/NamedWildcardInDataFamilyInstanceLHS.hs b/tests/examples/ghc80/NamedWildcardInDataFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/NamedWildcardInDataFamilyInstanceLHS.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds, NamedWildCards #-} +module NamedWildcardInDataFamilyInstanceLHS where + +data MyKind = A | B + +data family Sing (a :: k) + +data instance Sing (_a :: MyKind) where + SingA :: Sing A + SingB :: Sing B diff --git a/tests/examples/ghc80/NamedWildcardInTypeFamilyInstanceLHS.hs b/tests/examples/ghc80/NamedWildcardInTypeFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/NamedWildcardInTypeFamilyInstanceLHS.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NamedWildCards #-} +module NamedWildcardInTypeFamilyInstanceLHS where + +type family F a where + F _t = Int diff --git a/tests/examples/ghc80/NamedWildcardInTypeSplice.hs b/tests/examples/ghc80/NamedWildcardInTypeSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/NamedWildcardInTypeSplice.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedWildCards #-} +module NamedWildcardInTypeSplice where + +import Language.Haskell.TH + +metaType :: TypeQ +metaType = [t| _a -> _a |] diff --git a/tests/examples/ghc80/OutOfHeap.hs b/tests/examples/ghc80/OutOfHeap.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/OutOfHeap.hs @@ -0,0 +1,10 @@ +import qualified Data.Array.Unboxed as UA +import Data.Word + +main :: IO () +main = print (UA.listArray (1, 2^(20::Int)) (repeat 0) + :: UA.UArray Int Word64) + -- this unboxed array should at least take: + -- 2^20 * 64 bits + -- = 8 * (2^20 bytes) + -- = 8 MiB (in heap) diff --git a/tests/examples/ghc80/OverloadedRecFldsFail04_A.hs b/tests/examples/ghc80/OverloadedRecFldsFail04_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/OverloadedRecFldsFail04_A.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module OverloadedRecFldsFail04_A (U(..), V(MkV, x), Unused(..), u) where + +data U = MkU { x :: Bool, y :: Bool } +data V = MkV { x :: Int } +data Unused = MkUnused { unused :: Bool } + +u = MkU False True diff --git a/tests/examples/ghc80/OverloadedRecFldsFail06_A.hs b/tests/examples/ghc80/OverloadedRecFldsFail06_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/OverloadedRecFldsFail06_A.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -fwarn-unused-binds #-} + +module OverloadedRecFldsFail06_A (U(..), V(..), Unused(unused), u, getX, getY, z) where + +data U = MkU { x :: Bool, y :: Bool } | MkU2 { used_locally :: Bool } + deriving Show +data V = MkV { x :: Int } | MkV2 { y :: Bool } +data Unused = MkUnused { unused :: Bool, unused2 :: Bool, used_locally :: Bool } + +u = MkU False True + +z MkU2{used_locally=used_locally} = used_locally + +getX MkU{x=x} = x +getY MkV2{y=y} = y diff --git a/tests/examples/ghc80/OverloadedRecFldsFail10_A.hs b/tests/examples/ghc80/OverloadedRecFldsFail10_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/OverloadedRecFldsFail10_A.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} +module OverloadedRecFldsFail10_A where + +data family F a +data instance F Int = MkFInt { foo :: Int } diff --git a/tests/examples/ghc80/OverloadedRecFldsFail10_B.hs b/tests/examples/ghc80/OverloadedRecFldsFail10_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/OverloadedRecFldsFail10_B.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module OverloadedRecFldsFail10_B (F(..)) where + +import OverloadedRecFldsFail10_A hiding (foo) + +data instance F Bool = MkFBool { foo :: Int } diff --git a/tests/examples/ghc80/OverloadedRecFldsFail10_C.hs b/tests/examples/ghc80/OverloadedRecFldsFail10_C.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/OverloadedRecFldsFail10_C.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} +module OverloadedRecFldsFail10_C (F(..)) where + +import OverloadedRecFldsFail10_A + +data instance F Char = MkFChar { foo :: Char } diff --git a/tests/examples/ghc80/OverloadedRecFldsFail11_A.hs b/tests/examples/ghc80/OverloadedRecFldsFail11_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/OverloadedRecFldsFail11_A.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module OverloadedRecFldsFail11_A where + +{-# WARNING foo "Warning on a record field" #-} +data S = MkS { foo :: Bool } +data T = MkT { foo :: Int } diff --git a/tests/examples/ghc80/OverloadedRecFldsFail12_A.hs b/tests/examples/ghc80/OverloadedRecFldsFail12_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/OverloadedRecFldsFail12_A.hs @@ -0,0 +1,5 @@ +module OverloadedRecFldsFail12_A where + +{-# WARNING foo "Deprecated foo" #-} +{-# WARNING bar "Deprecated bar" #-} +data T = MkT { foo :: Int, bar :: Int } diff --git a/tests/examples/ghc80/OverloadedRecFldsRun02_A.hs b/tests/examples/ghc80/OverloadedRecFldsRun02_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/OverloadedRecFldsRun02_A.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module OverloadedRecFldsRun02_A (U(..), V(MkV, x), Unused(..), u) where + +data U = MkU { x :: Bool, y :: Bool } +data V = MkV { x :: Int } +data Unused = MkUnused { unused :: Bool } + +u = MkU False True diff --git a/tests/examples/ghc80/P.hs b/tests/examples/ghc80/P.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/P.hs @@ -0,0 +1,12 @@ +module P where + +import qualified Map +import qualified Set + +foo = do + let x = Map.insert 0 "foo" + . Map.insert (6 :: Int) "foo" + $ Map.empty + print (Map.lookup 1 x) + print (Set.size (Map.keysSet x)) + return x diff --git a/tests/examples/ghc80/PSQ.hs b/tests/examples/ghc80/PSQ.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/PSQ.hs @@ -0,0 +1,4 @@ + +data TourView a = Null + | Single {-# UNPACK #-} !(Elem a) + | (PSQ a) `Play` (PSQ a) diff --git a/tests/examples/ghc80/ParenFunBind.hs b/tests/examples/ghc80/ParenFunBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ParenFunBind.hs @@ -0,0 +1,5 @@ +module ParenFunBind where + +(foo x) y = x + y +((bar x)) y = x + y +((baz x)) (y) = x + y diff --git a/tests/examples/ghc80/ParenTypeSynonym.hs b/tests/examples/ghc80/ParenTypeSynonym.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ParenTypeSynonym.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} +module ParenTypeSynonym where + +type Is = (~) diff --git a/tests/examples/ghc80/PartialClassMethodSignature2.hs b/tests/examples/ghc80/PartialClassMethodSignature2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/PartialClassMethodSignature2.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module PartialClassMethodSignature2 where + +class Foo a where + foo :: (Eq a, _) => a -> a diff --git a/tests/examples/ghc80/PluralS.hs b/tests/examples/ghc80/PluralS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/PluralS.hs @@ -0,0 +1,27 @@ +-- Test purpose: +-- +-- Ensure the plural "s" in warnings is only shown if there are more than +-- one entries + +{-# OPTIONS_GHC -Wredundant-constraints #-} +{-# OPTIONS_GHC -Wtype-defaults #-} + +module PluralS () where + + + +-- Defaulting type classes + +defaultingNum = 123 `seq` () + +defaultingNumAndShow = show 123 + + + +-- Redundant constraints + +redundantNum :: (Num a, Num a) => a +redundantNum = 123 + +redundantMultiple :: (Num a, Show a, Num a, Eq a, Eq a) => a +redundantMultiple = 123 diff --git a/tests/examples/ghc80/PolyInstances.hs b/tests/examples/ghc80/PolyInstances.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/PolyInstances.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE PolyKinds, FlexibleInstances, ScopedTypeVariables, + UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module PolyInstances where + +import GHC.Exts +import Data.Proxy + +class C (a :: k) + +instance (C a, C b) => C (a b) + +data Dict :: Constraint -> * + +instance C Dict + +foo :: C p => proxy p -> () +foo = undefined + +bar :: forall (p :: Constraint) proxy. C p => proxy p -> () +bar _ = foo (Proxy :: Proxy (Dict p)) diff --git a/tests/examples/ghc80/PopCnt.hs b/tests/examples/ghc80/PopCnt.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/PopCnt.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-} +module Main where + +import GHC.Exts + +foreign import prim "do_popcnt32" popcnt32 :: Int# -> Int# + +main = print (I# (popcnt32 0xffff#)) + diff --git a/tests/examples/ghc80/Ppr017.hs b/tests/examples/ghc80/Ppr017.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Ppr017.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ExplicitNamespaces #-} +module Imports( f, type (+), pattern Single ) where + +import GHC.TypeLits + +pattern Single x = [x] + +f = undefined diff --git a/tests/examples/ghc80/Primop.hs b/tests/examples/ghc80/Primop.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Primop.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE GHCForeignImportPrim, MagicHash, + UnliftedFFITypes, UnboxedTuples #-} + +import GHC.Exts + +foreign import prim "dummy" + dummy :: Word# -> Word# + +foreign import prim "dummy2" + dummy2 :: Any -> State# RealWorld -> (# State# RealWorld, Word# #) diff --git a/tests/examples/ghc80/Printf.hs b/tests/examples/ghc80/Printf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Printf.hs @@ -0,0 +1,34 @@ +-- Copyright (C) 2015, Luke Iannini + +{-# LANGUAGE TemplateHaskell #-} +module Printf where + +-- Skeletal printf from the paper: +-- http://research.microsoft.com/pubs/67015/meta-haskell.pdf +-- It needs to be in a separate module to the one where +-- you intend to use it. + +-- Import some Template Haskell syntax +import Language.Haskell.TH + +-- Describe a format string +data Format = D | S | L String + +-- Parse a format string. This is left largely to you +-- as we are here interested in building our first ever +-- Template Haskell program and not in building printf. +parse :: String -> [Format] +parse s = [ L s ] + +-- Generate Haskell source code from a parsed representation +-- of the format string. This code will be spliced into +-- the module which calls "pr", at compile time. +gen :: [Format] -> Q Exp +gen [D] = [| \n -> show n |] +gen [S] = [| \s -> s |] +gen [L s] = stringE s + +-- Here we generate the Haskell code for the splice +-- from an input format string. +pr :: String -> Q Exp +pr s = gen (parse s) diff --git a/tests/examples/ghc80/PromotedClass.hs b/tests/examples/ghc80/PromotedClass.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/PromotedClass.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeInType, GADTs #-} + +module PromotedClass where + +import Data.Proxy + +data X a where + MkX :: Show a => a -> X a + +foo :: Proxy ('MkX 'True) +foo = Proxy diff --git a/tests/examples/ghc80/Q.hs b/tests/examples/ghc80/Q.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Q.hs @@ -0,0 +1,7 @@ +module Q where + +import qualified Map +import Map(Map) + +mymember :: Int -> Map Int a -> Bool +mymember k m = Map.member k m || Map.member (k + 1) m diff --git a/tests/examples/ghc80/QQ.hs b/tests/examples/ghc80/QQ.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/QQ.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +module QQ where + +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax +import Language.Haskell.TH + +pq = QuasiQuoter { quoteDec = \_ -> return [sig], + quoteType = \_ -> undefined, + quoteExp = \_ -> undefined, + quotePat = \_ -> undefined } + +sig = SigD (mkName "f") (ArrowT `AppT` int `AppT` int) +int = ConT (mkName "Int") diff --git a/tests/examples/ghc80/Query.hs b/tests/examples/ghc80/Query.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Query.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} + +module AWS.Lib.Query where + +requestQuery = do + if st < 400 +#ifdef DEBUG + do e +#else + then return body + else fail "not reached" +#endif + diff --git a/tests/examples/ghc80/RAE_T32a.hs b/tests/examples/ghc80/RAE_T32a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/RAE_T32a.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds, + PolyKinds, TypeFamilies, GADTs, TypeInType #-} + +module RAE_T32a where + +import Data.Kind + +data family Sing (k :: *) :: k -> * + +data TyArr' (a :: *) (b :: *) :: * +type TyArr (a :: *) (b :: *) = TyArr' a b -> * +type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2 +data TyPi' (a :: *) (b :: TyArr a *) :: * +type TyPi (a :: *) (b :: TyArr a *) = TyPi' a b -> * +type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b +$(return []) + +data MkStar (p :: *) (x :: TyArr' p *) +type instance MkStar p @@ x = * +$(return []) + +data Sigma (p :: *) (r :: TyPi p (MkStar p)) :: * where + Sigma :: + forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a). + Sing * p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b -> Sigma p r +$(return []) + +data instance Sing Sigma (Sigma p r) x where + SSigma :: + forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a) + (sp :: Sing * p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) (sb :: Sing (r @@@ a) b). + Sing (Sing (r @@@ a) b) sb -> + Sing (Sigma p r) ('Sigma sp sr sa sb) + +-- I (RAE) believe this last definition is ill-typed. diff --git a/tests/examples/ghc80/RAE_T32b.hs b/tests/examples/ghc80/RAE_T32b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/RAE_T32b.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, DataKinds, PolyKinds, + RankNTypes, TypeOperators, TypeInType #-} + +module RAE_T32b where + +import Data.Kind + +data family Sing (k :: *) :: k -> * + +data TyArr (a :: *) (b :: *) :: * +type family (a :: TyArr k1 k2 -> *) @@ (b :: k1) :: k2 +$(return []) + +data Sigma (p :: *) (r :: TyArr p * -> *) :: * where + Sigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a). + Sing * p -> Sing (TyArr p * -> *) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r +$(return []) + +data instance Sing (Sigma p r) (x :: Sigma p r) :: * where + SSigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a) + (sp :: Sing * p) (sr :: Sing (TyArr p * -> *) r) (sa :: Sing p a) (sb :: Sing (r @@ a) b). + Sing (Sing (r @@ a) b) sb -> + Sing (Sigma p r) ('Sigma sp sr sa sb) diff --git a/tests/examples/ghc80/Rae31.hs b/tests/examples/ghc80/Rae31.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Rae31.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds, + TypeFamilies, TypeInType #-} + +module A where + +import Data.Kind + +data family Sing (k :: *) :: k -> * +type Sing' (x :: k) = Sing k x +data TyFun' (a :: *) (b :: *) :: * +type TyFun (a :: *) (b :: *) = TyFun' a b -> * +type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2 +data TyPi' (a :: *) (b :: TyFun a *) :: * +type TyPi (a :: *) (b :: TyFun a *) = TyPi' a b -> * +type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b +$(return []) + +data A (a :: *) (b :: a) (c :: TyFun' a *) -- A :: forall a -> a -> a ~> * +type instance (@@) (A a b) c = * +$(return []) +data B (a :: *) (b :: TyFun' a *) -- B :: forall a -> a ~> * +type instance (@@) (B a) b = TyPi a (A a b) +$(return []) +data C (a :: *) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) *) diff --git a/tests/examples/ghc80/RaeBlogPost.hs b/tests/examples/ghc80/RaeBlogPost.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/RaeBlogPost.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies, + TypeInType #-} +{-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-} + +module RaeBlogPost where + +import Data.Kind + +-- a Proxy type with an explicit kind +data Proxy k (a :: k) = P +prox :: Proxy * Bool +prox = P + +prox2 :: Proxy Bool 'True +prox2 = P + +-- implicit kinds still work +data A +data B :: A -> * +data C :: B a -> * +data D :: C b -> * +data E :: D c -> * +-- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> * + +-- a kind-indexed GADT +data TypeRep (a :: k) where + TInt :: TypeRep Int + TMaybe :: TypeRep Maybe + TApp :: TypeRep a -> TypeRep b -> TypeRep (a b) + +zero :: TypeRep a -> a +zero TInt = 0 +zero (TApp TMaybe _) = Nothing + +data Nat = Zero | Succ Nat +type family a + b where + 'Zero + b = b + ('Succ a) + b = 'Succ (a + b) + +data Vec :: * -> Nat -> * where + Nil :: Vec a 'Zero + (:>) :: a -> Vec a n -> Vec a ('Succ n) +infixr 5 :> + +-- promoted GADT, and using + as a "kind family": +type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where + 'Nil ++ y = y + (h ':> t) ++ y = h ':> (t ++ y) + +-- datatype that mentions * +data U = Star (*) + | Bool Bool + +-- kind synonym +type Monadish = * -> * +class MonadTrans (t :: Monadish -> Monadish) where + lift :: Monad m => m a -> t m a +data Free :: Monadish where + Return :: a -> Free a + Bind :: Free a -> (a -> Free b) -> Free b + +-- yes, * really does have type *. +type Star = (* :: (* :: (* :: *))) diff --git a/tests/examples/ghc80/RandomPGC.hs b/tests/examples/ghc80/RandomPGC.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/RandomPGC.hs @@ -0,0 +1,597 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Random +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE in the 'random' repository) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- This library deals with the common task of pseudo-random number +-- generation. The library makes it possible to generate repeatable +-- results, by starting with a specified initial random number generator, +-- or to get different results on each run by using the system-initialised +-- generator or by supplying a seed from some other source. +-- +-- The library is split into two layers: +-- +-- * A core /random number generator/ provides a supply of bits. +-- The class 'RandomGen' provides a common interface to such generators. +-- The library provides one instance of 'RandomGen', the abstract +-- data type 'StdGen'. Programmers may, of course, supply their own +-- instances of 'RandomGen'. +-- +-- * The class 'Random' provides a way to extract values of a particular +-- type from a random number generator. For example, the 'Float' +-- instance of 'Random' allows one to generate random values of type +-- 'Float'. +-- +-- This implementation uses the Portable Combined Generator of L'Ecuyer +-- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by +-- Lennart Augustsson. It has a period of roughly 2.30584e18. +-- +----------------------------------------------------------------------------- + +#include "MachDeps.h" + +module RandomPGC + ( + + -- $intro + + -- * Random number generators + +#ifdef ENABLE_SPLITTABLEGEN + RandomGen(next, genRange) + , SplittableGen(split) +#else + RandomGen(next, genRange, split) +#endif + -- ** Standard random number generators + , StdGen + , mkStdGen + + -- ** The global random number generator + + -- $globalrng + + , getStdRandom + , getStdGen + , setStdGen + , newStdGen + + -- * Random values of various types + , Random ( random, randomR, + randoms, randomRs, + randomIO, randomRIO ) + + -- * References + -- $references + + ) where + +import Prelude + +import Data.Bits +import Data.Int +import Data.Word +import Foreign.C.Types + +#ifdef __NHC__ +import CPUTime ( getCPUTime ) +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.C ( CTime, CUInt ) +#else +import System.CPUTime ( getCPUTime ) +import Data.Time ( getCurrentTime, UTCTime(..) ) +import Data.Ratio ( numerator, denominator ) +#endif +import Data.Char ( isSpace, chr, ord ) +import System.IO.Unsafe ( unsafePerformIO ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Data.IORef ( atomicModifyIORef' ) +import Numeric ( readDec ) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Exts ( build ) +#else +-- | A dummy variant of build without fusion. +{-# INLINE build #-} +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build g = g (:) [] +#endif + +-- The standard nhc98 implementation of Time.ClockTime does not match +-- the extended one expected in this module, so we lash-up a quick +-- replacement here. +#ifdef __NHC__ +foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime +getTime :: IO (Integer, Integer) +getTime = do CTime t <- readtime nullPtr; return (toInteger t, 0) +#else +getTime :: IO (Integer, Integer) +getTime = do + utc <- getCurrentTime + let daytime = toRational $ utctDayTime utc + return $ quotRem (numerator daytime) (denominator daytime) +#endif + +-- | The class 'RandomGen' provides a common interface to random number +-- generators. +-- +#ifdef ENABLE_SPLITTABLEGEN +-- Minimal complete definition: 'next'. +#else +-- Minimal complete definition: 'next' and 'split'. +#endif + +class RandomGen g where + + -- |The 'next' operation returns an 'Int' that is uniformly distributed + -- in the range returned by 'genRange' (including both end points), + -- and a new generator. + next :: g -> (Int, g) + + -- |The 'genRange' operation yields the range of values returned by + -- the generator. + -- + -- It is required that: + -- + -- * If @(a,b) = 'genRange' g@, then @a < b@. + -- + -- * 'genRange' always returns a pair of defined 'Int's. + -- + -- The second condition ensures that 'genRange' cannot examine its + -- argument, and hence the value it returns can be determined only by the + -- instance of 'RandomGen'. That in turn allows an implementation to make + -- a single call to 'genRange' to establish a generator's range, without + -- being concerned that the generator returned by (say) 'next' might have + -- a different range to the generator passed to 'next'. + -- + -- The default definition spans the full range of 'Int'. + genRange :: g -> (Int,Int) + + -- default method + genRange _ = (minBound, maxBound) + +#ifdef ENABLE_SPLITTABLEGEN +-- | The class 'SplittableGen' proivides a way to specify a random number +-- generator that can be split into two new generators. +class SplittableGen g where +#endif + -- |The 'split' operation allows one to obtain two distinct random number + -- generators. This is very useful in functional programs (for example, when + -- passing a random number generator down to recursive calls), but very + -- little work has been done on statistically robust implementations of + -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"] + -- are the only examples we know of). + split :: g -> (g, g) + +{- | +The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits. + +The result of repeatedly using 'next' should be at least as statistically +robust as the /Minimal Standard Random Number Generator/ described by +["System.Random\#Park", "System.Random\#Carta"]. +Until more is known about implementations of 'split', all we require is +that 'split' deliver generators that are (a) not identical and +(b) independently robust in the sense just given. + +The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the +state of a random number generator. +It is required that @'read' ('show' g) == g@. + +In addition, 'reads' may be used to map an arbitrary string (not necessarily one +produced by 'show') onto a value of type 'StdGen'. In general, the 'Read' +instance of 'StdGen' has the following properties: + +* It guarantees to succeed on any string. + +* It guarantees to consume only a finite portion of the string. + +* Different argument strings are likely to result in different results. + +-} + +data StdGen + = StdGen !Int32 !Int32 + +instance RandomGen StdGen where + next = stdNext + genRange _ = stdRange + +#ifdef ENABLE_SPLITTABLEGEN +instance SplittableGen StdGen where +#endif + split = stdSplit + +instance Show StdGen where + showsPrec p (StdGen s1 s2) = + showsPrec p s1 . + showChar ' ' . + showsPrec p s2 + +instance Read StdGen where + readsPrec _p = \ r -> + case try_read r of + r'@[_] -> r' + _ -> [stdFromString r] -- because it shouldn't ever fail. + where + try_read r = do + (s1, r1) <- readDec (dropWhile isSpace r) + (s2, r2) <- readDec (dropWhile isSpace r1) + return (StdGen s1 s2, r2) + +{- + If we cannot unravel the StdGen from a string, create + one based on the string given. +-} +stdFromString :: String -> (StdGen, String) +stdFromString s = (mkStdGen num, rest) + where (cs, rest) = splitAt 6 s + num = foldl (\a x -> x + 3 * a) 1 (map ord cs) + + +{- | +The function 'mkStdGen' provides an alternative way of producing an initial +generator, by mapping an 'Int' into a generator. Again, distinct arguments +should be likely to produce distinct generators. +-} +mkStdGen :: Int -> StdGen -- why not Integer ? +mkStdGen s = mkStdGen32 $ fromIntegral s + +{- +From ["System.Random\#LEcuyer"]: "The integer variables s1 and s2 ... must be +initialized to values in the range [1, 2147483562] and [1, 2147483398] +respectively." +-} +mkStdGen32 :: Int32 -> StdGen +mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1) + where + -- We want a non-negative number, but we can't just take the abs + -- of sMaybeNegative as -minBound == minBound. + s = sMaybeNegative .&. maxBound + (q, s1) = s `divMod` 2147483562 + s2 = q `mod` 2147483398 + +createStdGen :: Integer -> StdGen +createStdGen s = mkStdGen32 $ fromIntegral s + +{- | +With a source of random number supply in hand, the 'Random' class allows the +programmer to extract random values of a variety of types. + +Minimal complete definition: 'randomR' and 'random'. + +-} + +class Random a where + -- | Takes a range /(lo,hi)/ and a random number generator + -- /g/, and returns a random value uniformly distributed in the closed + -- interval /[lo,hi]/, together with a new generator. It is unspecified + -- what happens if /lo>hi/. For continuous types there is no requirement + -- that the values /lo/ and /hi/ are ever produced, but they may be, + -- depending on the implementation and the interval. + randomR :: RandomGen g => (a,a) -> g -> (a,g) + + -- | The same as 'randomR', but using a default range determined by the type: + -- + -- * For bounded types (instances of 'Bounded', such as 'Char'), + -- the range is normally the whole type. + -- + -- * For fractional types, the range is normally the semi-closed interval + -- @[0,1)@. + -- + -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. + random :: RandomGen g => g -> (a, g) + + -- | Plural variant of 'randomR', producing an infinite list of + -- random values instead of returning a new generator. + {-# INLINE randomRs #-} + randomRs :: RandomGen g => (a,a) -> g -> [a] + randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g) + + -- | Plural variant of 'random', producing an infinite list of + -- random values instead of returning a new generator. + {-# INLINE randoms #-} + randoms :: RandomGen g => g -> [a] + randoms g = build (\cons _nil -> buildRandoms cons random g) + + -- | A variant of 'randomR' that uses the global random number generator + -- (see "System.Random#globalrng"). + randomRIO :: (a,a) -> IO a + randomRIO range = getStdRandom (randomR range) + + -- | A variant of 'random' that uses the global random number generator + -- (see "System.Random#globalrng"). + randomIO :: IO a + randomIO = getStdRandom random + +-- | Produce an infinite list-equivalent of random values. +{-# INLINE buildRandoms #-} +buildRandoms :: RandomGen g + => (a -> as -> as) -- ^ E.g. '(:)' but subject to fusion + -> (g -> (a,g)) -- ^ E.g. 'random' + -> g -- ^ A 'RandomGen' instance + -> as +buildRandoms cons rand = go + where + -- The seq fixes part of #4218 and also makes fused Core simpler. + go g = x `seq` (x `cons` go g') where (x,g') = rand g + + +instance Random Integer where + randomR ival g = randomIvalInteger ival g + random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g + +instance Random Int where randomR = randomIvalIntegral; random = randomBounded +instance Random Int8 where randomR = randomIvalIntegral; random = randomBounded +instance Random Int16 where randomR = randomIvalIntegral; random = randomBounded +instance Random Int32 where randomR = randomIvalIntegral; random = randomBounded +instance Random Int64 where randomR = randomIvalIntegral; random = randomBounded + +#ifndef __NHC__ +-- Word is a type synonym in nhc98. +instance Random Word where randomR = randomIvalIntegral; random = randomBounded +#endif +instance Random Word8 where randomR = randomIvalIntegral; random = randomBounded +instance Random Word16 where randomR = randomIvalIntegral; random = randomBounded +instance Random Word32 where randomR = randomIvalIntegral; random = randomBounded +instance Random Word64 where randomR = randomIvalIntegral; random = randomBounded + +instance Random CChar where randomR = randomIvalIntegral; random = randomBounded +instance Random CSChar where randomR = randomIvalIntegral; random = randomBounded +instance Random CUChar where randomR = randomIvalIntegral; random = randomBounded +instance Random CShort where randomR = randomIvalIntegral; random = randomBounded +instance Random CUShort where randomR = randomIvalIntegral; random = randomBounded +instance Random CInt where randomR = randomIvalIntegral; random = randomBounded +instance Random CUInt where randomR = randomIvalIntegral; random = randomBounded +instance Random CLong where randomR = randomIvalIntegral; random = randomBounded +instance Random CULong where randomR = randomIvalIntegral; random = randomBounded +instance Random CPtrdiff where randomR = randomIvalIntegral; random = randomBounded +instance Random CSize where randomR = randomIvalIntegral; random = randomBounded +instance Random CWchar where randomR = randomIvalIntegral; random = randomBounded +instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded +instance Random CLLong where randomR = randomIvalIntegral; random = randomBounded +instance Random CULLong where randomR = randomIvalIntegral; random = randomBounded +instance Random CIntPtr where randomR = randomIvalIntegral; random = randomBounded +instance Random CUIntPtr where randomR = randomIvalIntegral; random = randomBounded +instance Random CIntMax where randomR = randomIvalIntegral; random = randomBounded +instance Random CUIntMax where randomR = randomIvalIntegral; random = randomBounded + +instance Random Char where + randomR (a,b) g = + case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of + (x,g') -> (chr x, g') + random g = randomR (minBound,maxBound) g + +instance Random Bool where + randomR (a,b) g = + case (randomIvalInteger (bool2Int a, bool2Int b) g) of + (x, g') -> (int2Bool x, g') + where + bool2Int :: Bool -> Integer + bool2Int False = 0 + bool2Int True = 1 + + int2Bool :: Int -> Bool + int2Bool 0 = False + int2Bool _ = True + + random g = randomR (minBound,maxBound) g + +{-# INLINE randomRFloating #-} +randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g) +randomRFloating (l,h) g + | l>h = randomRFloating (h,l) g + | otherwise = let (coef,g') = random g in + (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g') -- avoid overflow + +instance Random Double where + randomR = randomRFloating + random rng = + case random rng of + (x,rng') -> + -- We use 53 bits of randomness corresponding to the 53 bit significand: + ((fromIntegral (mask53 .&. (x::Int64)) :: Double) + / fromIntegral twoto53, rng') + where + twoto53 = (2::Int64) ^ (53::Int64) + mask53 = twoto53 - 1 + +instance Random Float where + randomR = randomRFloating + random rng = + -- TODO: Faster to just use 'next' IF it generates enough bits of randomness. + case random rng of + (x,rng') -> + -- We use 24 bits of randomness corresponding to the 24 bit significand: + ((fromIntegral (mask24 .&. (x::Int32)) :: Float) + / fromIntegral twoto24, rng') + -- Note, encodeFloat is another option, but I'm not seeing slightly + -- worse performance with the following [2011.06.25]: +-- (encodeFloat rand (-24), rng') + where + mask24 = twoto24 - 1 + twoto24 = (2::Int32) ^ (24::Int32) + +-- CFloat/CDouble are basically the same as a Float/Double: +instance Random CFloat where + randomR = randomRFloating + random rng = case random rng of + (x,rng') -> (realToFrac (x::Float), rng') + +instance Random CDouble where + randomR = randomRFloating + -- A MYSTERY: + -- Presently, this is showing better performance than the Double instance: + -- (And yet, if the Double instance uses randomFrac then its performance is much worse!) + random = randomFrac + -- random rng = case random rng of + -- (x,rng') -> (realToFrac (x::Double), rng') + +mkStdRNG :: Integer -> IO StdGen +mkStdRNG o = do + ct <- getCPUTime + (sec, psec) <- getTime + return (createStdGen (sec * 12345 + psec + ct + o)) + +randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g) +randomBounded = randomR (minBound, maxBound) + +-- The two integer functions below take an [inclusive,inclusive] range. +randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g) +randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h) + +{-# SPECIALIZE randomIvalInteger :: (Num a) => + (Integer, Integer) -> StdGen -> (a, StdGen) #-} + +randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) +randomIvalInteger (l,h) rng + | l > h = randomIvalInteger (h,l) rng + | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') + where + (genlo, genhi) = genRange rng + b = fromIntegral genhi - fromIntegral genlo + 1 + + -- Probabilities of the most likely and least likely result + -- will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen + -- is uniform, of course + + -- On average, log q / log b more random values will be generated + -- than the minimum + q = 1000 + k = h - l + 1 + magtgt = k * q + + -- generate random values until we exceed the target magnitude + f mag v g | mag >= magtgt = (v, g) + | otherwise = v' `seq`f (mag*b) v' g' where + (x,g') = next g + v' = (v * b + (fromIntegral x - fromIntegral genlo)) + + +-- The continuous functions on the other hand take an [inclusive,exclusive) range. +randomFrac :: (RandomGen g, Fractional a) => g -> (a, g) +randomFrac = randomIvalDouble (0::Double,1) realToFrac + +randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g) +randomIvalDouble (l,h) fromDouble rng + | l > h = randomIvalDouble (h,l) fromDouble rng + | otherwise = + case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of + (x, rng') -> + let + scaled_x = + fromDouble (0.5*l + 0.5*h) + -- previously (l+h)/2, overflowed + fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) * -- avoid overflow + fromIntegral (x::Int32) + in + (scaled_x, rng') + +int32Count :: Integer +int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1 -- GHC ticket #3982 + +stdRange :: (Int,Int) +stdRange = (1, 2147483562) + +stdNext :: StdGen -> (Int, StdGen) +-- Returns values in the range stdRange +stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'') + where z' = if z < 1 then z + 2147483562 else z + z = s1'' - s2'' + + k = s1 `quot` 53668 + s1' = 40014 * (s1 - k * 53668) - k * 12211 + s1'' = if s1' < 0 then s1' + 2147483563 else s1' + + k' = s2 `quot` 52774 + s2' = 40692 * (s2 - k' * 52774) - k' * 3791 + s2'' = if s2' < 0 then s2' + 2147483399 else s2' + +stdSplit :: StdGen -> (StdGen, StdGen) +stdSplit std@(StdGen s1 s2) + = (left, right) + where + -- no statistical foundation for this! + left = StdGen new_s1 t2 + right = StdGen t1 new_s2 + + new_s1 | s1 == 2147483562 = 1 + | otherwise = s1 + 1 + + new_s2 | s2 == 1 = 2147483398 + | otherwise = s2 - 1 + + StdGen t1 t2 = snd (next std) + +-- The global random number generator + +{- $globalrng #globalrng# + +There is a single, implicit, global random number generator of type +'StdGen', held in some global variable maintained by the 'IO' monad. It is +initialised automatically in some system-dependent fashion, for example, by +using the time of day, or Linux's kernel random number generator. To get +deterministic behaviour, use 'setStdGen'. +-} + +-- |Sets the global random number generator. +setStdGen :: StdGen -> IO () +setStdGen sgen = writeIORef theStdGen sgen + +-- |Gets the global random number generator. +getStdGen :: IO StdGen +getStdGen = readIORef theStdGen + +theStdGen :: IORef StdGen +theStdGen = unsafePerformIO $ do + rng <- mkStdRNG 0 + newIORef rng + +-- |Applies 'split' to the current global random generator, +-- updates it with one of the results, and returns the other. +newStdGen :: IO StdGen +newStdGen = atomicModifyIORef' theStdGen split + +{- |Uses the supplied function to get a value from the current global +random generator, and updates the global generator with the new generator +returned by the function. For example, @rollDice@ gets a random integer +between 1 and 6: + +> rollDice :: IO Int +> rollDice = getStdRandom (randomR (1,6)) + +-} + +getStdRandom :: (StdGen -> (a,StdGen)) -> IO a +getStdRandom f = atomicModifyIORef' theStdGen (swap . f) + where swap (v,g) = (g,v) + +{- $references + +1. FW #Burton# Burton and RL Page, /Distributed random number generation/, +Journal of Functional Programming, 2(2):203-212, April 1992. + +2. SK #Park# Park, and KW Miller, /Random number generators - +good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201. + +3. DG #Carta# Carta, /Two fast implementations of the minimal standard +random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88. + +4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/, +Department of Mathematics, University of Salzburg, +, 1998. + +5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random +number generators/, Comm ACM, 31(6), Jun 1988, pp742-749. + +The Web site is a great source of information. + +-} diff --git a/tests/examples/ghc80/RenamingStar.hs b/tests/examples/ghc80/RenamingStar.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/RenamingStar.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeInType #-} + +module RenamingStar where + +data Foo :: * diff --git a/tests/examples/ghc80/RepArrow.hs b/tests/examples/ghc80/RepArrow.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/RepArrow.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleContexts #-} + +module RepArrow where + +import Data.Ord ( Down ) -- convenient "Id" newtype, without its constructor +import Data.Coerce + +foo :: Coercible (Down (Int -> Int)) (Int -> Int) => Down (Int -> Int) -> Int -> Int +foo = coerce diff --git a/tests/examples/ghc80/Roles12a.hs b/tests/examples/ghc80/Roles12a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Roles12a.hs @@ -0,0 +1,2 @@ +module Roles12a where +import {-# SOURCE #-} Roles12 diff --git a/tests/examples/ghc80/RuleDefiningPlugin.hs b/tests/examples/ghc80/RuleDefiningPlugin.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/RuleDefiningPlugin.hs @@ -0,0 +1,8 @@ +module RuleDefiningPlugin where + +import GhcPlugins + +{-# RULES "unsound" forall x. show x = "SHOWED" #-} + +plugin :: Plugin +plugin = defaultPlugin diff --git a/tests/examples/ghc80/RulePragma.hs b/tests/examples/ghc80/RulePragma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/RulePragma.hs @@ -0,0 +1,7 @@ +module Data.Text.Internal.Fusion.Common where + +{-# + RULES "STREAM map/map fusion" forall f g s. + map f (map g s) = map (\x -> f (g x)) s + #-} + diff --git a/tests/examples/ghc80/SH_Overlap1.hs b/tests/examples/ghc80/SH_Overlap1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap1.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Compilation should fail as we have overlapping instances that don't obey +-- our heuristics. +module SH_Overlap1 where + +import safe SH_Overlap1_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/tests/examples/ghc80/SH_Overlap10.hs b/tests/examples/ghc80/SH_Overlap10.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap10.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as `SH_Overlap6`, but now we are inferring safety. Safe since +-- overlapped instance declares itself overlappable. +module SH_Overlap10 where + +import SH_Overlap10_A + +instance + {-# OVERLAPS #-} + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/tests/examples/ghc80/SH_Overlap10_A.hs b/tests/examples/ghc80/SH_Overlap10_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap10_A.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap10_A ( + C(..) + ) where + +import SH_Overlap10_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/tests/examples/ghc80/SH_Overlap10_B.hs b/tests/examples/ghc80/SH_Overlap10_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap10_B.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +module SH_Overlap10_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/tests/examples/ghc80/SH_Overlap11.hs b/tests/examples/ghc80/SH_Overlap11.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap11.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred +-- unsafe due to overlapping instances at call site `f`. +-- +-- Testing that we are given correct reason. +module SH_Overlap11 where + +import SH_Overlap11_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/tests/examples/ghc80/SH_Overlap11_A.hs b/tests/examples/ghc80/SH_Overlap11_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap11_A.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap11_A ( + C(..) + ) where + +import SH_Overlap11_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/tests/examples/ghc80/SH_Overlap11_B.hs b/tests/examples/ghc80/SH_Overlap11_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap11_B.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +module SH_Overlap11_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/tests/examples/ghc80/SH_Overlap1_A.hs b/tests/examples/ghc80/SH_Overlap1_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap1_A.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap1_A ( + C(..) + ) where + +import SH_Overlap1_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/tests/examples/ghc80/SH_Overlap1_B.hs b/tests/examples/ghc80/SH_Overlap1_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap1_B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe #-} +module SH_Overlap1_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/tests/examples/ghc80/SH_Overlap2.hs b/tests/examples/ghc80/SH_Overlap2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap2.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as SH_Overlap1, but SH_Overlap2_A is not imported as 'safe'. +-- +-- Question: Should the OI-check be enforced? Y, see reasoning in +-- `SH_Overlap4.hs` for why the Safe Haskell overlapping instance check should +-- be tied to Safe Haskell mode only, and not to safe imports. +module SH_Overlap2 where + +import SH_Overlap2_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/tests/examples/ghc80/SH_Overlap2_A.hs b/tests/examples/ghc80/SH_Overlap2_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap2_A.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap2_A ( + C(..) + ) where + +import SH_Overlap2_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/tests/examples/ghc80/SH_Overlap2_B.hs b/tests/examples/ghc80/SH_Overlap2_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap2_B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe #-} +module SH_Overlap2_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/tests/examples/ghc80/SH_Overlap3.hs b/tests/examples/ghc80/SH_Overlap3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap3.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as SH_Overlap1, but module where overlap occurs (SH_Overlap3) is +-- marked `Unsafe`. Compilation should succeed (symetry with inferring safety). +module SH_Overlap3 where + +import SH_Overlap3_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/tests/examples/ghc80/SH_Overlap3_A.hs b/tests/examples/ghc80/SH_Overlap3_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap3_A.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap3_A ( + C(..) + ) where + +import SH_Overlap3_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/tests/examples/ghc80/SH_Overlap3_B.hs b/tests/examples/ghc80/SH_Overlap3_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap3_B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe #-} +module SH_Overlap3_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/tests/examples/ghc80/SH_Overlap4.hs b/tests/examples/ghc80/SH_Overlap4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap4.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as SH_Overlap3, however, SH_Overlap4_A is imported as `safe`. +-- +-- Question: Should compilation now fail? N. At first it seems a nice idea to +-- tie the overlap check to safe imports. However, instances are a global +-- entity and can be imported by multiple import paths. How should safe imports +-- interact with this? Especially when considering transitive situations... +-- +-- Simplest is to just enforce the overlap check in Safe and Trustworthy +-- modules, but not in Unsafe ones. +module SH_Overlap4 where + +import safe SH_Overlap4_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/tests/examples/ghc80/SH_Overlap4_A.hs b/tests/examples/ghc80/SH_Overlap4_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap4_A.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap4_A ( + C(..) + ) where + +import SH_Overlap4_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/tests/examples/ghc80/SH_Overlap4_B.hs b/tests/examples/ghc80/SH_Overlap4_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap4_B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe #-} +module SH_Overlap4_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/tests/examples/ghc80/SH_Overlap5.hs b/tests/examples/ghc80/SH_Overlap5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap5.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Compilation should fail as we have overlapping instances that don't obey +-- our heuristics. +module SH_Overlap5 where + +import safe SH_Overlap5_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/tests/examples/ghc80/SH_Overlap5_A.hs b/tests/examples/ghc80/SH_Overlap5_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap5_A.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap5_A ( + C(..) + ) where + +import SH_Overlap5_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/tests/examples/ghc80/SH_Overlap5_B.hs b/tests/examples/ghc80/SH_Overlap5_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap5_B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Safe #-} +module SH_Overlap5_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/tests/examples/ghc80/SH_Overlap6.hs b/tests/examples/ghc80/SH_Overlap6.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap6.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as `SH_Overlap5` but dependencies are now inferred-safe, not +-- explicitly marked. Compilation should still fail. +module SH_Overlap6 where + +import safe SH_Overlap6_A + +instance C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/tests/examples/ghc80/SH_Overlap6_A.hs b/tests/examples/ghc80/SH_Overlap6_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap6_A.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap6_A ( + C(..) + ) where + +import SH_Overlap6_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/tests/examples/ghc80/SH_Overlap6_B.hs b/tests/examples/ghc80/SH_Overlap6_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap6_B.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +module SH_Overlap6_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/tests/examples/ghc80/SH_Overlap7.hs b/tests/examples/ghc80/SH_Overlap7.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap7.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred +-- unsafe due to overlapping instances at call site `f`. +module SH_Overlap7 where + +import SH_Overlap7_A + +instance C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/tests/examples/ghc80/SH_Overlap7_A.hs b/tests/examples/ghc80/SH_Overlap7_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap7_A.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Safe #-} +module SH_Overlap7_A ( + C(..) + ) where + +import SH_Overlap7_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/tests/examples/ghc80/SH_Overlap7_B.hs b/tests/examples/ghc80/SH_Overlap7_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap7_B.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE Safe #-} +module SH_Overlap7_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/tests/examples/ghc80/SH_Overlap8.hs b/tests/examples/ghc80/SH_Overlap8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap8.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Overlapping instances, but with a single parameter type-class and no +-- orphans. So `SH_Overlap8` decided to explictly depend on `SH_Overlap8_A` +-- since that's where the type-class `C` with function `f` is defined. +-- +-- Question: Safe or Unsafe? Safe +module SH_Overlap8 where + +import safe SH_Overlap8_A + +instance C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/tests/examples/ghc80/SH_Overlap8_A.hs b/tests/examples/ghc80/SH_Overlap8_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap8_A.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap8_A ( + C(..) + ) where + +class C a where + f :: a -> String + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/tests/examples/ghc80/SH_Overlap9.hs b/tests/examples/ghc80/SH_Overlap9.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap9.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fwarn-safe #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred +-- unsafe due to overlapping instances at call site `f`. +module SH_Overlap9 where + +import SH_Overlap9_A + +instance + C [a] where + f _ = "[a]" + +test :: String +test = f ([1,2,3,4] :: [Int]) + diff --git a/tests/examples/ghc80/SH_Overlap9_A.hs b/tests/examples/ghc80/SH_Overlap9_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap9_A.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +{-# LANGUAGE FlexibleInstances #-} +module SH_Overlap9_A ( + C(..) + ) where + +import SH_Overlap9_B + +instance + {-# OVERLAPS #-} + C [Int] where + f _ = "[Int]" + diff --git a/tests/examples/ghc80/SH_Overlap9_B.hs b/tests/examples/ghc80/SH_Overlap9_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SH_Overlap9_B.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -fwarn-unsafe #-} +module SH_Overlap9_B ( + C(..) + ) where + +class C a where + f :: a -> String + diff --git a/tests/examples/ghc80/SayAnnNames.hs b/tests/examples/ghc80/SayAnnNames.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SayAnnNames.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module SayAnnNames (plugin, SomeAnn(..)) where +import GhcPlugins +import Control.Monad (unless) +import Data.Data + +data SomeAnn = SomeAnn deriving (Data, Typeable) + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = do + reinitializeGlobals + return (CoreDoPluginPass "Say name" pass : todo) + +pass :: ModGuts -> CoreM ModGuts +pass g = do + dflags <- getDynFlags + mapM_ (printAnn dflags g) (mg_binds g) >> return g + where printAnn :: DynFlags -> ModGuts -> CoreBind -> CoreM CoreBind + printAnn dflags guts bndr@(NonRec b _) = do + anns <- annotationsOn guts b :: CoreM [SomeAnn] + unless (null anns) $ putMsgS $ + "Annotated binding found: " ++ showSDoc dflags (ppr b) + return bndr + printAnn _ _ bndr = return bndr + +annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] +annotationsOn guts bndr = do + anns <- getAnnotations deserializeWithData guts + return $ lookupWithDefaultUFM anns [] (varUnique bndr) diff --git a/tests/examples/ghc80/SelfDep.hs b/tests/examples/ghc80/SelfDep.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SelfDep.hs @@ -0,0 +1,3 @@ +module SelfDep where + +data T :: T -> * diff --git a/tests/examples/ghc80/SemicolonIf.hs b/tests/examples/ghc80/SemicolonIf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SemicolonIf.hs @@ -0,0 +1,15 @@ +module Bar where + +import Data.Text as Text + +replace :: Text -> Text +replace = Text.map (\c -> if c == '_' then '.'; else c) + +replace1 :: Text -> Text +replace1 = Text.map (\c -> if c == '_' ; then '.' else c) + +replace2 :: Text -> Text +replace2 = Text.map (\c -> if c == '_'; then '.'; else c) + +replace4 :: Text -> Text +replace4 = Text.map (\c -> if c == '_' then '.' else c) diff --git a/tests/examples/ghc80/SemigroupWarnings.hs b/tests/examples/ghc80/SemigroupWarnings.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SemigroupWarnings.hs @@ -0,0 +1,34 @@ +-- Test purpose: +-- Ensure that missing semigroup warnings are issued +-- correctly if the warning flag is enabled + +{-# OPTIONS_GHC -fwarn-semigroup #-} + +module SemigroupWarnings where + + + +import Data.Semigroup + + + +-- Bad instance, should complain about missing Semigroup parent +data LacksSemigroup +instance Monoid LacksSemigroup where + mempty = undefined + mappend = undefined + + + +-- Correct instance, should not warn +data HasSemigroup +instance Semigroup HasSemigroup where + (<>) = undefined +instance Monoid HasSemigroup where + mempty = undefined + mappend = undefined + + + +-- Should issue a Prelude clash warning +(<>) = undefined diff --git a/tests/examples/ghc80/Setup.hs b/tests/examples/ghc80/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/tests/examples/ghc80/ShouldFail.hs b/tests/examples/ghc80/ShouldFail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ShouldFail.hs @@ -0,0 +1,1 @@ +import Set diff --git a/tests/examples/ghc80/SigTvKinds.hs b/tests/examples/ghc80/SigTvKinds.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SigTvKinds.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PolyKinds #-} + +module SigTvKinds where + +data T (a :: k1) x = MkT (S a ()) +data S (b :: k2) y = MkS (T b ()) + -- tests TcTyClsDecls.no_sig_tv diff --git a/tests/examples/ghc80/SigTvKinds2.hs b/tests/examples/ghc80/SigTvKinds2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SigTvKinds2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PolyKinds #-} + +module SigTvKinds2 where + +data SameKind :: k -> k -> * + +data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) diff --git a/tests/examples/ghc80/SpecializePhaseControl.hs b/tests/examples/ghc80/SpecializePhaseControl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SpecializePhaseControl.hs @@ -0,0 +1,15 @@ +{-# SPECIALISE [1] x :: + Integer -> Integer -> Integer, + Integer -> Int -> Integer, + Int -> Int -> Int #-} +{-# INLINABLE [1] x #-} +x :: (Num a, Integral b) => a -> b -> a +x = undefined + +{-# SPECIALISE INLINE [999] y :: + Integer -> Integer -> Integer, + Integer -> Int -> Integer, + Int -> Int -> Int #-} +{-# INLINABLE [1] y #-} +y :: (Num a, Integral b) => a -> b -> a +y = undefined diff --git a/tests/examples/ghc80/Splices.hs b/tests/examples/ghc80/Splices.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Splices.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedWildCards #-} +module Splices where + +import Language.Haskell.TH +import Language.Haskell.TH.Lib (wildCardT) + +metaType1 :: TypeQ +metaType1 = wildCardT + +metaType2 :: TypeQ +metaType2 = [t| _ |] + +metaType3 :: TypeQ +metaType3 = [t| _ -> _ -> _ |] + +metaDec1 :: Q [Dec] +metaDec1 = [d| foo :: _ => _ + foo x y = x == y |] + +metaDec2 :: Q [Dec] +metaDec2 = [d| bar :: _a -> _b -> (_a, _b) + bar x y = (not x, y) |] + +-- An expression with a partial type annotation +metaExp1 :: ExpQ +metaExp1 = [| Just True :: Maybe _ |] + +metaExp2 :: ExpQ +metaExp2 = [| id :: _a -> _a |] diff --git a/tests/examples/ghc80/SplicesUsed.hs b/tests/examples/ghc80/SplicesUsed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/SplicesUsed.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PartialTypeSignatures #-} +module SplicesUsed where + +import Splices + +maybeBool :: $(metaType1) +maybeBool = $(metaExp2) $(metaExp1) + +charA :: a -> $(metaType2) +charA x = ('x', x) + +filter' :: $(metaType3) +filter' = filter + +$(metaDec1) + +$(metaDec2) diff --git a/tests/examples/ghc80/StackOverflow.hs b/tests/examples/ghc80/StackOverflow.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/StackOverflow.hs @@ -0,0 +1,4 @@ +main :: IO () +main = main' () + where + main' _ = main >> main' () diff --git a/tests/examples/ghc80/Structure8.hs b/tests/examples/ghc80/Structure8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Structure8.hs @@ -0,0 +1,1 @@ +foo x | otherwise = y diff --git a/tests/examples/ghc80/Structure8a.hs b/tests/examples/ghc80/Structure8a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Structure8a.hs @@ -0,0 +1,1 @@ +foo x = y diff --git a/tests/examples/ghc80/T10009.hs b/tests/examples/ghc80/T10009.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10009.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +module T10009 where + + +type family F a +type family UnF a + +f :: (UnF (F b) ~ b) => F b -> () +f = error "urk" + +g :: forall a. (UnF (F a) ~ a) => a -> () +g _ = f (undefined :: F a) + + +{- --------------- +[G] UnF (F b) ~ b + +[W] UnF (F beta) ~ beta +[W] F a ~ F beta + +------------------- +[G] g1: F a ~ fsk1 fsk1 := F a +[G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1 +[G] g3: fsk2 ~ a + +[W] w1: F beta ~ fmv1 +[W] w2: UnF fmv1 ~ fmv2 +[W] w3: fmv2 ~ beta +[W] w5: fsk1 ~ fmv1 -- From F a ~ F beta + -- using flat-cache + +---- No progress in solving ----- +-- Unflatten: + +[W] w3: UnF (F beta) ~ beta +[W] w5: fsk1 ~ F beta + +--- Improvement + +[D] F beta ~ fmv1 +[D] UnF fmv1 ~ fmv2 -- (A) +[D] fmv2 ~ beta +[D] fmv1 ~ fsk1 -- (B) From F a ~ F beta + -- NB: put fmv on left + +--> rewrite (A) with (B), and match with g2 + +[D] F beta ~ fmv1 +[D] fmv2 ~ fsk2 -- (C) +[D] fmv2 ~ beta -- (D) +[D] fmv1 ~ fsk1 + +--> rewrite (D) with (C) and re-orient + +[D] F beta ~ fmv1 +[D] fmv2 ~ fsk2 +[D] beta ~ fsk2 -- (E) +[D] fmv1 ~ fsk1 + +-- Now we can unify beta! +-} + + + +{- + +----- +Inert: [G] fsk_amA ~ b_amr + [G] UnF fsk_amy ~ fsk_amA + [G} F b_amr ~ fsk_amy + +wl: [W] F b_amr ~ F b_amt + +work item: [W] UnF (F b_amt) ~ b_amt + b_amt is the unification variable + +===> b_amt := s_amF + +Inert: [G] fsk_amA ~ b_amr + [G] UnF fsk_amy ~ fsk_amA + [G} F b_amr ~ fsk_amy + +wl: [W] F b_amr ~ F b_amt + [W] UnF s_amD ~ s_amF + +work item: [W] F b_amt ~ s_amD + + +===> +wl: [W] F b_amr ~ F b_amt + [W] UnF s_amD ~ s_amF + +Inert: [G] fsk_amA ~ b_amr + [G] UnF fsk_amy ~ fsk_amA + [G} F b_amr ~ fsk_amy + [W] F s_amF ~ s_amD + +===> +wl: [W] F b_amr ~ F b_amt + +Inert: [G] fsk_amA ~ b_amr + [G] UnF fsk_amy ~ fsk_amA + [G} F b_amr ~ fsk_amy + [W] F s_amF ~ s_amD + [W] UnF s_amD ~ s_amF + +===> +Inert: [G] fsk_amA ~ b_amr + [G] UnF fsk_amy ~ fsk_amA + [G} F b_amr ~ fsk_amy + [W] UnF s_amD ~ s_amF + [W] F s_amF ~ s_amD + +wl: + +work-item: [W] F b_amr ~ F b_amt +--> fsk_amy ~ s_amD +--> s_amD ~ fsk_amy + +===> +Inert: [G] fsk_amA ~ b_amr + [G] UnF fsk_amy ~ fsk_amA + [G} F b_amr ~ fsk_amy + [W] UnF s_amD ~ s_amF + [W] F s_amF ~ s_amD + [W] s_amD ~ fsk_amy + +wl: + +work item: [D] UnF s_amD ~ s_amF + +--> [D] UnF fsk_amy ~ s_amF +--> [D] s_amF ~ fsk_amA + +===> +Inert: [G] fsk_amA ~ b_amr + [G] UnF fsk_amy ~ fsk_amA + [G} F b_amr ~ fsk_amy + [W] UnF s_amD ~ s_amF + [W] F s_amF ~ s_amD + [W] s_amD ~ fsk_amy + [D] s_amF ~ fsk_amA + +wl: + +work item: [D] F s_amF ~ s_amD +--> F fsk_amA ~ s_amD +--> s_amd ~ b_amr +-} diff --git a/tests/examples/ghc80/T10030.hs b/tests/examples/ghc80/T10030.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10030.hs @@ -0,0 +1,7 @@ +module Main where + +import GHC.Generics + +main = do + putStrLn $ packageName $ from $ Just True + putStrLn $ packageName $ from $ True diff --git a/tests/examples/ghc80/T10041.hs b/tests/examples/ghc80/T10041.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10041.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds #-} +{-# LANGUAGE TypeOperators, GADTs, InstanceSigs #-} + +module T10041 where + +data family Sing (a :: k) +data instance Sing (xs :: [k]) where + SNil :: Sing '[] + +class SingI (a :: ĸ) where diff --git a/tests/examples/ghc80/T10045.hs b/tests/examples/ghc80/T10045.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10045.hs @@ -0,0 +1,8 @@ +module T10045 where + +newtype Meta = Meta () + +foo (Meta ws1) = + let copy :: _ + copy w from = copy w True + in copy ws1 False diff --git a/tests/examples/ghc80/T10047.hs b/tests/examples/ghc80/T10047.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10047.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +module T10047 where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +n = QuasiQuoter { quoteExp = dyn } diff --git a/tests/examples/ghc80/T10052-input.hs b/tests/examples/ghc80/T10052-input.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10052-input.hs @@ -0,0 +1,1 @@ +main = let (x :: String) = "hello" in putStrLn x diff --git a/tests/examples/ghc80/T10052.hs b/tests/examples/ghc80/T10052.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10052.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wall #-} +module Main where + +import System.Environment +import GHC + +main :: IO () +main = do + flags <- getArgs + runGhc' flags $ do + setTargets [Target (TargetFile "T10052-input.hs" Nothing) True Nothing] + _success <- load LoadAllTargets + return () + +runGhc' :: [String] -> Ghc a -> IO a +runGhc' args act = do + let libdir = head args + flags = tail args + (dynFlags, _warns) <- parseStaticFlags (map noLoc flags) + runGhc (Just libdir) $ do + dflags0 <- getSessionDynFlags + (dflags1, _leftover, _warns) <- parseDynamicFlags dflags0 dynFlags + let dflags2 = dflags1 { + hscTarget = HscInterpreted + , ghcLink = LinkInMemory + , verbosity = 1 + } + _newPkgs <- setSessionDynFlags dflags2 + act diff --git a/tests/examples/ghc80/T10083.hs b/tests/examples/ghc80/T10083.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10083.hs @@ -0,0 +1,5 @@ +module T10083 where + import T10083a + data RSR = MkRSR SR + eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) + foo x y = not (eqRSR x y) diff --git a/tests/examples/ghc80/T10083a.hs b/tests/examples/ghc80/T10083a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10083a.hs @@ -0,0 +1,4 @@ +module T10083a where + import {-# SOURCE #-} T10083 + data SR = MkSR RSR + eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 diff --git a/tests/examples/ghc80/T10100.hs b/tests/examples/ghc80/T10100.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10100.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module T10100 where + +data Zero +data Succ a + +class Add a b ab | a b -> ab, a ab -> b +instance Add Zero b b +instance (Add a b ab) => Add (Succ a) b (Succ ab) diff --git a/tests/examples/ghc80/T10104.hs b/tests/examples/ghc80/T10104.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10104.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MagicHash #-} +module Main where + +import GHC.Prim + +data P = Positives Int# Float# Double# Char# Word# deriving Show +data N = Negatives Int# Float# Double# deriving Show + +main = do + print $ Positives 42# 4.23# 4.23## '4'# 4## + print $ Negatives -4# -4.0# -4.0## diff --git a/tests/examples/ghc80/T10109.hs b/tests/examples/ghc80/T10109.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10109.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PolyKinds, MultiParamTypeClasses, FunctionalDependencies, + UndecidableInstances, FlexibleInstances #-} + +module T10109 where + +data Succ a + +class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab +instance (Add a b ab) => Add (Succ a) b (Succ ab) + diff --git a/tests/examples/ghc80/T10110A.hs b/tests/examples/ghc80/T10110A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10110A.hs @@ -0,0 +1,4 @@ +module T10110A (a) where +{-# NOINLINE a #-} +a :: Int +a = 3 diff --git a/tests/examples/ghc80/T10110B.hs b/tests/examples/ghc80/T10110B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10110B.hs @@ -0,0 +1,3 @@ +module T10110B (b) where +b :: Int +b = 5 diff --git a/tests/examples/ghc80/T10110C.hs b/tests/examples/ghc80/T10110C.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10110C.hs @@ -0,0 +1,5 @@ +module T10110C (c) where +import T10110A (a) +import T10110B (b) +c :: Int +c = a+b diff --git a/tests/examples/ghc80/T10112.hs b/tests/examples/ghc80/T10112.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10112.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE RankNTypes, RebindableSyntax #-} +module T10112 where + +import qualified Prelude as P + +(>>=) :: a -> ((forall b . b) -> c) -> c +a >>= f = f P.undefined +return a = a +fail s = P.undefined + +t1 = 'd' >>= (\_ -> 'k') + +t2 = do { _ <- 'd' + ; 'k' } + +foo = P.putStrLn [t1, t2] diff --git a/tests/examples/ghc80/T10134.hs b/tests/examples/ghc80/T10134.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10134.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds, TypeOperators, ConstraintKinds, TypeFamilies, NoMonoLocalBinds, NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module T10134 where + +import GHC.TypeLits +import T10134a +import Prelude + +type Positive n = ((n-1)+1)~n + +data Dummy n d = Dummy { vec :: Vec n (Vec d Bool) } + +nextDummy :: Positive (2*(n+d)) => Dummy n d -> Dummy n d +nextDummy d = Dummy { vec = vec dFst } + where (dFst,dSnd) = nextDummy' d + +nextDummy' :: Positive (2*(n+d)) => Dummy n d -> ( Dummy n d, Bool ) +nextDummy' _ = undefined diff --git a/tests/examples/ghc80/T10134a.hs b/tests/examples/ghc80/T10134a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10134a.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module T10134a where + +import GHC.TypeLits + +data Vec :: Nat -> * -> * where + Nil :: Vec 0 a + (:>) :: a -> Vec n a -> Vec (n + 1) a diff --git a/tests/examples/ghc80/T10139.hs b/tests/examples/ghc80/T10139.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10139.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances, + MultiParamTypeClasses, FunctionalDependencies #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module T10139 where + +import GHC.Exts +import Data.Monoid + +class Monoid v => Measured v a | a -> v where + _measure :: v -> a +data FingerTree v a = Dummy v a +singleton :: Measured v a => a -> FingerTree v a +singleton = undefined + +class DOps a where + plus :: a -> D a -> a + +type family D a :: * +type instance D (FingerTree (Size Int, v) (Sized a)) = [Diff (Normal a)] + +type family Normal a :: * + +data Diff a = Add Int a + +newtype Sized a = Sized a +newtype Size a = Size a + +-- This works: +{- +instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where + plus = foldr (\(Add index val) seq -> singleton ((coerce) val)) +-} + +-- This hangs: +instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where + plus = foldr (flip f) + where f _seq x = case x of + Add _index val -> singleton ((coerce) val) diff --git a/tests/examples/ghc80/T10141.hs b/tests/examples/ghc80/T10141.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10141.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies, PolyKinds #-} + +module T10141 where + +type family G (a :: k) where + G Int = Bool + G Bool = Int + G a = a diff --git a/tests/examples/ghc80/T10148.hs b/tests/examples/ghc80/T10148.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10148.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE BangPatterns #-} +module Main where + +import Debug.Trace + +data Machine = Machine (Int -> Machine) Int + +main :: IO () +main = (go 7 $ Machine (gstep (Array 99)) 8) `seq` return () + where + go :: Int -> Machine -> Int + go 0 (Machine _ done) = done + go nq (Machine step _) = go (nq-1) $ step 0 + +gstep :: Array Int -> Int -> Machine +gstep m x = Machine (gstep m') (mindexA m) + where + !m' = adjustA x m + +data Array a = Array a + +adjustA :: (Show a) => Int -> Array a -> Array a +adjustA i (Array t) + | i < 0 = undefined i -- not just undefined! + | otherwise = Array $ trace ("adj " ++ show t) $ t + +mindexA :: Array a -> a +mindexA (Array v) = v diff --git a/tests/examples/ghc80/T10156.hs b/tests/examples/ghc80/T10156.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10156.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + +module T10156 where + +import Data.Coerce + +data Iso a b = Iso (a -> b) (b -> a) + +coerceIso :: Coercible a b => Iso a b +coerceIso = Iso coerce coerce + +type family F x + +f :: (Coercible a (F b), Coercible c (F b)) => a -> b -> c +f x _ = coerce x diff --git a/tests/examples/ghc80/T10180.hs b/tests/examples/ghc80/T10180.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10180.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TypeOperators, TypeFamilies, GADTs, EmptyCase #-} +module T10180 where + +newtype Foo = Foo Int + +type family Bar a +type instance Bar Int = Int + +type family Baz a where + Baz Int = Int + Baz Char = Int + +data a :~: b where + Refl :: a :~: a + +absurd0 :: Int :~: Bool -> a +absurd0 x = case x of {} + +absurd1 :: Foo :~: Bool -> a +absurd1 x = case x of {} + +absurd2 :: Bar Int :~: Bool -> a +absurd2 x = case x of {} + +absurd3 :: Baz a :~: Bool -> a +absurd3 x = case x of {} + diff --git a/tests/examples/ghc80/T10181.hs b/tests/examples/ghc80/T10181.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10181.hs @@ -0,0 +1,3 @@ +module T10181 where + +t a = t a diff --git a/tests/examples/ghc80/T10182.hs b/tests/examples/ghc80/T10182.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10182.hs @@ -0,0 +1,4 @@ +module T10182 where +import T10182a +instance Show (a -> b) where + show _ = "" diff --git a/tests/examples/ghc80/T10182a.hs b/tests/examples/ghc80/T10182a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10182a.hs @@ -0,0 +1,2 @@ +module T10182a where +import {-# SOURCE #-} T10182 diff --git a/tests/examples/ghc80/T10184.hs b/tests/examples/ghc80/T10184.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10184.hs @@ -0,0 +1,9 @@ +module T10184 where + +import Data.Coerce + +newtype Bar a = Bar (Either a (Bar a)) +newtype Age = MkAge Int + +x :: Bar Age +x = coerce (Bar (Left (5 :: Int))) diff --git a/tests/examples/ghc80/T10185.hs b/tests/examples/ghc80/T10185.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10185.hs @@ -0,0 +1,7 @@ +module T10185 where + +import Data.Coerce +import Data.Proxy + +foo :: (Coercible (a b) (c d), Coercible (c d) (e f)) => Proxy (c d) -> a b -> e f +foo _ = coerce diff --git a/tests/examples/ghc80/T10188.hs b/tests/examples/ghc80/T10188.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10188.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} + +module T10188 where + +data Peano = Zero | Succ Peano + +type family Length (as :: [k]) :: Peano where + Length (a : as) = Succ (Length as) + Length '[] = Zero + +type family Length' (as :: [k]) :: Peano where + Length' ((:) a as) = Succ (Length' as) + Length' '[] = Zero diff --git a/tests/examples/ghc80/T10194.hs b/tests/examples/ghc80/T10194.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10194.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes #-} +module T10194 where + +type X = forall a . a + +comp :: (X -> c) -> (a -> X) -> (a -> c) +comp = (.) diff --git a/tests/examples/ghc80/T10195.hs b/tests/examples/ghc80/T10195.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10195.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, GADTs, + ConstraintKinds, DataKinds, KindSignatures, + FlexibleInstances #-} +{-# OPTIONS -fno-warn-redundant-constraints #-} + +module T10195 where + +import GHC.Exts + +data Foo m zp r'q = Foo zp +data Dict :: Constraint -> * where + Dict :: a => Dict a + +type family BarFamily a b :: Bool +class Bar m m' +instance (BarFamily m m' ~ 'True) => Bar m m' + +magic :: (Bar m m') => c m zp -> Foo m zp (c m' zq) +magic = undefined + +getDict :: a -> Dict (Num a) +getDict _ = undefined +fromScalar :: r -> c m r +fromScalar = undefined + +foo :: (Bar m m') + => c m zp -> Foo m zp (c m' zq) -> Foo m zp (c m' zq) +foo b (Foo sc) = + let scinv = fromScalar sc + in case getDict scinv of + Dict -> magic $ scinv * b diff --git a/tests/examples/ghc80/T10196.hs b/tests/examples/ghc80/T10196.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10196.hs @@ -0,0 +1,13 @@ +module T10196 where + +data X = Xᵦ | Xᵤ | Xᵩ | Xᵢ | Xᵪ | Xᵣ + +f :: Int +f = + let xᵦ = 1 + xᵤ = xᵦ + xᵩ = xᵤ + xᵢ = xᵩ + xᵪ = xᵢ + xᵣ = xᵪ + in xᵣ diff --git a/tests/examples/ghc80/T10215.hs b/tests/examples/ghc80/T10215.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10215.hs @@ -0,0 +1,9 @@ +testF :: Float -> Bool +testF x = x == 0 && not (isNegativeZero x) + +testD :: Double -> Bool +testD x = x == 0 && not (isNegativeZero x) + +main :: IO () +main = do print $ testF (-0.0) + print $ testD (-0.0) diff --git a/tests/examples/ghc80/T10218.hs b/tests/examples/ghc80/T10218.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10218.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -feager-blackholing #-} + +module Main where + +{-# NOINLINE foo #-} +foo :: Bool -> Int -> Int -> Int +foo True _ x = 1 +foo False _ x = x+1 + +{-# NOINLINE bar #-} +bar :: Int -> (Int,Int) +bar x = let y1 = x * 2 + y2 = x * 2 + in (foo False y1 y2,foo False y2 y1) + +main = print (fst p + snd p) + where + p = bar 3 diff --git a/tests/examples/ghc80/T10220B.hs b/tests/examples/ghc80/T10220B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10220B.hs @@ -0,0 +1,1 @@ +module T10220B where diff --git a/tests/examples/ghc80/T10226.hs b/tests/examples/ghc80/T10226.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10226.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -- only necessary in 7.10 +{-# LANGUAGE FlexibleContexts #-} -- necessary for showFromF' example +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module T10226 where + +type family F a +type family FInv a + +-- This definition is accepted in 7.8 without anything extra, but requires +-- AllowAmbiguousTypes in 7.10 (this, by itself, is not a problem): +showFromF :: (Show a, FInv (F a) ~ a) => F a -> String +showFromF fa = undefined + +-- Consider what happens when we attempt to call `showFromF` at some type b. +-- In order to check that this is valid, we have to find an a such that +-- +-- > b ~ F a /\ Show a /\ FInv (F a) ~ a +-- +-- Introducing an intermediate variable `x` for the result of `F a` gives us +-- +-- > b ~ F a /\ Show a /\ FInv x ~ a /\ F a ~ x +-- +-- Simplifying +-- +-- > b ~ x /\ Show a /\ FInv x ~ a /\ F a ~ x +-- +-- Set x := b +-- +-- > Show a /\ FInv b ~ a /\ F a ~ b +-- +-- Set a := FInv b +-- +-- > Show (FInv b) /\ FInv b ~ FInv b /\ F (FInv b) ~ b +-- +-- Simplifying +-- +-- > Show (FInv b) /\ F (FInv b) ~ b +-- +-- Indeed, we can give this definition in 7.8, but not in 7.10: +showFromF' :: (Show (FInv b), F (FInv b) ~ b) => b -> String +showFromF' = showFromF + +{------------------------------------------------------------------------------- + In 7.10 the definition of showFromF' is not accepted, but it gets stranger. + In 7.10 we cannot _call_ showFromF at all, even at a concrete type. Below + we try to call it at type b ~ Int. It would need to show + + > Show (FInv Int) /\ F (FInt Int) ~ Int + + all of which should easily get resolved, but somehow don't. +-------------------------------------------------------------------------------} + +type instance F Int = Int +type instance FInv Int = Int + +test :: String +test = showFromF (0 :: Int) diff --git a/tests/examples/ghc80/T10233.hs b/tests/examples/ghc80/T10233.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10233.hs @@ -0,0 +1,2 @@ +module T10233 where +import T10233a( Constraint, Int ) diff --git a/tests/examples/ghc80/T10233a.hs b/tests/examples/ghc80/T10233a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10233a.hs @@ -0,0 +1,3 @@ +module T10233a ( module GHC.Exts ) where +import GHC.Exts ( Constraint, Int ) + diff --git a/tests/examples/ghc80/T10245.hs b/tests/examples/ghc80/T10245.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10245.hs @@ -0,0 +1,13 @@ +f :: Int -> String +f n = case n of + 0x8000000000000000 -> "yes" + _ -> "no" +{-# NOINLINE f #-} + +main = do + let string = "0x8000000000000000" + let i = read string :: Integer + let i' = fromIntegral i :: Int + print i + print i' + print (f i') diff --git a/tests/examples/ghc80/T10246.hs b/tests/examples/ghc80/T10246.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10246.hs @@ -0,0 +1,32 @@ +f1 :: Int -> String +f1 n = case n of + 0 -> "bar" + 0x10000000000000000 -> "foo" + _ -> "c" +{-# NOINLINE f1 #-} + +g1 :: Int -> String +g1 n = if n == 0 then "bar" else + if n == 0x10000000000000000 then "foo" else + "c" +{-# NOINLINE g1 #-} + +f2 :: Int -> String +f2 n = case n of + 0x10000000000000000 -> "foo" + 0 -> "bar" + _ -> "c" +{-# NOINLINE f2 #-} + +g2 :: Int -> String +g2 n = if n == 0x10000000000000000 then "foo" else + if n == 0 then "bar" else + "c" +{-# NOINLINE g2 #-} + +main = do + let i = read "0" :: Int + print (f1 i) + print (g1 i) + print (f2 i) + print (g2 i) diff --git a/tests/examples/ghc80/T10251.hs b/tests/examples/ghc80/T10251.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10251.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -O #-} +module T10251 where + +data D = D +data E = E + +class Storable a where + poke2 :: a -> E +instance Storable D where + poke2 = poke2 -- undefined + +class Foo a where +instance Foo D where + +class (Foo t, Storable t) => FooStorable t where + +instance FooStorable D where + {-# SPECIALIZE instance FooStorable D #-} + +{-# SPECIALIZE bug :: D -> E #-} + +bug + :: FooStorable t + => t + -> E +bug = poke2 +{- +sf 9160 # ghc -c -fforce-recomp -Wall B.hs + +ghc: panic! (the 'impossible' happened) + (GHC version 7.10.1 for x86_64-unknown-linux): + Template variable unbound in rewrite rule + $fFooStorableD_XU + [$fFooStorableD_XU] + [$fFooStorableD_XU] + [] + [] + +Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug +-} diff --git a/tests/examples/ghc80/T10263.hs b/tests/examples/ghc80/T10263.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10263.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +module T10263 where + +data Maybe a = AF +type role Maybe representational diff --git a/tests/examples/ghc80/T10267.hs b/tests/examples/ghc80/T10267.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10267.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T10267 where + +import Language.Haskell.TH +import T10267a + +[d| i :: a -> a + i = _foo + + j :: a -> a + j x = _ |] + +$(return [ + SigD (mkName "k") + (ForallT [PlainTV (mkName "a")] + [] + (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) + , FunD (mkName "k") + [Clause [] (NormalB (UnboundVarE (mkName "_foo"))) []] + ]) + +$(return [ + SigD (mkName "l") + (ForallT [PlainTV (mkName "a")] + [] + (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) + , FunD (mkName "l") + [Clause [VarP (mkName "x")] (NormalB (UnboundVarE (mkName "_"))) []] + ]) + +foo :: a -> a +foo x = $varX diff --git a/tests/examples/ghc80/T10267a.hs b/tests/examples/ghc80/T10267a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10267a.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T10267a where + +import Language.Haskell.TH + +varX :: Q Exp +varX = [| x |] diff --git a/tests/examples/ghc80/T10279.hs b/tests/examples/ghc80/T10279.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10279.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module T10279 where +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +-- NB: rts-1.0 is used here because it doesn't change. +-- You do need to pick the right version number, otherwise the +-- error message doesn't recognize it as a source package ID, +-- (This is OK, since it will look obviously wrong when they +-- try to find the package in their package database.) +blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A")))) diff --git a/tests/examples/ghc80/T10283.hs b/tests/examples/ghc80/T10283.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10283.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-} +{-# LANGUAGE ImpredicativeTypes #-} + +module T9834 where +import Control.Applicative +import Data.Functor.Identity + +type Nat f g = forall a. f a -> g a + +newtype Comp p q a = Comp (p (q a)) + +liftOuter :: (Functor p, Applicative q) => p a -> (Comp p q) a +liftOuter pa = Comp (pure <$> pa) + +runIdComp :: Functor p => Comp p Identity a -> p a +runIdComp (Comp p) = runIdentity <$> p + +wrapIdComp :: Applicative p => (forall q. Applicative q => Nat (Comp p q) (Comp p q)) -> p a -> p a +wrapIdComp f = runIdComp . f . liftOuter + +class Applicative p => ApplicativeFix p where + afix :: (forall q. Applicative q => (Comp p q) a -> (Comp p q) a) -> p a + afix = wrapIdComp diff --git a/tests/examples/ghc80/T10284.hs b/tests/examples/ghc80/T10284.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10284.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-} + +import Control.Exception + +a :: Int +a = 'a' + +main :: IO () +main = do + catch (evaluate a) + (\e -> do let err = show (e :: TypeError) + putStrLn ("As expected, TypeError: " ++ err) + return "") + catch (evaluate a) + (\e -> do let err = show (e :: ErrorCall) + putStrLn ("Something went horribly wrong: " ++ err) + return "") diff --git a/tests/examples/ghc80/T10285.hs b/tests/examples/ghc80/T10285.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10285.hs @@ -0,0 +1,11 @@ +module T10285 where + +import T10285a +import Data.Type.Coercion +import Data.Coerce + +oops :: Coercion (N a) (N b) -> a -> b +oops Coercion = coerce + +unsafeCoerce :: a -> b +unsafeCoerce = oops coercion diff --git a/tests/examples/ghc80/T10285a.hs b/tests/examples/ghc80/T10285a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10285a.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RoleAnnotations #-} + +module T10285a (N, coercion) where + +import Data.Type.Coercion + +newtype N a = MkN Int +type role N representational + +coercion :: Coercion (N a) (N b) +coercion = Coercion diff --git a/tests/examples/ghc80/T10294.hs b/tests/examples/ghc80/T10294.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10294.hs @@ -0,0 +1,7 @@ +module T10294 where + +import SayAnnNames + +{-# ANN foo SomeAnn #-} +foo :: () +foo = () diff --git a/tests/examples/ghc80/T10294a.hs b/tests/examples/ghc80/T10294a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10294a.hs @@ -0,0 +1,7 @@ +module T10294a where + +import SayAnnNames +import Data.Data + +baz :: Constr +baz = toConstr SomeAnn diff --git a/tests/examples/ghc80/T10306.hs b/tests/examples/ghc80/T10306.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10306.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} + +module T10306 where + +import Language.Haskell.TH +import GHC.TypeLits + +-- Attempting to reify a built-in type family like (+) previously +-- caused a crash, because it has no equations +$(do x <- reify ''(+) + case x of + FamilyI (ClosedTypeFamilyD _ _ _ _ []) _ -> return [] + _ -> error $ show x + ) diff --git a/tests/examples/ghc80/T10318.hs b/tests/examples/ghc80/T10318.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10318.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, + FlexibleInstances, TypeFamilies, + UndecidableSuperClasses #-} + +module T10318 where + +-- | Product of non-zero elements always non-zero. +-- Every integral domain has a field of fractions. +-- The field of fractions of any field is itself. +class (Frac (Frac a) ~ Frac a, Fractional (Frac a), IntegralDomain (Frac a)) + => IntegralDomain a where + type Frac a :: * + embed :: a -> Frac a + +instance IntegralDomain Integer where + type Frac Integer = Rational + embed = fromInteger + +instance IntegralDomain Rational where + type Frac Rational = Rational + embed = id + +g :: IntegralDomain a => a -> a +g x = g x + +h :: a -> Frac a +h x = h x + +-- This is the test function + +f :: IntegralDomain a => a -> Frac a +f x = g (h (h x)) + -- Given: IntegralDomain (Frac a) + -- Wanted: IntegralDomain (Frac (Frac a)) + diff --git a/tests/examples/ghc80/T10321.hs b/tests/examples/ghc80/T10321.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10321.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module T10321 where + +import GHC.TypeLits + +data Vec :: Nat -> * -> * where + Nil :: Vec 0 a + (:>) :: a -> Vec n a -> Vec (n + 1) a + +infixr 5 :> diff --git a/tests/examples/ghc80/T10322A.hs b/tests/examples/ghc80/T10322A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10322A.hs @@ -0,0 +1,4 @@ +module T10322A (a) where +{-# NOINLINE a #-} +a :: Int +a = 3 diff --git a/tests/examples/ghc80/T10322B.hs b/tests/examples/ghc80/T10322B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10322B.hs @@ -0,0 +1,4 @@ +module T10322B (b) where +import T10322A (a) +b :: Int +b = a+1 diff --git a/tests/examples/ghc80/T10322C.hs b/tests/examples/ghc80/T10322C.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10322C.hs @@ -0,0 +1,5 @@ +module T10322C (c) where +import T10322A (a) +import T10322B (b) +c :: Int +c = a+b diff --git a/tests/examples/ghc80/T10335.hs b/tests/examples/ghc80/T10335.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10335.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-} + +module Foo where + +type X a = (Eq a, Show a) + +class Eq a => C a b + +-- HEAD was unable to find the (Eq a) superclass +-- for a while in March/April 2015 +instance X a => C a [b] + + + + + diff --git a/tests/examples/ghc80/T10340.hs b/tests/examples/ghc80/T10340.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10340.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module T10340 where + +import GHC.Exts (Any) + +class MonadState s m where + get :: m s + +newtype State s a = State (s -> (s, a)) + +instance MonadState s (State s) where + get = State $ \s -> (s, s) + +foo :: State Any Any +foo = get diff --git a/tests/examples/ghc80/T10348.hs b/tests/examples/ghc80/T10348.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10348.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE AutoDeriveTypeable, GADTs, DataKinds, KindSignatures, StandaloneDeriving, TypeOperators #-} + +module T10348 where + +import GHC.TypeLits +import Data.Typeable +import Data.Proxy + +data Foo (n :: Nat) where + Hey :: KnownNat n => Foo n + +deriving instance Show (Foo n) + +data T t where + T :: (Show t, Typeable t) => t -> T t + +deriving instance Show (T n) + +hey :: KnownNat n => T (Foo n) +hey = T Hey + +ho :: T (Foo 42) +ho = T Hey + +f1 :: KnownNat a => Proxy a -> TypeRep +f1 = typeRep + +g2 :: KnownSymbol a => Proxy a -> TypeRep +g2 = typeRep + +pEqT :: (KnownSymbol a, KnownSymbol b) => Proxy a -> Proxy b -> Maybe (a :~: b) +pEqT Proxy Proxy = eqT diff --git a/tests/examples/ghc80/T10351.hs b/tests/examples/ghc80/T10351.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10351.hs @@ -0,0 +1,6 @@ +module T10351 where + +class C a where + op :: a -> () + +f x = op [x] diff --git a/tests/examples/ghc80/T10359.hs b/tests/examples/ghc80/T10359.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10359.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ConstraintKinds #-} + +module Main( main, boo ) where + +import Prelude hiding (repeat) + +boo xs f = (\x -> f x, xs) + +repeat :: Int -> (a -> a) -> a -> a +repeat 1 f x = f x +repeat n f x = n `seq` x `seq` repeat (n-1) f $ f x + +---- Buggy version +------------------ + +type Numerical a = (Fractional a, Real a) + +data Box a = Box + { func :: forall dum. (Numerical dum) => dum -> a -> a + , obj :: !a } + +do_step :: (Numerical num) => num -> Box a -> Box a +do_step number Box{..} = Box{ obj = func number obj, .. } + +start :: Box Double +start = Box { func = \x y -> realToFrac x + y + , obj = 0 } + +test :: Int -> IO () +test steps = putStrLn $ show $ obj $ repeat steps (do_step 1) start + +---- Driver +----------- + +main :: IO () +main = test 2000 -- compare test2 10000000 or test3 10000000, but test4 20000 + + +{- +---- No tuple constraint synonym is better +------------------------------------------ + +data Box2 a = Box2 + { func2 :: forall num. (Fractional num, Real num) => num -> a -> a + , obj2 :: !a } + +do_step2 :: (Fractional num, Real num) => num -> Box2 a -> Box2 a +do_step2 number Box2{..} = Box2{ obj2 = func2 number obj2, ..} + +start2 :: Box2 Double +start2 = Box2 { func2 = \x y -> realToFrac x + y + , obj2 = 0 } + +test2 :: Int -> IO () +test2 steps = putStrLn $ show $ obj2 $ repeat steps (do_step2 1) start2 + +---- Not copying the function field works too +--------------------------------------------- + +do_step3 :: (Numerical num) => num -> Box a -> Box a +do_step3 number b@Box{..} = b{ obj = func number obj } + +test3 :: Int -> IO () +test3 steps = putStrLn $ show $ obj $ repeat steps (do_step3 1) start + +---- But record wildcards are not at fault +------------------------------------------ + +do_step4 :: (Numerical num) => num -> Box a -> Box a +do_step4 number Box{func = f, obj = x} = Box{ obj = f number x, func = f } + +test4 :: Int -> IO () +test4 steps = putStrLn $ show $ obj $ repeat steps (do_step4 1) start +-} + + +{- +First of all, very nice example. Thank you for making it so small and easy to work with. + +I can see what's happening. The key part is what happens here: +{{{ +do_step4 :: (Numerical num) => num -> Box a -> Box a +do_step4 number Box{ func = f, obj = x} + = Box{ func = f, obj = f number x } +}}} +After elaboration (ie making dictionaries explicit) we get this: +{{{ +do_step4 dn1 number (Box {func = f, obj = x }) + = Box { func = \dn2 -> f ( case dn2 of (f,r) -> f + , case dn2 of (f,r) -> r) + , obj = f dn1 number x } +}}} +That's odd! We expected this: +{{{ +do_step4 dn1 number (Box {func = f, obj = x }) + = Box { func = f + , obj = f dn1 number x } +}}} +And indeed, the allocation of all those `\dn2` closures is what is causing the problem. +So we are missing this optimisation: +{{{ + (case dn2 of (f,r) -> f, case dn2 of (f,r) -> r) +===> + dn2 +}}} +If we did this, then the lambda would look like `\dn2 -> f dn2` which could eta-reduce to `f`. +But there are at least three problems: + * The tuple transformation above is hard to spot + * The tuple transformation is not quite semantically right; if `dn2` was bottom, the LHS and RHS are different + * The eta-reduction isn't quite semantically right: if `f` ws bottom, the LHS and RHS are different. + +You might argue that the latter two can be ignored because dictionary arguments are special; +indeed we often toy with making them strict. + +But perhaps a better way to avoid the tuple-transformation issue would be not to construct that strange expression in the first place. Where is it coming from? It comes from the call to `f` (admittedly applied to no arguments) in `Box { ..., func = f }`. GHC needs a dictionary for `(Numerical dum)` (I changed the name of the type variable in `func`'s type in the definition of `Box`). Since it's just a pair GHC says "fine, I'll build a pair, out of `Fractional dum` and `Real dum`. How does it get those dictionaries? By selecting the components of the `Franctional dum` passed to `f`. + +If GHC said instead "I need `Numerical dum` and behold I have one in hand, it'd be much better. It doesn't because tuple constraints are treated specially. But if we adopted the idea in #10362, we would (automatically) get to re-use the `Numerical dum` constraint. That would leave us with eta reduction, which is easier. + +As to what will get you rolling, a good solution is `test3`, which saves instantiating and re-generalising `f`. The key thing is to update all the fields ''except'' the polymorphic `func` field. I'm surprised you say that it doesn't work. Can you give a (presumably more complicated) example to demonstrate? Maybe there's a separate bug! + +-} + + diff --git a/tests/examples/ghc80/T10361a.hs b/tests/examples/ghc80/T10361a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10361a.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module T10361a where + +class C1 a where + type T1 a + type instance T1 a = Char + +class C2 a where -- equivalent to C1 + type T2 a + type instance T2 a = Char + +class C3 a where -- equivalent to C1, C2 + type T3 a + type instance T3 a = Char + +data A = B + deriving C1 + +deriving instance C2 A + +instance C3 A + +test1 :: T1 A +test1 = 'x' + +test2 :: T2 A +test2 = 'x' + +test3 :: T3 A +test3 = 'x' diff --git a/tests/examples/ghc80/T10361b.hs b/tests/examples/ghc80/T10361b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10361b.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module T10361b where + +import GHC.Generics + +--------------------------------------------------------------------- +class Convert a where + type Result a + type instance Result a = GResult (Rep a) + + convert :: a -> Result a + default convert :: (Generic a, GConvert (Rep a)) => a -> GResult (Rep a) + convert x = gconvert (from x) + +instance Convert Float where + type Result Float = Float + convert = id + +instance Convert Int where + type Result Int = Int + convert = id + +--------------------------------------------------------------------- +class GConvert f where + type GResult f + gconvert :: f p -> GResult f + +instance (Convert c) => GConvert (K1 i c) where + type GResult (K1 i c) = Result c + gconvert (K1 x) = convert x + +instance (GConvert f) => GConvert (M1 i t f) where + type GResult (M1 i t f) = GResult f + gconvert (M1 x) = gconvert x + +instance (GConvert f, GConvert g) => GConvert (f :*: g) where + type GResult (f :*: g) = (GResult f, GResult g) + gconvert (x :*: y) = (gconvert x, gconvert y) + +--------------------------------------------------------------------- + +data Data1 = Data1 Int Float + deriving (Generic) + +instance Convert Data1 + +val :: (Int, Float) +val = convert $ Data1 0 0.0 + +data Data2 = Data2 Int Float + deriving (Generic, Convert) diff --git a/tests/examples/ghc80/T10370.hs b/tests/examples/ghc80/T10370.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10370.hs @@ -0,0 +1,1002 @@ +module Out where +import Control.Monad (forever) +a1 :: IO (); a1 = forever $ putStrLn "a1" +a2 :: IO (); a2 = forever $ putStrLn "a2" +a3 :: IO (); a3 = forever $ putStrLn "a3" +a4 :: IO (); a4 = forever $ putStrLn "a4" +a5 :: IO (); a5 = forever $ putStrLn "a5" +a6 :: IO (); a6 = forever $ putStrLn "a6" +a7 :: IO (); a7 = forever $ putStrLn "a7" +a8 :: IO (); a8 = forever $ putStrLn "a8" +a9 :: IO (); a9 = forever $ putStrLn "a9" +a10 :: IO (); a10 = forever $ putStrLn "a10" +a11 :: IO (); a11 = forever $ putStrLn "a11" +a12 :: IO (); a12 = forever $ putStrLn "a12" +a13 :: IO (); a13 = forever $ putStrLn "a13" +a14 :: IO (); a14 = forever $ putStrLn "a14" +a15 :: IO (); a15 = forever $ putStrLn "a15" +a16 :: IO (); a16 = forever $ putStrLn "a16" +a17 :: IO (); a17 = forever $ putStrLn "a17" +a18 :: IO (); a18 = forever $ putStrLn "a18" +a19 :: IO (); a19 = forever $ putStrLn "a19" +a20 :: IO (); a20 = forever $ putStrLn "a20" +a21 :: IO (); a21 = forever $ putStrLn "a21" +a22 :: IO (); a22 = forever $ putStrLn "a22" +a23 :: IO (); a23 = forever $ putStrLn "a23" +a24 :: IO (); a24 = forever $ putStrLn "a24" +a25 :: IO (); a25 = forever $ putStrLn "a25" +a26 :: IO (); a26 = forever $ putStrLn "a26" +a27 :: IO (); a27 = forever $ putStrLn "a27" +a28 :: IO (); a28 = forever $ putStrLn "a28" +a29 :: IO (); a29 = forever $ putStrLn "a29" +a30 :: IO (); a30 = forever $ putStrLn "a30" +a31 :: IO (); a31 = forever $ putStrLn "a31" +a32 :: IO (); a32 = forever $ putStrLn "a32" +a33 :: IO (); a33 = forever $ putStrLn "a33" +a34 :: IO (); a34 = forever $ putStrLn "a34" +a35 :: IO (); a35 = forever $ putStrLn "a35" +a36 :: IO (); a36 = forever $ putStrLn "a36" +a37 :: IO (); a37 = forever $ putStrLn "a37" +a38 :: IO (); a38 = forever $ putStrLn "a38" +a39 :: IO (); a39 = forever $ putStrLn "a39" +a40 :: IO (); a40 = forever $ putStrLn "a40" +a41 :: IO (); a41 = forever $ putStrLn "a41" +a42 :: IO (); a42 = forever $ putStrLn "a42" +a43 :: IO (); a43 = forever $ putStrLn "a43" +a44 :: IO (); a44 = forever $ putStrLn "a44" +a45 :: IO (); a45 = forever $ putStrLn "a45" +a46 :: IO (); a46 = forever $ putStrLn "a46" +a47 :: IO (); a47 = forever $ putStrLn "a47" +a48 :: IO (); a48 = forever $ putStrLn "a48" +a49 :: IO (); a49 = forever $ putStrLn "a49" +a50 :: IO (); a50 = forever $ putStrLn "a50" +a51 :: IO (); a51 = forever $ putStrLn "a51" +a52 :: IO (); a52 = forever $ putStrLn "a52" +a53 :: IO (); a53 = forever $ putStrLn "a53" +a54 :: IO (); a54 = forever $ putStrLn "a54" +a55 :: IO (); a55 = forever $ putStrLn "a55" +a56 :: IO (); a56 = forever $ putStrLn "a56" +a57 :: IO (); a57 = forever $ putStrLn "a57" +a58 :: IO (); a58 = forever $ putStrLn "a58" +a59 :: IO (); a59 = forever $ putStrLn "a59" +a60 :: IO (); a60 = forever $ putStrLn "a60" +a61 :: IO (); a61 = forever $ putStrLn "a61" +a62 :: IO (); a62 = forever $ putStrLn "a62" +a63 :: IO (); a63 = forever $ putStrLn "a63" +a64 :: IO (); a64 = forever $ putStrLn "a64" +a65 :: IO (); a65 = forever $ putStrLn "a65" +a66 :: IO (); a66 = forever $ putStrLn "a66" +a67 :: IO (); a67 = forever $ putStrLn "a67" +a68 :: IO (); a68 = forever $ putStrLn "a68" +a69 :: IO (); a69 = forever $ putStrLn "a69" +a70 :: IO (); a70 = forever $ putStrLn "a70" +a71 :: IO (); a71 = forever $ putStrLn "a71" +a72 :: IO (); a72 = forever $ putStrLn "a72" +a73 :: IO (); a73 = forever $ putStrLn "a73" +a74 :: IO (); a74 = forever $ putStrLn "a74" +a75 :: IO (); a75 = forever $ putStrLn "a75" +a76 :: IO (); a76 = forever $ putStrLn "a76" +a77 :: IO (); a77 = forever $ putStrLn "a77" +a78 :: IO (); a78 = forever $ putStrLn "a78" +a79 :: IO (); a79 = forever $ putStrLn "a79" +a80 :: IO (); a80 = forever $ putStrLn "a80" +a81 :: IO (); a81 = forever $ putStrLn "a81" +a82 :: IO (); a82 = forever $ putStrLn "a82" +a83 :: IO (); a83 = forever $ putStrLn "a83" +a84 :: IO (); a84 = forever $ putStrLn "a84" +a85 :: IO (); a85 = forever $ putStrLn "a85" +a86 :: IO (); a86 = forever $ putStrLn "a86" +a87 :: IO (); a87 = forever $ putStrLn "a87" +a88 :: IO (); a88 = forever $ putStrLn "a88" +a89 :: IO (); a89 = forever $ putStrLn "a89" +a90 :: IO (); a90 = forever $ putStrLn "a90" +a91 :: IO (); a91 = forever $ putStrLn "a91" +a92 :: IO (); a92 = forever $ putStrLn "a92" +a93 :: IO (); a93 = forever $ putStrLn "a93" +a94 :: IO (); a94 = forever $ putStrLn "a94" +a95 :: IO (); a95 = forever $ putStrLn "a95" +a96 :: IO (); a96 = forever $ putStrLn "a96" +a97 :: IO (); a97 = forever $ putStrLn "a97" +a98 :: IO (); a98 = forever $ putStrLn "a98" +a99 :: IO (); a99 = forever $ putStrLn "a99" +a100 :: IO (); a100 = forever $ putStrLn "a100" +a101 :: IO (); a101 = forever $ putStrLn "a101" +a102 :: IO (); a102 = forever $ putStrLn "a102" +a103 :: IO (); a103 = forever $ putStrLn "a103" +a104 :: IO (); a104 = forever $ putStrLn "a104" +a105 :: IO (); a105 = forever $ putStrLn "a105" +a106 :: IO (); a106 = forever $ putStrLn "a106" +a107 :: IO (); a107 = forever $ putStrLn "a107" +a108 :: IO (); a108 = forever $ putStrLn "a108" +a109 :: IO (); a109 = forever $ putStrLn "a109" +a110 :: IO (); a110 = forever $ putStrLn "a110" +a111 :: IO (); a111 = forever $ putStrLn "a111" +a112 :: IO (); a112 = forever $ putStrLn "a112" +a113 :: IO (); a113 = forever $ putStrLn "a113" +a114 :: IO (); a114 = forever $ putStrLn "a114" +a115 :: IO (); a115 = forever $ putStrLn "a115" +a116 :: IO (); a116 = forever $ putStrLn "a116" +a117 :: IO (); a117 = forever $ putStrLn "a117" +a118 :: IO (); a118 = forever $ putStrLn "a118" +a119 :: IO (); a119 = forever $ putStrLn "a119" +a120 :: IO (); a120 = forever $ putStrLn "a120" +a121 :: IO (); a121 = forever $ putStrLn "a121" +a122 :: IO (); a122 = forever $ putStrLn "a122" +a123 :: IO (); a123 = forever $ putStrLn "a123" +a124 :: IO (); a124 = forever $ putStrLn "a124" +a125 :: IO (); a125 = forever $ putStrLn "a125" +a126 :: IO (); a126 = forever $ putStrLn "a126" +a127 :: IO (); a127 = forever $ putStrLn "a127" +a128 :: IO (); a128 = forever $ putStrLn "a128" +a129 :: IO (); a129 = forever $ putStrLn "a129" +a130 :: IO (); a130 = forever $ putStrLn "a130" +a131 :: IO (); a131 = forever $ putStrLn "a131" +a132 :: IO (); a132 = forever $ putStrLn "a132" +a133 :: IO (); a133 = forever $ putStrLn "a133" +a134 :: IO (); a134 = forever $ putStrLn "a134" +a135 :: IO (); a135 = forever $ putStrLn "a135" +a136 :: IO (); a136 = forever $ putStrLn "a136" +a137 :: IO (); a137 = forever $ putStrLn "a137" +a138 :: IO (); a138 = forever $ putStrLn "a138" +a139 :: IO (); a139 = forever $ putStrLn "a139" +a140 :: IO (); a140 = forever $ putStrLn "a140" +a141 :: IO (); a141 = forever $ putStrLn "a141" +a142 :: IO (); a142 = forever $ putStrLn "a142" +a143 :: IO (); a143 = forever $ putStrLn "a143" +a144 :: IO (); a144 = forever $ putStrLn "a144" +a145 :: IO (); a145 = forever $ putStrLn "a145" +a146 :: IO (); a146 = forever $ putStrLn "a146" +a147 :: IO (); a147 = forever $ putStrLn "a147" +a148 :: IO (); a148 = forever $ putStrLn "a148" +a149 :: IO (); a149 = forever $ putStrLn "a149" +a150 :: IO (); a150 = forever $ putStrLn "a150" +a151 :: IO (); a151 = forever $ putStrLn "a151" +a152 :: IO (); a152 = forever $ putStrLn "a152" +a153 :: IO (); a153 = forever $ putStrLn "a153" +a154 :: IO (); a154 = forever $ putStrLn "a154" +a155 :: IO (); a155 = forever $ putStrLn "a155" +a156 :: IO (); a156 = forever $ putStrLn "a156" +a157 :: IO (); a157 = forever $ putStrLn "a157" +a158 :: IO (); a158 = forever $ putStrLn "a158" +a159 :: IO (); a159 = forever $ putStrLn "a159" +a160 :: IO (); a160 = forever $ putStrLn "a160" +a161 :: IO (); a161 = forever $ putStrLn "a161" +a162 :: IO (); a162 = forever $ putStrLn "a162" +a163 :: IO (); a163 = forever $ putStrLn "a163" +a164 :: IO (); a164 = forever $ putStrLn "a164" +a165 :: IO (); a165 = forever $ putStrLn "a165" +a166 :: IO (); a166 = forever $ putStrLn "a166" +a167 :: IO (); a167 = forever $ putStrLn "a167" +a168 :: IO (); a168 = forever $ putStrLn "a168" +a169 :: IO (); a169 = forever $ putStrLn "a169" +a170 :: IO (); a170 = forever $ putStrLn "a170" +a171 :: IO (); a171 = forever $ putStrLn "a171" +a172 :: IO (); a172 = forever $ putStrLn "a172" +a173 :: IO (); a173 = forever $ putStrLn "a173" +a174 :: IO (); a174 = forever $ putStrLn "a174" +a175 :: IO (); a175 = forever $ putStrLn "a175" +a176 :: IO (); a176 = forever $ putStrLn "a176" +a177 :: IO (); a177 = forever $ putStrLn "a177" +a178 :: IO (); a178 = forever $ putStrLn "a178" +a179 :: IO (); a179 = forever $ putStrLn "a179" +a180 :: IO (); a180 = forever $ putStrLn "a180" +a181 :: IO (); a181 = forever $ putStrLn "a181" +a182 :: IO (); a182 = forever $ putStrLn "a182" +a183 :: IO (); a183 = forever $ putStrLn "a183" +a184 :: IO (); a184 = forever $ putStrLn "a184" +a185 :: IO (); a185 = forever $ putStrLn "a185" +a186 :: IO (); a186 = forever $ putStrLn "a186" +a187 :: IO (); a187 = forever $ putStrLn "a187" +a188 :: IO (); a188 = forever $ putStrLn "a188" +a189 :: IO (); a189 = forever $ putStrLn "a189" +a190 :: IO (); a190 = forever $ putStrLn "a190" +a191 :: IO (); a191 = forever $ putStrLn "a191" +a192 :: IO (); a192 = forever $ putStrLn "a192" +a193 :: IO (); a193 = forever $ putStrLn "a193" +a194 :: IO (); a194 = forever $ putStrLn "a194" +a195 :: IO (); a195 = forever $ putStrLn "a195" +a196 :: IO (); a196 = forever $ putStrLn "a196" +a197 :: IO (); a197 = forever $ putStrLn "a197" +a198 :: IO (); a198 = forever $ putStrLn "a198" +a199 :: IO (); a199 = forever $ putStrLn "a199" +a200 :: IO (); a200 = forever $ putStrLn "a200" +a201 :: IO (); a201 = forever $ putStrLn "a201" +a202 :: IO (); a202 = forever $ putStrLn "a202" +a203 :: IO (); a203 = forever $ putStrLn "a203" +a204 :: IO (); a204 = forever $ putStrLn "a204" +a205 :: IO (); a205 = forever $ putStrLn "a205" +a206 :: IO (); a206 = forever $ putStrLn "a206" +a207 :: IO (); a207 = forever $ putStrLn "a207" +a208 :: IO (); a208 = forever $ putStrLn "a208" +a209 :: IO (); a209 = forever $ putStrLn "a209" +a210 :: IO (); a210 = forever $ putStrLn "a210" +a211 :: IO (); a211 = forever $ putStrLn "a211" +a212 :: IO (); a212 = forever $ putStrLn "a212" +a213 :: IO (); a213 = forever $ putStrLn "a213" +a214 :: IO (); a214 = forever $ putStrLn "a214" +a215 :: IO (); a215 = forever $ putStrLn "a215" +a216 :: IO (); a216 = forever $ putStrLn "a216" +a217 :: IO (); a217 = forever $ putStrLn "a217" +a218 :: IO (); a218 = forever $ putStrLn "a218" +a219 :: IO (); a219 = forever $ putStrLn "a219" +a220 :: IO (); a220 = forever $ putStrLn "a220" +a221 :: IO (); a221 = forever $ putStrLn "a221" +a222 :: IO (); a222 = forever $ putStrLn "a222" +a223 :: IO (); a223 = forever $ putStrLn "a223" +a224 :: IO (); a224 = forever $ putStrLn "a224" +a225 :: IO (); a225 = forever $ putStrLn "a225" +a226 :: IO (); a226 = forever $ putStrLn "a226" +a227 :: IO (); a227 = forever $ putStrLn "a227" +a228 :: IO (); a228 = forever $ putStrLn "a228" +a229 :: IO (); a229 = forever $ putStrLn "a229" +a230 :: IO (); a230 = forever $ putStrLn "a230" +a231 :: IO (); a231 = forever $ putStrLn "a231" +a232 :: IO (); a232 = forever $ putStrLn "a232" +a233 :: IO (); a233 = forever $ putStrLn "a233" +a234 :: IO (); a234 = forever $ putStrLn "a234" +a235 :: IO (); a235 = forever $ putStrLn "a235" +a236 :: IO (); a236 = forever $ putStrLn "a236" +a237 :: IO (); a237 = forever $ putStrLn "a237" +a238 :: IO (); a238 = forever $ putStrLn "a238" +a239 :: IO (); a239 = forever $ putStrLn "a239" +a240 :: IO (); a240 = forever $ putStrLn "a240" +a241 :: IO (); a241 = forever $ putStrLn "a241" +a242 :: IO (); a242 = forever $ putStrLn "a242" +a243 :: IO (); a243 = forever $ putStrLn "a243" +a244 :: IO (); a244 = forever $ putStrLn "a244" +a245 :: IO (); a245 = forever $ putStrLn "a245" +a246 :: IO (); a246 = forever $ putStrLn "a246" +a247 :: IO (); a247 = forever $ putStrLn "a247" +a248 :: IO (); a248 = forever $ putStrLn "a248" +a249 :: IO (); a249 = forever $ putStrLn "a249" +a250 :: IO (); a250 = forever $ putStrLn "a250" +a251 :: IO (); a251 = forever $ putStrLn "a251" +a252 :: IO (); a252 = forever $ putStrLn "a252" +a253 :: IO (); a253 = forever $ putStrLn "a253" +a254 :: IO (); a254 = forever $ putStrLn "a254" +a255 :: IO (); a255 = forever $ putStrLn "a255" +a256 :: IO (); a256 = forever $ putStrLn "a256" +a257 :: IO (); a257 = forever $ putStrLn "a257" +a258 :: IO (); a258 = forever $ putStrLn "a258" +a259 :: IO (); a259 = forever $ putStrLn "a259" +a260 :: IO (); a260 = forever $ putStrLn "a260" +a261 :: IO (); a261 = forever $ putStrLn "a261" +a262 :: IO (); a262 = forever $ putStrLn "a262" +a263 :: IO (); a263 = forever $ putStrLn "a263" +a264 :: IO (); a264 = forever $ putStrLn "a264" +a265 :: IO (); a265 = forever $ putStrLn "a265" +a266 :: IO (); a266 = forever $ putStrLn "a266" +a267 :: IO (); a267 = forever $ putStrLn "a267" +a268 :: IO (); a268 = forever $ putStrLn "a268" +a269 :: IO (); a269 = forever $ putStrLn "a269" +a270 :: IO (); a270 = forever $ putStrLn "a270" +a271 :: IO (); a271 = forever $ putStrLn "a271" +a272 :: IO (); a272 = forever $ putStrLn "a272" +a273 :: IO (); a273 = forever $ putStrLn "a273" +a274 :: IO (); a274 = forever $ putStrLn "a274" +a275 :: IO (); a275 = forever $ putStrLn "a275" +a276 :: IO (); a276 = forever $ putStrLn "a276" +a277 :: IO (); a277 = forever $ putStrLn "a277" +a278 :: IO (); a278 = forever $ putStrLn "a278" +a279 :: IO (); a279 = forever $ putStrLn "a279" +a280 :: IO (); a280 = forever $ putStrLn "a280" +a281 :: IO (); a281 = forever $ putStrLn "a281" +a282 :: IO (); a282 = forever $ putStrLn "a282" +a283 :: IO (); a283 = forever $ putStrLn "a283" +a284 :: IO (); a284 = forever $ putStrLn "a284" +a285 :: IO (); a285 = forever $ putStrLn "a285" +a286 :: IO (); a286 = forever $ putStrLn "a286" +a287 :: IO (); a287 = forever $ putStrLn "a287" +a288 :: IO (); a288 = forever $ putStrLn "a288" +a289 :: IO (); a289 = forever $ putStrLn "a289" +a290 :: IO (); a290 = forever $ putStrLn "a290" +a291 :: IO (); a291 = forever $ putStrLn "a291" +a292 :: IO (); a292 = forever $ putStrLn "a292" +a293 :: IO (); a293 = forever $ putStrLn "a293" +a294 :: IO (); a294 = forever $ putStrLn "a294" +a295 :: IO (); a295 = forever $ putStrLn "a295" +a296 :: IO (); a296 = forever $ putStrLn "a296" +a297 :: IO (); a297 = forever $ putStrLn "a297" +a298 :: IO (); a298 = forever $ putStrLn "a298" +a299 :: IO (); a299 = forever $ putStrLn "a299" +a300 :: IO (); a300 = forever $ putStrLn "a300" +a301 :: IO (); a301 = forever $ putStrLn "a301" +a302 :: IO (); a302 = forever $ putStrLn "a302" +a303 :: IO (); a303 = forever $ putStrLn "a303" +a304 :: IO (); a304 = forever $ putStrLn "a304" +a305 :: IO (); a305 = forever $ putStrLn "a305" +a306 :: IO (); a306 = forever $ putStrLn "a306" +a307 :: IO (); a307 = forever $ putStrLn "a307" +a308 :: IO (); a308 = forever $ putStrLn "a308" +a309 :: IO (); a309 = forever $ putStrLn "a309" +a310 :: IO (); a310 = forever $ putStrLn "a310" +a311 :: IO (); a311 = forever $ putStrLn "a311" +a312 :: IO (); a312 = forever $ putStrLn "a312" +a313 :: IO (); a313 = forever $ putStrLn "a313" +a314 :: IO (); a314 = forever $ putStrLn "a314" +a315 :: IO (); a315 = forever $ putStrLn "a315" +a316 :: IO (); a316 = forever $ putStrLn "a316" +a317 :: IO (); a317 = forever $ putStrLn "a317" +a318 :: IO (); a318 = forever $ putStrLn "a318" +a319 :: IO (); a319 = forever $ putStrLn "a319" +a320 :: IO (); a320 = forever $ putStrLn "a320" +a321 :: IO (); a321 = forever $ putStrLn "a321" +a322 :: IO (); a322 = forever $ putStrLn "a322" +a323 :: IO (); a323 = forever $ putStrLn "a323" +a324 :: IO (); a324 = forever $ putStrLn "a324" +a325 :: IO (); a325 = forever $ putStrLn "a325" +a326 :: IO (); a326 = forever $ putStrLn "a326" +a327 :: IO (); a327 = forever $ putStrLn "a327" +a328 :: IO (); a328 = forever $ putStrLn "a328" +a329 :: IO (); a329 = forever $ putStrLn "a329" +a330 :: IO (); a330 = forever $ putStrLn "a330" +a331 :: IO (); a331 = forever $ putStrLn "a331" +a332 :: IO (); a332 = forever $ putStrLn "a332" +a333 :: IO (); a333 = forever $ putStrLn "a333" +a334 :: IO (); a334 = forever $ putStrLn "a334" +a335 :: IO (); a335 = forever $ putStrLn "a335" +a336 :: IO (); a336 = forever $ putStrLn "a336" +a337 :: IO (); a337 = forever $ putStrLn "a337" +a338 :: IO (); a338 = forever $ putStrLn "a338" +a339 :: IO (); a339 = forever $ putStrLn "a339" +a340 :: IO (); a340 = forever $ putStrLn "a340" +a341 :: IO (); a341 = forever $ putStrLn "a341" +a342 :: IO (); a342 = forever $ putStrLn "a342" +a343 :: IO (); a343 = forever $ putStrLn "a343" +a344 :: IO (); a344 = forever $ putStrLn "a344" +a345 :: IO (); a345 = forever $ putStrLn "a345" +a346 :: IO (); a346 = forever $ putStrLn "a346" +a347 :: IO (); a347 = forever $ putStrLn "a347" +a348 :: IO (); a348 = forever $ putStrLn "a348" +a349 :: IO (); a349 = forever $ putStrLn "a349" +a350 :: IO (); a350 = forever $ putStrLn "a350" +a351 :: IO (); a351 = forever $ putStrLn "a351" +a352 :: IO (); a352 = forever $ putStrLn "a352" +a353 :: IO (); a353 = forever $ putStrLn "a353" +a354 :: IO (); a354 = forever $ putStrLn "a354" +a355 :: IO (); a355 = forever $ putStrLn "a355" +a356 :: IO (); a356 = forever $ putStrLn "a356" +a357 :: IO (); a357 = forever $ putStrLn "a357" +a358 :: IO (); a358 = forever $ putStrLn "a358" +a359 :: IO (); a359 = forever $ putStrLn "a359" +a360 :: IO (); a360 = forever $ putStrLn "a360" +a361 :: IO (); a361 = forever $ putStrLn "a361" +a362 :: IO (); a362 = forever $ putStrLn "a362" +a363 :: IO (); a363 = forever $ putStrLn "a363" +a364 :: IO (); a364 = forever $ putStrLn "a364" +a365 :: IO (); a365 = forever $ putStrLn "a365" +a366 :: IO (); a366 = forever $ putStrLn "a366" +a367 :: IO (); a367 = forever $ putStrLn "a367" +a368 :: IO (); a368 = forever $ putStrLn "a368" +a369 :: IO (); a369 = forever $ putStrLn "a369" +a370 :: IO (); a370 = forever $ putStrLn "a370" +a371 :: IO (); a371 = forever $ putStrLn "a371" +a372 :: IO (); a372 = forever $ putStrLn "a372" +a373 :: IO (); a373 = forever $ putStrLn "a373" +a374 :: IO (); a374 = forever $ putStrLn "a374" +a375 :: IO (); a375 = forever $ putStrLn "a375" +a376 :: IO (); a376 = forever $ putStrLn "a376" +a377 :: IO (); a377 = forever $ putStrLn "a377" +a378 :: IO (); a378 = forever $ putStrLn "a378" +a379 :: IO (); a379 = forever $ putStrLn "a379" +a380 :: IO (); a380 = forever $ putStrLn "a380" +a381 :: IO (); a381 = forever $ putStrLn "a381" +a382 :: IO (); a382 = forever $ putStrLn "a382" +a383 :: IO (); a383 = forever $ putStrLn "a383" +a384 :: IO (); a384 = forever $ putStrLn "a384" +a385 :: IO (); a385 = forever $ putStrLn "a385" +a386 :: IO (); a386 = forever $ putStrLn "a386" +a387 :: IO (); a387 = forever $ putStrLn "a387" +a388 :: IO (); a388 = forever $ putStrLn "a388" +a389 :: IO (); a389 = forever $ putStrLn "a389" +a390 :: IO (); a390 = forever $ putStrLn "a390" +a391 :: IO (); a391 = forever $ putStrLn "a391" +a392 :: IO (); a392 = forever $ putStrLn "a392" +a393 :: IO (); a393 = forever $ putStrLn "a393" +a394 :: IO (); a394 = forever $ putStrLn "a394" +a395 :: IO (); a395 = forever $ putStrLn "a395" +a396 :: IO (); a396 = forever $ putStrLn "a396" +a397 :: IO (); a397 = forever $ putStrLn "a397" +a398 :: IO (); a398 = forever $ putStrLn "a398" +a399 :: IO (); a399 = forever $ putStrLn "a399" +a400 :: IO (); a400 = forever $ putStrLn "a400" +a401 :: IO (); a401 = forever $ putStrLn "a401" +a402 :: IO (); a402 = forever $ putStrLn "a402" +a403 :: IO (); a403 = forever $ putStrLn "a403" +a404 :: IO (); a404 = forever $ putStrLn "a404" +a405 :: IO (); a405 = forever $ putStrLn "a405" +a406 :: IO (); a406 = forever $ putStrLn "a406" +a407 :: IO (); a407 = forever $ putStrLn "a407" +a408 :: IO (); a408 = forever $ putStrLn "a408" +a409 :: IO (); a409 = forever $ putStrLn "a409" +a410 :: IO (); a410 = forever $ putStrLn "a410" +a411 :: IO (); a411 = forever $ putStrLn "a411" +a412 :: IO (); a412 = forever $ putStrLn "a412" +a413 :: IO (); a413 = forever $ putStrLn "a413" +a414 :: IO (); a414 = forever $ putStrLn "a414" +a415 :: IO (); a415 = forever $ putStrLn "a415" +a416 :: IO (); a416 = forever $ putStrLn "a416" +a417 :: IO (); a417 = forever $ putStrLn "a417" +a418 :: IO (); a418 = forever $ putStrLn "a418" +a419 :: IO (); a419 = forever $ putStrLn "a419" +a420 :: IO (); a420 = forever $ putStrLn "a420" +a421 :: IO (); a421 = forever $ putStrLn "a421" +a422 :: IO (); a422 = forever $ putStrLn "a422" +a423 :: IO (); a423 = forever $ putStrLn "a423" +a424 :: IO (); a424 = forever $ putStrLn "a424" +a425 :: IO (); a425 = forever $ putStrLn "a425" +a426 :: IO (); a426 = forever $ putStrLn "a426" +a427 :: IO (); a427 = forever $ putStrLn "a427" +a428 :: IO (); a428 = forever $ putStrLn "a428" +a429 :: IO (); a429 = forever $ putStrLn "a429" +a430 :: IO (); a430 = forever $ putStrLn "a430" +a431 :: IO (); a431 = forever $ putStrLn "a431" +a432 :: IO (); a432 = forever $ putStrLn "a432" +a433 :: IO (); a433 = forever $ putStrLn "a433" +a434 :: IO (); a434 = forever $ putStrLn "a434" +a435 :: IO (); a435 = forever $ putStrLn "a435" +a436 :: IO (); a436 = forever $ putStrLn "a436" +a437 :: IO (); a437 = forever $ putStrLn "a437" +a438 :: IO (); a438 = forever $ putStrLn "a438" +a439 :: IO (); a439 = forever $ putStrLn "a439" +a440 :: IO (); a440 = forever $ putStrLn "a440" +a441 :: IO (); a441 = forever $ putStrLn "a441" +a442 :: IO (); a442 = forever $ putStrLn "a442" +a443 :: IO (); a443 = forever $ putStrLn "a443" +a444 :: IO (); a444 = forever $ putStrLn "a444" +a445 :: IO (); a445 = forever $ putStrLn "a445" +a446 :: IO (); a446 = forever $ putStrLn "a446" +a447 :: IO (); a447 = forever $ putStrLn "a447" +a448 :: IO (); a448 = forever $ putStrLn "a448" +a449 :: IO (); a449 = forever $ putStrLn "a449" +a450 :: IO (); a450 = forever $ putStrLn "a450" +a451 :: IO (); a451 = forever $ putStrLn "a451" +a452 :: IO (); a452 = forever $ putStrLn "a452" +a453 :: IO (); a453 = forever $ putStrLn "a453" +a454 :: IO (); a454 = forever $ putStrLn "a454" +a455 :: IO (); a455 = forever $ putStrLn "a455" +a456 :: IO (); a456 = forever $ putStrLn "a456" +a457 :: IO (); a457 = forever $ putStrLn "a457" +a458 :: IO (); a458 = forever $ putStrLn "a458" +a459 :: IO (); a459 = forever $ putStrLn "a459" +a460 :: IO (); a460 = forever $ putStrLn "a460" +a461 :: IO (); a461 = forever $ putStrLn "a461" +a462 :: IO (); a462 = forever $ putStrLn "a462" +a463 :: IO (); a463 = forever $ putStrLn "a463" +a464 :: IO (); a464 = forever $ putStrLn "a464" +a465 :: IO (); a465 = forever $ putStrLn "a465" +a466 :: IO (); a466 = forever $ putStrLn "a466" +a467 :: IO (); a467 = forever $ putStrLn "a467" +a468 :: IO (); a468 = forever $ putStrLn "a468" +a469 :: IO (); a469 = forever $ putStrLn "a469" +a470 :: IO (); a470 = forever $ putStrLn "a470" +a471 :: IO (); a471 = forever $ putStrLn "a471" +a472 :: IO (); a472 = forever $ putStrLn "a472" +a473 :: IO (); a473 = forever $ putStrLn "a473" +a474 :: IO (); a474 = forever $ putStrLn "a474" +a475 :: IO (); a475 = forever $ putStrLn "a475" +a476 :: IO (); a476 = forever $ putStrLn "a476" +a477 :: IO (); a477 = forever $ putStrLn "a477" +a478 :: IO (); a478 = forever $ putStrLn "a478" +a479 :: IO (); a479 = forever $ putStrLn "a479" +a480 :: IO (); a480 = forever $ putStrLn "a480" +a481 :: IO (); a481 = forever $ putStrLn "a481" +a482 :: IO (); a482 = forever $ putStrLn "a482" +a483 :: IO (); a483 = forever $ putStrLn "a483" +a484 :: IO (); a484 = forever $ putStrLn "a484" +a485 :: IO (); a485 = forever $ putStrLn "a485" +a486 :: IO (); a486 = forever $ putStrLn "a486" +a487 :: IO (); a487 = forever $ putStrLn "a487" +a488 :: IO (); a488 = forever $ putStrLn "a488" +a489 :: IO (); a489 = forever $ putStrLn "a489" +a490 :: IO (); a490 = forever $ putStrLn "a490" +a491 :: IO (); a491 = forever $ putStrLn "a491" +a492 :: IO (); a492 = forever $ putStrLn "a492" +a493 :: IO (); a493 = forever $ putStrLn "a493" +a494 :: IO (); a494 = forever $ putStrLn "a494" +a495 :: IO (); a495 = forever $ putStrLn "a495" +a496 :: IO (); a496 = forever $ putStrLn "a496" +a497 :: IO (); a497 = forever $ putStrLn "a497" +a498 :: IO (); a498 = forever $ putStrLn "a498" +a499 :: IO (); a499 = forever $ putStrLn "a499" +a500 :: IO (); a500 = forever $ putStrLn "a500" +a501 :: IO (); a501 = forever $ putStrLn "a501" +a502 :: IO (); a502 = forever $ putStrLn "a502" +a503 :: IO (); a503 = forever $ putStrLn "a503" +a504 :: IO (); a504 = forever $ putStrLn "a504" +a505 :: IO (); a505 = forever $ putStrLn "a505" +a506 :: IO (); a506 = forever $ putStrLn "a506" +a507 :: IO (); a507 = forever $ putStrLn "a507" +a508 :: IO (); a508 = forever $ putStrLn "a508" +a509 :: IO (); a509 = forever $ putStrLn "a509" +a510 :: IO (); a510 = forever $ putStrLn "a510" +a511 :: IO (); a511 = forever $ putStrLn "a511" +a512 :: IO (); a512 = forever $ putStrLn "a512" +a513 :: IO (); a513 = forever $ putStrLn "a513" +a514 :: IO (); a514 = forever $ putStrLn "a514" +a515 :: IO (); a515 = forever $ putStrLn "a515" +a516 :: IO (); a516 = forever $ putStrLn "a516" +a517 :: IO (); a517 = forever $ putStrLn "a517" +a518 :: IO (); a518 = forever $ putStrLn "a518" +a519 :: IO (); a519 = forever $ putStrLn "a519" +a520 :: IO (); a520 = forever $ putStrLn "a520" +a521 :: IO (); a521 = forever $ putStrLn "a521" +a522 :: IO (); a522 = forever $ putStrLn "a522" +a523 :: IO (); a523 = forever $ putStrLn "a523" +a524 :: IO (); a524 = forever $ putStrLn "a524" +a525 :: IO (); a525 = forever $ putStrLn "a525" +a526 :: IO (); a526 = forever $ putStrLn "a526" +a527 :: IO (); a527 = forever $ putStrLn "a527" +a528 :: IO (); a528 = forever $ putStrLn "a528" +a529 :: IO (); a529 = forever $ putStrLn "a529" +a530 :: IO (); a530 = forever $ putStrLn "a530" +a531 :: IO (); a531 = forever $ putStrLn "a531" +a532 :: IO (); a532 = forever $ putStrLn "a532" +a533 :: IO (); a533 = forever $ putStrLn "a533" +a534 :: IO (); a534 = forever $ putStrLn "a534" +a535 :: IO (); a535 = forever $ putStrLn "a535" +a536 :: IO (); a536 = forever $ putStrLn "a536" +a537 :: IO (); a537 = forever $ putStrLn "a537" +a538 :: IO (); a538 = forever $ putStrLn "a538" +a539 :: IO (); a539 = forever $ putStrLn "a539" +a540 :: IO (); a540 = forever $ putStrLn "a540" +a541 :: IO (); a541 = forever $ putStrLn "a541" +a542 :: IO (); a542 = forever $ putStrLn "a542" +a543 :: IO (); a543 = forever $ putStrLn "a543" +a544 :: IO (); a544 = forever $ putStrLn "a544" +a545 :: IO (); a545 = forever $ putStrLn "a545" +a546 :: IO (); a546 = forever $ putStrLn "a546" +a547 :: IO (); a547 = forever $ putStrLn "a547" +a548 :: IO (); a548 = forever $ putStrLn "a548" +a549 :: IO (); a549 = forever $ putStrLn "a549" +a550 :: IO (); a550 = forever $ putStrLn "a550" +a551 :: IO (); a551 = forever $ putStrLn "a551" +a552 :: IO (); a552 = forever $ putStrLn "a552" +a553 :: IO (); a553 = forever $ putStrLn "a553" +a554 :: IO (); a554 = forever $ putStrLn "a554" +a555 :: IO (); a555 = forever $ putStrLn "a555" +a556 :: IO (); a556 = forever $ putStrLn "a556" +a557 :: IO (); a557 = forever $ putStrLn "a557" +a558 :: IO (); a558 = forever $ putStrLn "a558" +a559 :: IO (); a559 = forever $ putStrLn "a559" +a560 :: IO (); a560 = forever $ putStrLn "a560" +a561 :: IO (); a561 = forever $ putStrLn "a561" +a562 :: IO (); a562 = forever $ putStrLn "a562" +a563 :: IO (); a563 = forever $ putStrLn "a563" +a564 :: IO (); a564 = forever $ putStrLn "a564" +a565 :: IO (); a565 = forever $ putStrLn "a565" +a566 :: IO (); a566 = forever $ putStrLn "a566" +a567 :: IO (); a567 = forever $ putStrLn "a567" +a568 :: IO (); a568 = forever $ putStrLn "a568" +a569 :: IO (); a569 = forever $ putStrLn "a569" +a570 :: IO (); a570 = forever $ putStrLn "a570" +a571 :: IO (); a571 = forever $ putStrLn "a571" +a572 :: IO (); a572 = forever $ putStrLn "a572" +a573 :: IO (); a573 = forever $ putStrLn "a573" +a574 :: IO (); a574 = forever $ putStrLn "a574" +a575 :: IO (); a575 = forever $ putStrLn "a575" +a576 :: IO (); a576 = forever $ putStrLn "a576" +a577 :: IO (); a577 = forever $ putStrLn "a577" +a578 :: IO (); a578 = forever $ putStrLn "a578" +a579 :: IO (); a579 = forever $ putStrLn "a579" +a580 :: IO (); a580 = forever $ putStrLn "a580" +a581 :: IO (); a581 = forever $ putStrLn "a581" +a582 :: IO (); a582 = forever $ putStrLn "a582" +a583 :: IO (); a583 = forever $ putStrLn "a583" +a584 :: IO (); a584 = forever $ putStrLn "a584" +a585 :: IO (); a585 = forever $ putStrLn "a585" +a586 :: IO (); a586 = forever $ putStrLn "a586" +a587 :: IO (); a587 = forever $ putStrLn "a587" +a588 :: IO (); a588 = forever $ putStrLn "a588" +a589 :: IO (); a589 = forever $ putStrLn "a589" +a590 :: IO (); a590 = forever $ putStrLn "a590" +a591 :: IO (); a591 = forever $ putStrLn "a591" +a592 :: IO (); a592 = forever $ putStrLn "a592" +a593 :: IO (); a593 = forever $ putStrLn "a593" +a594 :: IO (); a594 = forever $ putStrLn "a594" +a595 :: IO (); a595 = forever $ putStrLn "a595" +a596 :: IO (); a596 = forever $ putStrLn "a596" +a597 :: IO (); a597 = forever $ putStrLn "a597" +a598 :: IO (); a598 = forever $ putStrLn "a598" +a599 :: IO (); a599 = forever $ putStrLn "a599" +a600 :: IO (); a600 = forever $ putStrLn "a600" +a601 :: IO (); a601 = forever $ putStrLn "a601" +a602 :: IO (); a602 = forever $ putStrLn "a602" +a603 :: IO (); a603 = forever $ putStrLn "a603" +a604 :: IO (); a604 = forever $ putStrLn "a604" +a605 :: IO (); a605 = forever $ putStrLn "a605" +a606 :: IO (); a606 = forever $ putStrLn "a606" +a607 :: IO (); a607 = forever $ putStrLn "a607" +a608 :: IO (); a608 = forever $ putStrLn "a608" +a609 :: IO (); a609 = forever $ putStrLn "a609" +a610 :: IO (); a610 = forever $ putStrLn "a610" +a611 :: IO (); a611 = forever $ putStrLn "a611" +a612 :: IO (); a612 = forever $ putStrLn "a612" +a613 :: IO (); a613 = forever $ putStrLn "a613" +a614 :: IO (); a614 = forever $ putStrLn "a614" +a615 :: IO (); a615 = forever $ putStrLn "a615" +a616 :: IO (); a616 = forever $ putStrLn "a616" +a617 :: IO (); a617 = forever $ putStrLn "a617" +a618 :: IO (); a618 = forever $ putStrLn "a618" +a619 :: IO (); a619 = forever $ putStrLn "a619" +a620 :: IO (); a620 = forever $ putStrLn "a620" +a621 :: IO (); a621 = forever $ putStrLn "a621" +a622 :: IO (); a622 = forever $ putStrLn "a622" +a623 :: IO (); a623 = forever $ putStrLn "a623" +a624 :: IO (); a624 = forever $ putStrLn "a624" +a625 :: IO (); a625 = forever $ putStrLn "a625" +a626 :: IO (); a626 = forever $ putStrLn "a626" +a627 :: IO (); a627 = forever $ putStrLn "a627" +a628 :: IO (); a628 = forever $ putStrLn "a628" +a629 :: IO (); a629 = forever $ putStrLn "a629" +a630 :: IO (); a630 = forever $ putStrLn "a630" +a631 :: IO (); a631 = forever $ putStrLn "a631" +a632 :: IO (); a632 = forever $ putStrLn "a632" +a633 :: IO (); a633 = forever $ putStrLn "a633" +a634 :: IO (); a634 = forever $ putStrLn "a634" +a635 :: IO (); a635 = forever $ putStrLn "a635" +a636 :: IO (); a636 = forever $ putStrLn "a636" +a637 :: IO (); a637 = forever $ putStrLn "a637" +a638 :: IO (); a638 = forever $ putStrLn "a638" +a639 :: IO (); a639 = forever $ putStrLn "a639" +a640 :: IO (); a640 = forever $ putStrLn "a640" +a641 :: IO (); a641 = forever $ putStrLn "a641" +a642 :: IO (); a642 = forever $ putStrLn "a642" +a643 :: IO (); a643 = forever $ putStrLn "a643" +a644 :: IO (); a644 = forever $ putStrLn "a644" +a645 :: IO (); a645 = forever $ putStrLn "a645" +a646 :: IO (); a646 = forever $ putStrLn "a646" +a647 :: IO (); a647 = forever $ putStrLn "a647" +a648 :: IO (); a648 = forever $ putStrLn "a648" +a649 :: IO (); a649 = forever $ putStrLn "a649" +a650 :: IO (); a650 = forever $ putStrLn "a650" +a651 :: IO (); a651 = forever $ putStrLn "a651" +a652 :: IO (); a652 = forever $ putStrLn "a652" +a653 :: IO (); a653 = forever $ putStrLn "a653" +a654 :: IO (); a654 = forever $ putStrLn "a654" +a655 :: IO (); a655 = forever $ putStrLn "a655" +a656 :: IO (); a656 = forever $ putStrLn "a656" +a657 :: IO (); a657 = forever $ putStrLn "a657" +a658 :: IO (); a658 = forever $ putStrLn "a658" +a659 :: IO (); a659 = forever $ putStrLn "a659" +a660 :: IO (); a660 = forever $ putStrLn "a660" +a661 :: IO (); a661 = forever $ putStrLn "a661" +a662 :: IO (); a662 = forever $ putStrLn "a662" +a663 :: IO (); a663 = forever $ putStrLn "a663" +a664 :: IO (); a664 = forever $ putStrLn "a664" +a665 :: IO (); a665 = forever $ putStrLn "a665" +a666 :: IO (); a666 = forever $ putStrLn "a666" +a667 :: IO (); a667 = forever $ putStrLn "a667" +a668 :: IO (); a668 = forever $ putStrLn "a668" +a669 :: IO (); a669 = forever $ putStrLn "a669" +a670 :: IO (); a670 = forever $ putStrLn "a670" +a671 :: IO (); a671 = forever $ putStrLn "a671" +a672 :: IO (); a672 = forever $ putStrLn "a672" +a673 :: IO (); a673 = forever $ putStrLn "a673" +a674 :: IO (); a674 = forever $ putStrLn "a674" +a675 :: IO (); a675 = forever $ putStrLn "a675" +a676 :: IO (); a676 = forever $ putStrLn "a676" +a677 :: IO (); a677 = forever $ putStrLn "a677" +a678 :: IO (); a678 = forever $ putStrLn "a678" +a679 :: IO (); a679 = forever $ putStrLn "a679" +a680 :: IO (); a680 = forever $ putStrLn "a680" +a681 :: IO (); a681 = forever $ putStrLn "a681" +a682 :: IO (); a682 = forever $ putStrLn "a682" +a683 :: IO (); a683 = forever $ putStrLn "a683" +a684 :: IO (); a684 = forever $ putStrLn "a684" +a685 :: IO (); a685 = forever $ putStrLn "a685" +a686 :: IO (); a686 = forever $ putStrLn "a686" +a687 :: IO (); a687 = forever $ putStrLn "a687" +a688 :: IO (); a688 = forever $ putStrLn "a688" +a689 :: IO (); a689 = forever $ putStrLn "a689" +a690 :: IO (); a690 = forever $ putStrLn "a690" +a691 :: IO (); a691 = forever $ putStrLn "a691" +a692 :: IO (); a692 = forever $ putStrLn "a692" +a693 :: IO (); a693 = forever $ putStrLn "a693" +a694 :: IO (); a694 = forever $ putStrLn "a694" +a695 :: IO (); a695 = forever $ putStrLn "a695" +a696 :: IO (); a696 = forever $ putStrLn "a696" +a697 :: IO (); a697 = forever $ putStrLn "a697" +a698 :: IO (); a698 = forever $ putStrLn "a698" +a699 :: IO (); a699 = forever $ putStrLn "a699" +a700 :: IO (); a700 = forever $ putStrLn "a700" +a701 :: IO (); a701 = forever $ putStrLn "a701" +a702 :: IO (); a702 = forever $ putStrLn "a702" +a703 :: IO (); a703 = forever $ putStrLn "a703" +a704 :: IO (); a704 = forever $ putStrLn "a704" +a705 :: IO (); a705 = forever $ putStrLn "a705" +a706 :: IO (); a706 = forever $ putStrLn "a706" +a707 :: IO (); a707 = forever $ putStrLn "a707" +a708 :: IO (); a708 = forever $ putStrLn "a708" +a709 :: IO (); a709 = forever $ putStrLn "a709" +a710 :: IO (); a710 = forever $ putStrLn "a710" +a711 :: IO (); a711 = forever $ putStrLn "a711" +a712 :: IO (); a712 = forever $ putStrLn "a712" +a713 :: IO (); a713 = forever $ putStrLn "a713" +a714 :: IO (); a714 = forever $ putStrLn "a714" +a715 :: IO (); a715 = forever $ putStrLn "a715" +a716 :: IO (); a716 = forever $ putStrLn "a716" +a717 :: IO (); a717 = forever $ putStrLn "a717" +a718 :: IO (); a718 = forever $ putStrLn "a718" +a719 :: IO (); a719 = forever $ putStrLn "a719" +a720 :: IO (); a720 = forever $ putStrLn "a720" +a721 :: IO (); a721 = forever $ putStrLn "a721" +a722 :: IO (); a722 = forever $ putStrLn "a722" +a723 :: IO (); a723 = forever $ putStrLn "a723" +a724 :: IO (); a724 = forever $ putStrLn "a724" +a725 :: IO (); a725 = forever $ putStrLn "a725" +a726 :: IO (); a726 = forever $ putStrLn "a726" +a727 :: IO (); a727 = forever $ putStrLn "a727" +a728 :: IO (); a728 = forever $ putStrLn "a728" +a729 :: IO (); a729 = forever $ putStrLn "a729" +a730 :: IO (); a730 = forever $ putStrLn "a730" +a731 :: IO (); a731 = forever $ putStrLn "a731" +a732 :: IO (); a732 = forever $ putStrLn "a732" +a733 :: IO (); a733 = forever $ putStrLn "a733" +a734 :: IO (); a734 = forever $ putStrLn "a734" +a735 :: IO (); a735 = forever $ putStrLn "a735" +a736 :: IO (); a736 = forever $ putStrLn "a736" +a737 :: IO (); a737 = forever $ putStrLn "a737" +a738 :: IO (); a738 = forever $ putStrLn "a738" +a739 :: IO (); a739 = forever $ putStrLn "a739" +a740 :: IO (); a740 = forever $ putStrLn "a740" +a741 :: IO (); a741 = forever $ putStrLn "a741" +a742 :: IO (); a742 = forever $ putStrLn "a742" +a743 :: IO (); a743 = forever $ putStrLn "a743" +a744 :: IO (); a744 = forever $ putStrLn "a744" +a745 :: IO (); a745 = forever $ putStrLn "a745" +a746 :: IO (); a746 = forever $ putStrLn "a746" +a747 :: IO (); a747 = forever $ putStrLn "a747" +a748 :: IO (); a748 = forever $ putStrLn "a748" +a749 :: IO (); a749 = forever $ putStrLn "a749" +a750 :: IO (); a750 = forever $ putStrLn "a750" +a751 :: IO (); a751 = forever $ putStrLn "a751" +a752 :: IO (); a752 = forever $ putStrLn "a752" +a753 :: IO (); a753 = forever $ putStrLn "a753" +a754 :: IO (); a754 = forever $ putStrLn "a754" +a755 :: IO (); a755 = forever $ putStrLn "a755" +a756 :: IO (); a756 = forever $ putStrLn "a756" +a757 :: IO (); a757 = forever $ putStrLn "a757" +a758 :: IO (); a758 = forever $ putStrLn "a758" +a759 :: IO (); a759 = forever $ putStrLn "a759" +a760 :: IO (); a760 = forever $ putStrLn "a760" +a761 :: IO (); a761 = forever $ putStrLn "a761" +a762 :: IO (); a762 = forever $ putStrLn "a762" +a763 :: IO (); a763 = forever $ putStrLn "a763" +a764 :: IO (); a764 = forever $ putStrLn "a764" +a765 :: IO (); a765 = forever $ putStrLn "a765" +a766 :: IO (); a766 = forever $ putStrLn "a766" +a767 :: IO (); a767 = forever $ putStrLn "a767" +a768 :: IO (); a768 = forever $ putStrLn "a768" +a769 :: IO (); a769 = forever $ putStrLn "a769" +a770 :: IO (); a770 = forever $ putStrLn "a770" +a771 :: IO (); a771 = forever $ putStrLn "a771" +a772 :: IO (); a772 = forever $ putStrLn "a772" +a773 :: IO (); a773 = forever $ putStrLn "a773" +a774 :: IO (); a774 = forever $ putStrLn "a774" +a775 :: IO (); a775 = forever $ putStrLn "a775" +a776 :: IO (); a776 = forever $ putStrLn "a776" +a777 :: IO (); a777 = forever $ putStrLn "a777" +a778 :: IO (); a778 = forever $ putStrLn "a778" +a779 :: IO (); a779 = forever $ putStrLn "a779" +a780 :: IO (); a780 = forever $ putStrLn "a780" +a781 :: IO (); a781 = forever $ putStrLn "a781" +a782 :: IO (); a782 = forever $ putStrLn "a782" +a783 :: IO (); a783 = forever $ putStrLn "a783" +a784 :: IO (); a784 = forever $ putStrLn "a784" +a785 :: IO (); a785 = forever $ putStrLn "a785" +a786 :: IO (); a786 = forever $ putStrLn "a786" +a787 :: IO (); a787 = forever $ putStrLn "a787" +a788 :: IO (); a788 = forever $ putStrLn "a788" +a789 :: IO (); a789 = forever $ putStrLn "a789" +a790 :: IO (); a790 = forever $ putStrLn "a790" +a791 :: IO (); a791 = forever $ putStrLn "a791" +a792 :: IO (); a792 = forever $ putStrLn "a792" +a793 :: IO (); a793 = forever $ putStrLn "a793" +a794 :: IO (); a794 = forever $ putStrLn "a794" +a795 :: IO (); a795 = forever $ putStrLn "a795" +a796 :: IO (); a796 = forever $ putStrLn "a796" +a797 :: IO (); a797 = forever $ putStrLn "a797" +a798 :: IO (); a798 = forever $ putStrLn "a798" +a799 :: IO (); a799 = forever $ putStrLn "a799" +a800 :: IO (); a800 = forever $ putStrLn "a800" +a801 :: IO (); a801 = forever $ putStrLn "a801" +a802 :: IO (); a802 = forever $ putStrLn "a802" +a803 :: IO (); a803 = forever $ putStrLn "a803" +a804 :: IO (); a804 = forever $ putStrLn "a804" +a805 :: IO (); a805 = forever $ putStrLn "a805" +a806 :: IO (); a806 = forever $ putStrLn "a806" +a807 :: IO (); a807 = forever $ putStrLn "a807" +a808 :: IO (); a808 = forever $ putStrLn "a808" +a809 :: IO (); a809 = forever $ putStrLn "a809" +a810 :: IO (); a810 = forever $ putStrLn "a810" +a811 :: IO (); a811 = forever $ putStrLn "a811" +a812 :: IO (); a812 = forever $ putStrLn "a812" +a813 :: IO (); a813 = forever $ putStrLn "a813" +a814 :: IO (); a814 = forever $ putStrLn "a814" +a815 :: IO (); a815 = forever $ putStrLn "a815" +a816 :: IO (); a816 = forever $ putStrLn "a816" +a817 :: IO (); a817 = forever $ putStrLn "a817" +a818 :: IO (); a818 = forever $ putStrLn "a818" +a819 :: IO (); a819 = forever $ putStrLn "a819" +a820 :: IO (); a820 = forever $ putStrLn "a820" +a821 :: IO (); a821 = forever $ putStrLn "a821" +a822 :: IO (); a822 = forever $ putStrLn "a822" +a823 :: IO (); a823 = forever $ putStrLn "a823" +a824 :: IO (); a824 = forever $ putStrLn "a824" +a825 :: IO (); a825 = forever $ putStrLn "a825" +a826 :: IO (); a826 = forever $ putStrLn "a826" +a827 :: IO (); a827 = forever $ putStrLn "a827" +a828 :: IO (); a828 = forever $ putStrLn "a828" +a829 :: IO (); a829 = forever $ putStrLn "a829" +a830 :: IO (); a830 = forever $ putStrLn "a830" +a831 :: IO (); a831 = forever $ putStrLn "a831" +a832 :: IO (); a832 = forever $ putStrLn "a832" +a833 :: IO (); a833 = forever $ putStrLn "a833" +a834 :: IO (); a834 = forever $ putStrLn "a834" +a835 :: IO (); a835 = forever $ putStrLn "a835" +a836 :: IO (); a836 = forever $ putStrLn "a836" +a837 :: IO (); a837 = forever $ putStrLn "a837" +a838 :: IO (); a838 = forever $ putStrLn "a838" +a839 :: IO (); a839 = forever $ putStrLn "a839" +a840 :: IO (); a840 = forever $ putStrLn "a840" +a841 :: IO (); a841 = forever $ putStrLn "a841" +a842 :: IO (); a842 = forever $ putStrLn "a842" +a843 :: IO (); a843 = forever $ putStrLn "a843" +a844 :: IO (); a844 = forever $ putStrLn "a844" +a845 :: IO (); a845 = forever $ putStrLn "a845" +a846 :: IO (); a846 = forever $ putStrLn "a846" +a847 :: IO (); a847 = forever $ putStrLn "a847" +a848 :: IO (); a848 = forever $ putStrLn "a848" +a849 :: IO (); a849 = forever $ putStrLn "a849" +a850 :: IO (); a850 = forever $ putStrLn "a850" +a851 :: IO (); a851 = forever $ putStrLn "a851" +a852 :: IO (); a852 = forever $ putStrLn "a852" +a853 :: IO (); a853 = forever $ putStrLn "a853" +a854 :: IO (); a854 = forever $ putStrLn "a854" +a855 :: IO (); a855 = forever $ putStrLn "a855" +a856 :: IO (); a856 = forever $ putStrLn "a856" +a857 :: IO (); a857 = forever $ putStrLn "a857" +a858 :: IO (); a858 = forever $ putStrLn "a858" +a859 :: IO (); a859 = forever $ putStrLn "a859" +a860 :: IO (); a860 = forever $ putStrLn "a860" +a861 :: IO (); a861 = forever $ putStrLn "a861" +a862 :: IO (); a862 = forever $ putStrLn "a862" +a863 :: IO (); a863 = forever $ putStrLn "a863" +a864 :: IO (); a864 = forever $ putStrLn "a864" +a865 :: IO (); a865 = forever $ putStrLn "a865" +a866 :: IO (); a866 = forever $ putStrLn "a866" +a867 :: IO (); a867 = forever $ putStrLn "a867" +a868 :: IO (); a868 = forever $ putStrLn "a868" +a869 :: IO (); a869 = forever $ putStrLn "a869" +a870 :: IO (); a870 = forever $ putStrLn "a870" +a871 :: IO (); a871 = forever $ putStrLn "a871" +a872 :: IO (); a872 = forever $ putStrLn "a872" +a873 :: IO (); a873 = forever $ putStrLn "a873" +a874 :: IO (); a874 = forever $ putStrLn "a874" +a875 :: IO (); a875 = forever $ putStrLn "a875" +a876 :: IO (); a876 = forever $ putStrLn "a876" +a877 :: IO (); a877 = forever $ putStrLn "a877" +a878 :: IO (); a878 = forever $ putStrLn "a878" +a879 :: IO (); a879 = forever $ putStrLn "a879" +a880 :: IO (); a880 = forever $ putStrLn "a880" +a881 :: IO (); a881 = forever $ putStrLn "a881" +a882 :: IO (); a882 = forever $ putStrLn "a882" +a883 :: IO (); a883 = forever $ putStrLn "a883" +a884 :: IO (); a884 = forever $ putStrLn "a884" +a885 :: IO (); a885 = forever $ putStrLn "a885" +a886 :: IO (); a886 = forever $ putStrLn "a886" +a887 :: IO (); a887 = forever $ putStrLn "a887" +a888 :: IO (); a888 = forever $ putStrLn "a888" +a889 :: IO (); a889 = forever $ putStrLn "a889" +a890 :: IO (); a890 = forever $ putStrLn "a890" +a891 :: IO (); a891 = forever $ putStrLn "a891" +a892 :: IO (); a892 = forever $ putStrLn "a892" +a893 :: IO (); a893 = forever $ putStrLn "a893" +a894 :: IO (); a894 = forever $ putStrLn "a894" +a895 :: IO (); a895 = forever $ putStrLn "a895" +a896 :: IO (); a896 = forever $ putStrLn "a896" +a897 :: IO (); a897 = forever $ putStrLn "a897" +a898 :: IO (); a898 = forever $ putStrLn "a898" +a899 :: IO (); a899 = forever $ putStrLn "a899" +a900 :: IO (); a900 = forever $ putStrLn "a900" +a901 :: IO (); a901 = forever $ putStrLn "a901" +a902 :: IO (); a902 = forever $ putStrLn "a902" +a903 :: IO (); a903 = forever $ putStrLn "a903" +a904 :: IO (); a904 = forever $ putStrLn "a904" +a905 :: IO (); a905 = forever $ putStrLn "a905" +a906 :: IO (); a906 = forever $ putStrLn "a906" +a907 :: IO (); a907 = forever $ putStrLn "a907" +a908 :: IO (); a908 = forever $ putStrLn "a908" +a909 :: IO (); a909 = forever $ putStrLn "a909" +a910 :: IO (); a910 = forever $ putStrLn "a910" +a911 :: IO (); a911 = forever $ putStrLn "a911" +a912 :: IO (); a912 = forever $ putStrLn "a912" +a913 :: IO (); a913 = forever $ putStrLn "a913" +a914 :: IO (); a914 = forever $ putStrLn "a914" +a915 :: IO (); a915 = forever $ putStrLn "a915" +a916 :: IO (); a916 = forever $ putStrLn "a916" +a917 :: IO (); a917 = forever $ putStrLn "a917" +a918 :: IO (); a918 = forever $ putStrLn "a918" +a919 :: IO (); a919 = forever $ putStrLn "a919" +a920 :: IO (); a920 = forever $ putStrLn "a920" +a921 :: IO (); a921 = forever $ putStrLn "a921" +a922 :: IO (); a922 = forever $ putStrLn "a922" +a923 :: IO (); a923 = forever $ putStrLn "a923" +a924 :: IO (); a924 = forever $ putStrLn "a924" +a925 :: IO (); a925 = forever $ putStrLn "a925" +a926 :: IO (); a926 = forever $ putStrLn "a926" +a927 :: IO (); a927 = forever $ putStrLn "a927" +a928 :: IO (); a928 = forever $ putStrLn "a928" +a929 :: IO (); a929 = forever $ putStrLn "a929" +a930 :: IO (); a930 = forever $ putStrLn "a930" +a931 :: IO (); a931 = forever $ putStrLn "a931" +a932 :: IO (); a932 = forever $ putStrLn "a932" +a933 :: IO (); a933 = forever $ putStrLn "a933" +a934 :: IO (); a934 = forever $ putStrLn "a934" +a935 :: IO (); a935 = forever $ putStrLn "a935" +a936 :: IO (); a936 = forever $ putStrLn "a936" +a937 :: IO (); a937 = forever $ putStrLn "a937" +a938 :: IO (); a938 = forever $ putStrLn "a938" +a939 :: IO (); a939 = forever $ putStrLn "a939" +a940 :: IO (); a940 = forever $ putStrLn "a940" +a941 :: IO (); a941 = forever $ putStrLn "a941" +a942 :: IO (); a942 = forever $ putStrLn "a942" +a943 :: IO (); a943 = forever $ putStrLn "a943" +a944 :: IO (); a944 = forever $ putStrLn "a944" +a945 :: IO (); a945 = forever $ putStrLn "a945" +a946 :: IO (); a946 = forever $ putStrLn "a946" +a947 :: IO (); a947 = forever $ putStrLn "a947" +a948 :: IO (); a948 = forever $ putStrLn "a948" +a949 :: IO (); a949 = forever $ putStrLn "a949" +a950 :: IO (); a950 = forever $ putStrLn "a950" +a951 :: IO (); a951 = forever $ putStrLn "a951" +a952 :: IO (); a952 = forever $ putStrLn "a952" +a953 :: IO (); a953 = forever $ putStrLn "a953" +a954 :: IO (); a954 = forever $ putStrLn "a954" +a955 :: IO (); a955 = forever $ putStrLn "a955" +a956 :: IO (); a956 = forever $ putStrLn "a956" +a957 :: IO (); a957 = forever $ putStrLn "a957" +a958 :: IO (); a958 = forever $ putStrLn "a958" +a959 :: IO (); a959 = forever $ putStrLn "a959" +a960 :: IO (); a960 = forever $ putStrLn "a960" +a961 :: IO (); a961 = forever $ putStrLn "a961" +a962 :: IO (); a962 = forever $ putStrLn "a962" +a963 :: IO (); a963 = forever $ putStrLn "a963" +a964 :: IO (); a964 = forever $ putStrLn "a964" +a965 :: IO (); a965 = forever $ putStrLn "a965" +a966 :: IO (); a966 = forever $ putStrLn "a966" +a967 :: IO (); a967 = forever $ putStrLn "a967" +a968 :: IO (); a968 = forever $ putStrLn "a968" +a969 :: IO (); a969 = forever $ putStrLn "a969" +a970 :: IO (); a970 = forever $ putStrLn "a970" +a971 :: IO (); a971 = forever $ putStrLn "a971" +a972 :: IO (); a972 = forever $ putStrLn "a972" +a973 :: IO (); a973 = forever $ putStrLn "a973" +a974 :: IO (); a974 = forever $ putStrLn "a974" +a975 :: IO (); a975 = forever $ putStrLn "a975" +a976 :: IO (); a976 = forever $ putStrLn "a976" +a977 :: IO (); a977 = forever $ putStrLn "a977" +a978 :: IO (); a978 = forever $ putStrLn "a978" +a979 :: IO (); a979 = forever $ putStrLn "a979" +a980 :: IO (); a980 = forever $ putStrLn "a980" +a981 :: IO (); a981 = forever $ putStrLn "a981" +a982 :: IO (); a982 = forever $ putStrLn "a982" +a983 :: IO (); a983 = forever $ putStrLn "a983" +a984 :: IO (); a984 = forever $ putStrLn "a984" +a985 :: IO (); a985 = forever $ putStrLn "a985" +a986 :: IO (); a986 = forever $ putStrLn "a986" +a987 :: IO (); a987 = forever $ putStrLn "a987" +a988 :: IO (); a988 = forever $ putStrLn "a988" +a989 :: IO (); a989 = forever $ putStrLn "a989" +a990 :: IO (); a990 = forever $ putStrLn "a990" +a991 :: IO (); a991 = forever $ putStrLn "a991" +a992 :: IO (); a992 = forever $ putStrLn "a992" +a993 :: IO (); a993 = forever $ putStrLn "a993" +a994 :: IO (); a994 = forever $ putStrLn "a994" +a995 :: IO (); a995 = forever $ putStrLn "a995" +a996 :: IO (); a996 = forever $ putStrLn "a996" +a997 :: IO (); a997 = forever $ putStrLn "a997" +a998 :: IO (); a998 = forever $ putStrLn "a998" +a999 :: IO (); a999 = forever $ putStrLn "a999" +a1000 :: IO (); a1000 = forever $ putStrLn "a1000" diff --git a/tests/examples/ghc80/T10384.hs b/tests/examples/ghc80/T10384.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10384.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TemplateHaskell, RankNTypes, ScopedTypeVariables #-} +module A where +x = \(y :: forall a. a -> a) -> [|| y ||] diff --git a/tests/examples/ghc80/T10390.hs b/tests/examples/ghc80/T10390.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10390.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE RankNTypes #-} + +module T10390 where + +class ApPair r where + apPair :: (forall a . (ApPair a, Num a) => Maybe a) -> Maybe r + +instance (ApPair a, ApPair b) => ApPair (a,b) where + apPair = apPair' + +apPair' :: (ApPair b, ApPair c) + => (forall a . (Num a, ApPair a) => Maybe a) -> Maybe (b,c) + -- NB constraints in a different order to apPair +apPair' f = let (Just a) = apPair f + (Just b) = apPair f + in Just $ (a, b) diff --git a/tests/examples/ghc80/T10398.hs b/tests/examples/ghc80/T10398.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10398.hs @@ -0,0 +1,25 @@ +module Foo +( + -- The reference to chunk2 should show up in the -ddump-parsed output. + -- $chunk1 + -- $chunk2 + foo, + -- $chunk3 + bar +) +where + +{- $chunk1 +This is chunk 1. +-} + +{- $chunk2 +This is chunk 2. +-} + +{- $chunk3 +This is chunk 3. +-} + +foo = 3 +bar = 7 diff --git a/tests/examples/ghc80/T10403.hs b/tests/examples/ghc80/T10403.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10403.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -fdefer-type-errors #-} +module T10403 where + +data I a = I a +instance Functor I where + fmap f (I a) = I (f a) + +newtype B t a = B a +instance Functor (B t) where + fmap f (B a) = B (f a) + +newtype H f = H (f ()) + +h1 :: _ => _ +-- h :: Functor m => (a -> b) -> m a -> H m +h1 f b = (H . fmap (const ())) (fmap f b) + +h2 :: _ +-- h2 :: Functor m => (a -> b) -> m a -> H m +h2 f b = (H . fmap (const ())) (fmap f b) + +app1 :: H (B t) +app1 = h1 (H . I) (B ()) + +app2 :: H (B t) +app2 = h2 (H . I) (B ()) diff --git a/tests/examples/ghc80/T10414.hs b/tests/examples/ghc80/T10414.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10414.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +import GHC.Exts +newtype Eval a = Eval {runEval :: State# RealWorld -> (# State# RealWorld, a #)} + +-- inline sequence :: [Eval a] -> Eval [a] +well_sequenced :: [Eval a] -> Eval [a] +well_sequenced = foldr cons nil where + cons e es = Eval $ \s -> case runEval e s of + (# s', a #) -> case runEval es s' of + (# s'', as #) -> (# s'', a : as #) + nil = Eval $ \s -> (# s, [] #) + +-- seemingly demonic use of spark# +ill_sequenced :: [Eval a] -> Eval [a] +ill_sequenced as = Eval $ spark# (case well_sequenced as of + Eval f -> case f realWorld# of (# _, a' #) -> a') + +-- 'parallelized' version of (show >=> show >=> show >=> show >=> show) +main :: IO () +main = putStrLn ((layer . layer . layer . layer . layer) (:[]) 'y') + where + layer :: (Char -> String) -> (Char -> String) + layer f = (\(Eval x) -> case x realWorld# of (# _, as #) -> concat as) + . well_sequenced -- [Eval String] -> Eval [String] + . map ill_sequenced -- [[Eval Char]] -> [Eval String]; + -- 'map well_sequenced' is fine + . map (map (\x -> Eval $ \s -> (# s, x #))) -- wrap each Char in Eval + . chunk' -- String -> [String] + . concatMap f + . show -- add single quotes + + chunk' :: String -> [String] + chunk' [] = [] + chunk' xs = as : chunk' bs where (as,bs) = splitAt 3 xs + + -- this doesn't work: + -- chunk (a:b:c:xs) = [a,b,c]:chunk xs + -- chunk xs = [xs] diff --git a/tests/examples/ghc80/T10420.hs b/tests/examples/ghc80/T10420.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10420.hs @@ -0,0 +1,10 @@ +module Main where + +import T10420a + +import RuleDefiningPlugin + +{-# NOINLINE x #-} +x = "foo" + +main = putStrLn (show x) diff --git a/tests/examples/ghc80/T10420a.hs b/tests/examples/ghc80/T10420a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10420a.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -fplugin RuleDefiningPlugin #-} +module T10420a where diff --git a/tests/examples/ghc80/T10423.hs b/tests/examples/ghc80/T10423.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10423.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleInstances, TypeFamilies, MultiParamTypeClasses #-} + +module T10423 where + +class Monad m => Testable m a + +newtype Prop m = MkProp (m Int) + +instance (Monad m, m ~ n) => Testable n (Prop m) diff --git a/tests/examples/ghc80/T10428.hs b/tests/examples/ghc80/T10428.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10428.hs @@ -0,0 +1,5 @@ +module T10428 where + +import Data.Coerce +coerceNewtype :: (Coercible (o r) (n m' r)) => [o r] -> [n m' r] +coerceNewtype = coerce diff --git a/tests/examples/ghc80/T10438.hs b/tests/examples/ghc80/T10438.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10438.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TypeFamilies #-} +module T10438 where + +foo f = g + where g r = x + where x :: _ + x = r diff --git a/tests/examples/ghc80/T10447.hs b/tests/examples/ghc80/T10447.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10447.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveFoldable, GADTs, StandaloneDeriving #-} +module Main where + +class (a ~ Int) => Foo a +instance Foo Int + +data A a where + A1 :: Ord a => a -> A a + A2 :: Int -> A Int + A3 :: b ~ Int => b -> A Int + A4 :: a ~ Int => Int -> A a + A5 :: a ~ Int => a -> A a + A6 :: (a ~ b, b ~ Int) => Int -> b -> A a + A7 :: Foo a => Int -> a -> A a + +deriving instance Foldable A + +data HK f a where + HK1 :: f a -> HK f (f a) + HK2 :: f a -> HK f a + +deriving instance Foldable f => Foldable (HK f) + +one :: Int +one = 1 + +main :: IO () +main = do + mapM_ (print . foldr (+) one) + [ A1 one + , A2 one + , A3 one + , A4 one + , A5 one + , A6 one one + , A7 one one + ] + mapM_ (print . foldr mappend Nothing) + [ HK1 (Just "Hello") + , HK2 (Just (Just "World")) + ] diff --git a/tests/examples/ghc80/T10451.hs b/tests/examples/ghc80/T10451.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10451.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ConstraintKinds #-} + +module T10451 where + +type S a = ( Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a ) + +type T a = ( Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a + , Eq a, Eq a, Eq a, Eq a) + diff --git a/tests/examples/ghc80/T10460.hs b/tests/examples/ghc80/T10460.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10460.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GHCForeignImportPrim #-} +module T10460 where +import GHC.Exts +-- don't link me! +foreign import prim "f" f :: Any -> Any diff --git a/tests/examples/ghc80/T10461.hs b/tests/examples/ghc80/T10461.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10461.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE MagicHash, GHCForeignImportPrim #-} + +module T10461 where +import GHC.Exts + +foreign import prim cheneycopy :: Any -> Word# diff --git a/tests/examples/ghc80/T10463.hs b/tests/examples/ghc80/T10463.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10463.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables, PartialTypeSignatures #-} + +module T10463 where + +f (x :: _) = x ++ "" diff --git a/tests/examples/ghc80/T10481.hs b/tests/examples/ghc80/T10481.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10481.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts +import Control.Exception + +f :: ArithException -> Int# +f x = raise# (toException x) + +main = print (I# (f Overflow)) diff --git a/tests/examples/ghc80/T10482.hs b/tests/examples/ghc80/T10482.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10482.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +module T10482 where + +data family Foo a +data instance Foo (a, b) = FooPair !(Foo a) !(Foo b) +newtype instance Foo Int = Foo Int + +foo :: Foo ((Int, Int), Int) -> Int -> Int +foo !f k = + if k == 0 then 0 + else if even k then foo f (k-1) + else case f of + FooPair (FooPair (Foo n) _) _ -> n diff --git a/tests/examples/ghc80/T10482a.hs b/tests/examples/ghc80/T10482a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10482a.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} + -- Makes f2 a bit more challenging + +-- Tests inspired by Note [CPR examples] in DmdAnal, and Trac #10482 + +module Foo where + + +h :: Int -> Int -> Bool +h 0 y = y>0 +h n y = h (n-1) y + +-- The main point: all of these functions can have the CPR property + +------- f1 ----------- +-- x is used strictly by h, so it'll be available +-- unboxed before it is returned in the True branch + +f1 :: Int -> Int +f1 x = case h x x of + True -> x + False -> f1 (x-1) + + +------- f2 ----------- +-- x is a strict field of MkT2, so we'll pass it unboxed +-- to $wf2, so it's available unboxed. This depends on +-- the case expression analysing (a subcomponent of) one +-- of the original arguments to the function, so it's +-- a bit more delicate. + +data T2 = MkT2 !Int Int + +f2 :: T2 -> Int +f2 (MkT2 x y) | y>0 = f2 (MkT2 x (y-1)) + | y>1 = 1 + | otherwise = x + + +------- f3 ----------- +-- h is strict in x, so x will be unboxed before it +-- is rerturned in the otherwise case. + +data T3 = MkT3 Int Int + +f3 :: T3 -> Int +f3 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) + | otherwise = x + + +------- f4 ----------- +-- Just like f2, but MkT4 can't unbox its strict +-- argument automatically, as f2 can + +data family Foo a +newtype instance Foo Int = Foo Int + +data T4 a = MkT4 !(Foo a) Int + +f4 :: T4 Int -> Int +f4 (MkT4 x@(Foo v) y) | y>0 = f4 (MkT4 x (y-1)) + | otherwise = v diff --git a/tests/examples/ghc80/T10487.hs b/tests/examples/ghc80/T10487.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10487.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-} + +module T10487 where + +import GHC.Generics + +import qualified T10487_M as M + +data Name = Name + +deriving instance Generic Name +deriving instance Generic M.Name diff --git a/tests/examples/ghc80/T10487_M.hs b/tests/examples/ghc80/T10487_M.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10487_M.hs @@ -0,0 +1,3 @@ +module T10487_M where + +data Name = Name diff --git a/tests/examples/ghc80/T10489.hs b/tests/examples/ghc80/T10489.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10489.hs @@ -0,0 +1,4 @@ +module T10489 where + +-- Triggered an ASSERT in a debug build at some point. +convert d = let d' = case d of '0' -> '!' in d' diff --git a/tests/examples/ghc80/T10493.hs b/tests/examples/ghc80/T10493.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10493.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleContexts #-} + +module T10493 where + +import Data.Coerce +import Data.Ord (Down) -- no constructor + +foo :: Coercible (Down Int) Int => Down Int -> Int +foo = coerce diff --git a/tests/examples/ghc80/T10494.hs b/tests/examples/ghc80/T10494.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10494.hs @@ -0,0 +1,6 @@ +module App where + +import Data.Coerce + +foo :: Coercible (a b) (c d) => a b -> c d +foo = coerce diff --git a/tests/examples/ghc80/T10495.hs b/tests/examples/ghc80/T10495.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10495.hs @@ -0,0 +1,5 @@ +module T10495 where + +import Data.Coerce + +foo = coerce diff --git a/tests/examples/ghc80/T10503.hs b/tests/examples/ghc80/T10503.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10503.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE RankNTypes, PolyKinds, DataKinds, TypeFamilies #-} +module GHCBug where + +data Proxy p = Proxy + +data KProxy (a :: *) = KProxy + +h :: forall r . (Proxy ('KProxy :: KProxy k) ~ Proxy ('KProxy :: KProxy *) => r) -> r +h = undefined diff --git a/tests/examples/ghc80/T10507.hs b/tests/examples/ghc80/T10507.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10507.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +module T10507 where + +import Data.Type.Equality ( (:~:)(Refl) ) +import Prelude (Maybe(..), undefined) +import GHC.TypeLits ( Nat, type (<=)) + +data V (n::Nat) + +testEq :: (m <= n) => V m -> V n -> Maybe (m :~: n) +testEq = undefined + + +uext :: (1 <= m, m <= n) => V m -> V n -> V n +uext e w = + case testEq e w of + Just Refl -> e diff --git a/tests/examples/ghc80/T10508_api.hs b/tests/examples/ghc80/T10508_api.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10508_api.hs @@ -0,0 +1,32 @@ +module Main where + +import DynFlags +import GHC + +import Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import System.Environment (getArgs) + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags $ dflags + `gopt_unset` Opt_ImplicitImportQualified + `xopt_unset` Opt_ImplicitPrelude + + forM_ exprs $ \expr -> + handleSourceError printException $ do + dyn <- dynCompileExpr expr + liftIO $ print dyn + where + exprs = + [ "" + , "(),()" + , "()" + , "\"test\"" + , unlines [ "[()]" + , " :: [()]" + ] + ] diff --git a/tests/examples/ghc80/T10516.hs b/tests/examples/ghc80/T10516.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10516.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PolyKinds #-} +module T10516 where + +type App f a = f a + +newtype X f a = X (f a) + +f :: f a -> X (App f) a +f = X diff --git a/tests/examples/ghc80/T10519.hs b/tests/examples/ghc80/T10519.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10519.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE PartialTypeSignatures #-} +module T10519 where + +foo :: forall a. _ => a -> a -> Bool +foo x y = x == y diff --git a/tests/examples/ghc80/T10521.hs b/tests/examples/ghc80/T10521.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10521.hs @@ -0,0 +1,11 @@ +import Data.Word( Word8 ) + +toV :: Float -> Word8 +toV d = let coeff = significand d * 255.9999 / d + a = truncate $ d * coeff + b = exponent d + in a `seq` (b `seq` a) + +main :: IO () +main = + print $ map toV [ 3.56158e-2, 0.7415215, 0.5383201, 0.1289829, 0.45520145 ] diff --git a/tests/examples/ghc80/T10521b.hs b/tests/examples/ghc80/T10521b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10521b.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Exts + +f :: Float# -> Float# +f x = x +{-# NOINLINE f #-} + +g :: Double# -> Double# +g x = x +{-# NOINLINE g #-} + +h :: Float -> Float +h (F# x) = let a = F# (f x) + b = D# (g (2.0##)) + in a `seq` (b `seq` a) + +main = print (h 1.0) diff --git a/tests/examples/ghc80/T10524.hs b/tests/examples/ghc80/T10524.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10524.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +module T10524 where + +import Data.Data + +newtype WrappedFunctor f a = WrapFunctor (f a) deriving (Data, Typeable) + +-- WrappedFunctor :: forall k. (k -> *) -> k -> * diff --git a/tests/examples/ghc80/T10534.hs b/tests/examples/ghc80/T10534.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10534.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies #-} + +module T10534 where + +import T10534a + +newtype instance DF a = MkDF () + +unsafeCoerce :: a -> b +unsafeCoerce = silly diff --git a/tests/examples/ghc80/T10534a.hs b/tests/examples/ghc80/T10534a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10534a.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} + +module T10534a where + +import Data.Coerce + +data family DF a + +silly :: Coercible (DF a) (DF b) => a -> b +silly = coerce diff --git a/tests/examples/ghc80/T10549.hs b/tests/examples/ghc80/T10549.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10549.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -O2 #-} + +-- Verify that -O2 is rejected when this module is loaded by GHCi +module T10549 where + +import qualified Data.ByteString.Internal as Internal +import System.IO.Unsafe (unsafePerformIO) +import Data.Word (Word8) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peek) + +type S = Ptr Word8 + +chr :: S -> Char +chr x = Internal.w2c $ unsafePerformIO $ peek x diff --git a/tests/examples/ghc80/T10549a.hs b/tests/examples/ghc80/T10549a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10549a.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -O #-} +module Main(main) where +import GHC.Exts +main = print 1 +go (Ptr a) = a diff --git a/tests/examples/ghc80/T10561.hs b/tests/examples/ghc80/T10561.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10561.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE PolyKinds, DeriveFunctor, RankNTypes #-} + +module T10561 where + +-- Ultimately this should "Just Work", +-- but in GHC 7.10 it gave a Lint failure +-- For now (HEAD, Jun 2015) it gives a kind error message, +-- which is better than a crash + +newtype Compose f g a = Compose (f (g a)) deriving Functor + +{- +instance forall (f_ant :: k_ans -> *) + (g_anu :: * -> k_ans). + (Functor f_ant, Functor g_anu) => + Functor (Compose f_ant g_anu) where + fmap f_anv (T10561.Compose a1_anw) + = Compose (fmap (fmap f_anv) a1_anw) +-} diff --git a/tests/examples/ghc80/T10562.hs b/tests/examples/ghc80/T10562.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10562.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs, TypeFamilies #-} +module T10562 where + +type family Flip a + +data QueryRep qtyp a where + QAtom :: a -> QueryRep () a + QOp :: QueryRep (Flip qtyp) a -> QueryRep qtyp a + +instance Eq (QueryRep qtyp a) where + (==) = error "urk" + +instance (Ord a) => Ord (QueryRep qtyp a) where + compare (QOp a) (QOp b) = a `compare` b diff --git a/tests/examples/ghc80/T10564.hs b/tests/examples/ghc80/T10564.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10564.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances, + DataKinds, TypeFamilies, KindSignatures, PolyKinds, FunctionalDependencies #-} + +module T10564 where + +class HasFieldM (l :: k) r (v :: Maybe *) + | l r -> v + +class HasFieldM1 (b :: Maybe [*]) (l :: k) r v + | b l r -> v + +class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) + | e1 l -> r + +data Label a +type family LabelsOf (a :: [*]) :: [*] + +instance (HMemberM (Label (l::k)) (LabelsOf xs) b, + HasFieldM1 b l (r xs) v) + => HasFieldM l (r xs) v where diff --git a/tests/examples/ghc80/T10570.hs b/tests/examples/ghc80/T10570.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10570.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE FunctionalDependencies, PolyKinds, FlexibleInstances #-} + +module T10570 where + +import Data.Proxy + +class ConsByIdx2 x a m cls | x -> m where + consByIdx2 :: x -> a -> m cls + +instance ConsByIdx2 Int a Proxy cls where + consByIdx2 _ _ = Proxy diff --git a/tests/examples/ghc80/T10590.hs b/tests/examples/ghc80/T10590.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10590.hs @@ -0,0 +1,37 @@ +import Foreign.C +import Foreign.Marshal.Array +import Foreign.Storable +import Control.Concurrent + +-- The test works only on UNIX like. +-- unportable bits: +import qualified System.Posix.Internals as SPI +import qualified System.Posix.Types as SPT + +pipe :: IO (CInt, CInt) +pipe = allocaArray 2 $ \fds -> do + throwErrnoIfMinus1_ "pipe" $ SPI.c_pipe fds + rd <- peekElemOff fds 0 + wr <- peekElemOff fds 1 + return (rd, wr) + +main :: IO () +main = do + (r1, w1) <- pipe + (r2, _w2) <- pipe + _ <- forkIO $ do -- thread A + threadWaitRead (SPT.Fd r1) + _ <- forkIO $ do -- thread B + threadWaitRead (SPT.Fd r2) + yield -- switch to A, then B + -- now both are blocked + _ <- SPI.c_close w1 -- unblocking thread A fd + _ <- SPI.c_close r2 -- breaking thread B fd + yield -- kick RTS IO manager + +{- + Trac #10590 exposed a bug as: + T10590: internal error: removeThreadFromDeQueue: not found + (GHC version 7.11.20150702 for x86_64_unknown_linux) + Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug + -} diff --git a/tests/examples/ghc80/T10596.hs b/tests/examples/ghc80/T10596.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10596.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +module T10596 where +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import System.IO + +do + putQ (100 :: Int) + x <- (getQ :: Q (Maybe Int)) + + -- It should print "Just 100" + runIO $ print x + runIO $ hFlush stdout + return [] diff --git a/tests/examples/ghc80/T10602.hs b/tests/examples/ghc80/T10602.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10602.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -O2 #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- {-# OPTIONS_GHC -fno-spec-constr #-} -- Makes the problem go away. +-- {-# OPTIONS_GHC -fspec-constr-count=1 #-} -- Makes the problem go away. + +module T10602 where + +-- Copy-pasting T10602b.hs into the current module makes the problem go away. +import T10602b + +data PairS a = PairS a a + +-- Removing the '~' makes the problem go away. +(PairS _ _) >> ~(PairS b g) = PairS b g + +class Binary t where + put :: t -> PairS () + +-- Not using a newtype makes the problem go away. +newtype A a = A [a] + +instance Binary a => Binary (A a) where + put (A xs) = case splitAt 254 xs of + (_, []) -> foldr (>>) (PairS () ()) (map put xs) + (_, b) -> put (A b) diff --git a/tests/examples/ghc80/T10602b.hs b/tests/examples/ghc80/T10602b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10602b.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -O2 #-} +{-# LANGUAGE NoImplicitPrelude #-} +module T10602b (splitAt, map, foldr) where + +import GHC.Classes +import GHC.Types +import GHC.Num +import GHC.Base + +splitAt :: Int -> [a] -> ([a],[a]) +splitAt n ls + | n <= 0 = ([], ls) + | otherwise = splitAt' n ls + where + splitAt' :: Int -> [a] -> ([a], [a]) + splitAt' _ [] = ([], []) + splitAt' 1 (x:xs) = ([x], xs) + splitAt' m (x:xs) = (x:xs', xs'') + where + (xs', xs'') = splitAt' (m - 1) xs diff --git a/tests/examples/ghc80/T10615.hs b/tests/examples/ghc80/T10615.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10615.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes #-} +module T10615 where + +f1 :: _ -> f +f1 = const + +f2 :: _ -> _f +f2 = const diff --git a/tests/examples/ghc80/T10618.hs b/tests/examples/ghc80/T10618.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10618.hs @@ -0,0 +1,3 @@ +module T10618 where + +foo = Just $ Nothing <> Nothing diff --git a/tests/examples/ghc80/T10620.hs b/tests/examples/ghc80/T10620.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10620.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash, TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +main :: IO () +main = do + putStrLn $([| 'a'# |] >>= stringE . show) + putStrLn $([| "abc"# |] >>= stringE . show) diff --git a/tests/examples/ghc80/T10627.hs b/tests/examples/ghc80/T10627.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10627.hs @@ -0,0 +1,17 @@ +-- Made GHC 6.10.2 go into a loop in substRecBndrs +{-# OPTIONS_GHC -w #-} + +module T10627 where + +import Data.Word + +class C a where + splitFraction :: a -> (b,a) + +roundSimple :: (C a) => a -> b +roundSimple x = error "rik" + +{-# RULES + "rs" roundSimple = (fromIntegral :: Int -> Word) . roundSimple; + #-} + diff --git a/tests/examples/ghc80/T10632.hs b/tests/examples/ghc80/T10632.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10632.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ImplicitParams #-} + +f :: (?file1 :: String) => IO () +f = putStrLn $ "f2: " + +main :: IO () +main = let ?file1 = "A" in f diff --git a/tests/examples/ghc80/T10634.hs b/tests/examples/ghc80/T10634.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10634.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeFamilies #-} +module T10634 where + +import Data.Int (Int8, Int16, Int32) + +type family Up a +type instance Up Int8 = Int16 +type instance Up Int16 = Int32 + +class (Up (Down a) ~ a) => Convert a where + type Down a + down :: a -> Down a + +instance Convert Int16 where + type Down Int16 = Int8 + down = fromIntegral + +instance Convert Int32 where + type Down Int32 = Int16 + down = fromIntegral + +x :: Int8 +x = down 8 diff --git a/tests/examples/ghc80/T10637.hs b/tests/examples/ghc80/T10637.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10637.hs @@ -0,0 +1,4 @@ +module T10637 where + +import {-# SOURCE #-} A () +data B = B diff --git a/tests/examples/ghc80/T10638.hs b/tests/examples/ghc80/T10638.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10638.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-} + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import GHC.Exts + +{- + the prim and javascript calling conventions do not support + headers and the static keyword. +-} + +-- check that quasiquoting roundtrips succesfully and that the declaration +-- does not include the static keyword +test1 :: String +test1 = $(do (ds@[ForeignD (ImportF _ _ p _ _)]) <- + [d| foreign import prim "test1" cmm_test1 :: Int# -> Int# |] + addTopDecls ds + case p of + "test1" -> return (LitE . stringL $ p) + _ -> error $ "unexpected value: " ++ show p + ) + +-- check that constructed prim imports with the static keyword are rejected +test2 :: String +test2 = $(do t <- [t| Int# -> Int# |] + cmm_test2 <- newName "cmm_test2" + addTopDecls + [ForeignD (ImportF Prim Safe "static test2" cmm_test2 t)] + [| test1 |] + ) diff --git a/tests/examples/ghc80/T10642.hs b/tests/examples/ghc80/T10642.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10642.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeFamilies #-} +module T10642 where + +import Data.Coerce + +type family F a + +newtype D a = D (F a) + +-- | This works on 7.10.1, but fails on HEAD (20150711) +coerceD :: F a -> D a +coerceD = coerce diff --git a/tests/examples/ghc80/T10662.hs b/tests/examples/ghc80/T10662.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10662.hs @@ -0,0 +1,4 @@ +main :: IO () +main = do + return $ let a = "hello" in a + return () diff --git a/tests/examples/ghc80/T10667.hs b/tests/examples/ghc80/T10667.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10667.hs @@ -0,0 +1,6 @@ +module A where + +-- when used with '-g' debug generation option +-- '*/*' leaked into a /* comment */ and broke +-- GNU as. +x */* y = 42 diff --git a/tests/examples/ghc80/T10668.hs b/tests/examples/ghc80/T10668.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10668.hs @@ -0,0 +1,3 @@ +module T10668 where + +import Data.Type.Equality(Refl) diff --git a/tests/examples/ghc80/T10670.hs b/tests/examples/ghc80/T10670.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10670.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ScopedTypeVariables, RankNTypes, GADTs, PolyKinds #-} + +module T10670 where + +import Unsafe.Coerce + +data TypeRepT (a::k) where + TRCon :: TypeRepT a + +data G2 c a where + G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b) + +getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a) +{-# NOINLINE getT2 #-} +getT2 c t = Nothing + +tyRepTArr :: TypeRepT (->) +{-# NOINLINE tyRepTArr #-} +tyRepTArr = TRCon + +s :: forall a x. TypeRepT (a :: *) -> Maybe x +s tf = case getT2 tyRepTArr tf :: Maybe (G2 (->) a) of + Just (G2 _ _) -> Nothing + _ -> Nothing diff --git a/tests/examples/ghc80/T10670a.hs b/tests/examples/ghc80/T10670a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10670a.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GADTs , PolyKinds #-} + +module Bug2 where + +import Unsafe.Coerce + +data TyConT (a::k) = TyConT String + +eqTyConT :: TyConT a -> TyConT b -> Bool +eqTyConT (TyConT a) (TyConT b) = a == b + + + +tyConTArr :: TyConT (->) +tyConTArr = TyConT "(->)" + + +data TypeRepT (a::k) where + TRCon :: TyConT a -> TypeRepT a + TRApp :: TypeRepT a -> TypeRepT b -> TypeRepT (a b) + + +data GetAppT a where + GA :: TypeRepT a -> TypeRepT b -> GetAppT (a b) + +getAppT :: TypeRepT a -> Maybe (GetAppT a) +getAppT (TRApp a b) = Just $ GA a b +getAppT _ = Nothing + + + +eqTT :: TypeRepT (a::k1) -> TypeRepT (b::k2) -> Bool +eqTT (TRCon a) (TRCon b) = eqTyConT a b +eqTT (TRApp c a) (TRApp d b) = eqTT c d && eqTT a b +eqTT _ _ = False + + +data G2 c a where + G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b) + + +getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a) +getT2 c t = do GA t' b <- getAppT t + GA c' a <- getAppT t' + if eqTT c c' + then Just (unsafeCoerce $ G2 a b :: G2 c a) + else Nothing + +tyRepTArr :: TypeRepT (->) +tyRepTArr = TRCon tyConTArr + +s tf = case getT2 tyRepTArr tf + of Just (G2 _ _) -> Nothing + _ -> Nothing diff --git a/tests/examples/ghc80/T10678.hs b/tests/examples/ghc80/T10678.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10678.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Prim + +main :: IO () +main = go 1000000# 10 (2^100) + +go :: Int# -> Integer -> Integer -> IO () +go 0# _ _ = return () +go n# a b = (a + b) `seq` go (n# -# 1#) a b +{-# NOINLINE go #-} + +{- +This test is based on a strategy from rwbarton relying on the inefficiency +of `Integer` addition as defined by `integer-gmp` without `runRW#`. + + When I was testing the patch interactively, I measured allocations for, + say, a million (large Integer) + (small Integer) additions. If that + addition allocates, say, 6 words, then one can fairly reliably write the + program so that it will allocate between 6 million and 7 million words, + total. +-} diff --git a/tests/examples/ghc80/T10689.hs b/tests/examples/ghc80/T10689.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10689.hs @@ -0,0 +1,11 @@ +module T10694 where + +f :: Eq a => a -> Bool +{-# NOINLINE f #-} +f x = x==x + +type Foo a b = b + +{-# RULES "foo" forall (x :: Foo a Char). f x = True #-} + +finkle = f 'c' diff --git a/tests/examples/ghc80/T10689a.hs b/tests/examples/ghc80/T10689a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10689a.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE TypeOperators + , DataKinds + , PolyKinds + , TypeFamilies + , GADTs + , UndecidableInstances + , RankNTypes + , ScopedTypeVariables + #-} + +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Werror #-} +{-# OPTIONS_GHC -O1 -fspec-constr #-} + +{- +ghc-stage2: panic! (the 'impossible' happened) + (GHC version 7.11.20150723 for x86_64-unknown-linux): + Template variable unbound in rewrite rule +-} + +module List (sFoldr1) where + +data Proxy t + +data family Sing (a :: k) + +data TyFun (a :: *) (b :: *) + +type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2 + +data instance Sing (f :: TyFun k1 k2 -> *) = + SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } + +type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) + +type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) +singFun2 :: Proxy f -> SingFunction2 f -> Sing f +singFun2 _ f = SLambda (\x -> SLambda (f x)) + +data (:$$) (j :: a) (i :: TyFun [a] [a]) +type instance Apply ((:$$) j) i = (:) j i + +data (:$) (l :: TyFun a (TyFun [a] [a] -> *)) +type instance Apply (:$) l = (:$$) l +data instance Sing (z :: [a]) + = z ~ '[] => + SNil + | forall (m :: a) + (n :: [a]). z ~ (:) m n => + SCons (Sing m) (Sing n) + +data ErrorSym0 (t1 :: TyFun k1 k2) + +type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh + +type Let1627448493Xs f_afe9 + x_afea + wild_1627448474_afeb + wild_1627448476_afec = + Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec +type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) + -> *) + (t_afdZ :: [a_afdP]) = + Foldr1 t_afdY t_afdZ +data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) + -> *) + (l_afe2 :: TyFun [a_afdP] a_afdP) +type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 + +data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP + -> *) + -> *) (TyFun [a_afdP] a_afdP -> *)) +type instance Apply Foldr1Sym0 l = Foldr1Sym1 l + +type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP + -> *) + -> *) + (a_afe6 :: [a_afdP]) :: a_afdP where + Foldr1 z_afe7 '[x_afe8] = x_afe8 + Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) + Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" + +sFoldr1 :: + forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) + (y :: [a_afdP]). + Sing x + -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) +sFoldr1 _ (SCons _sX SNil) = undefined +sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) + = let + lambda_afeC :: + forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. + Sing f_afe9 + -> Sing x_afea + -> Sing wild_1627448474_afeb + -> Sing wild_1627448476_afec + -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) + lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG + = let + sXs :: + Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) + sXs + = applySing + (applySing + (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) + wild_1627448476_afeG + in + applySing + (applySing f_afeD x_afeE) + (applySing + (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) + sXs) + in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 +sFoldr1 _ SNil = undefined diff --git a/tests/examples/ghc80/T10694.hs b/tests/examples/ghc80/T10694.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10694.hs @@ -0,0 +1,16 @@ +module T10694 where + +-- The point here is that 'm' should NOT have the CPR property +-- Checked by grepping in the -ddump-simpl + + +-- Some nonsense so that the simplifier can't see through +-- to the I# constructor +pm :: Int -> Int -> (Int, Int) +pm x y = (l !! 0, l !! 1) + where l = [x+y, x-y] +{-# NOINLINE pm #-} + +m :: Int -> Int -> Int +m x y = case pm x y of + (pr, mr) -> mr diff --git a/tests/examples/ghc80/T10698.hs b/tests/examples/ghc80/T10698.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10698.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE RoleAnnotations #-} + +module T10698 where +import Data.Coerce + +data Map k a = Map k a +type role Map nominal representational + +map1 :: (k1->k2) -> Map k1 a -> Map k2 a +map1 f (Map a b) = Map (f a) b +{-# NOINLINE [1] map1 #-} +{-# RULES +"map1/coerce" map1 coerce = coerce + #-} + + +map2 :: (a -> b) -> Map k a -> Map k b +map2 f (Map a b) = Map a (f b) +{-# NOINLINE [1] map2 #-} + +{-# RULES +"map2/coerce" map2 coerce = coerce + #-} diff --git a/tests/examples/ghc80/T10704.hs b/tests/examples/ghc80/T10704.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10704.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE MagicHash, TemplateHaskell #-} +module Main where + +import GHC.Exts +import T10704a + +main :: IO () +main = do + putStrLn $(fixityExp ''(->)) + putStrLn $(fixityExp ''Show) + putStrLn $(fixityExp 'show) + putStrLn $(fixityExp '(+)) + putStrLn $(fixityExp ''Int) + putStrLn $(fixityExp ''Item) + putStrLn $(fixityExp ''Char#) + putStrLn $(fixityExp 'Just) + putStrLn $(fixityExp 'seq) + putStrLn $(fixityExp '($)) + putStrLn $(fixityExp ''(:=>)) + putStrLn $(fixityExp ''(:+:)) + putStrLn $(fixityExp ''(:*:)) + putStrLn $(fixityExp ''(:%:)) + putStrLn $(fixityExp ''(:?:)) + putStrLn $(fixityExp ''(:@:)) diff --git a/tests/examples/ghc80/T10704a.hs b/tests/examples/ghc80/T10704a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10704a.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, TypeOperators #-} +module T10704a where + +import Language.Haskell.TH + +infixl 1 :=> +infixl 2 :+: +infix 3 :*: +infix 4 :%: +infixr 5 :?: +infixr 6 :@: + +class a :=> b +type a :+: b = Either a b +data a :*: b = a :*: b +newtype a :%: b = Percent (a, b) +data family a :?: b +type family a :@: b where a :@: b = Int + +fixityExp :: Name -> Q Exp +fixityExp n = reifyFixity n >>= stringE . show diff --git a/tests/examples/ghc80/T10713.hs b/tests/examples/ghc80/T10713.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10713.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies, PolyKinds, DataKinds #-} + +module T10713 where + +import Data.Proxy + +type family TEq t s where + TEq t t = 'True + TEq t s = 'False +data family T a + +foo :: Proxy (TEq (T Int) (T Bool)) -> Proxy 'False +foo = id diff --git a/tests/examples/ghc80/T10734.hs b/tests/examples/ghc80/T10734.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10734.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +main :: IO () +main = do + pprint <$> runQ [| do { let { }; return (); } |] >>= putStrLn + pprint <$> runQ [| do { let { x = 5 }; return x; } |] >>= putStrLn + pprint <$> runQ [| do { let { x = 5; y = 3 }; return x; } |] >>= putStrLn diff --git a/tests/examples/ghc80/T10742.hs b/tests/examples/ghc80/T10742.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10742.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module T10742 where + +import GHC.TypeLits + +data T a where MkT :: T Int + +test :: ((x <=? y) ~ 'True, (y <=? z) ~ 'True) + => proxy x y z -> () +test _ = case MkT of MkT -> () diff --git a/tests/examples/ghc80/T10744.hs b/tests/examples/ghc80/T10744.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10744.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE MagicHash #-} +module T10744 where + +import GHC.Exts +import GHC.Magic + +-- Checks if oneShot is open-kinded + +f0 :: Int -> Int +f0 = oneShot $ \n -> n + +f1 :: Int# -> Int +f1 = oneShot $ \n# -> I# n# + +f2 :: Int -> Int# +f2 = oneShot $ \(I# n#) -> n# + diff --git a/tests/examples/ghc80/T10747.hs b/tests/examples/ghc80/T10747.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10747.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + +module T10747 where + +pattern head `Cons` tail = head : tail diff --git a/tests/examples/ghc80/T10753.hs b/tests/examples/ghc80/T10753.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10753.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-missing-methods #-} +module T10753 where + + +class MonadState s m | m -> s where + get :: m s + +newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } +instance (Monad m) => Monad (StateT s m) where +instance (Functor m, Monad m) => Applicative (StateT s m) where +instance (Functor m) => Functor (StateT s m) where + +instance (Monad m) => MonadState s (StateT s m) where + +class HasConns (m :: * -> *) where + type Conn m + +foo :: (Monad m) => StateT (Conn m) m () +foo = + do _ <- get + return () diff --git a/tests/examples/ghc80/T10767.hs b/tests/examples/ghc80/T10767.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10767.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} + +module Main where + +{- ghc-7.8.4 and ghc-7.10.2 showed a confusing warning: + +T10767.hs:43:1: Warning: + RULE left-hand side too complicated to desugar + Optimised lhs: case cobox_aWY + of _ [Occ=Dead] { GHC.Types.Eq# cobox -> + genLength @ Int $dSpecList_aWX + } + Orig lhs: case cobox_aWY of cobox_aWY { GHC.Types.Eq# cobox -> + genLength @ Int $dSpecList_aWX + } +-} + +import Data.Proxy + +class SpecList a where + type List a :: * + + slCase :: List a -> b -> (a -> List a -> b) -> b + +data IntList + = ILNil + | ILCons {-# UNPACK #-} !Int IntList + deriving (Show) + +instance SpecList Int where + type List Int = IntList + + slCase ILNil n _ = n + slCase (ILCons i t) _ c = c i t + +fromList :: [Int] -> IntList +fromList [] = ILNil +fromList (h : t) = ILCons h (fromList t) + +lst1 :: IntList +lst1 = fromList [1..10] + +{-# SPECIALIZE genLength :: Proxy Int -> List Int -> Int #-} +genLength :: forall a . SpecList a => Proxy a -> List a -> Int +genLength p lst = slCase lst 0 (\(_ :: a) tail -> 1 + genLength p tail) + +main :: IO () +main = print (genLength (Proxy :: Proxy Int) lst1) diff --git a/tests/examples/ghc80/T10781.hs b/tests/examples/ghc80/T10781.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10781.hs @@ -0,0 +1,12 @@ +module T10781 where +{- ghc-7.10.2 reported: + +T10781.hs:6:5: + Found hole ‘_name’ with type: t + Where: ‘t’ is a rigid type variable bound by + the inferred type of f :: t at T10781.hs:6:1 + Relevant bindings include f :: t (bound at T10781.hs:6:1) + In the expression: Foo._name + In an equation for ‘f’: f = Foo._name +-} +f = Foo._name diff --git a/tests/examples/ghc80/T10796a.hs b/tests/examples/ghc80/T10796a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10796a.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +module T10796a where + +import Data.Ratio +import Data.Set (Set, fromList) +import Language.Haskell.TH.Syntax (liftData) + +-- Data instance with toConstr implemented using a variable, +-- not a data constructor +splicedSet :: Set Char +splicedSet = $(liftData (fromList "test")) + +-- Infix data constructor +splicedRatio :: Ratio Int +splicedRatio = $(liftData (1 % 2 :: Ratio Int)) diff --git a/tests/examples/ghc80/T10796b.hs b/tests/examples/ghc80/T10796b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10796b.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module T10796b where + +import Data.Set (Set, fromList) +import Language.Haskell.TH.Quote (dataToPatQ) + +badPattern :: Set Char -> Set Char +badPattern s@($(dataToPatQ (const Nothing) (fromList "test"))) = s diff --git a/tests/examples/ghc80/T10806.hs b/tests/examples/ghc80/T10806.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10806.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTs, ExplicitNamespaces, TypeOperators, DataKinds #-} + +module T10806 where + +import GHC.TypeLits (Nat, type (<=)) + +data Q a where + Q :: (a <= b, b <= c) => proxy a -> proxy b -> Q c + +triggersLoop :: Q b -> Q b -> Bool +triggersLoop (Q _ _) (Q _ _) = print 'x' 'y' diff --git a/tests/examples/ghc80/T10815.hs b/tests/examples/ghc80/T10815.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10815.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies #-} + +module T10815 where + +import Data.Proxy + +type family Any :: k + +class kproxy ~ 'KProxy => C (kproxy :: KProxy k) where + type F (a :: k) + type G a :: k + +instance C ('KProxy :: KProxy Bool) where + type F a = Int + type G a = Any diff --git a/tests/examples/ghc80/T10819.hs b/tests/examples/ghc80/T10819.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10819.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module T10819 where + +import T10819_Lib + +import Language.Haskell.TH.Syntax + +class C a b | b -> a where + f :: b -> a + +data D = X + +instance C Int D where + f X = 2 + +$(doSomeTH "N" (mkName "D") [ConT (mkName "C") `AppT` ConT (mkName "Int")]) + +thing :: N +thing = N X + +thing1 :: Int +thing1 = f thing diff --git a/tests/examples/ghc80/T10819_Lib.hs b/tests/examples/ghc80/T10819_Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10819_Lib.hs @@ -0,0 +1,7 @@ +module T10819_Lib where + +import Language.Haskell.TH.Syntax + +doSomeTH s tp drv = return [NewtypeD [] n [] Nothing (NormalC n + [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) drv] + where n = mkName s diff --git a/tests/examples/ghc80/T10820.hs b/tests/examples/ghc80/T10820.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10820.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Language.Haskell.TH.Syntax +import GHC.LanguageExtensions + +main = do + print $(isExtEnabled Cpp >>= lift) + print $(isExtEnabled LiberalTypeSynonyms >>= lift) + print $(isExtEnabled RankNTypes >>= lift) + print $(isExtEnabled TypeSynonymInstances >>= lift) + print $(isExtEnabled MagicHash >>= lift) diff --git a/tests/examples/ghc80/T10826.hs b/tests/examples/ghc80/T10826.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10826.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE Safe #-} +module Test (hook) where + +import System.IO.Unsafe + +{-# ANN hook (unsafePerformIO (putStrLn "Woops.")) #-} +hook = undefined diff --git a/tests/examples/ghc80/T10830.hs b/tests/examples/ghc80/T10830.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10830.hs @@ -0,0 +1,3 @@ +import GHC.OldList +main :: IO () +main = maximumBy compare [1..10000] `seq` return () diff --git a/tests/examples/ghc80/T10836.hs b/tests/examples/ghc80/T10836.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10836.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies #-} +module T10836 where + +type family Foo a = r | r -> a where + Foo Int = Int + Foo Bool = Int + +type family Bar a = r | r -> a where + Bar Int = Int + Bar Bool = Int diff --git a/tests/examples/ghc80/T10845.hs b/tests/examples/ghc80/T10845.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10845.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ImplicitParams #-} +{-# OPTIONS_GHC -dcore-lint #-} + +import GHC.Stack + +f1 :: (?loc :: CallStack) => CallStack +-- we can infer a CallStack for let-binders +f1 = let y x = (?loc :: CallStack) + in y 0 + +f2 :: (?loc :: CallStack) => CallStack +-- but only when we would infer an IP. +-- i.e. the monomorphism restriction prevents us +-- from inferring a CallStack. +f2 = let y = (?loc :: CallStack) + in y + +main :: IO () +main = do putStrLn $ prettyCallStack f1 + putStrLn $ prettyCallStack f2 diff --git a/tests/examples/ghc80/T10846.hs b/tests/examples/ghc80/T10846.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10846.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-} + +module Main where + +import GHC.Stack + +f1 :: (?loc :: CallStack) => String +f1 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc + +f2 :: (?loc :: CallStack) => _ +f2 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc + +f3 :: (?loc :: CallStack, _) => String +f3 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc + +main :: IO () +main = do + putStrLn f1 + putStrLn f2 + putStrLn f3 diff --git a/tests/examples/ghc80/T10870.hs b/tests/examples/ghc80/T10870.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10870.hs @@ -0,0 +1,12 @@ +import Data.Bits +import Data.Int +import Data.Word + +unsafeShift32R :: (Bits a, Num a) => a -> a +unsafeShift32R x = unsafeShiftR x 32 + +main :: IO () +main = do + print $ map unsafeShift32R [ 123456, 0x7fffffff :: Int ] + print $ map unsafeShift32R [ -123456, -0x80000000 :: Int ] + print $ map unsafeShift32R [ 123456, 0xffffffff :: Word ] diff --git a/tests/examples/ghc80/T10890.hs b/tests/examples/ghc80/T10890.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10890.hs @@ -0,0 +1,23 @@ +module Main where + +-- Previously GHC was printing this warning: +-- +-- Main.hs:5:1: Warning: +-- The import of ‘A.has’ from module ‘A’ is redundant +-- +-- Main.hs:6:1: Warning: +-- The import of ‘B.has’ from module ‘B’ is redundant + +import A (A (has)) +import B (B (has)) + +data Blah = Blah + +instance A Blah where + has = Blah + +instance B Blah where + has = Blah + +main :: IO () +main = return () diff --git a/tests/examples/ghc80/T10890_1.hs b/tests/examples/ghc80/T10890_1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10890_1.hs @@ -0,0 +1,22 @@ +module Main where + +import Base +import Extends + +-- Previously GHC was giving this false positive: +-- +-- T10890_1.hs:4:1: Warning: +-- The import of ‘Extends’ is redundant +-- except perhaps to import instances from ‘Extends’ +-- To import instances alone, use: import Extends() + +data Bar = Bar + +instance AClass Bar where + has = Bar + +instance BClass Bar where + has = Bar + +main :: IO () +main = return () diff --git a/tests/examples/ghc80/T10890_2.hs b/tests/examples/ghc80/T10890_2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10890_2.hs @@ -0,0 +1,17 @@ +module T10890_2 where + +-- Previously GHC was printing this warning: +-- +-- Main.hs:5:1: Warning: +-- The import of ‘A.has’ from module ‘A’ is redundant +-- +-- Main.hs:6:1: Warning: +-- The import of ‘B.has’ from module ‘B’ is redundant + +import T10890_2A (A (has)) +import T10890_2B (B (has)) + +data Blah = Blah + +instance A Blah where + has = Blah diff --git a/tests/examples/ghc80/T10890_2A.hs b/tests/examples/ghc80/T10890_2A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10890_2A.hs @@ -0,0 +1,4 @@ +module T10890_2A where + +class A a where + has :: a diff --git a/tests/examples/ghc80/T10890_2B.hs b/tests/examples/ghc80/T10890_2B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10890_2B.hs @@ -0,0 +1,4 @@ +module T10890_2B where + +class B a where + has :: a diff --git a/tests/examples/ghc80/T10891.hs b/tests/examples/ghc80/T10891.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10891.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} + +module T10891 where + +import Language.Haskell.TH +import System.IO + +class C a where + f :: a -> Int + +class C' a where + type F a :: * + type F a = a + f' :: a -> Int + +class C'' a where + data Fd a :: * + +instance C' Int where + type F Int = Bool + f' = id + +instance C'' Int where + data Fd Int = B Bool | C Char + +$(return []) + +test :: () +test = + $(let + display :: Name -> Q () + display q = do + i <- reify q + runIO (hPutStrLn stderr (pprint i) >> hFlush stderr) + in do + display ''C + display ''C' + display ''C'' + [| () |]) diff --git a/tests/examples/ghc80/T10895.hs b/tests/examples/ghc80/T10895.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10895.hs @@ -0,0 +1,1 @@ +module NotMain where diff --git a/tests/examples/ghc80/T10897a.hs b/tests/examples/ghc80/T10897a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10897a.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} +module T10897a where +pattern Single :: a -> a +pattern Single x = x diff --git a/tests/examples/ghc80/T10897b.hs b/tests/examples/ghc80/T10897b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10897b.hs @@ -0,0 +1,4 @@ +module B where +import T10897a + +Single y = True diff --git a/tests/examples/ghc80/T10904.hs b/tests/examples/ghc80/T10904.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10904.hs @@ -0,0 +1,28 @@ +import Control.Concurrent +import Control.Monad +import Foreign +import Foreign.C.Types +import System.Environment + + +foreign import ccall safe "finalizerlib.h init_value" + init_value :: Ptr CInt -> IO () + +foreign import ccall safe "finalizerlib.h &finalize_value" + finalize_value :: FinalizerPtr CInt + + +allocateValue :: IO () +allocateValue = do + fp <- mallocForeignPtrBytes 10000 + withForeignPtr fp init_value + addForeignPtrFinalizer finalize_value fp + + +main :: IO () +main = do + [n] <- fmap (fmap read) getArgs + _ <- forkIO (loop n) + loop n + where + loop n = replicateM_ n allocateValue diff --git a/tests/examples/ghc80/T10908.hs b/tests/examples/ghc80/T10908.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10908.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fwarn-missing-exported-sigs #-} + +module Bug (Data.List.intercalate, x) where + +import qualified Data.List + +intercalate = True + +x :: Bool +x = intercalate diff --git a/tests/examples/ghc80/T10929.hs b/tests/examples/ghc80/T10929.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10929.hs @@ -0,0 +1,31 @@ +module T10929 where + +x1 :: [Integer] +x1 = [5 .. 3] + +x2 :: [Integer] +x2 = [3 .. 5] + +x3 :: [Integer] +x3 = [5, 3 .. 1] + +x4 :: [Integer] +x4 = [5, (3+0) .. 1] + +x5 :: [Integer] +x5 = [1, 3 .. 5] + +x6 :: [Integer] +x6 = [1, (3+0) .. 5] + +x7 :: [Integer] +x7 = [5, 7 .. 1] + +x8 :: [Integer] +x8 = [5, (7+0) .. 1] + +x9 :: [Integer] +x9 = [3, 1 .. 5] + +x10 :: [Integer] +x10 = [3, (1+0) .. 5] diff --git a/tests/examples/ghc80/T10931.hs b/tests/examples/ghc80/T10931.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10931.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} + +{-# OPTIONS_GHC -Wall #-} + +module T10931 ( BugC(..) ) where + +data IdT f a = IdC (f a) + +class ( m ~ Outer m (Inner m) ) => BugC (m :: * -> *) where + type Inner m :: * -> * + type Outer m :: (* -> *) -> * -> * + + bug :: ( forall n. ( n ~ Outer n (Inner n) + , Outer n ~ Outer m + ) + => Inner n a) + -> m a + +instance BugC (IdT m) where + type Inner (IdT m) = m + type Outer (IdT m) = IdT + + bug f = IdC f diff --git a/tests/examples/ghc80/T10934.hs b/tests/examples/ghc80/T10934.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10934.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE + ScopedTypeVariables + , DataKinds + , GADTs + , RankNTypes + , TypeOperators + , PolyKinds -- Comment out PolyKinds and the bug goes away. + #-} +{-# OPTIONS_GHC -O #-} + -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it + +module KeyValue where + +data AccValidation err a = AccFailure err | AccSuccess a + +data KeyValueError = MissingValue + +type WithKeyValueError = AccValidation [KeyValueError] + +missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs +missing = rpure missingField + where + missingField :: forall x. (WithKeyValueError :. f) x + missingField = Compose $ AccFailure [MissingValue] + +data Rec :: (u -> *) -> [u] -> * where + RNil :: Rec f '[] + (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) + +newtype Compose (f :: l -> *) (g :: k -> l) (x :: k) + = Compose { getCompose :: f (g x) } + +type (:.) f g = Compose f g + +class RecApplicative rs where + rpure + :: (forall x. f x) + -> Rec f rs diff --git a/tests/examples/ghc80/T10935.hs b/tests/examples/ghc80/T10935.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10935.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -fwarn-monomorphism-restriction #-} + +module T10935 where + +f x = let y = x+1 in (y,y) diff --git a/tests/examples/ghc80/T10942.hs b/tests/examples/ghc80/T10942.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10942.hs @@ -0,0 +1,22 @@ +module Main where + +import DynFlags +import GHC + +import Control.Monad.IO.Class (liftIO) +import System.Environment +import HeaderInfo +import Outputable +import StringBuffer + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + let dflags' = dflags `gopt_set` Opt_KeepRawTokenStream + `gopt_set` Opt_Haddock + filename = "T10942_A.hs" + setSessionDynFlags dflags' + stringBuffer <- liftIO $ hGetStringBuffer filename + liftIO $ print (map unLoc (getOptions dflags' stringBuffer filename)) diff --git a/tests/examples/ghc80/T10942_A.hs b/tests/examples/ghc80/T10942_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10942_A.hs @@ -0,0 +1,16 @@ +{- + +A normal comment, to check if we can still pick up the CPP directive after it. + +-} +-- Check that we can parse a file with leading comments + +-- ^ haddock +-- * haddock +-- | haddock +-- $ haddock +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +module T10942 where + +main = return () diff --git a/tests/examples/ghc80/T10945.hs b/tests/examples/ghc80/T10945.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10945.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T10945 where + +import Language.Haskell.TH + +$$(return [ + SigD (mkName "m") + (ForallT [PlainTV (mkName "a")] + [] + (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) + , FunD (mkName "m") + [Clause [VarP (mkName "x")] (NormalB (VarE (mkName "x"))) []] + ]) diff --git a/tests/examples/ghc80/T10946.hs b/tests/examples/ghc80/T10946.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10946.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T10946 where + +import Language.Haskell.TH + +m :: a -> a +m x = $$([||_||]) diff --git a/tests/examples/ghc80/T10955dyn.hs b/tests/examples/ghc80/T10955dyn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10955dyn.hs @@ -0,0 +1,7 @@ +module Main where + +import Foreign +import Foreign.C.Types +foreign import ccall "bar" dle :: IO CInt + +main = dle >>= print diff --git a/tests/examples/ghc80/T10962.hs b/tests/examples/ghc80/T10962.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10962.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Base + +main :: IO () +main = do + -- Overflow. + let (# w1, i1 #) = subWordC# 1## 3## + print (W# w1, I# i1) + + -- No overflow. + let (# w2, i2 #) = subWordC# 3## 1## + print (W# w2, I# i2) diff --git a/tests/examples/ghc80/T10970a.hs b/tests/examples/ghc80/T10970a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10970a.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE CPP #-} +main = do +#ifndef VERSION_containers + putStrLn "OK" +#endif +#ifndef MIN_VERSION_base + putStrLn "OK" +#endif diff --git a/tests/examples/ghc80/T10971a.hs b/tests/examples/ghc80/T10971a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10971a.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-} +module T10971a where + +import Data.Traversable (fmapDefault) + +f = \x -> length x +g = \f x -> fmapDefault f x +h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/ghc80/T10971b.hs b/tests/examples/ghc80/T10971b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10971b.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE MonomorphismRestriction, NoExtendedDefaultRules #-} +module T10971b where +import Data.Traversable (fmapDefault) +f = \x -> length x +g = \f x -> fmapDefault f x +h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/ghc80/T10971c.hs b/tests/examples/ghc80/T10971c.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10971c.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-} +module T10971c where + +import Data.Traversable (fmapDefault) + +f = \x -> length x +g = \f x -> fmapDefault f x +h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/ghc80/T10971d.hs b/tests/examples/ghc80/T10971d.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10971d.hs @@ -0,0 +1,6 @@ +import T10971c + +main = do + print $ f (Just 1) + print $ g (+1) (Just 5) + print $ h (const 5) Nothing diff --git a/tests/examples/ghc80/T10997.hs b/tests/examples/ghc80/T10997.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10997.hs @@ -0,0 +1,6 @@ +module T10997 where + +import T10997a + +foo :: Exp a -> String +foo Tru = "True" diff --git a/tests/examples/ghc80/T10997_1.hs b/tests/examples/ghc80/T10997_1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10997_1.hs @@ -0,0 +1,15 @@ +module T10997_1 where + +import T10997_1a + +{- With ghc-7.10.2: + + The interface for ‘T10997a’ + Declaration for Just' + Pattern synonym Just': + Iface type variable out of scope: k + Cannot continue after interface file error +-} + +bar :: (Showable a) => Maybe a -> Maybe a +bar (Just' a) = Just' a diff --git a/tests/examples/ghc80/T10997_1a.hs b/tests/examples/ghc80/T10997_1a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10997_1a.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns, ConstraintKinds, TypeFamilies, PolyKinds, KindSignatures #-} +module T10997_1a where + +import GHC.Exts + +type family Showable (a :: k) :: Constraint where + Showable (a :: *) = (Show a) + Showable a = () + +extractJust :: Maybe a -> (Bool, a) +extractJust (Just a) = (True, a) +extractJust _ = (False, undefined) + +pattern Just' :: Showable a => a -> (Maybe a) +pattern Just' a <- (extractJust -> (True, a)) where + Just' a = Just a + diff --git a/tests/examples/ghc80/T10997a.hs b/tests/examples/ghc80/T10997a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10997a.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTs, PatternSynonyms #-} + +module T10997a where + +data Exp ty where + LitB :: Bool -> Exp Bool + +pattern Tru :: () => b ~ Bool => Exp b +pattern Tru = LitB True + + diff --git a/tests/examples/ghc80/T10999.hs b/tests/examples/ghc80/T10999.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T10999.hs @@ -0,0 +1,8 @@ +module T10999 where + +import qualified Data.Set as Set + +f :: _ => () -> _ +f _ = Set.fromList undefined + +g = map fst $ Set.toList $ f () diff --git a/tests/examples/ghc80/T11010.hs b/tests/examples/ghc80/T11010.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11010.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE PatternSynonyms, ExistentialQuantification, GADTSyntax #-} + +module T11010 where + +data Expr a where + Fun :: String -> (a -> b) -> (Expr a -> Expr b) + +pattern IntFun :: (a ~ Int) => String -> (a -> b) -> (Expr a -> Expr b) +pattern IntFun str f x = Fun str f x + +-- Alternative syntax for pattern synonyms: +-- pattern +-- Suc :: () => (a ~ Int) => Expr a -> Expr Int +-- Suc n <- IntFun _ _ n where +-- Suc n = IntFun "suc" (+ 1) n +pattern Suc :: (a ~ Int) => Expr a -> Expr Int +pattern Suc n <- IntFun _ _ n where + Suc n = IntFun "suc" (+ 1) n diff --git a/tests/examples/ghc80/T11016.hs b/tests/examples/ghc80/T11016.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11016.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-} + +module T11016 where + +f1 :: (?x :: Int, _) => Int +f1 = ?x + +f2 :: (?x :: Int) => _ +f2 = ?x diff --git a/tests/examples/ghc80/T11039.hs b/tests/examples/ghc80/T11039.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11039.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module Foo () where + +data A a = A a + +pattern Q :: () => (A ~ f) => a -> f a +pattern Q a = A a diff --git a/tests/examples/ghc80/T11053.hs b/tests/examples/ghc80/T11053.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11053.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE PatternSynonyms #-} +-- turn on with -fwarn-missing-pat-syn-sigs + +module Foo where + +-- Should warn because of missing signature +pattern T = True + +pattern J a = Just a + +pattern J1 a <- Just a + +pattern J2{b} = Just b + +pattern J3{c} <- Just c + +pattern F :: Bool +pattern F = False diff --git a/tests/examples/ghc80/T11067.hs b/tests/examples/ghc80/T11067.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11067.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +module T11067 where + +import Data.Monoid +import GHC.Exts (Constraint) + +type family Skolem (p :: k -> Constraint) :: k +type family SkolemF (p :: k2 -> Constraint) (f :: k1 -> k2) :: k1 + +-- | A quantified constraint +type Forall (p :: k -> Constraint) = p (Skolem p) +type ForallF (p :: k2 -> Constraint) (f :: k1 -> k2) = p (f (SkolemF p f)) + +-- These work +class ForallF Monoid t => Monoid1 t +instance ForallF Monoid t => Monoid1 t + +class ForallF Monoid1 t => Monoid2 t +instance ForallF Monoid1 t => Monoid2 t + +-- Changing f a ~ g a to, (Ord (f a), Ord (g a)), say, removes the error +class (f a ~ g a) => H f g a +instance (f a ~ g a) => H f g a + +-- This one gives a superclass cycle error. +class Forall (H f g) => H1 f g +instance Forall (H f g) => H1 f g diff --git a/tests/examples/ghc80/T11071.hs b/tests/examples/ghc80/T11071.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11071.hs @@ -0,0 +1,28 @@ +module T11071 where + +import Data.List (lines) +import qualified Data.Map as M () +import qualified Data.IntMap as M () +import qualified Data.IntMap as M () -- just to see if this confused the code + +import qualified Data.Ord as Ord hiding (Down) + +import qualified Data.Map as M' hiding (size, filter) +import qualified Data.Map as M' hiding (size) +import qualified Data.IntMap as M' hiding (size) +import qualified System.IO as M' () -- unrelated + +ignore :: a -> IO () +ignore = const (return ()) + +main = do + ignore NoSuchModule.foo -- no such module + ignore Data.List.foobar -- does not exist (one import) + ignore M.foobar -- does not exist (two imports) + ignore M'.foobar -- does not exist (three imports) + ignore Data.List.sort -- needs import + ignore Data.List.unlines -- needs import, similar to imported + ignore M.size -- multiple modules to import from + ignore M.valid -- only one module to import from + ignore Ord.Down -- explicit hiding + ignore M'.size -- hidden and/or missing in import list diff --git a/tests/examples/ghc80/T11071a.hs b/tests/examples/ghc80/T11071a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11071a.hs @@ -0,0 +1,16 @@ +module T11071 where + +import Data.List (lines) +import Data.IntMap () +import Data.Ord hiding (Down) +import Prelude hiding (True) + +ignore :: a -> IO () +ignore = const (return ()) + +main = do + ignore intersperse -- missing in import list (one import) + ignore foldl' -- missing in import list (two imports) + ignore Down -- explicitly hidden + ignore True -- explicitly hidden from prelude (not really special) + ignore foobar -- genuinely out of scope diff --git a/tests/examples/ghc80/T11076.hs b/tests/examples/ghc80/T11076.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11076.hs @@ -0,0 +1,15 @@ +{- + Test case for a problem where GHC had incorrect strictness + information for foreign calls with lifted arguments + -} +{-# OPTIONS_GHC -O0 #-} +module Main where + +import T11076A +import Control.Exception +x :: Bool +x = error "OK: x has been forced" + +main :: IO () +main = print (testBool x) `catch` + \(ErrorCall e) -> putStrLn e -- x should be forced diff --git a/tests/examples/ghc80/T11076A.hs b/tests/examples/ghc80/T11076A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11076A.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -O #-} +{-# LANGUAGE MagicHash, + ForeignFunctionInterface, + UnliftedFFITypes, + GHCForeignImportPrim, + BangPatterns + #-} +module T11076A where + +import GHC.Exts +import Unsafe.Coerce + +{- + If the demand type for the foreign call argument is incorrectly strict, + the bang pattern can be optimized out + -} +testBool :: Bool -> Int +testBool !x = I# (cmm_testPrim (unsafeCoerce x)) +{-# INLINE testBool #-} + +foreign import prim "testPrim" cmm_testPrim :: Any -> Int# diff --git a/tests/examples/ghc80/T11077.hs b/tests/examples/ghc80/T11077.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11077.hs @@ -0,0 +1,3 @@ +module T11077 (module X, foo) where +import Data.List as X +foo = undefined diff --git a/tests/examples/ghc80/T11103.hs b/tests/examples/ghc80/T11103.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11103.hs @@ -0,0 +1,20 @@ +-- When using DuplicateRecordFields with TemplateHaskell, it is not possible to +-- reify ambiguous names that are output by reifying field labels. +-- See also overloadedrecflds/should_run/overloadedrecfldsrun04.hs + +{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +data R = MkR { foo :: Int, bar :: Int } +data S = MkS { foo :: Int } + +$(do info <- reify ''R + case info of + TyConI (DataD _ _ _ [RecC _ [(foo_n, _, _), (bar_n, _, _)]] _) + -> do { reify bar_n -- This is unambiguous + ; reify foo_n -- This is ambiguous + ; return [] + } + _ -> error "unexpected result of reify") diff --git a/tests/examples/ghc80/T11112.hs b/tests/examples/ghc80/T11112.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11112.hs @@ -0,0 +1,4 @@ +module T11112 where + +sort :: Ord s -> [s] -> [s] +sort xs = xs diff --git a/tests/examples/ghc80/T11128.hs b/tests/examples/ghc80/T11128.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11128.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -fwarn-noncanonical-monad-instances #-} + +-- | Test noncanonical-monad-instances warnings +module T11128 where + +import Control.Applicative as A +import Control.Monad as M + +---------------------------------------------------------------------------- +-- minimal definition + +data T0 a = T0 a deriving Functor + +instance A.Applicative T0 where + pure = T0 + (<*>) = M.ap + +instance M.Monad T0 where + (>>=) = undefined + +---------------------------------------------------------------------------- +-- trigger all 4 warnings + +data T1 a = T1 a deriving Functor + +instance A.Applicative T1 where + pure = return + (<*>) = M.ap + (*>) = (M.>>) + +instance M.Monad T1 where + (>>=) = undefined + return = T1 + (>>) = undefined + +---------------------------------------------------------------------------- +-- backward compat canonical defintion + +data T2 a = T2 a deriving Functor + +instance Applicative T2 where + pure = T2 + (<*>) = ap + (*>) = undefined + +instance M.Monad T2 where + (>>=) = undefined + return = pure + (>>) = (*>) diff --git a/tests/examples/ghc80/T11136.hs b/tests/examples/ghc80/T11136.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11136.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module T11136 where + +class C a where + type D a + type instance D a x = x diff --git a/tests/examples/ghc80/T11142.hs b/tests/examples/ghc80/T11142.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11142.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeInType, RankNTypes #-} + +module T11142 where + +import Data.Kind + +data SameKind :: k -> k -> * + +foo :: forall b. (forall k (a :: k). SameKind a b) -> () +foo = undefined diff --git a/tests/examples/ghc80/T11148.hs b/tests/examples/ghc80/T11148.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11148.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} + +module T11148 where + +data family G a b c d +data instance G Int b Float d = G deriving Functor + +data family H a b c d +data instance H [b] b d c = H deriving Functor diff --git a/tests/examples/ghc80/T11155.hs b/tests/examples/ghc80/T11155.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11155.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -O -fno-full-laziness #-} +module T11155 where + +foo :: Bool +{-# NOINLINE foo #-} +foo = error "rk" + +bar x = let t :: Char + t = case foo of { True -> 'v'; False -> 'y' } + in [t] + diff --git a/tests/examples/ghc80/T11164.hs b/tests/examples/ghc80/T11164.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11164.hs @@ -0,0 +1,3 @@ +module T11164 where + +import T11164b (T) diff --git a/tests/examples/ghc80/T11164a.hs b/tests/examples/ghc80/T11164a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11164a.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} +module T11164a where + +data family T a diff --git a/tests/examples/ghc80/T11164b.hs b/tests/examples/ghc80/T11164b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11164b.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module T11164b where + +import T11164a + +data instance T Int = MkT diff --git a/tests/examples/ghc80/T11167.hs b/tests/examples/ghc80/T11167.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11167.hs @@ -0,0 +1,21 @@ +module T11167 where + +data SomeException + +newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r} + +runContT' :: ContT r m a -> (a -> m r) -> m r +runContT' = runContT + +catch_ :: IO a -> (SomeException -> IO a) -> IO a +catch_ = undefined + +foo :: IO () +foo = (undefined :: ContT () IO a) + `runContT` (undefined :: a -> IO ()) + `catch_` (undefined :: SomeException -> IO ()) + +foo' :: IO () +foo' = (undefined :: ContT () IO a) + `runContT'` (undefined :: a -> IO ()) + `catch_` (undefined :: SomeException -> IO ()) diff --git a/tests/examples/ghc80/T11167_ambig.hs b/tests/examples/ghc80/T11167_ambig.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11167_ambig.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T11167_ambig where + +data SomeException + +newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r} +newtype ContT' r m a = ContT' {runContT :: (a -> m r) -> m r} + +runContT' :: ContT r m a -> (a -> m r) -> m r +runContT' = runContT + +catch_ :: IO a -> (SomeException -> IO a) -> IO a +catch_ = undefined + +foo :: IO () +foo = (undefined :: ContT () IO a) + `runContT` (undefined :: a -> IO ()) + `catch_` (undefined :: SomeException -> IO ()) + +foo' :: IO () +foo' = (undefined :: ContT () IO a) + `runContT'` (undefined :: a -> IO ()) + `catch_` (undefined :: SomeException -> IO ()) diff --git a/tests/examples/ghc80/T11167_ambiguous_fixity.hs b/tests/examples/ghc80/T11167_ambiguous_fixity.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11167_ambiguous_fixity.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T11167_ambiguous_fixity where +import T11167_ambiguous_fixity_A +import T11167_ambiguous_fixity_B + +x a = (a :: A) `foo` 0 diff --git a/tests/examples/ghc80/T11167_ambiguous_fixity_A.hs b/tests/examples/ghc80/T11167_ambiguous_fixity_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11167_ambiguous_fixity_A.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T11167_ambiguous_fixity_A where +data A = MkA { foo :: Int -> Int } +data C = MkC { foo :: Int -> Int } +infixr 3 `foo` diff --git a/tests/examples/ghc80/T11167_ambiguous_fixity_B.hs b/tests/examples/ghc80/T11167_ambiguous_fixity_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11167_ambiguous_fixity_B.hs @@ -0,0 +1,3 @@ +module T11167_ambiguous_fixity_B where +data B = MkB { foo :: Int -> Int } +infixl 5 `foo` diff --git a/tests/examples/ghc80/T11173.hs b/tests/examples/ghc80/T11173.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11173.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T11173 where +import T11173a (A(..)) + +-- Check that the fixity declaration applied to the field 'foo' is used +x b = b `foo` b `foo` 0 diff --git a/tests/examples/ghc80/T11173a.hs b/tests/examples/ghc80/T11173a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11173a.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T11173a where + +data A = A { foo :: Int -> Int, bar :: Int -> Int } +newtype B = B { foo :: Int -> Int } +infixr 5 `foo` +infixr 5 `bar` + +-- This is well-typed only if the fixity is correctly applied +y b = b `bar` b `bar` 0 diff --git a/tests/examples/ghc80/T11182.hs b/tests/examples/ghc80/T11182.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11182.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Strict #-} +-- | Strict should imply StrictData +module Main where + +data Lazy a = Lazy ~a + +main :: IO () +main = + case Lazy undefined of + Lazy _ -> putStrLn "Lazy" diff --git a/tests/examples/ghc80/T11187.hs b/tests/examples/ghc80/T11187.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11187.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module T11187 where +import Data.Type.Coercion + +type family X + +coercionXX :: Coercion X X +coercionXX = Coercion + +coercionXX1 :: Coercion X X +coercionXX1 = c where + c :: x ~ X => Coercion x x + c = Coercion + +coercionXX2 :: Coercion X X +coercionXX2 = c where c = Coercion diff --git a/tests/examples/ghc80/T11192.hs b/tests/examples/ghc80/T11192.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11192.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PartialTypeSignatures #-} + +module T11192 where + +fails :: a +fails = + let go :: _ + go 0 a = a + in go (0 :: Int) undefined + +succeeds :: a +succeeds = + let go :: _ + go _ a = a + in go (0 :: Int) undefined diff --git a/tests/examples/ghc80/T11193.hs b/tests/examples/ghc80/T11193.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11193.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Strict #-} + +module Main where + +main = do + ~a <- return (error "don't error here!") + b <- return (error "error here!") -- this binding should be strict + print "should never reach here" diff --git a/tests/examples/ghc80/T11208.hs b/tests/examples/ghc80/T11208.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11208.hs @@ -0,0 +1,8 @@ +module T11208 where + +import qualified Prelude as P + +f n = n P.+ 1 + +g h (P.Just x) = P.Just (h x) +g _ P.Nothing = P.Nothing diff --git a/tests/examples/ghc80/T11216.hs b/tests/examples/ghc80/T11216.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11216.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RebindableSyntax #-} + +module Bug where + +foo :: (a, b) -> () +foo x | (_,_) <- x = () diff --git a/tests/examples/ghc80/T11224.hs b/tests/examples/ghc80/T11224.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11224.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE PatternSynonyms , ViewPatterns #-} + +-- inlining a pattern synonym shouldn't change semantics + +import Text.Read + +-- pattern PRead :: () => Read a => a -> String +pattern PRead a <- (readMaybe -> Just a) + +foo :: String -> Int +foo (PRead x) = (x::Int) +foo (PRead xs) = sum (xs::[Int]) +foo _ = 666 + +bar :: String -> Int +bar (readMaybe -> Just x) = (x::Int) +bar (readMaybe -> Just xs) = sum (xs::[Int]) +bar _ = 666 + +main :: IO () +main = do + print $ foo "1" -- 1 + print $ foo "[1,2,3]" -- 666 -- ??? + print $ foo "xxx" -- 666 + + print $ bar "1" -- 1 + print $ bar "[1,2,3]" -- 6 + print $ bar "xxx" -- 666 diff --git a/tests/examples/ghc80/T11232.hs b/tests/examples/ghc80/T11232.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11232.hs @@ -0,0 +1,15 @@ +module T11232 where + +import Control.Monad +import Data.Data + +mkMp :: ( MonadPlus m + , Typeable a + , Typeable b + ) + => (b -> m b) + -> a + -> m a +mkMp ext = unM (maybe (M (const mzero)) id (gcast (M ext))) + +newtype M m x = M { unM :: x -> m x } diff --git a/tests/examples/ghc80/T11237.hs b/tests/examples/ghc80/T11237.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11237.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE GADTs #-} +module TypeInTypeBug where + +import qualified Data.Kind + +data Works :: Data.Kind.Type where + WorksConstr :: Works + +type Set = Data.Kind.Type + +data ShouldWork :: Set where + ShouldWorkConstr :: ShouldWork diff --git a/tests/examples/ghc80/T1133Aa.hs b/tests/examples/ghc80/T1133Aa.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T1133Aa.hs @@ -0,0 +1,3 @@ +module T1133Aa where + +import {-# SOURCE #-} T1133A diff --git a/tests/examples/ghc80/T1133a.hs b/tests/examples/ghc80/T1133a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T1133a.hs @@ -0,0 +1,3 @@ +module T1133a where + +import {-# SOURCE #-} T1133 diff --git a/tests/examples/ghc80/T11381.hs b/tests/examples/ghc80/T11381.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11381.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} + +module T11381 where + +-- ensure that this code does not compile without InjectiveTypeFamilies and that +-- injectivity error is not reported. +type family F a = r | r -> a +type instance F Int = Bool +type instance F Int = Char diff --git a/tests/examples/ghc80/T11959.hs b/tests/examples/ghc80/T11959.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T11959.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} +module Main where + +import T11959Lib (Vec2(..), pattern (:>)) + +main = return () diff --git a/tests/examples/ghc80/T17a.hs b/tests/examples/ghc80/T17a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T17a.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fwarn-unused-top-binds #-} + +-- Trac #17 + +module Temp (foo, bar, quux) where + +top :: Int +top = 1 + +foo :: () +foo = let True = True in () + +bar :: Int -> Int +bar match = 1 + +quux :: Int +quux = let local = True + in 2 diff --git a/tests/examples/ghc80/T17b.hs b/tests/examples/ghc80/T17b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T17b.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fwarn-unused-local-binds #-} + +-- Trac #17 + +module Temp (foo, bar, quux) where + +top :: Int +top = 1 + +foo :: () +foo = let True = True in () + +bar :: Int -> Int +bar match = 1 + +quux :: Int +quux = let local = True + in 2 diff --git a/tests/examples/ghc80/T17c.hs b/tests/examples/ghc80/T17c.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T17c.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fwarn-unused-pattern-binds #-} + +-- Trac #17 + +module Temp (foo, bar, quux) where + +top :: Int +top = 1 + +foo :: () +foo = let True = True in () + +bar :: Int -> Int +bar match = 1 + +quux :: Int +quux = let local = True + in 2 diff --git a/tests/examples/ghc80/T17d.hs b/tests/examples/ghc80/T17d.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T17d.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fwarn-unused-matches #-} + +-- Trac #17 + +module Temp (foo, bar, quux) where + +top :: Int +top = 1 + +foo :: () +foo = let True = True in () + +bar :: Int -> Int +bar match = 1 + +quux :: Int +quux = let local = True + in 2 diff --git a/tests/examples/ghc80/T17e.hs b/tests/examples/ghc80/T17e.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T17e.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fwarn-unused-binds #-} + +-- Trac #17 + +module Temp (foo, bar, quux) where + +top :: Int +top = 1 + +foo :: () +foo = let True = True in () + +bar :: Int -> Int +bar match = 1 + +quux :: Int +quux = let local = True + in 2 diff --git a/tests/examples/ghc80/T1830_1.hs b/tests/examples/ghc80/T1830_1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T1830_1.hs @@ -0,0 +1,5 @@ +module T1830_1 where + +import Language.Haskell.TH.Syntax (Lift) + +data Foo a = Foo a deriving Lift diff --git a/tests/examples/ghc80/T1830_2.hs b/tests/examples/ghc80/T1830_2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T1830_2.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DeriveLift #-} +module T1830_2 where + +import Language.Haskell.TH.Syntax (Lift) + +data Nothing deriving Lift diff --git a/tests/examples/ghc80/T1830_3.hs b/tests/examples/ghc80/T1830_3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T1830_3.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH.Syntax (lift) +import T1830_3a + +main :: IO () +main = do + print ($(lift algDT1) == algDT1) + print ($(lift algDT2) == algDT2) + print ($(lift algDT3) == algDT3) + print ($(lift prim) == prim) + print ($(lift df1) == df1) + print ($(lift df2) == df2) + print ($(lift df3) == df3) diff --git a/tests/examples/ghc80/T1830_3a.hs b/tests/examples/ghc80/T1830_3a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T1830_3a.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +module T1830_3a where + +import GHC.Exts +import Language.Haskell.TH.Syntax (Lift(..)) + +data AlgDT a b c = NormalCon a b + | RecCon { recCon1 :: a, recCon2 :: b} + | a :^: b + deriving (Eq, Lift) + +data Prim = Prim Char# Double# Int# Float# Word# + deriving (Eq, Lift) + +-- We can't test this for equality easily due to the unstable nature of +-- primitive string literal equality. We include this anyway to ensure that +-- deriving Lift for datatypes with Addr# in them does in fact work. +data AddrHash = AddrHash Addr# + deriving Lift + +data Empty deriving Lift + +data family DataFam a b c + +data instance DataFam Int b c = DF1 Int | DF2 b + deriving (Eq, Lift) + +newtype instance DataFam Char b c = DF3 Char + deriving (Eq, Lift) + +algDT1, algDT2, algDT3 :: AlgDT Int String () +algDT1 = NormalCon 1 "foo" +algDT2 = RecCon 2 "bar" +algDT3 = 3 :^: "baz" + +prim :: Prim +prim = Prim 'a'# 1.0## 1# 1.0# 1## + +df1, df2 :: DataFam Int Char () +df1 = DF1 1 +df2 = DF2 'a' + +df3 :: DataFam Char () () +df3 = DF3 'b' diff --git a/tests/examples/ghc80/T2006.hs b/tests/examples/ghc80/T2006.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T2006.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} +{-# LANGUAGE GADTs #-} + +module T2006 where + +data Expr a vs where + EPrim :: String -> a -> Expr a vs + EVar :: Expr a (a,vs) + +interpret :: Expr a () -> a +interpret (EPrim _ a) = a +-- interpret EVar = error "unreachable" + diff --git a/tests/examples/ghc80/T2204.hs b/tests/examples/ghc80/T2204.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T2204.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T2204 where + +f :: String -> Int +f "01" = 0 + +g :: Int -> Int +g 0 = 0 diff --git a/tests/examples/ghc80/T2632.hs b/tests/examples/ghc80/T2632.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T2632.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- Trac #2632 + +module MkData where + +import Language.Haskell.TH + +op :: Num v => v -> v -> v +op a b = a + b + +decl1 = [d| func = 0 `op` 3 |] + +decl2 = [d| op x y = x + func = 0 `op` 3 |] + diff --git a/tests/examples/ghc80/T2931.hs b/tests/examples/ghc80/T2931.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T2931.hs @@ -0,0 +1,7 @@ +-- Trac #2931 + +module Foo where +a = 1 + +-- NB: no newline after the 'a'! +b = 'a diff --git a/tests/examples/ghc80/T2991.hs b/tests/examples/ghc80/T2991.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T2991.hs @@ -0,0 +1,5 @@ +module Main where +-- Test that there are actually entries in the .mix file for an imported +-- literate module generated with --make. +import T2991LiterateModule +main = return () diff --git a/tests/examples/ghc80/T3078.hs b/tests/examples/ghc80/T3078.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T3078.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T3078 where + +data T = A Int | B Int + +funny :: T -> Int +funny t = n + where + n | A x <- t = x + | B x <- t = x diff --git a/tests/examples/ghc80/T322.hs b/tests/examples/ghc80/T322.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T322.hs @@ -0,0 +1,29 @@ +{-# OPTIONS -fwarn-incomplete-patterns -fwarn-overlapping-patterns -Werror #-} + +module T322 where + +instance (Num a) => Num (Maybe a) where + (Just a) + (Just b) = Just (a + b) + _ + _ = Nothing + + (Just a) - (Just b) = Just (a - b) + _ - _ = Nothing + + (Just a) * (Just b) = Just (a * b) + _ * _ = Nothing + + negate (Just a) = Just (negate a) + negate _ = Nothing + + abs (Just a) = Just (abs a) + abs _ = Nothing + + signum (Just a) = Just (signum a) + signum _ = Nothing + + fromInteger = Just . fromInteger + +f :: Maybe Int -> Int +f 1 = 1 +f Nothing = 2 +f _ = 3 diff --git a/tests/examples/ghc80/T3468a.hs b/tests/examples/ghc80/T3468a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T3468a.hs @@ -0,0 +1,3 @@ +module T3468a where + +import {-# SOURCE #-} T3468 diff --git a/tests/examples/ghc80/T3572.hs b/tests/examples/ghc80/T3572.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T3572.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- Trac #3572 + +module Main where + +import Language.Haskell.TH +import Language.Haskell.TH.Ppr + +main = putStrLn . pprint =<< runQ [d| data Void |] diff --git a/tests/examples/ghc80/T365.hs b/tests/examples/ghc80/T365.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T365.hs @@ -0,0 +1,4 @@ +{-# OPTIONS_GHC -F -pgmF ./test_preprocessor.txt #-} +module Main where + +main = print "Hello World" diff --git a/tests/examples/ghc80/T366.hs b/tests/examples/ghc80/T366.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T366.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -XGADTs -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T366 where + +data T a where + C1 :: T Char + C2 :: T Float + +exhaustive :: T Char -> Char +exhaustive C1 = ' ' diff --git a/tests/examples/ghc80/T3927.hs b/tests/examples/ghc80/T3927.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T3927.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T3927 where + +data T a where + T1 :: T Int + T2 :: T Bool + +-- f1 is exhaustive +f1 :: T a -> T a -> Bool +f1 T1 T1 = True +f1 T2 T2 = False diff --git a/tests/examples/ghc80/T3927a.hs b/tests/examples/ghc80/T3927a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T3927a.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} +{-# LANGUAGE GADTs, TypeFamilies #-} + +module T3927a where + +type family F a +type instance F a = () + +data Foo a where + FooA :: Foo () + FooB :: Foo Int + +f :: a -> Foo (F a) -> () -- F a can only be () so only FooA is accepted +f _ FooA = () + diff --git a/tests/examples/ghc80/T3927b.hs b/tests/examples/ghc80/T3927b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T3927b.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T3927b where + +import Data.Proxy +import GHC.Exts + +data Message + +data SocketType = Dealer | Push | Pull + +data SocketOperation = Read | Write + +type family Restrict (a :: SocketOperation) (as :: [SocketOperation]) :: Constraint where + Restrict a (a ': as) = () + Restrict x (a ': as) = Restrict x as + Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!") + +type family Implements (t :: SocketType) :: [SocketOperation] where + Implements Dealer = ['Read, Write] + Implements Push = '[Write] + Implements Pull = '[ 'Read] + +data SockOp :: SocketType -> SocketOperation -> * where + SRead :: SockOp sock 'Read + SWrite :: SockOp sock Write + +data Socket :: SocketType -> * where + Socket :: proxy sock + -> (forall op . Restrict op (Implements sock) => SockOp sock op -> Operation op) + -> Socket sock + +type family Operation (op :: SocketOperation) :: * where + Operation 'Read = IO Message + Operation Write = Message -> IO () + +class Restrict 'Read (Implements t) => Readable t where + readSocket :: Socket t -> Operation 'Read + readSocket (Socket _ f) = f (SRead :: SockOp t 'Read) + +instance Readable Dealer + +type family Writable (t :: SocketType) :: Constraint where + Writable Dealer = () + Writable Push = () + +dealer :: Socket Dealer +dealer = Socket (Proxy :: Proxy Dealer) f + where + f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op + f SRead = undefined + f SWrite = undefined + +push :: Socket Push +push = Socket (Proxy :: Proxy Push) f + where + f :: Restrict op (Implements Push) => SockOp Push op -> Operation op + f SWrite = undefined + +pull :: Socket Pull +pull = Socket (Proxy :: Proxy Pull) f + where + f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op + f SRead = undefined + +foo :: IO Message +foo = readSocket dealer diff --git a/tests/examples/ghc80/T4056.hs b/tests/examples/ghc80/T4056.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T4056.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module T4056 where +import Language.Haskell.TH + +astTest :: Q [Dec] +astTest = [d| + class C t where + op :: [t] -> [t] + op = undefined + |] + +class D t where + bop :: [t] -> [t] + bop = undefined diff --git a/tests/examples/ghc80/T4139.hs b/tests/examples/ghc80/T4139.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T4139.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module T4139 where + +data F a where + FInt :: F Int + FBool :: F Bool + +class Baz a where + baz :: F a -> G a +instance Baz Int where + baz _ = GInt +instance Baz Bool where + baz _ = GBool + +data G a where + GInt :: G Int + GBool :: G Bool + +bar :: Baz a => F a -> () +bar a@(FInt) = + case baz a of + GInt -> () + -- GBool -> () +bar _ = () + + diff --git a/tests/examples/ghc80/T4169.hs b/tests/examples/ghc80/T4169.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T4169.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- Crashed GHC 6.12 + +module T4165 where + +import Language.Haskell.TH +class Numeric a where + fromIntegerNum :: a + fromIntegerNum = undefined + +ast :: Q [Dec] +ast = [d| + instance Numeric Int + |] diff --git a/tests/examples/ghc80/T4170.hs b/tests/examples/ghc80/T4170.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T4170.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module T4170 where + +import Language.Haskell.TH + +class LOL a + +lol :: Q [Dec] +lol = [d| + instance LOL Int + |] + +instance LOL Int diff --git a/tests/examples/ghc80/T5001b.hs b/tests/examples/ghc80/T5001b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T5001b.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DefaultSignatures #-} +module T5001b where + +class GEnum a where + genum :: [a] + default genum :: [a] + genum = undefined + +instance GEnum Int where + {-# INLINE genum #-} diff --git a/tests/examples/ghc80/T5333.hs b/tests/examples/ghc80/T5333.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T5333.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE Arrows, NoMonomorphismRestriction #-} +module T5333 where + +import Prelude hiding ( id, (.) ) +import Control.Arrow + +cc1 :: a e b -> a e b -> a e b +cc1 = undefined + +-- With GHC < 7.10.1, the following compile failures occured: +-- +-- ghc: panic! (the 'impossible' happened) +-- (GHC version 7.8.4 for x86_64-unknown-linux): +-- mkCmdEnv Not found: base:GHC.Desugar.>>>{v 02V} + +-- 'g' fails to compile. +g = proc (x, y, z) -> + ((returnA -< x) &&& (returnA -< y) &&& (returnA -< z)) + +-- 'f' compiles: +-- - without an infix declaration +-- - with the infixl declaration +-- and fails with the infixr declaration +infixr 6 `cc1` +-- infixl 6 `cc1` + +f = proc (x, y, z) -> + ((returnA -< x) `cc1` (returnA -< y) `cc1` (returnA -< z)) diff --git a/tests/examples/ghc80/T5721.hs b/tests/examples/ghc80/T5721.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T5721.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module T5371 where +import Language.Haskell.TH + +f :: a -> Name +f (x :: a) = ''a diff --git a/tests/examples/ghc80/T5821.hs b/tests/examples/ghc80/T5821.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T5821.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +module T5821 where + +type family T a +type instance T Int = Bool + +foo :: Num a => a -> T a +foo = undefined + +{-# SPECIALISE foo :: Int -> Bool #-} diff --git a/tests/examples/ghc80/T5884Other.hs b/tests/examples/ghc80/T5884Other.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T5884Other.hs @@ -0,0 +1,3 @@ +module T5884Other where + +data Pair a = Pair a a diff --git a/tests/examples/ghc80/T5908.hs b/tests/examples/ghc80/T5908.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T5908.hs @@ -0,0 +1,72 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE + ExplicitForAll + , GADTs + , RebindableSyntax #-} +module T5908 + ( Writer + , runWriter + , execWriter + , WriterT + , runWriterT + , execWriterT + , tell + ) where + +import Control.Category (Category (id), (>>>)) + +import Prelude hiding (Monad (..), id) +import qualified Prelude + +newtype Identity a = Identity { runIdentity :: a } + +class Monad m where + (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b + (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b + return :: a -> m ex ex a + fail :: String -> m e x a + + {-# INLINE (>>) #-} + m >> k = m >>= \ _ -> k + fail = error + +type Writer w = WriterT w Identity + +runWriter :: Writer w e x a -> (a, w e x) +runWriter = runIdentity . runWriterT + +execWriter :: Writer w e x a -> w e x +execWriter m = snd (runWriter m) + +newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) } + +execWriterT :: Prelude.Monad m => WriterT w m e x a -> m (w e x) +execWriterT m = do + ~(_, w) <- runWriterT m + return w + where + (>>=) = (Prelude.>>=) + return = Prelude.return + +instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where + return a = WriterT $ return (a, id) + where + return = Prelude.return + m >>= k = WriterT $ do + ~(a, w) <- runWriterT m + ~(b, w') <- runWriterT (k a) + return (b, w >>> w') + where + (>>=) = (Prelude.>>=) + return = Prelude.return + fail msg = WriterT $ fail msg + where + fail = Prelude.fail + +tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x () +tell w = WriterT $ return ((), w) + where + return = Prelude.return + + diff --git a/tests/examples/ghc80/T6018.hs b/tests/examples/ghc80/T6018.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6018.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module T6018 where + +import T6018a -- defines G, identical to F + +type family F a b c = (result :: k) | result -> a b c +type instance F Int Char Bool = Bool +type instance F Char Bool Int = Int +type instance F Bool Int Char = Char + + +type instance G Bool Int Char = Char + +type family I (a :: k) b (c :: k) = r | r -> a b +type instance I Int Char Bool = Bool +type instance I Int Char Int = Bool +type instance I Bool Int Int = Int + +-- this is injective - a type variable introduced in the LHS is not mentioned on +-- RHS but we don't claim injectivity in that argument. +type family J a (b :: k) = r | r -> a +type instance J Int b = Char + +type MaybeSyn a = Maybe a +newtype MaybeNew a = MaybeNew (Maybe a) + +-- make sure we look through type synonyms... +type family K a = r | r -> a +type instance K a = MaybeSyn a + +-- .. but not newtypes +type family M a = r | r -> a +type instance M (Maybe a) = MaybeSyn a +type instance M (MaybeNew a) = MaybeNew a + +-- Closed type families + +-- these are simple conversions from open type families. They should behave the +-- same +type family FClosed a b c = result | result -> a b c where + FClosed Int Char Bool = Bool + FClosed Char Bool Int = Int + FClosed Bool Int Char = Char + +type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where + IClosed Int Char Bool = Bool + IClosed Int Char Int = Bool + IClosed Bool Int Int = Int + +type family JClosed a (b :: k) = r | r -> a where + JClosed Int b = Char + +type family KClosed a = r | r -> a where + KClosed a = MaybeSyn a + +-- Here the last equation might return both Int and Char but we have to +-- recognize that it is not possible due to equation overlap +type family Bak a = r | r -> a where + Bak Int = Char + Bak Char = Int + Bak a = a + +-- This is similar, except that the last equation contains concrete type. Since +-- it is overlapped it should be dropped with a warning +type family Foo a = r | r -> a where + Foo Int = Bool + Foo Bool = Int + Foo Bool = Bool + +-- this one was tricky in the early implementation of injectivity. Now it is +-- identical to the above but we still keep it as a regression test. +type family Bar a = r | r -> a where + Bar Int = Bool + Bar Bool = Int + Bar Bool = Char + +-- Now let's use declared type families. All the below definitions should work + +-- No ambiguity for any of the arguments - all are injective +f :: F a b c -> F a b c +f x = x + +-- From 1st instance of F: a ~ Int, b ~ Char, c ~ Bool +fapp :: Bool +fapp = f True + +-- now the closed variant of F +fc :: FClosed a b c -> FClosed a b c +fc x = x + +fcapp :: Bool +fcapp = fc True + +-- The last argument is not injective so it must be instantiated +i :: I a b Int -> I a b Int +i x = x + +-- From 1st instance of I: a ~ Int, b ~ Char +iapp :: Bool +iapp = i True + +-- again, closed variant of I +ic :: IClosed a b Int -> IClosed a b Int +ic x = x + +icapp :: Bool +icapp = ic True + +-- Now we have to test weird closed type families: +bak :: Bak a -> Bak a +bak x = x + +bakapp1 :: Char +bakapp1 = bak 'c' + +bakapp2 :: Double +bakapp2 = bak 1.0 + +bakapp3 :: () +bakapp3 = bak () + +foo :: Foo a -> Foo a +foo x = x + +fooapp1 :: Bool +fooapp1 = foo True + +bar :: Bar a -> Bar a +bar x = x + +barapp1 :: Bool +barapp1 = bar True + +barapp2 :: Int +barapp2 = bar 1 + +-- Declarations below test more liberal RHSs of injectivity annotations: +-- permiting variables to appear in different order than the one in which they +-- were declared. +type family H a b = r | r -> b a +type family Hc a b = r | r -> b a where + Hc a b = a b +class Hcl a b where + type Ht a b = r | r -> b a + +-- repeated tyvars in the RHS of injectivity annotation: no warnings or errors +-- (consistent with behaviour for functional dependencies) +type family Jx a b = r | r -> a a +type family Jcx a b = r | r -> a a where + Jcx a b = a b +class Jcl a b where + type Jt a b = r | r -> a a + +type family Kx a b = r | r -> a b b +type family Kcx a b = r | r -> a b b where + Kcx a b = a b +class Kcl a b where + type Kt a b = r | r -> a b b + +-- Declaring kind injectivity. Here we only claim that knowing the RHS +-- determines the LHS kind but not the type. +type family L (a :: k1) = (r :: k2) | r -> k1 where + L 'True = Int + L 'False = Int + L Maybe = 3 + L IO = 3 + +data KProxy (a :: *) = KProxy +type family KP (kproxy :: KProxy k) = r | r -> k +type instance KP ('KProxy :: KProxy Bool) = Int +type instance KP ('KProxy :: KProxy *) = Char + +kproxy_id :: KP ('KProxy :: KProxy k) -> KP ('KProxy :: KProxy k) +kproxy_id x = x + +kproxy_id_use = kproxy_id 'a' + +-- Now test some awkward cases from The Injectivity Paper. All should be +-- accepted. +type family Gx a +type family Hx a +type family Gi a = r | r -> a +type instance Gi Int = Char +type family Hi a = r | r -> a + +type family F2 a = r | r -> a +type instance F2 [a] = [Gi a] +type instance F2 (Maybe a) = Hi a -> Int + +type family F4 a = r | r -> a +type instance F4 [a] = (Gx a, a, a, a) +type instance F4 (Maybe a) = (Hx a, a, Int, Bool) + +type family G2 a b = r | r -> a b +type instance G2 a Bool = (a, a) +type instance G2 Bool b = (b, Bool) + +type family G6 a = r | r -> a +type instance G6 [a] = [Gi a] +type instance G6 Bool = Int + +g6_id :: G6 a -> G6 a +g6_id x = x + +g6_use :: [Char] +g6_use = g6_id "foo" + +-- A sole exception to "bare variables in the RHS" rule +type family Id (a :: k) = (result :: k) | result -> a +type instance Id a = a + +-- This makes sure that over-saturated type family applications at the top-level +-- are accepted. +type family IdProxy (a :: k) b = r | r -> a +type instance IdProxy a b = (Id a) b + +-- make sure we look through type synonyms properly +type IdSyn a = Id a +type family IdProxySyn (a :: k) b = r | r -> a +type instance IdProxySyn a b = (IdSyn a) b + +-- this has bare variable in the RHS but all LHS varaiables are also bare so it +-- should be accepted +type family Fa (a :: k) (b :: k) = (r :: k2) | r -> k +type instance Fa a b = a + +-- Taken from #9587. This exposed a bug in the solver. +type family Arr (repr :: * -> *) (a :: *) (b :: *) = (r :: *) | r -> repr a b + +class ESymantics repr where + int :: Int -> repr Int + add :: repr Int -> repr Int -> repr Int + + lam :: (repr a -> repr b) -> repr (Arr repr a b) + app :: repr (Arr repr a b) -> repr a -> repr b + +te4 = let c3 = lam (\f -> lam (\x -> f `app` (f `app` (f `app` x)))) + in (c3 `app` (lam (\x -> x `add` int 14))) `app` (int 0) + +-- This used to fail during development +class Manifold' a where + type Base a = r | r -> a + project :: a -> Base a + unproject :: Base a -> a + +id' :: forall a. ( Manifold' a ) => Base a -> Base a +id' = project . unproject diff --git a/tests/examples/ghc80/T6018Afail.hs b/tests/examples/ghc80/T6018Afail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6018Afail.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018Afail where + +type family G a b c = (result :: *) | result -> a b c +type instance G Int Char Bool = Bool +type instance G Char Bool Int = Int diff --git a/tests/examples/ghc80/T6018Bfail.hs b/tests/examples/ghc80/T6018Bfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6018Bfail.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018Bfail where + +type family H a b c = (result :: *) | result -> a b c diff --git a/tests/examples/ghc80/T6018Cfail.hs b/tests/examples/ghc80/T6018Cfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6018Cfail.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018Cfail where + +import T6018Bfail + +type instance H Int Char Bool = Bool +type instance H Char Bool Int = Int diff --git a/tests/examples/ghc80/T6018Dfail.hs b/tests/examples/ghc80/T6018Dfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6018Dfail.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018Dfail where + +import T6018Bfail + +type instance H Bool Int Char = Int diff --git a/tests/examples/ghc80/T6018a.hs b/tests/examples/ghc80/T6018a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6018a.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018a where + +import {-# SOURCE #-} T6018 -- test support for hs-boot files + +type family G a b c = (result :: *) | result -> a b c +type instance G Int Char Bool = Bool +type instance G Char Bool Int = Int + +type instance F Bool Int Char = Char diff --git a/tests/examples/ghc80/T6018fail.hs b/tests/examples/ghc80/T6018fail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6018fail.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds, + MultiParamTypeClasses, FlexibleInstances #-} + +module T6018fail where + +import T6018Afail -- defines G, identical to F +import T6018Cfail -- imports H from T6018Bfail, defines some equations for H +import T6018Dfail -- imports H from T6018Bfail, defines conflicting eqns + +type family F a b c = (result :: *) | result -> a b c +type instance F Int Char Bool = Bool +type instance F Char Bool Int = Int +type instance F Bool Int Char = Int + +type instance G Bool Int Char = Int + +type family I a b c = r | r -> a b +type instance I Int Char Bool = Bool +type instance I Int Int Int = Bool +type instance I Bool Int Int = Int + +-- Id is injective... +type family Id a = result | result -> a +type instance Id a = a + +-- ...but despite that we disallow a call to Id +type family IdProxy a = r | r -> a +type instance IdProxy a = Id a + +data N = Z | S N + +-- P is not injective, although the user declares otherwise. This +-- should be rejected on the grounds of calling a type family in the +-- RHS. +type family P (a :: N) (b :: N) = (r :: N) | r -> a b +type instance P Z m = m +type instance P (S n) m = S (P n m) + +-- this is not injective - not all injective type variables mentioned +-- on LHS are mentioned on RHS +type family J a b c = r | r -> a b +type instance J Int b c = Char + +-- same as above, but tyvar is now nested inside a tycon +type family K (a :: N) (b :: N) = (r :: N) | r -> a b +type instance K (S n) m = S m + +-- Make sure we look through type synonyms to catch errors +type MaybeSyn a = Id a +type family L a = r | r -> a +type instance L a = MaybeSyn a + +-- These should fail because given the RHS kind there is no way to determine LHS +-- kind +class PolyKindVarsC a where + type PolyKindVarsF a = (r :: k) | r -> a + +instance PolyKindVarsC '[] where + type PolyKindVarsF '[] = '[] + +type family PolyKindVars (a :: k0) = (r :: k1) | r -> a +type instance PolyKindVars '[] = '[] + +-- This should fail because there is no way to determine k from the RHS +type family Fc (a :: k) (b :: k) = r | r -> k +type instance Fc a b = Int + +-- This should fail because there is no way to determine a, b and k from the RHS +type family Gc (a :: k) (b :: k) = r | r -> a b +type instance Gc a b = Int + +-- fails because injectivity is not compositional in this case +type family F1 a = r | r -> a +type instance F1 [a] = Maybe (GF1 a) +type instance F1 (Maybe a) = Maybe (GF2 a) + +type family GF1 a = r | r -> a +type instance GF1 Int = Bool + +type family GF2 a = r | r -> a +type instance GF2 Int = Bool + +type family HF1 a +type instance HF1 Bool = Bool + +type family W1 a = r | r -> a +type instance W1 [a] = a + +type family W2 a = r | r -> a +type instance W2 [a] = W2 a + +-- not injective because of infinite types +type family Z1 a = r | r -> a +type instance Z1 [a] = (a, a) +type instance Z1 (Maybe b) = (b, [b]) + +type family G1 a = r | r -> a +type instance G1 [a] = [a] +type instance G1 (Maybe b) = [(b, b)] + +type family G3 a b = r | r -> b +type instance G3 a Int = (a, Int) +type instance G3 a Bool = (Bool, a) + +type family G4 a b = r | r -> a b +type instance G4 a b = [a] + +type family G5 a = r | r -> a +type instance G5 [a] = [GF1 a] -- GF1 injective +type instance G5 Int = [Bool] + +type family G6 a = r | r -> a +type instance G6 [a] = [HF1 a] -- HF1 not injective +type instance G6 Bool = Int + +type family G7a a b (c :: k) = r | r -> a b +type family G7 a b (c :: k) = r | r -> a b c +type instance G7 a b c = [G7a a b c] + +class C a b where + type FC a (b :: *) = r | r -> b + type instance FC a b = b + +instance C Int Char where + type FC Int Char = Bool + +-- this should fail because the default instance conflicts with one of the +-- earlier instances +instance C Int Bool {- where + type FC Int Bool = Bool-} + +-- and this should fail because it violates "bare variable in the RHS" +-- restriction +instance C Char a diff --git a/tests/examples/ghc80/T6018failclosed.hs b/tests/examples/ghc80/T6018failclosed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6018failclosed.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds, UndecidableInstances #-} + +module T6018failclosed where + +-- Id is injective... +type family IdClosed a = result | result -> a where + IdClosed a = a + +-- ...but despite that we disallow a call to Id +type family IdProxyClosed (a :: *) = r | r -> a where + IdProxyClosed a = IdClosed a + +data N = Z | S N + +-- PClosed is not injective, although the user declares otherwise. This +-- should be rejected on the grounds of calling a type family in the +-- RHS. +type family PClosed (a :: N) (b :: N) = (r :: N) | r -> a b where + PClosed Z m = m + PClosed (S n) m = S (PClosed n m) + +-- this is not injective - not all injective type variables mentioned +-- on LHS are mentioned on RHS +type family JClosed a b c = r | r -> a b where + JClosed Int b c = Char + +-- this is not injective - not all injective type variables mentioned +-- on LHS are mentioned on RHS (tyvar is now nested inside a tycon) +type family KClosed (a :: N) (b :: N) = (r :: N) | r -> a b where + KClosed (S n) m = S m + +-- hiding a type family application behind a type synonym should be rejected +type MaybeSynClosed a = IdClosed a +type family LClosed a = r | r -> a where + LClosed a = MaybeSynClosed a + +type family FClosed a b c = (result :: *) | result -> a b c where + FClosed Int Char Bool = Bool + FClosed Char Bool Int = Int + FClosed Bool Int Char = Int + +type family IClosed a b c = r | r -> a b where + IClosed Int Char Bool = Bool + IClosed Int Int Int = Bool + IClosed Bool Int Int = Int + +type family E2 (a :: Bool) = r | r -> a where + E2 False = True + E2 True = False + E2 a = False + +-- This exposed a subtle bug in the implementation during development. After +-- unifying the RHS of (1) and (2) the LHS substitution was done only in (2) +-- which made it look like an overlapped equation. This is not the case and this +-- definition should be rejected. The first two equations are here to make sure +-- that the internal implementation does list indexing corrcectly (this is a bit +-- tricky because the list is kept in reverse order). +type family F a b = r | r -> a b where + F Float IO = Float + F Bool IO = Bool + F a IO = IO a -- (1) + F Char b = b Int -- (2) + +-- This should fail because there is no way to determine a, b and k from the RHS +type family Gc (a :: k) (b :: k) = r | r -> k where + Gc a b = Int diff --git a/tests/examples/ghc80/T6018failclosed2.hs b/tests/examples/ghc80/T6018failclosed2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6018failclosed2.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} + +module T6018failclosed2 where + +-- this one is a strange beast. Last equation is unreachable and thus it is +-- removed. It is then impossible to typecheck barapp and thus we generate an +-- error +type family Bar a = r | r -> a where + Bar Int = Bool + Bar Bool = Int + Bar Bool = Char + +bar :: Bar a -> Bar a +bar x = x + +barapp :: Char +barapp = bar 'c' diff --git a/tests/examples/ghc80/T6018rnfail.hs b/tests/examples/ghc80/T6018rnfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6018rnfail.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeFamilies, PolyKinds #-} + +module T6018rnfail where + +-- IA = injectivity annotation `| foo -> bar` + +-- use incorrect tyvar in LHS of IA +type family F a = r | a -> a +type family Fc a = r | a -> a where + Fc a = a +class Fcl a where + type Ft a = r | a -> a + +-- declare result tyvar to be duplicate (without IA) +type family G a = a +type family Gc a = a where + Gc a = a + +-- declare result tyvar to be duplicate (with IA) +type family Gb a = a | a -> a +type family Gcb a = a | a -> a where + Gcb a = a +class Gclb a where -- here we want two errors + type Gtb a = a | a -> a + +-- not in-scope tyvar in RHS of IA +type family I a b = r | r -> c +type family Ic a b = r | r -> c where + Ic a b = a +class Icl a b where + type It a b = r | r -> c + +-- not in-scope tyvar in LHS of IA +type family L a b = r | c -> a +type family Lc a b = r | c -> a where + Lc a b = a +class Lcl a b where + type Lt a b = r | c -> a + +-- result variable shadows variable in class head +class M a b where + type Mt b = a | a -> b + +-- here b is out-of-scope +class N a b where + type Nt a = r | r -> a b + +-- result is out of scope. Not possible for associated types +type family O1 a | r -> a +type family Oc1 a | r -> a where + Oc1 a = a +type family O2 a :: * | r -> a +type family Oc2 a :: * | r -> a where + Oc2 a = a diff --git a/tests/examples/ghc80/T6018th.hs b/tests/examples/ghc80/T6018th.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6018th.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds #-} + +module T6018th where + +import Language.Haskell.TH + +-- Test that injectivity works correct with TH. This test is not as exhaustive +-- as the original T6018 test. + +-- type family F a b c = (result :: k) | result -> a b c +-- type instance F Int Char Bool = Bool +-- type instance F Char Bool Int = Int +-- type instance F Bool Int Char = Char +$( return + [ OpenTypeFamilyD + (mkName "F") + [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] + (TyVarSig (KindedTV (mkName "result") (VarT (mkName "k")))) + (Just $ InjectivityAnn (mkName "result") + [(mkName "a"), (mkName "b"), (mkName "c") ]) + , TySynInstD + (mkName "F") + (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Bool")] + ( ConT (mkName "Bool"))) + , TySynInstD + (mkName "F") + (TySynEqn [ ConT (mkName "Char"), ConT (mkName "Bool") + , ConT (mkName "Int")] + ( ConT (mkName "Int"))) + , TySynInstD + (mkName "F") + (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") + , ConT (mkName "Char")] + ( ConT (mkName "Char"))) + ] ) + +-- this is injective - a type variables mentioned on LHS is not mentioned on RHS +-- but we don't claim injectivity in that argument. +-- +-- type family J a (b :: k) = r | r -> a +---type instance J Int b = Char +$( return + [ OpenTypeFamilyD + (mkName "J") + [ PlainTV (mkName "a"), KindedTV (mkName "b") (VarT (mkName "k")) ] + (TyVarSig (PlainTV (mkName "r"))) + (Just $ InjectivityAnn (mkName "r") [mkName "a"]) + , TySynInstD + (mkName "J") + (TySynEqn [ ConT (mkName "Int"), VarT (mkName "b") ] + ( ConT (mkName "Int"))) + ] ) + +-- Closed type families + +-- type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where +-- IClosed Int Char Bool = Bool +-- IClosed Int Char Int = Bool +-- IClosed Bool Int Int = Int + +$( return + [ ClosedTypeFamilyD + (mkName "I") + [ KindedTV (mkName "a") StarT, KindedTV (mkName "b") StarT + , KindedTV (mkName "c") StarT ] + (TyVarSig (PlainTV (mkName "r"))) + (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")]) + [ TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Bool")] + ( ConT (mkName "Bool")) + , TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Int")] + ( ConT (mkName "Bool")) + , TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") + , ConT (mkName "Int")] + ( ConT (mkName "Int")) + ] + ] ) + +-- reification test +$( do { decl@([ClosedTypeFamilyD _ _ _ (Just inj) _]) <- + [d| type family Bak a = r | r -> a where + Bak Int = Char + Bak Char = Int + Bak a = a |] + ; return decl + } + ) + +-- Check whether incorrect injectivity declarations are caught + +-- type family I a b c = r | r -> a b +-- type instance I Int Char Bool = Bool +-- type instance I Int Int Int = Bool +-- type instance I Bool Int Int = Int +$( return + [ OpenTypeFamilyD + (mkName "H") + [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] + (TyVarSig (PlainTV (mkName "r"))) + (Just $ InjectivityAnn (mkName "r") + [(mkName "a"), (mkName "b") ]) + , TySynInstD + (mkName "H") + (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Bool")] + ( ConT (mkName "Bool"))) + , TySynInstD + (mkName "H") + (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Int") + , ConT (mkName "Int")] + ( ConT (mkName "Bool"))) + , TySynInstD + (mkName "H") + (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") + , ConT (mkName "Int")] + ( ConT (mkName "Int"))) + ] ) diff --git a/tests/examples/ghc80/T6062.hs b/tests/examples/ghc80/T6062.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6062.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module T6062 where +x = [| False True |] diff --git a/tests/examples/ghc80/T6124.hs b/tests/examples/ghc80/T6124.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T6124.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module T6124 where + +newtype A = MkA Int +newtype B = MkB Char + +data T a where + A :: T A + B :: T B + +f :: T A -> A +f A = undefined diff --git a/tests/examples/ghc80/T7411.hs b/tests/examples/ghc80/T7411.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T7411.hs @@ -0,0 +1,3 @@ +import Control.Exception +import Control.DeepSeq +main = evaluate (('a' : undefined) `deepseq` return () :: IO ()) diff --git a/tests/examples/ghc80/T7669a.hs b/tests/examples/ghc80/T7669a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T7669a.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module T7669 where + +data Void + +foo :: Void -> () +foo x = case x of {} diff --git a/tests/examples/ghc80/T7672.hs b/tests/examples/ghc80/T7672.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T7672.hs @@ -0,0 +1,3 @@ +module T7672 where +import qualified T7672a as XX +data T = S XX.T diff --git a/tests/examples/ghc80/T7672a.hs b/tests/examples/ghc80/T7672a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T7672a.hs @@ -0,0 +1,2 @@ +module T7672a(Decl.T) where +import {-# SOURCE #-} qualified T7672 as Decl diff --git a/tests/examples/ghc80/T7765.hs b/tests/examples/ghc80/T7765.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T7765.hs @@ -0,0 +1,1 @@ +module Main where diff --git a/tests/examples/ghc80/T7788.hs b/tests/examples/ghc80/T7788.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T7788.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module T7788 where + +data Proxy a = Proxy + +foo :: Proxy (F (Fix Id)) -> () +foo = undefined + +newtype Fix a = Fix (a (Fix a)) +newtype Id a = Id a + +type family F a +type instance F (Fix a) = F (a (Fix a)) +type instance F (Id a) = F a + +main :: IO () +main = print $ foo Proxy diff --git a/tests/examples/ghc80/T8030.hs b/tests/examples/ghc80/T8030.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8030.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PolyKinds, FlexibleContexts, TypeFamilies #-} +module T8030 where + +-- The types of op1 and op2 are both ambiguous +-- and should be reported as such + +class C (a :: k) where + type Pr a :: * + op1 :: Pr a + op2 :: Pr a -> Pr a -> Pr a + diff --git a/tests/examples/ghc80/T8034.hs b/tests/examples/ghc80/T8034.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8034.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module T8034 where + +class C a where + type F a + foo :: F a -> F a diff --git a/tests/examples/ghc80/T8101b.hs b/tests/examples/ghc80/T8101b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8101b.hs @@ -0,0 +1,8 @@ + +module A where + +data ABC = A | B | C + +abc :: ABC -> Int +abc x = case x of + A -> 1 diff --git a/tests/examples/ghc80/T8131b.hs b/tests/examples/ghc80/T8131b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8131b.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +import GHC.Prim +import GHC.IO + +main = IO $ \s -> + let (# s1, p0 #) = newByteArray# 10# s + (# s2, p #) = unsafeFreezeByteArray# p0 s1 + (# s3, q #) = newByteArray# 10# s2 + in (# copyByteArray# p 0# q 0# 10# s, () #) diff --git a/tests/examples/ghc80/T8274.hs b/tests/examples/ghc80/T8274.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8274.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MagicHash #-} +module T8274 where + +import GHC.Prim + +data P = Positives Int# Float# Double# Char# Word# +data N = Negatives Int# Float# Double# + +p = Positives 42# 4.23# 4.23## '4'# 4## +n = Negatives -4# -4.0# -4.0## diff --git a/tests/examples/ghc80/T8455.hs b/tests/examples/ghc80/T8455.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8455.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE DataKinds #-} + +module T8455 where + +ty = [t| 5 |] diff --git a/tests/examples/ghc80/T8550.hs b/tests/examples/ghc80/T8550.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8550.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeFamilies, GADTs, UndecidableInstances #-} + +module T8550 where + +type family F a +type instance F () = F () +data A where + A :: F () ~ () => A +x :: A +x = A + +main :: IO () +main = seq A (return ()) + +-- Note: This worked in GHC 7.8, but I (Richard E) think this regression +-- is acceptable. diff --git a/tests/examples/ghc80/T8555.hs b/tests/examples/ghc80/T8555.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8555.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE FlexibleContexts #-} + +module T8555 where +import Data.Coerce + +foo :: Coercible [a] [b] => a -> b +foo = coerce diff --git a/tests/examples/ghc80/T8633.hs b/tests/examples/ghc80/T8633.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8633.hs @@ -0,0 +1,19 @@ +module Main where +import Language.Haskell.TH.Syntax + +t1 = case mkName "^.." of + Name (OccName ".") (NameQ (ModName "^")) -> error "bug0" + Name (OccName "^..") NameS -> return () + +t2 = case mkName "Control.Lens.^.." of + Name (OccName ".") (NameQ (ModName "Control.Lens.^")) -> error "bug1" + Name (OccName "^..") (NameQ (ModName "Control.Lens")) -> return () + +t3 = case mkName "Data.Bits..&." of + Name (OccName ".&.") (NameQ (ModName "Data.Bits")) -> return () + +t4 = case mkName "abcde" of + Name (OccName "abcde") NameS -> return () + +main :: IO () +main = do t1; t2; t3; t4 diff --git a/tests/examples/ghc80/T8743a.hs b/tests/examples/ghc80/T8743a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8743a.hs @@ -0,0 +1,3 @@ +module T8743a where + +import {-# SOURCE #-} T8743 () diff --git a/tests/examples/ghc80/T8759a.hs b/tests/examples/ghc80/T8759a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8759a.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE PatternSynonyms #-} + +module T8759a where + +foo = [d| pattern Q = False |] diff --git a/tests/examples/ghc80/T8799.hs b/tests/examples/ghc80/T8799.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8799.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} + +module T8555 where +import Data.Coerce + +foo :: Coercible a b => b -> a +foo = coerce + +bar :: (Coercible a b, Coercible b c) => b -> c -> a +bar b c = coerce c diff --git a/tests/examples/ghc80/T8970.hs b/tests/examples/ghc80/T8970.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T8970.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T8970 where + +data K = Foo + | Bar + +data D1 :: K -> * where + F1 :: D1 Foo + B1 :: D1 Bar + +class C (a :: K -> *) where + data D2 a :: K -> * + foo :: a k -> D2 a k -> Bool + +instance C D1 where + data D2 D1 k where + F2 :: D2 D1 Foo + B2 :: D2 D1 Bar + foo F1 F2 = True + foo B1 B2 = True diff --git a/tests/examples/ghc80/T9015.hs b/tests/examples/ghc80/T9015.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9015.hs @@ -0,0 +1,59 @@ +module Main where + +import GHC +import DynFlags +import System.Environment +import GhcMonad + +testStrings = [ + "import Data.Maybe" + , "import qualified Data.Maybe" + , "import Data.Maybe (isJust)" + + , "add a b = a+b" + , "data Foo = Foo String" + , "deriving instance Show Foo" + , "{-# NOVECTORISE foo #-}" + , "{-# WARNING Foo \"Just a warning\" #-}" + , "{-# ANN foo (Just \"Hello\") #-}" + , "{-# RULES \"map/map\" forall f g xs. map f (map g xs) = map (f.g) xs #-}" + , "class HasString a where\n\ + \ update :: a -> (String -> String) -> a\n\ + \ upcase :: a -> a\n\ + \ upcase x = update x (fmap toUpper)\n\ + \ content :: a -> String\n\ + \ default content :: Show a => a -> String\n\ + \ content = show" + , "instance HasString Foo where\n\ + \ update (Foo s) f = Foo (f s)\n\ + \ content (Foo s) = s" + + , "add a b" + , "let foo = add a b" + , "x <- foo y" + , "5 + 8" + + , "a <-" + , "2 +" + , "@#" + ] + +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ do + liftIO (putStrLn "Is import:") + testWithParser isImport + + liftIO (putStrLn "Is declaration:") + testWithParser isDecl + + liftIO (putStrLn "Is statement:") + testWithParser isStmt + + where + testWithParser parser = do + dflags <- getSessionDynFlags + liftIO . putStrLn . unlines $ map (testExpr (parser dflags)) testStrings + + testExpr parser expr = do + expr ++ ": " ++ show (parser expr) diff --git a/tests/examples/ghc80/T9017.hs b/tests/examples/ghc80/T9017.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9017.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PolyKinds #-} + +module T9017 where + +import Control.Arrow + +foo :: a b (m b) +foo = arr return diff --git a/tests/examples/ghc80/T9177a.hs b/tests/examples/ghc80/T9177a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9177a.hs @@ -0,0 +1,6 @@ +module T9177a where + +foo3 = bar +foo4 = Fun + + diff --git a/tests/examples/ghc80/T9204a.hs b/tests/examples/ghc80/T9204a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9204a.hs @@ -0,0 +1,2 @@ +module T9204a where +import {-# SOURCE #-} T9204 diff --git a/tests/examples/ghc80/T9204b.hs b/tests/examples/ghc80/T9204b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9204b.hs @@ -0,0 +1,5 @@ +module T9204b where + +import T9204b2 + +data P a = P diff --git a/tests/examples/ghc80/T9204b2.hs b/tests/examples/ghc80/T9204b2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9204b2.hs @@ -0,0 +1,3 @@ +module T9204b2 where + +import {-# SOURCE #-} T9204b diff --git a/tests/examples/ghc80/T9233.hs b/tests/examples/ghc80/T9233.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9233.hs @@ -0,0 +1,12 @@ +module T9233 where + +import T9233a +import Data.Functor.Identity + +upds :: (Monad m) => [String -> Options -> m Options] +upds = [ + \a o -> return o { flags = (flags o) { f1 = splitComma a ++ " " ++ f1 (flags o) } } + ] + +setAll :: Options -> Options +setAll _ = (getOpt upds :: Identity ()) `seq` undefined diff --git a/tests/examples/ghc80/T9233a.hs b/tests/examples/ghc80/T9233a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9233a.hs @@ -0,0 +1,128 @@ +module T9233a where + + +data X = X { + f1 :: String, + f2 :: !Bool, + f3 :: !Bool, + f4 :: !Bool, + f5 :: !Bool, + f6 :: !Bool, + f7 :: !Bool, + f8 :: !Bool, + f9 :: !Bool, + f10 :: !Bool, + f11 :: !Bool, + f12 :: !Bool, + f13 :: !Bool, + f14 :: !Bool, + f15 :: !Bool, + f16 :: !Bool, + f17 :: !Bool, + f18 :: !Bool, + f19 :: !Bool, + f20 :: !Bool, + f21 :: !Bool, + f22 :: !Bool, + f23 :: !Bool, + f24 :: !Bool, + f25 :: !Bool, + f26 :: !Bool, + f27 :: !Bool, + f28 :: !Bool, + f29 :: !Bool, + f30 :: !Bool, + f31 :: !Bool, + f32 :: !Bool, + f33 :: !Bool, + f34 :: !Bool, + f35 :: !Bool, + f36 :: !Bool, + f37 :: !Bool, + f38 :: !Bool, + f39 :: !Bool, + f40 :: !Bool, + f41 :: !Bool, + f42 :: !Bool, + f43 :: !Bool, + f44 :: !Bool, + f45 :: !Bool, + f46 :: !Bool, + f47 :: !Bool, + f48 :: !Bool, + f49 :: !Bool, + f50 :: !Bool, + f51 :: !Bool, + f52 :: !Bool, + f53 :: !Bool, + f54 :: !Bool, + f55 :: !Bool, + f56 :: !Bool, + f57 :: !Bool, + f58 :: !Bool, + f59 :: !Bool, + f60 :: !Bool, + f61 :: !Bool, + f62 :: !Bool, + f63 :: !Bool, + f64 :: !Bool, + f65 :: !Bool, + f66 :: !Bool, + f67 :: !Bool, + f68 :: !Bool, + f69 :: !Bool, + f70 :: !Bool, + f71 :: !Bool, + f72 :: !Bool, + f73 :: !Bool, + f74 :: !Bool, + f75 :: !Bool, + f76 :: !Bool, + f77 :: !Bool, + f78 :: !Bool, + f79 :: !Bool, + f80 :: !Bool, + f81 :: !Bool, + f82 :: !Bool, + f83 :: !Bool, + f84 :: !Bool, + f85 :: !Bool, + f86 :: !Bool, + f87 :: !Bool, + f88 :: !Bool, + f89 :: !Bool, + f90 :: !Bool, + f91 :: !Bool, + f92 :: !Bool, + f93 :: !Bool, + f94 :: !Bool, + f95 :: !Bool, + f96 :: !Bool, + f97 :: !Bool, + f98 :: !Bool, + f99 :: !Bool, + f100 :: !Bool + } + +data Options = Options { + flags :: !X, + o2 :: !Bool, + o3 :: !Bool, + o4 :: !Bool, + o5 :: !Bool, + o6 :: !Bool, + o7 :: !Bool, + o8 :: !Bool, + o9 :: !Bool, + o10 :: !Bool, + o11 :: !Bool, + o12 :: !Bool + } + +splitComma :: String -> String +splitComma _ = "a" +{-# NOINLINE splitComma #-} + +getOpt :: Monad m => [String -> Options -> m Options] -> m () +getOpt _ = return () +{-# NOINLINE getOpt #-} diff --git a/tests/examples/ghc80/T9238.hs b/tests/examples/ghc80/T9238.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9238.hs @@ -0,0 +1,16 @@ +compareDouble :: Double -> Double -> Ordering +compareDouble x y = + case (isNaN x, isNaN y) of + (True, True) -> EQ + (True, False) -> LT + (False, True) -> GT + (False, False) -> + -- Make -0 less than 0 + case (x == 0, y == 0, isNegativeZero x, isNegativeZero y) of + (True, True, True, False) -> LT + (True, True, False, True) -> GT + _ -> x `compare` y + +main = do + let l = [-0, 0] + print [ (x, y, compareDouble x y) | x <- l, y <- l ] diff --git a/tests/examples/ghc80/T9260.hs b/tests/examples/ghc80/T9260.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9260.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds, TypeOperators, GADTs #-} + +module T9260 where + +import GHC.TypeLits + +data Fin n where + Fzero :: Fin (n + 1) + Fsucc :: Fin n -> Fin (n + 1) + +test :: Fin 1 +test = Fsucc Fzero + +{- Only the second error is legitimate. + +% ghc --version +The Glorious Glasgow Haskell Compilation System, version 7.8.2 +% ghc -ignore-dot-ghci /tmp/Error.hs +[1 of 1] Compiling Error ( /tmp/Error.hs, /tmp/Error.o ) + +/tmp/Error.hs:12:8: + Couldn't match type ‘0’ with ‘1’ + Expected type: Fin 1 + Actual type: Fin (0 + 1) + In the expression: Fsucc Fzero + In an equation for ‘test’: test = Fsucc Fzero + +/tmp/Error.hs:12:14: + Couldn't match type ‘1’ with ‘0’ + Expected type: Fin 0 + Actual type: Fin (0 + 1) + In the first argument of ‘Fsucc’, namely ‘Fzero’ + In the expression: Fsucc Fzero +-} diff --git a/tests/examples/ghc80/T9430.hs b/tests/examples/ghc80/T9430.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9430.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Exts + +checkI + :: (Int, Int) -- ^ expected results + -> (Int# -> Int# -> (# Int#, Int# #)) -- ^ primop + -> Int -- ^ first argument + -> Int -- ^ second argument + -> Maybe String -- ^ maybe error +checkI (expX, expY) op (I# a) (I# b) = + case op a b of + (# x, y #) + | I# x == expX && I# y == expY -> Nothing + | otherwise -> + Just $ + "Expected " ++ show expX ++ " and " ++ show expY + ++ " but got " ++ show (I# x) ++ " and " ++ show (I# y) +checkW + :: (Word, Word) -- ^ expected results + -> (Word# -> Word# -> (# Word#, Word# #)) -- ^ primop + -> Word -- ^ first argument + -> Word -- ^ second argument + -> Maybe String -- ^ maybe error +checkW (expX, expY) op (W# a) (W# b) = + case op a b of + (# x, y #) + | W# x == expX && W# y == expY -> Nothing + | otherwise -> + Just $ + "Expected " ++ show expX ++ " and " ++ show expY + ++ " but got " ++ show (W# x) ++ " and " ++ show (W# y) + +checkW2 + :: (Word, Word) -- ^ expected results + -> (Word# -> Word# -> Word# -> (# Word#, Word# #)) + -- ^ primop + -> Word -- ^ first argument + -> Word -- ^ second argument + -> Word -- ^ third argument + -> Maybe String -- ^ maybe error +checkW2 (expX, expY) op (W# a) (W# b) (W# c) = + case op a b c of + (# x, y #) + | W# x == expX && W# y == expY -> Nothing + | otherwise -> + Just $ + "Expected " ++ show expX ++ " and " ++ show expY + ++ " but got " ++ show (W# x) ++ " and " ++ show (W# y) + +check :: String -> Maybe String -> IO () +check s (Just err) = error $ "Error for " ++ s ++ ": " ++ err +check _ Nothing = return () + +main :: IO () +main = do + -- First something trivial + check "addIntC# maxBound 0" $ checkI (maxBound, 0) addIntC# maxBound 0 + check "addIntC# 0 maxBound" $ checkI (maxBound, 0) addIntC# 0 maxBound + -- Overflows + check "addIntC# maxBound 1" $ checkI (minBound, 1) addIntC# maxBound 1 + check "addIntC# 1 maxBound" $ checkI (minBound, 1) addIntC# 1 maxBound + check "addIntC# maxBound 2" $ checkI (minBound + 1, 1) addIntC# maxBound 2 + check "addIntC# 2 maxBound" $ checkI (minBound + 1, 1) addIntC# 2 maxBound + check "addIntC# minBound minBound" $ + checkI (0, 1) addIntC# minBound minBound + + -- First something trivial + check "subIntC# minBound 0" $ checkI (minBound, 0) subIntC# minBound 0 + -- Overflows + check "subIntC# minBound 1" $ checkI (maxBound, 1) subIntC# minBound 1 + check "subIntC# minBound 1" $ checkI (maxBound - 1, 1) subIntC# minBound 2 + check "subIntC# 0 minBound" $ checkI (minBound, 1) subIntC# 0 minBound + check "subIntC# -1 minBound" $ checkI (maxBound, 0) subIntC# (-1) minBound + check "subIntC# minBound -1" $ + checkI (minBound + 1, 0) subIntC# minBound (-1) + + -- First something trivial (note that the order of results is different!) + check "plusWord2# maxBound 0" $ checkW (0, maxBound) plusWord2# maxBound 0 + check "plusWord2# 0 maxBound" $ checkW (0, maxBound) plusWord2# 0 maxBound + -- Overflows + check "plusWord2# maxBound 1" $ + checkW (1, minBound) plusWord2# maxBound 1 + check "plusWord2# 1 maxBound" $ + checkW (1, minBound) plusWord2# 1 maxBound + check "plusWord2# maxBound 2" $ + checkW (1, minBound + 1) plusWord2# maxBound 2 + check "plusWord2# 2 maxBound" $ + checkW (1, minBound + 1) plusWord2# 2 maxBound + + check "timesWord2# maxBound 0" $ checkW (0, 0) timesWord2# maxBound 0 + check "timesWord2# 0 maxBound" $ checkW (0, 0) timesWord2# 0 maxBound + check "timesWord2# maxBound 1" $ checkW (0, maxBound) timesWord2# maxBound 1 + check "timesWord2# 1 maxBound" $ checkW (0, maxBound) timesWord2# 1 maxBound + -- Overflows + check "timesWord2# " $ checkW (1, 0) timesWord2# (2 ^ 63) 2 + check "timesWord2# " $ checkW (2, 0) timesWord2# (2 ^ 63) (2 ^ 2) + check "timesWord2# " $ checkW (4, 0) timesWord2# (2 ^ 63) (2 ^ 3) + check "timesWord2# " $ checkW (8, 0) timesWord2# (2 ^ 63) (2 ^ 4) + check "timesWord2# maxBound 2" $ + checkW (1, maxBound - 1) timesWord2# maxBound 2 + check "timesWord2# 2 maxBound" $ + checkW (1, maxBound - 1) timesWord2# 2 maxBound + check "timesWord2# maxBound 3" $ + checkW (2, maxBound - 2) timesWord2# maxBound 3 + check "timesWord2# 3 maxBound" $ + checkW (2, maxBound - 2) timesWord2# 3 maxBound + + check "quotRemWord2# 0 0 1" $ checkW2 (0, 0) quotRemWord2# 0 0 1 + check "quotRemWord2# 0 4 2" $ checkW2 (2, 0) quotRemWord2# 0 4 2 + check "quotRemWord2# 0 7 3" $ checkW2 (2, 1) quotRemWord2# 0 7 3 + check "quotRemWord2# 1 0 (2 ^ 63)" $ + checkW2 (2, 0) quotRemWord2# 1 0 (2 ^ 63) + check "quotRemWord2# 1 1 (2 ^ 63)" $ + checkW2 (2, 1) quotRemWord2# 1 1 (2 ^ 63) + check "quotRemWord2# 1 0 maxBound" $ + checkW2 (1, 1) quotRemWord2# 1 0 maxBound + check "quotRemWord2# 2 0 maxBound" $ + checkW2 (2, 2) quotRemWord2# 2 0 maxBound + check "quotRemWord2# 1 maxBound maxBound" $ + checkW2 (2, 1) quotRemWord2# 1 maxBound maxBound + check "quotRemWord2# (2 ^ 63) 0 maxBound" $ + checkW2 (2 ^ 63, 2 ^ 63) quotRemWord2# (2 ^ 63) 0 maxBound + check "quotRemWord2# (2 ^ 63) maxBound maxBound" $ + checkW2 (2 ^ 63 + 1, 2 ^ 63) quotRemWord2# (2 ^ 63) maxBound maxBound diff --git a/tests/examples/ghc80/T9554.hs b/tests/examples/ghc80/T9554.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9554.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies, UndecidableInstances #-} + +module T9554 where + +import Data.Proxy + +type family F a where + F a = F (F a) + +foo :: Proxy (F Bool) -> Proxy (F Int) +foo x = x + +main = case foo Proxy of Proxy -> putStrLn "Made it!" diff --git a/tests/examples/ghc80/T9600-1.hs b/tests/examples/ghc80/T9600-1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9600-1.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +import Control.Applicative + +newtype Foo a = Foo (a -> a) deriving Applicative diff --git a/tests/examples/ghc80/T9600.hs b/tests/examples/ghc80/T9600.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9600.hs @@ -0,0 +1,3 @@ +import Control.Applicative + +newtype Foo a = Foo (a -> a) deriving Applicative diff --git a/tests/examples/ghc80/T9632.hs b/tests/examples/ghc80/T9632.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9632.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeInType #-} + +module T9632 where + +import Data.Kind + +data B = T | F +data P :: B -> * + +type B' = B +data P' :: B' -> * diff --git a/tests/examples/ghc80/T9824.hs b/tests/examples/ghc80/T9824.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9824.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# OPTIONS_GHC -fwarn-unused-matches #-} + +module T9824 where + +foo = [p| (x, y) |] diff --git a/tests/examples/ghc80/T9839_02.hs b/tests/examples/ghc80/T9839_02.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9839_02.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/ghc80/T9839_03.hs b/tests/examples/ghc80/T9839_03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9839_03.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/ghc80/T9839_04.hs b/tests/examples/ghc80/T9839_04.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9839_04.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/ghc80/T9839_05.hs b/tests/examples/ghc80/T9839_05.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9839_05.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/ghc80/T9839_06.hs b/tests/examples/ghc80/T9839_06.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9839_06.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/ghc80/T9840.hs b/tests/examples/ghc80/T9840.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9840.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeFamilies #-} + +module T9840 where + +import T9840a + +type family X :: * -> * where + +type family F (a :: * -> *) where + +foo :: G (F X) -> G (F X) +foo x = x diff --git a/tests/examples/ghc80/T9840a.hs b/tests/examples/ghc80/T9840a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9840a.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies #-} + +module T9840a where + +import {-# SOURCE #-} T9840 + +type family G a where + +bar :: X a -> X a +bar = id diff --git a/tests/examples/ghc80/T9858a.hs b/tests/examples/ghc80/T9858a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9858a.hs @@ -0,0 +1,35 @@ +-- From comment:76 in Trac #9858 +-- This exploit still works in GHC 7.10.1. +-- By Shachaf Ben-Kiki, Ørjan Johansen and Nathan van Doorn + +{-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ImpredicativeTypes #-} + +module T9858a where + +import Data.Typeable + +type E = (:~:) +type PX = Proxy (((),()) => ()) +type PY = Proxy (() -> () -> ()) + +data family F p a b + +newtype instance F a b PX = ID (a -> a) +newtype instance F a b PY = UC (a -> b) + +{-# NOINLINE ecast #-} +ecast :: E p q -> f p -> f q +ecast Refl = id + +supercast :: F a b PX -> F a b PY +supercast = case cast e of + Just e' -> ecast e' + where + e = Refl + e :: E PX PX + +uc :: a -> b +uc = case supercast (ID id) of UC f -> f diff --git a/tests/examples/ghc80/T9858b.hs b/tests/examples/ghc80/T9858b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9858b.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE FlexibleContexts #-} + +module T9858b where +import Data.Typeable + +test = typeRep (Proxy :: Proxy (Eq Int => Int)) + + + diff --git a/tests/examples/ghc80/T9858c.hs b/tests/examples/ghc80/T9858c.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9858c.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE KindSignatures #-} +module Main(main) where + +import Data.Typeable +import GHC.Exts + +test1 :: Bool +test1 = typeRep (Proxy :: Proxy (() :: *)) == + typeRep (Proxy :: Proxy (() :: Constraint)) + +test2 :: Bool +test2 = typeRepTyCon (typeRep (Proxy :: Proxy (Int,Int))) == + typeRepTyCon (typeRep (Proxy :: Proxy (Eq Int, Eq Int))) + +main :: IO () +main = print (test1,test2) + + + diff --git a/tests/examples/ghc80/T9858d.hs b/tests/examples/ghc80/T9858d.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9858d.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds #-} +module Main where + +import Data.Typeable + +data A = A + +main = print $ typeRep (Proxy :: Proxy A) == typeRep (Proxy :: Proxy 'A) diff --git a/tests/examples/ghc80/T9858e.hs b/tests/examples/ghc80/T9858e.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9858e.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ImpredicativeTypes, FlexibleContexts #-} + +module T9858e where +import Data.Typeable + +i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep +i p = typeRep p + +j = i (Proxy :: Proxy (Eq Int => Int)) diff --git a/tests/examples/ghc80/T9867.hs b/tests/examples/ghc80/T9867.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9867.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-} + +module T9867 where + +pattern Nil = [] :: [a] diff --git a/tests/examples/ghc80/T9878b.hs b/tests/examples/ghc80/T9878b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9878b.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE StaticPointers #-} +module T9878b where + +import GHC.StaticPtr + +f = deRefStaticPtr (static True) diff --git a/tests/examples/ghc80/T9938.hs b/tests/examples/ghc80/T9938.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9938.hs @@ -0,0 +1,13 @@ +module Main where + +import Control.Monad +import Control.Monad.Trans.State + +solve :: Int -> StateT () [] () +solve carry | carry > 0 = + do guard (0 == carry) + solve (carry -1) +solve 0 = mzero + +main :: IO () +main = return () diff --git a/tests/examples/ghc80/T9938B.hs b/tests/examples/ghc80/T9938B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9938B.hs @@ -0,0 +1,13 @@ +module Main where + +import Control.Monad +import Control.Monad.Trans.State + +solve :: Int -> StateT () [] () +solve 0 = mzero +solve carry | carry > 0 = + do guard (0 == carry) + solve (carry -1) + +main :: IO () +main = return () diff --git a/tests/examples/ghc80/T9939.hs b/tests/examples/ghc80/T9939.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9939.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GADTs #-} + +module T9939 where + +f1 :: (Eq a, Ord a) => a -> a -> Bool +-- Eq a redundant +f1 x y = (x == y) && (x > y) + +f2 :: (Eq a, Ord a) => a -> a -> Bool +-- Ord a redundant, but Eq a is reported +f2 x y = (x == y) + +f3 :: (Eq a, a ~ b, Eq b) => a -> b -> Bool +-- Eq b redundant +f3 x y = x==y + +data Equal a b where + EQUAL :: Equal a a + +f4 :: (Eq a, Eq b) => a -> b -> Equal a b -> Bool +-- Eq b redundant +f4 x y EQUAL = y==y + diff --git a/tests/examples/ghc80/T9951.hs b/tests/examples/ghc80/T9951.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9951.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T9951 where + +f :: [a] -> () +f x = case x of + [] -> () + (_:_) -> () + diff --git a/tests/examples/ghc80/T9951b.hs b/tests/examples/ghc80/T9951b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9951b.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T9951b where + +f :: String -> Bool +f "ab" = True diff --git a/tests/examples/ghc80/T9964.hs b/tests/examples/ghc80/T9964.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9964.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE UnboxedTuples #-} +module T9964 where + +import GHC.Base + +crash :: IO () +crash = IO (\s -> + let + {-# NOINLINE s' #-} + s' = s + in (# s', () #)) diff --git a/tests/examples/ghc80/T9968.hs b/tests/examples/ghc80/T9968.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9968.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-} + +module T9968 where + +class C a b +data X = X deriving (C Int) + diff --git a/tests/examples/ghc80/T9968a.hs b/tests/examples/ghc80/T9968a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9968a.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module T9968 where + +import Data.Bifunctor + +data Blah a b = A a | B b + deriving (Bifunctor) diff --git a/tests/examples/ghc80/T9973.hs b/tests/examples/ghc80/T9973.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9973.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fwarn-redundant-constraints #-} + +module T9973 where + +duplicateDecl :: (Eq t) => t -> IO () +-- Trac #9973 was a bogus "redundant constraint" here +duplicateDecl sigs + = do { newSpan <- return typeSig + + -- **** commenting out the next three lines causes the original warning to disappear + ; let rowOffset = case typeSig of { _ -> 1 } + + ; undefined } + where + typeSig = definingSigsNames sigs + + +definingSigsNames :: (Eq t) => t -> () +definingSigsNames x = undefined + where + _ = x == x -- Suppress the complaint on this + diff --git a/tests/examples/ghc80/T9975a.hs b/tests/examples/ghc80/T9975a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9975a.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} +module T9975a where + +data Test = Test { x :: Int } +pattern Test wat = Test { x = wat } + diff --git a/tests/examples/ghc80/T9975b.hs b/tests/examples/ghc80/T9975b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/T9975b.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} +module T9975b where + +data Test = Test { x :: Int } +pattern PTest wat = Test { x = wat } + diff --git a/tests/examples/ghc80/TH_abstractFamily.hs b/tests/examples/ghc80/TH_abstractFamily.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_abstractFamily.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module TH_abstractFamily where + +import Language.Haskell.TH + +-- Empty closed type families are okay... +ds1 :: Q [Dec] +ds1 = [d| type family F a where |] + +-- ...but abstract ones should result in a type error +ds2 :: Q [Dec] +ds2 = [d| type family G a where .. |] diff --git a/tests/examples/ghc80/TH_bracket1.hs b/tests/examples/ghc80/TH_bracket1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_bracket1.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- Check that declarations in a bracket shadow the top-level +-- declarations, rather than clashing with them. + +module TH_bracket1 where + +foo = 1 +bar = [d| foo = 1 |] diff --git a/tests/examples/ghc80/TH_bracket2.hs b/tests/examples/ghc80/TH_bracket2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_bracket2.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module TH_bracket2 where + +d_show = [d| data A = A + + instance Show A where + show _ = "A" + |] diff --git a/tests/examples/ghc80/TH_bracket3.hs b/tests/examples/ghc80/TH_bracket3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_bracket3.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module TH_bracket3 where + +d_class = [d| class Classy a b where + f :: a -> b + + instance Classy Int Bool where + f x = if x == 0 then True else False + |] diff --git a/tests/examples/ghc80/TH_finalizer.hs b/tests/examples/ghc80/TH_finalizer.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_finalizer.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} + +module ShouldCompile where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +$( do + addModFinalizer (do b <- getQ; reportWarning (show (b::Maybe Bool))) + return [] ) +$( putQ True >> return [] ) diff --git a/tests/examples/ghc80/TH_localname.hs b/tests/examples/ghc80/TH_localname.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_localname.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module TH_localname where + +x = \y -> [| y |] diff --git a/tests/examples/ghc80/TH_namePackage.hs b/tests/examples/ghc80/TH_namePackage.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_namePackage.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +eitherName, fooName, moduleFooName :: Name +eitherName = ''Either +fooName = mkName "foo" +moduleFooName = mkName "Module.foo" + +main :: IO () +main = do + print $ nameBase eitherName + print $ nameBase fooName + print $ nameBase moduleFooName + + print $ nameModule eitherName + print $ nameModule fooName + print $ nameModule moduleFooName + + print $ namePackage eitherName + print $ namePackage fooName + print $ namePackage moduleFooName diff --git a/tests/examples/ghc80/TH_nameSpace.hs b/tests/examples/ghc80/TH_nameSpace.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_nameSpace.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Data.Maybe (Maybe(..)) +import Data.Ord (Ord) +import Language.Haskell.TH (mkName, nameSpace) + +main :: IO () +main = mapM_ (print . nameSpace) + [ 'Prelude.id + , mkName "id" + , 'Data.Maybe.Just + , ''Data.Maybe.Maybe + , ''Data.Ord.Ord + ] diff --git a/tests/examples/ghc80/TH_ppr1.hs b/tests/examples/ghc80/TH_ppr1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_ppr1.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Main (main) where + +import Language.Haskell.TH + +u1 :: a +u1 = undefined + +u2 :: a +u2 = undefined + +f :: a +f = undefined + +(.+.) :: a +(.+.) = undefined + +main :: IO () +main = do runQ [| f u1 u2 |] >>= p + runQ [| u1 `f` u2 |] >>= p + runQ [| (.+.) u1 u2 |] >>= p + runQ [| u1 .+. u2 |] >>= p + runQ [| (:) u1 u2 |] >>= p + runQ [| u1 : u2 |] >>= p + runQ [| \((:) x xs) -> x |] >>= p + runQ [| \(x : xs) -> x |] >>= p + runQ [d| class Foo a b where + foo :: a -> b |] >>= p + runQ [| \x -> (x, 1 `x` 2) |] >>= p + runQ [| \(+) -> ((+), 1 + 2) |] >>= p + runQ [| (f, 1 `f` 2) |] >>= p + runQ [| ((.+.), 1 .+. 2) |] >>= p + +p :: Ppr a => a -> IO () +p = putStrLn . pprint + diff --git a/tests/examples/ghc80/TH_reifyType1.hs b/tests/examples/ghc80/TH_reifyType1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_reifyType1.hs @@ -0,0 +1,13 @@ +-- test reification of monomorphic types + +module TH_reifyType1 +where + +import Language.Haskell.TH + +foo :: Int -> Int +foo x = x + 1 + +type_foo :: InfoQ +type_foo = reify 'foo + diff --git a/tests/examples/ghc80/TH_reifyType2.hs b/tests/examples/ghc80/TH_reifyType2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_reifyType2.hs @@ -0,0 +1,9 @@ +-- test reification of polymorphic types + +module TH_reifyType1 +where + +import Language.Haskell.TH + +type_length :: InfoQ +type_length = reify 'length diff --git a/tests/examples/ghc80/TH_repE1.hs b/tests/examples/ghc80/TH_repE1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_repE1.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- test the representation of literals and also explicit type annotations + +module TH_repE1 +where + +import Language.Haskell.TH + +integralExpr :: ExpQ +integralExpr = [| 42 |] + +intExpr :: ExpQ +intExpr = [| 42 :: Int |] + +integerExpr :: ExpQ +integerExpr = [| 42 :: Integer |] + +charExpr :: ExpQ +charExpr = [| 'x' |] + +stringExpr :: ExpQ +stringExpr = [| "A String" |] + +fractionalExpr :: ExpQ +fractionalExpr = [| 1.2 |] + +floatExpr :: ExpQ +floatExpr = [| 1.2 :: Float |] + +doubleExpr :: ExpQ +doubleExpr = [| 1.2 :: Double |] diff --git a/tests/examples/ghc80/TH_repE3.hs b/tests/examples/ghc80/TH_repE3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_repE3.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- test the representation of literals and also explicit type annotations + +module TH_repE1 +where + +import Language.Haskell.TH + +emptyListExpr :: ExpQ +emptyListExpr = [| [] |] + +singletonListExpr :: ExpQ +singletonListExpr = [| [4] |] + +listExpr :: ExpQ +listExpr = [| [4,5,6] |] + +consExpr :: ExpQ +consExpr = [| 4:5:6:[] |] + diff --git a/tests/examples/ghc80/TH_scope.hs b/tests/examples/ghc80/TH_scope.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_scope.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- Test for Trac #2188 + +module TH_scope where + +f g = [d| f :: Int + f = g + g :: Int + g = 4 |] diff --git a/tests/examples/ghc80/TH_spliceE5_prof_ext.hs b/tests/examples/ghc80/TH_spliceE5_prof_ext.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_spliceE5_prof_ext.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module Main where + +import TH_spliceE5_prof_ext_Lib + +v1 = "foo" + +main = putStrLn $(expandVars ["v1","v2"]) +-- The splice expands to refer to both v1 and v2, +-- and the test checks that we don't dependency-analyse +-- the program so that one or the other isn't in scope +-- to the type checker + + +v2 = "bar" diff --git a/tests/examples/ghc80/TH_spliceE5_prof_ext_Lib.hs b/tests/examples/ghc80/TH_spliceE5_prof_ext_Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_spliceE5_prof_ext_Lib.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module TH_spliceE5_prof_ext_Lib where + +import Language.Haskell.TH + +expandVars :: [String] -> Q Exp +expandVars s = [| concat $(return (ListE (map f s))) |] + where + f x = VarE (mkName x) diff --git a/tests/examples/ghc80/TH_tf2.hs b/tests/examples/ghc80/TH_tf2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TH_tf2.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -- 'bar' is ambiguous + +module TH_tf2 where + +{- +$( [d| class C a where + data T a + foo :: Bool -> T a |] ) + +$( [d| instance C Int where + data T Int = TInt Bool + foo b = TInt (b && b) |] ) + +$( [d| instance C Float where + data T Float = TFloat {flag :: Bool} + foo b = TFloat {flag = b && b} |] ) +-} + +class D a where + type S a + bar :: S a -> Int + +instance D Int where + type S Int = Bool + bar c = if c then 1 else 2 diff --git a/tests/examples/ghc80/TcCustomSolverSuper.hs b/tests/examples/ghc80/TcCustomSolverSuper.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TcCustomSolverSuper.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +module TcCustomSolverSuper where + +import GHC.TypeLits +import Data.Typeable + +{- + +When solving super-class instances, GHC solves the evidence without +using the solver (see `tcSuperClasses` in `TcInstDecls`). + +However, some classes need to be excepted from this behavior, +as they have custom solving rules, and this test checks that +we got this right. +-} + + +class (Typeable x, KnownNat x) => C x +class (Typeable x, KnownSymbol x) => D x + +instance C 2 +instance D "2" + diff --git a/tests/examples/ghc80/Templates.hs b/tests/examples/ghc80/Templates.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Templates.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeFamilies, FlexibleInstances, OverlappingInstances, TypeOperators, PatternGuards #-} +module Object.Templates( + makeName, + makeObject, + makeObjectFlexible + ) where + +import Object.Letters +import Object.Types + +import Prelude hiding ((.)) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Data.Char +import Data.Maybe + +-- | +-- implements 'makeObject' or 'makeObjectFlexible' depending on the first argument +makeObject' :: Bool -> Name -> Q [Dec] +makeObject' flexible name = go name where + go :: Name -> Q [Dec] + go obj = do + (name, vars, fields) <- reify name >>= getInfo + let objType = foldl AppT (ConT name) (VarT<*vars) + outputDecls <- if flexible + then return [] + else [d| + type instance Output $(return objType) (Method m) = + MethodOutput $(return objType) (Method m) + type instance Output $(return objType) (Method m := input) = + MethodOutput $(return objType) (Method m := input) + |] + fieldDecls <- (sequence $ makeField name vars <* fields) *> concat + return $ outputDecls ++ fieldDecls +-- "(Object.Example.Foo,[x_1627454179],[(Object.Example._bar,NotStrict,ConT GHC.Types.Int),(Object.Example._baz,NotStrict,ConT GHC.Types.Char),(Object.Example._blub,NotStrict,VarT x_1627454179)])" + makeField :: Name -> [Name] -> VarStrictType -> Q [Dec] + makeField _ _ (name,_,_) | '_' /= head (nameBase name) = fail $ show name ++ " did not start with underscore" + makeField name vars (fName, _, fType) = do + (decs1,(typeName,dataName)) <- makeName' (tail $ nameBase fName) + methodOutput <- lookupTypeName "Object.Types.MethodOutput" *> fromMaybe (error "no MethodOutput in scope") + let objType = foldl AppT (ConT name) (VarT<*vars) + + let methodOutInst = TySynInstD methodOutput $ TySynEqn [objType, ConT typeName] fType + actionInst <- [d| + instance Action $(return objType) $(return $ ConT typeName) where + object . _ = $(return $ VarE fName) object + |] + + matchType <- [t| $(return $ ConT typeName) := $(return $ VarT $ mkName "value") |] + let methodSetOutInst = TySynInstD methodOutput $ TySynEqn [objType, matchType] objType + actionSetInst <- [d| + instance (value ~ $(return fType)) => Action $(return objType) $(return matchType) where + object . ( _ := v) = $(recUpdE [e|object|] [return (fName, VarE $ mkName "v")]) + |] + + return $ [methodOutInst,methodSetOutInst] ++ actionInst ++ actionSetInst ++ decs1 + diff --git a/tests/examples/ghc80/Test.hs b/tests/examples/ghc80/Test.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE QuasiQuotes #-} +module Test where + +import QQ + +f' = f . (+ 1) + +[pq| foo |] -- Expands to f :: Int -> Int +f x = x + 1 diff --git a/tests/examples/ghc80/Test10255.hs b/tests/examples/ghc80/Test10255.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10255.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Test10255 where + +import Data.Maybe + +fob (f :: (Maybe t -> Int)) = + undefined diff --git a/tests/examples/ghc80/Test10268.hs b/tests/examples/ghc80/Test10268.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10268.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell,TypeOperators,DataKinds #-} + +module Test10268 where + +th = $footemplate + +give :: b -> Pattern '[b] a +give = undefined + +pfail :: Pattern '[] a +pfail = undefined diff --git a/tests/examples/ghc80/Test10269.hs b/tests/examples/ghc80/Test10269.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10269.hs @@ -0,0 +1,4 @@ +module Test10269 where + + +(f =*= g) sa i = undefined diff --git a/tests/examples/ghc80/Test10276.hs b/tests/examples/ghc80/Test10276.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10276.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test10276 where + +f1 = [| bar |] +f2 = [e| bar |] + +class QQExp a b where + qqExp x = [||fst $ runState $$(qqExpM x) + ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] + +class QQExp2 a b where + qqExp x = [e||fst $ runState $$(qqExpM x) + ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] diff --git a/tests/examples/ghc80/Test10278.hs b/tests/examples/ghc80/Test10278.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10278.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ScopedTypeVariables,GADTs #-} +module Test10278 where + +extremumNewton :: forall tag. forall tag1. tag -> tag1 -> Int +extremumNewton = undefined + +extremumNewton1 :: (Eq a, Fractional a) => + (forall tag. forall tag1. + Tower tag1 (Tower tag a) + -> Tower tag1 (Tower tag a)) + -> a -> [a] +extremumNewton1 f x0 = zeroNewton (diffUU f) x0 + +data MaybeDefault v where + SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v + SetTo2:: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v + SetTo3 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v + {- + SetTo4 :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a]) + -} diff --git a/tests/examples/ghc80/Test10280.hs b/tests/examples/ghc80/Test10280.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10280.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TupleSections #-} +module Test10280 where + +foo2 = atomicModifyIORef ciTokens ((,()) . f) diff --git a/tests/examples/ghc80/Test10307.hs b/tests/examples/ghc80/Test10307.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10307.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module Test10307 where + +class Foldable t where + type FoldableConstraint t x :: * + type FoldableConstraint t x = () diff --git a/tests/examples/ghc80/Test10309.hs b/tests/examples/ghc80/Test10309.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10309.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE GADTs #-} +module Test10309 where + +data H1 a b where + C3 :: (Num a) => { field :: a -- ^ hello docs + } -> H1 Int Int diff --git a/tests/examples/ghc80/Test10312.hs b/tests/examples/ghc80/Test10312.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10312.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ParallelListComp, + TransformListComp, + RecordWildCards #-} +module Test10312 where +-- From +-- https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html + +import GHC.Exts +import qualified Data.Map as M +import Data.Ord (comparing) +import Data.List (sortBy) + +-- Let’s look at a simple, normal list comprehension to start: + +regularListComp :: [Int] +regularListComp = [ x + y * z + | x <- [0..10] + , y <- [10..20] + , z <- [20..30] + ] + +parallelListComp :: [Int] +parallelListComp = [ x + y * z + | x <- [0..10] + | y <- [10..20] + | z <- [20..30] + ] + +-- fibs :: [Int] +-- fibs = 0 : 1 : zipWith (+) fibs (tail fibs) + +fibs :: [Int] +fibs = 0 : 1 : [ x + y + | x <- fibs + | y <- tail fibs + ] + +fiblikes :: [Int] +fiblikes = 0 : 1 : [ x + y + z + | x <- fibs + | y <- tail fibs + | z <- tail (tail fibs) + ] + +-- TransformListComp +data Character = Character + { firstName :: String + , lastName :: String + , birthYear :: Int + } deriving (Show, Eq) + +friends :: [Character] +friends = [ Character "Phoebe" "Buffay" 1963 + , Character "Chandler" "Bing" 1969 + , Character "Rachel" "Green" 1969 + , Character "Joey" "Tribbiani" 1967 + , Character "Monica" "Geller" 1964 + , Character "Ross" "Geller" 1966 + ] + +oldest :: Int -> [Character] -> [String] +oldest k tbl = [ firstName ++ " " ++ lastName + | Character{..} <- tbl + , then sortWith by birthYear + , then take k + ] + +groupByLargest :: Ord b => (a -> b) -> [a] -> [[a]] +groupByLargest f = sortBy (comparing (negate . length)) . groupWith f + +bestBirthYears :: [Character] -> [(Int, [String])] +bestBirthYears tbl = [ (the birthYear, firstName) + | Character{..} <- tbl + , then group by birthYear using groupByLargest + ] + +uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs + , let d' = ppDir d + , then group by Down (p,d') using groupWith ] diff --git a/tests/examples/ghc80/Test10313.hs b/tests/examples/ghc80/Test10313.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10313.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE MagicHash, UnliftedFFITypes #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Test10313 where + +import "b\x61se" Data.List + +{-# WARNING Logic + , solverCheckAndGetModel + "New Z3 API support is still incomplete and fragile: \ + \you may experience segmentation faults!" + #-} + +{-# Deprecated Logic + , solverCheckAndGetModel + "Deprecation: \ + \you may experience segmentation faults!" + #-} + +data {-# Ctype "foo\x63" "b\x61r" #-} Logic = Logic + +-- Should warn +foo1 x = x +{-# RULES "foo1\x67" [ 1] forall x. foo1 x = x #-} + +foreign import prim unsafe "a\x62" a :: IO Int + +{-# INLINE strictStream #-} +strictStream (Bitstream l v) + = {-# CORE "Strict Bitstream stre\x61m" #-} + S.concatMap stream (GV.stream v) + `S.sized` + Exact l + +b = {-# SCC "foo\x64" #-} 006 + +c = {-# GENERATED "foob\x61r" 1 : 2 - 3 : 4 #-} 0.00 diff --git a/tests/examples/ghc80/Test10354.hs b/tests/examples/ghc80/Test10354.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10354.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module Test10354 where + +f :: ((Eq a, _)) => a -> a -> Bool +f x y = x == y + +bar :: ( ) => a-> Bool +bar = undefined + +baz :: _ => a -> String +baz = undefined + +foo :: ForceError +foo = undefined diff --git a/tests/examples/ghc80/Test10357.hs b/tests/examples/ghc80/Test10357.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10357.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ParallelListComp #-} +module Test10357 where + +legendres = one : x : + [ multPoly + (poly LE [recip (n' + 1)]) + (addPoly (poly LE [0, 2 * n' + 1] `multPoly` p_n) + (poly LE [-n'] `multPoly` p_nm1) + ) + | n <- [1..], let n' = fromInteger n + | p_n <- tail legendres + | p_nm1 <- legendres + ] diff --git a/tests/examples/ghc80/Test10358.hs b/tests/examples/ghc80/Test10358.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10358.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE BangPatterns #-} +module Test10358 where + +mtGamma x v d = + let !x_2 = x*x; !x_4 = x_2*x_2 + v3 = v*v*v + dv = d * v3 + in 5 diff --git a/tests/examples/ghc80/Test10396.hs b/tests/examples/ghc80/Test10396.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10396.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Test10396 where + +errors :: IO () +errors= do + let ls :: Int = undefined + return () diff --git a/tests/examples/ghc80/Test10399.hs b/tests/examples/ghc80/Test10399.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test10399.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +module Test10399 where + +type MPI = ?mpi_secret :: MPISecret + +mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) + +data MaybeDefault v where + SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v + SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v + -> a -> MaybeDefault [a]) + +[t| Map.Map T.Text $tc |] + +bar $( [p| x |] ) = x diff --git a/tests/examples/ghc80/Test11018.hs b/tests/examples/ghc80/Test11018.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Test11018.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Test11018 where + +nonUnicode :: forall a . a -> IO Int +nonUnicode _ = do + x <- readChar + return 4 + +-- ^ An opaque ESD handle for recording data from the soundcard via ESD. +data Recorder fr ch (r ∷ * -> *) + = Recorder { + reCloseH :: !(FinalizerHandle r) + } + +f :: Arrow a => a (Int,Int,Int) Int +f = proc (x,y,z) -> returnA -< x+y + +f2 :: Arrow a => a (Int,Int,Int) Int +f2 = proc (x,y,z) -> returnA >- x+y + +g :: ArrowApply a => Int -> a (a Int Int,Int) Int +g y = proc (x,z) -> x -<< 2+y + +g2 :: ArrowApply a => Int -> a (a Int Int,Int) Int +g2 y = proc (x,z) -> x >>- 2+y + +-- ------------------------------------- + +unicode ∷ ∀ a . a → IO Int +unicode _ = do + x ← readChar + return 4 + +-- ^ An opaque ESD handle for recording data from the soundcard via ESD. +data RecorderU fr ch (r ∷ ★ → ★) + = RecorderU { + reCloseHU ∷ !(FinalizerHandle r) + } + +fU :: Arrow a ⇒ a (Int,Int,Int) Int +fU = proc (x,y,z) -> returnA ⤙ x+y + +f2U :: Arrow a ⇒ a (Int,Int,Int) Int +f2U = proc (x,y,z) -> returnA ⤚ x+y + +gU :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int +gU y = proc (x,z) -> x ⤛ 2+y + +g2U :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int +g2U y = proc (x,z) -> x ⤜ 2+y diff --git a/tests/examples/ghc80/TestBoolFormula.hs b/tests/examples/ghc80/TestBoolFormula.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TestBoolFormula.hs @@ -0,0 +1,36 @@ +module TestBoolFormula where + +class ManyOps a where + aOp :: a -> a -> Bool + aOp = undefined + bOp :: a -> a -> Bool + bOp = undefined + cOp :: a -> a -> Bool + cOp = undefined + dOp :: a -> a -> Bool + dOp = undefined + eOp :: a -> a -> Bool + eOp = undefined + fOp :: a -> a -> Bool + fOp = undefined + {-# MINIMAL ( aOp) + | ( bOp , cOp) + | ((dOp | eOp) , fOp) + #-} + +class Foo a where + bar :: a -> a -> Bool + foo :: a -> a -> Bool + baq :: a -> a -> Bool + baq = undefined + baz :: a -> a -> Bool + baz = undefined + quux :: a -> a -> Bool + quux = undefined + {-# MINIMAL bar, (foo, baq | foo, quux) #-} + +instance Foo Int where + bar = undefined + baz = undefined + quux = undefined + foo = undefined diff --git a/tests/examples/ghc80/TestUtils.hs b/tests/examples/ghc80/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TestUtils.hs @@ -0,0 +1,5 @@ + +module Math.NumberTheory.TestUtils where + +class (f `Compose` g) x + diff --git a/tests/examples/ghc80/Trac10045.hs b/tests/examples/ghc80/Trac10045.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Trac10045.hs @@ -0,0 +1,8 @@ +module Trac10045 where + +newtype Meta = Meta () + +foo (Meta ws1) = + let copy :: _ + copy w from = copy w 1 + in copy ws1 1 diff --git a/tests/examples/ghc80/TransAssociated.hs b/tests/examples/ghc80/TransAssociated.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TransAssociated.hs @@ -0,0 +1,9 @@ +module TransAssociated(A(..)) where + +import Associated (A(..)) + +foo = MkA 5 +baz = NoA + +qux (MkA x) = x +qux NoA = 0 diff --git a/tests/examples/ghc80/TransBundle.hs b/tests/examples/ghc80/TransBundle.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TransBundle.hs @@ -0,0 +1,9 @@ +module TransAssociated(A(..)) where + +import Bundle (A(..)) + +foo = MkA 5 +baz = NoA + +qux (MkA x) = x +qux NoA = 0 diff --git a/tests/examples/ghc80/TypeFamilyInstanceLHS.hs b/tests/examples/ghc80/TypeFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TypeFamilyInstanceLHS.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} +module TypeFamilyInstanceLHS where + +type family F (a :: *) (b :: *) :: * +type instance F Int _ = Int +type instance F Bool _ = Bool + +foo :: F Int Char -> Int +foo = id diff --git a/tests/examples/ghc80/TypeLevelVec.hs b/tests/examples/ghc80/TypeLevelVec.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TypeLevelVec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeInType, UnicodeSyntax, GADTs, NoImplicitPrelude, + TypeOperators, TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + +module TypeLevelVec where + +import Data.Kind + +data ℕ ∷ Type where + O ∷ ℕ + S ∷ ℕ → ℕ + +type family x + y where + O + n = n + S m + n = S (m + n) +infixl 5 + + +data Vec ∷ ℕ → Type → Type where + Nil ∷ Vec O a + (:>) ∷ a → Vec n a → Vec (S n) a +infixr 8 :> + +type family (x ∷ Vec n a) ++ (y ∷ Vec m a) ∷ Vec (n + m) a where + Nil ++ y = y + (x :> xs) ++ y = x :> (xs ++ y) +infixl 5 ++ diff --git a/tests/examples/ghc80/TypeSkolEscape.hs b/tests/examples/ghc80/TypeSkolEscape.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TypeSkolEscape.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes, PolyKinds, TypeInType #-} + +module TypeSkolEscape where + +import GHC.Types +import GHC.Exts + +type Bad = forall (v :: Levity) (a :: TYPE v). a diff --git a/tests/examples/ghc80/TypedSplice.hs b/tests/examples/ghc80/TypedSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/TypedSplice.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE PartialTypeSignatures #-} +module TypedSplice where + +import Language.Haskell.TH + +metaExp :: Q (TExp (Bool -> Bool)) +metaExp = [|| not :: _ -> _b ||] diff --git a/tests/examples/ghc80/UnicodeRules.hs b/tests/examples/ghc80/UnicodeRules.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/UnicodeRules.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE + BangPatterns + , FlexibleContexts + , FlexibleInstances + , ScopedTypeVariables + , UnboxedTuples + , UndecidableInstances + , UnicodeSyntax + #-} + +strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool +{-# RULES "head → strictHead" [1] + ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). + head v = strictHead v #-} +{-# INLINE strictHead #-} +strictHead (Bitstream _ v) = head (SV.head v) diff --git a/tests/examples/ghc80/UnicodeSyntax.hs b/tests/examples/ghc80/UnicodeSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/UnicodeSyntax.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE Arrows #-} + +module Tutorial where + +-- import Abt.Class +-- import Abt.Types +-- import Abt.Concrete.LocallyNameless + +import Control.Applicative +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Except +-- import Data.Vinyl +import Prelude hiding (pi) + +-- | We'll start off with a monad in which to manipulate ABTs; we'll need some +-- state for fresh variable generation. +-- +newtype M α + = M + { _M ∷ State Int α + } deriving (Functor, Applicative, Monad) + +-- | We'll run an ABT computation by starting the variable counter at @0@. +-- +runM ∷ M α → α +runM (M m) = evalState m 0 + +-- | Check out the source to see fresh variable generation. +-- +instance MonadVar Var M where + fresh = M $ do + n ← get + let n' = n + 1 + put n' + return $ Var Nothing n' + + named a = do + v ← fresh + return $ v { _varName = Just a } + +-- | Next, we'll define the operators for a tiny lambda calculus as a datatype +-- indexed by arities. +-- +data Lang ns where + LAM ∷ Lang '[S Z] + APP ∷ Lang '[Z, Z] + PI ∷ Lang '[Z, S Z] + UNIT ∷ Lang '[] + AX ∷ Lang '[] + +instance Show1 Lang where + show1 = \case + LAM → "lam" + APP → "ap" + PI → "pi" + UNIT → "unit" + AX → "<>" + +instance HEq1 Lang where + heq1 LAM LAM = Just Refl + heq1 APP APP = Just Refl + heq1 PI PI = Just Refl + heq1 UNIT UNIT = Just Refl + heq1 AX AX = Just Refl + heq1 _ _ = Nothing + +lam ∷ Tm Lang (S Z) → Tm0 Lang +lam e = LAM $$ e :& RNil + +app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang +app m n = APP $$ m :& n :& RNil + +ax ∷ Tm0 Lang +ax = AX $$ RNil + +unit ∷ Tm0 Lang +unit = UNIT $$ RNil + +pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang +pi α xβ = PI $$ α :& xβ :& RNil + +-- | A monad transformer for small step operational semantics. +-- +newtype StepT m α + = StepT + { runStepT ∷ MaybeT m α + } deriving (Monad, Functor, Applicative, Alternative) + +-- | To indicate that a term is in normal form. +-- +stepsExhausted + ∷ Applicative m + ⇒ StepT m α +stepsExhausted = StepT . MaybeT $ pure Nothing + +instance MonadVar Var m ⇒ MonadVar Var (StepT m) where + fresh = StepT . MaybeT $ Just <$> fresh + named str = StepT . MaybeT $ Just <$> named str + +-- | A single evaluation step. +-- +step + ∷ Tm0 Lang + → StepT M (Tm0 Lang) +step tm = + out tm >>= \case + APP :$ m :& n :& RNil → + out m >>= \case + LAM :$ xe :& RNil → xe // n + _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n + PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ + _ → stepsExhausted + +-- | The reflexive-transitive closure of a small-step operational semantics. +-- +star + ∷ Monad m + ⇒ (α → StepT m α) + → (α → m α) +star f a = + runMaybeT (runStepT $ f a) >>= + return a `maybe` star f + +-- | Evaluate a term to normal form +-- +eval ∷ Tm0 Lang → Tm0 Lang +eval = runM . star step + +newtype JudgeT m α + = JudgeT + { runJudgeT ∷ ExceptT String m α + } deriving (Monad, Functor, Applicative, Alternative) + +instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where + fresh = JudgeT . ExceptT $ Right <$> fresh + named str = JudgeT . ExceptT $ Right <$> named str + +type Ctx = [(Var, Tm0 Lang)] + +raise ∷ Monad m ⇒ String → JudgeT m α +raise = JudgeT . ExceptT . return . Left + +checkTy + ∷ Ctx + → Tm0 Lang + → Tm0 Lang + → JudgeT M () +checkTy g tm ty = do + let ntm = eval tm + nty = eval ty + (,) <$> out ntm <*> out nty >>= \case + (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do + z ← fresh + ez ← xe // var z + βz ← yβ // var z + checkTy ((z,α):g) ez βz + (AX :$ RNil, UNIT :$ RNil) → return () + _ → do + ty' ← inferTy g tm + if ty' === nty + then return () + else raise "Type error" + +inferTy + ∷ Ctx + → Tm0 Lang + → JudgeT M (Tm0 Lang) +inferTy g tm = do + out (eval tm) >>= \case + V v | Just (eval → ty) ← lookup v g → return ty + | otherwise → raise "Ill-scoped variable" + APP :$ m :& n :& RNil → do + inferTy g m >>= out >>= \case + PI :$ α :& xβ :& RNil → do + checkTy g n α + eval <$> xβ // n + _ → raise "Expected pi type for lambda abstraction" + _ → raise "Only infer neutral terms" + +-- | @λx.x@ +-- +identityTm ∷ M (Tm0 Lang) +identityTm = do + x ← fresh + return $ lam (x \\ var x) + +-- | @(λx.x)(λx.x)@ +-- +appTm ∷ M (Tm0 Lang) +appTm = do + tm ← identityTm + return $ app tm tm + +-- | A demonstration of evaluating (and pretty-printing). Output: +-- +-- @ +-- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4] +-- @ +-- +main ∷ IO () +main = do + -- Try out the type checker + either fail print . runM . runExceptT . runJudgeT $ do + x ← fresh + checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit)) + + print . runM $ do + mm ← appTm + mmStr ← toString mm + mmStr' ← toString $ eval mm + return $ mmStr ++ " ~>* " ++ mmStr' + +doMap ∷ FilePath → IOSArrow XmlTree TiledMap +doMap mapPath = proc m → do + mapWidth ← getAttrR "width" ⤙ m + returnA -< baz + +-- ^ An opaque ESD handle for recording data from the soundcard via ESD. +data Recorder fr ch (r ∷ ★ → ★) + = Recorder { + reRate ∷ !Int + , reHandle ∷ !Handle + , reCloseH ∷ !(FinalizerHandle r) + } + +-- from ghc-prim + +-- | A backward-compatible (pre-GHC 8.0) synonym for 'Type' +type * = TYPE 'PtrRepLifted + +-- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type' +type ★ = TYPE 'PtrRepLifted diff --git a/tests/examples/ghc80/Vta1.hs b/tests/examples/ghc80/Vta1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Vta1.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE TypeApplications, ScopedTypeVariables, PolyKinds, + TypeFamilies, RankNTypes, + FlexibleContexts #-} +-- tests about visible type application + +module Vta1 where + +quad :: a -> b -> c -> d -> (a, b, c, d) +quad = (,,,) + +silly = quad @_ @Bool @Char @_ 5 True 'a' "Hello" + +pairup_nosig x y = (x, y) + +pairup_sig :: a -> b -> (a,b) +pairup_sig u w = (u, w) + +answer_sig = pairup_sig @Bool @Int False 7 -- +-- (False, 7) :: (Bool, Int) + +answer_read = show (read @Int "3") -- "3" :: String +answer_show = show @Integer (read "5") -- "5" :: String +answer_showread = show @Int (read @Int "7") -- "7" :: String + +intcons a = (:) @Int a + +intpair x y = pairup_sig @Int x y + +answer_pairup = pairup_sig @Int 5 True -- (5, True) :: (Int, Bool) +answer_intpair = intpair 1 "hello" -- (1, "hello") :: (Int, String) +answer_intcons = intcons 7 [] -- [7] :: [Int] + +type family F a +type instance F Char = Bool + +g :: F a -> a +g _ = undefined + +f :: Char +f = g True + +answer = g @Char False + +mapSame :: forall b. (forall a. a -> a) -> [b] -> [b] +mapSame _ [] = [] +mapSame fun (x:xs) = fun @b x : (mapSame @b fun xs) + +pair :: forall a. a-> (forall b. b -> (a, b)) +pair x y = (x, y) + +b = pair @Int 3 @Bool True +c = mapSame id [1,2,3] +d = pair 3 @Bool True + +pairnum :: forall a. Num a => forall b. b -> (a, b) +pairnum = pair 3 + +e = (pair 3 :: forall a. Num a => forall b. b -> (a, b)) @Int @Bool True +h = pairnum @Int @Bool True + +data First (a :: * -> *) = F +data Proxy (a :: k) = P -- This expands to P (kind variable) (type variable) +data Three (a :: * -> k -> *) = T + +foo :: Proxy a -> Int +foo _ = 0 + +first :: First a -> Int +first _ = 0 + +fTest = first F +fMaybe = first @Maybe F + +test = foo P +bar = foo @Bool P -- should work + +too :: Three a -> Int +too _ = 3 + +threeBase = too T +threeOk = too @Either T + +blah = Nothing @Int + +newtype N = MkN { unMkN :: forall a. Show a => a -> String } + +n = MkN show + +boo = unMkN n @Bool + +boo2 :: forall (a :: * -> *) . Proxy a -> Bool +boo2 _ = False + +base = boo2 P +bar'= boo2 @Maybe P -- should work diff --git a/tests/examples/ghc80/Vta2.hs b/tests/examples/ghc80/Vta2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Vta2.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE RankNTypes, TypeApplications #-} + + +module Vta2 where + +checkIf :: Bool -> (forall a. a -> a) -> (Bool, Int) +checkIf _ = if True + then \f -> (f True, f 5) + else \f -> (f False, f @Int 3) + +checkCase :: Bool -> (forall a. a -> a) -> (Bool, Int) +checkCase _ = case True of + True -> \f -> (f True, f 5) + False -> \f -> (f False, f @Int 3) diff --git a/tests/examples/ghc80/WCompatWarningsNotOn.hs b/tests/examples/ghc80/WCompatWarningsNotOn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/WCompatWarningsNotOn.hs @@ -0,0 +1,26 @@ +-- Test purpose: +-- Ensure that not using -Wcompat does not enable its warnings + +-- {-# OPTIONS_GHC -Wcompat #-} +-- {-# OPTIONS_GHC -Wno-compat #-} + +module WCompatWarningsNotOn where + +import qualified Data.Semigroup as Semi + +monadFail :: Monad m => m a +monadFail = do + Just _ <- undefined + undefined + +(<>) = undefined -- Semigroup warnings + +-- -fwarn-noncanonical-monoid-instances +newtype S = S Int + +instance Semi.Semigroup S where + (<>) = mappend + +instance Semi.Monoid S where + S a `mappend` S b = S (a+b) + mempty = S 0 diff --git a/tests/examples/ghc80/WCompatWarningsOff.hs b/tests/examples/ghc80/WCompatWarningsOff.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/WCompatWarningsOff.hs @@ -0,0 +1,26 @@ +-- Test purpose: +-- Ensure that using -Wno-compat does not switch on warnings + +-- {-# OPTIONS_GHC -Wcompat #-} +{-# OPTIONS_GHC -Wno-compat #-} + +module WCompatWarningsOff where + +import qualified Data.Semigroup as Semi + +monadFail :: Monad m => m a +monadFail = do + Just _ <- undefined + undefined + +(<>) = undefined -- Semigroup warnings + +-- -fwarn-noncanonical-monoid-instances +newtype S = S Int + +instance Semi.Semigroup S where + (<>) = mappend + +instance Semi.Monoid S where + S a `mappend` S b = S (a+b) + mempty = S 0 diff --git a/tests/examples/ghc80/WCompatWarningsOn.hs b/tests/examples/ghc80/WCompatWarningsOn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/WCompatWarningsOn.hs @@ -0,0 +1,26 @@ +-- Test purpose: +-- Ensure that -Wcompat switches on the right warnings + +{-# OPTIONS_GHC -Wcompat #-} +-- {-# OPTIONS_GHC -Wno-compat #-} + +module WCompatWarningsOn where + +import qualified Data.Semigroup as Semi + +monadFail :: Monad m => m a +monadFail = do + Just _ <- undefined + undefined + +(<>) = undefined -- Semigroup warnings + +-- -fwarn-noncanonical-monoid-instances +newtype S = S Int + +instance Semi.Semigroup S where + (<>) = mappend + +instance Semi.Monoid S where + S a `mappend` S b = S (a+b) + mempty = S 0 diff --git a/tests/examples/ghc80/WCompatWarningsOnOff.hs b/tests/examples/ghc80/WCompatWarningsOnOff.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/WCompatWarningsOnOff.hs @@ -0,0 +1,26 @@ +-- Test purpose: +-- Ensure that -Wno-compat disables a previously set -Wcompat + +{-# OPTIONS_GHC -Wcompat #-} +{-# OPTIONS_GHC -Wno-compat #-} + +module WCompatWarningsOnOff where + +import qualified Data.Semigroup as Semi + +monadFail :: Monad m => m a +monadFail = do + Just _ <- undefined + undefined + +(<>) = undefined -- Semigroup warnings + +-- -fwarn-noncanonical-monoid-instances +newtype S = S Int + +instance Semi.Semigroup S where + (<>) = mappend + +instance Semi.Monoid S where + S a `mappend` S b = S (a+b) + mempty = S 0 diff --git a/tests/examples/ghc80/Webhook.hs b/tests/examples/ghc80/Webhook.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Webhook.hs @@ -0,0 +1,176 @@ +{-| +Module : Servant.GitHub.Webhook +Description : Easily write safe GitHub webhook handlers with Servant +Copyright : (c) Jacob Thomas Errington, 2016 +License : MIT +Maintainer : servant-github-webhook@mail.jerrington.me +Stability : experimental + +The GitHub webhook machinery will attach three headers to the HTTP requests +that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@. +The former two headers correspond with the 'GitHubEvent' and +'GitHubSignedReqBody''' routing combinators. This library ignores the +@X-Github-Delivery@ header; if you would like to access its value, then use the +builtin 'Header' combinator from Servant. + +Usage of the library is straightforward: protect routes with the 'GitHubEvent' +combinator to ensure that the route is only reached for specific +'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write +under that route with 'GitHubSignedReqBody'. It is advised to always include a +'GitHubSignedReqBody''', as this is the only way you can be sure that it is +GitHub who is sending the request, and not a malicious user. If you don't care +about the request body, then simply use Aeson\'s 'Object' type as the +deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and +ignore the @Object@ in the handler. + +The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in +order to extract the signing key. This is the same key that must be entered in +the configuration of the webhook on GitHub. See 'GitHubKey'' for more details. + +In order to support multiple keys on a per-route basis, the basic combinator +@GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this, +create a datatype, e.g. @KeyIndex@ whose constructors identify the different +keys you will be using. Generally, this means one constructor per repository. +Use the @DataKinds@ extension to promote this datatype to a kind, and write an +instance of 'Reflect' for each promoted constructor of your datatype. Finally, +create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is +the datatype you've built up. Thus, your function can determine which key to +retrieve. +-} + +{-# LANGUAGE CPP #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- GHC 8 seems to have improved its decidability check for type family +-- instances and class instances. In particular, without UndecidableInstances +-- enabled, the Demote' instance for lists, which we need, will not compile. +-- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol, +-- won't compile on GHC < 8 because the instance head is no smaller than the +-- instance head. +#if __GLASGOW_HASKELL__ < 800 +{-# LANGUAGE UndecidableInstances #-} +#endif + +module Servant.GitHub.Webhook +( -- * Servant combinators + GitHubSignedReqBody'' +, GitHubSignedReqBody' +, GitHubSignedReqBody +, GitHubEvent + + -- ** Security +, GitHubKey'(..) +, GitHubKey +, gitHubKey + + -- * Reexports + -- + -- | We reexport a few datatypes that are typically needed to use the + -- library. +, RepoWebhookEvent(..) +, KProxy(..) + + -- * Implementation details + + -- ** Type-level programming machinery +, Demote +, Demote' +, Reflect(..) + + -- ** Stringy stuff +, parseHeaderMaybe +, matchEvent + + -- * Examples + -- + -- $example1 + -- + -- $example2 +) where + +import Control.Monad.IO.Class ( liftIO ) +import Data.Aeson ( decode', encode ) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy ( fromStrict, toStrict ) +import qualified Data.ByteString.Base16 as B16 +import Data.HMAC ( hmac_sha1 ) +import Data.List ( intercalate ) +import Data.Maybe ( catMaybes, fromMaybe ) +import Data.Monoid ( (<>) ) +import Data.Proxy +import Data.String.Conversions ( cs ) +import qualified Data.Text.Encoding as E +import GHC.TypeLits +import GitHub.Data.Webhooks +import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Wai ( requestHeaders, strictRequestBody ) +import Servant +import Servant.API.ContentTypes ( AllCTUnrender(..) ) +import Servant.Server.Internal + + +-- | A clone of Servant's 'ReqBody' combinator, except that it will also +-- verify the signature provided by GitHub in the @X-Hub-Signature@ header by +-- computing the SHA1 HMAC of the request body and comparing. +-- +-- The use of this combinator will require that the router context contain an +-- appropriate 'GitHubKey'' entry. Specifically, the type parameter of +-- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the +-- index @key@ used here. Consequently, it will be necessary to use +-- 'serveWithContext' instead of 'serve'. +-- +-- Other routes are not tried upon the failure of this combinator, and a 401 +-- response is generated. +-- +-- Use of this datatype directly is discouraged, since the choice of the index +-- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use +-- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just +-- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for +-- the implementation of the 'HasServer' instance for the datatype. +data GitHubSignedReqBody'' + (proxy :: KProxy k) + (key :: k) + (list :: [*]) + (result :: *) where + +-- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first +-- type argument given just the second one. +-- +-- Use this type synonym if you are creating a webhook server to handle +-- webhooks from multiple repositories, with different secret keys. +type GitHubSignedReqBody' (key :: k) + = GitHubSignedReqBody'' ('KProxy :: KProxy k) key + +-- | A convenient alias for a trivial key index. +-- +-- USe this type synonym if you are creating a webhook server to handle only +-- webhooks from a single repository, or for mutliple repositories using the +-- same secret key. +type GitHubSignedReqBody = GitHubSignedReqBody' '() + +-- | A routing combinator that succeeds only for a webhook request that matches +-- one of the given 'RepoWebhookEvent' given in the type-level list @events@. +-- +-- If the list contains 'WebhookWildcardEvent', then all events will be +-- matched. +-- +-- The combinator will require that its associated handler take a +-- 'RepoWebhookEvent' parameter, and the matched event will be passed to the +-- handler. This allows the handler to determine which event triggered it from +-- the list. +-- +-- Other routes are tried if there is a mismatch. +data GitHubEvent (events :: [RepoWebhookEvent]) where + diff --git a/tests/examples/ghc80/ado001.hs b/tests/examples/ghc80/ado001.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ado001.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo #-} +module Main where + +import Control.Applicative +import Text.PrettyPrint + +(a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..] + +-- a | b +test1 :: M () +test1 = do + x1 <- a + x2 <- b + const (return ()) (x1,x2) + +-- no parallelism +test2 :: M () +test2 = do + x1 <- a + x2 <- const g x1 + const (return ()) (x1,x2) + +-- a | (b;g) | e +test3 :: M () +test3 = do + x1 <- a + x2 <- b + x3 <- const g x2 + x4 <- e + return () `const` (x1,x2,x3,x4) + +-- (a ; (b | g)) | c +-- or +-- ((a | b); g) | c +test4 :: M () +test4 = do + x1 <- a + x2 <- b + x3 <- const g x1 + x4 <- c + return () `const` (x2,x3,x4) + +-- (a | b | c); (g | h) +test5 :: M () +test5 = do + x1 <- a + x2 <- b + x3 <- c + x4 <- const g x1 + x5 <- const h x3 + return () `const` (x3,x4,x5) + +-- b/c in parallel, e/f in parallel +-- a; (b | (c; (d; (e | (f; g))))) +test6 :: M () +test6 = do + x1 <- a + x2 <- const b x1 + x3 <- const c x1 + x4 <- const d x3 + x5 <- const e x4 + x6 <- const f x4 + x7 <- const g x6 + return () `const` (x1,x2,x3,x4,x5,x6,x7) + +-- (a | b); (c | d) +test7 :: M () +test7 = do + x1 <- a + x2 <- b + x3 <- const c x1 + x4 <- const d x2 + return () `const` (x3,x4) + +-- a; (b | c | d) +-- +-- alternative (but less good): +-- ((a;b) | c); d +test8 :: M () +test8 = do + x1 <- a + x2 <- const b x1 + x3 <- c + x4 <- const d x1 + return () `const` (x2,x3,x4) + +-- test that Lets don't get in the way +-- ((a | (b; c)) | d) | e +test9 :: M () +test9 = do + x1 <- a + let x = doc "x" -- this shouldn't get in the way of grouping a/b + x2 <- b + x3 <- const c x2 + x4 <- d + x5 <- e + let y = doc "y" + return () + +-- ((a | b) ; (c | d)) | e +test10 :: M () +test10 = do + x1 <- a + x2 <- b + let z1 = (x1,x2) + x3 <- const c x1 + let z2 = (x1,x2) + x4 <- const d z1 + x5 <- e + return (const () (x3,x4,x5)) + +main = mapM_ run + [ test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + ] + +-- Testing code, prints out the structure of a monad/applicative expression + +newtype M a = M (Bool -> (Maybe Doc, a)) + +maybeParen True d = parens d +maybeParen _ d = d + +run :: M a -> IO () +run (M m) = print d where (Just d,_) = m False + +instance Functor M where + fmap f m = m >>= return . f + +instance Applicative M where + pure a = M $ \_ -> (Nothing, a) + M f <*> M a = M $ \p -> + let (Just d1, f') = f True + (Just d2, a') = a True + in + (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a') + +instance Monad M where + return = pure + M m >>= k = M $ \p -> + let (d1, a) = m True + (d2, b) = case k a of M f -> f True + in + case (d1,d2) of + (Nothing,Nothing) -> (Nothing, b) + (Just d, Nothing) -> (Just d, b) + (Nothing, Just d) -> (Just d, b) + (Just d1, Just d2) -> (Just (maybeParen p (d1 <> semi <+> d2)), b) + +doc :: String -> M () +doc d = M $ \_ -> (Just (text d), ()) diff --git a/tests/examples/ghc80/ado002.hs b/tests/examples/ghc80/ado002.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ado002.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ApplicativeDo,ScopedTypeVariables #-} +module Test where + +-- Test that type errors aren't affected by ApplicativeDo +f :: IO Int +f = do + x <- getChar + y <- getChar 'a' -- type error + print (x,y) + +g :: IO (Int,Int) +g = do + x <- getChar + y <- getChar + return (y,x) + +h :: IO (Int,Int) +h = do + x1 <- getChar + x2 <- getChar + x3 <- const (return ()) x1 + x4 <- getChar + x5 <- getChar x4 + return (x2,x4) diff --git a/tests/examples/ghc80/ado003.hs b/tests/examples/ghc80/ado003.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ado003.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ApplicativeDo #-} +module ShouldFail where + +g :: IO () +g = do + x <- getChar + 'a' <- return (3::Int) -- type error + return () diff --git a/tests/examples/ghc80/ado004.hs b/tests/examples/ghc80/ado004.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ado004.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# OPTIONS_GHC -ddump-types #-} +module Test where + +-- This is a do expression that typechecks with only an Applicative constraint +test1 :: Applicative f => (Int -> f Int) -> f Int +test1 f = do + x <- f 3 + y <- f 4 + return (x + y) + +-- Test we can also infer the Applicative version of the type +test2 f = do + x <- f 3 + y <- f 4 + return (x + y) + +-- This one will use join +test3 f g = do + x <- f 3 + y <- f 4 + g y x + +-- This one needs a tuple +test4 f g = do + x <- f 3 + y <- f 4 + let r = g y x + r + +-- This one used to need a big tuple, now it compiles to ApplicativeLastStmt +test5 f g = do + x01 <- f 01 + x02 <- f 02 + x03 <- f 03 + x04 <- f 04 + x05 <- f 05 + x06 <- f 06 + x07 <- f 07 + x08 <- f 08 + x09 <- f 09 + x11 <- f 11 + x12 <- f 12 + x13 <- f 13 + x14 <- f 14 + x15 <- f 15 + x16 <- f 16 + x17 <- f 17 + x18 <- f 18 + x19 <- f 19 + x20 <- f 20 + x21 <- f 21 + x22 <- f 22 + x23 <- f 23 + x24 <- f 24 + x25 <- f 25 + x26 <- f 26 + x27 <- f 27 + x28 <- f 28 + x29 <- f 29 + x30 <- f 30 + x31 <- f 31 + x32 <- f 32 + x33 <- f 33 + x34 <- f 34 + x35 <- f 35 + x36 <- f 36 + x37 <- f 37 + x38 <- f 38 + x39 <- f 39 + x40 <- f 40 + x41 <- f 41 + x42 <- f 42 + x43 <- f 43 + x44 <- f 44 + x45 <- f 45 + x46 <- f 46 + x47 <- f 47 + x48 <- f 48 + x49 <- f 49 + x50 <- f 50 + x51 <- f 51 + x52 <- f 52 + x53 <- f 53 + x54 <- f 54 + x55 <- f 55 + x56 <- f 56 + x57 <- f 57 + x58 <- f 58 + x59 <- f 59 + x60 <- f 60 + x61 <- f 61 + x62 <- f 62 + x63 <- f 63 + x64 <- f 64 + x65 <- f 65 + x66 <- f 66 + x67 <- f 67 + x68 <- f 68 + x69 <- f 69 + x70 <- f 70 + let r = g x70 x01 + r + +-- This one needs a big tuple +test6 f g = do + x01 <- f 01 + x02 <- f 02 + x03 <- f 03 + x04 <- f 04 + x05 <- f 05 + x06 <- f 06 + x07 <- f 07 + x08 <- f 08 + x09 <- f 09 + x11 <- f 11 + x12 <- f 12 + x13 <- f 13 + x14 <- f 14 + x15 <- f 15 + x16 <- f 16 + x17 <- f 17 + x18 <- f 18 + x19 <- f 19 + x20 <- f 20 + x21 <- f 21 + x22 <- f 22 + x23 <- f 23 + x24 <- f 24 + x25 <- f 25 + x26 <- f 26 + x27 <- f 27 + x28 <- f 28 + x29 <- f 29 + x30 <- f 30 + x31 <- f 31 + x32 <- f 32 + x33 <- f 33 + x34 <- f 34 + x35 <- f 35 + x36 <- f 36 + x37 <- f 37 + x38 <- f 38 + x39 <- f 39 + x40 <- f 40 + x41 <- f 41 + x42 <- f 42 + x43 <- f 43 + x44 <- f 44 + x45 <- f 45 + x46 <- f 46 + x47 <- f 47 + x48 <- f 48 + x49 <- f 49 + x50 <- f 50 + x51 <- f 51 + x52 <- f 52 + x53 <- f 53 + x54 <- f 54 + x55 <- f 55 + x56 <- f 56 + x57 <- f 57 + x58 <- f 58 + x59 <- f 59 + x60 <- f 60 + x61 <- f 61 + x62 <- f 62 + x63 <- f 63 + x64 <- f 64 + x65 <- f 65 + x66 <- f 66 + x67 <- f 67 + x68 <- f 68 + x69 <- f 69 + x70 <- f x01 + x71 <- f 70 + x71 `const` + [ x01 + , x02 + , x03 + , x04 + , x05 + , x06 + , x07 + , x08 + , x09 + , x11 + , x12 + , x13 + , x14 + , x15 + , x16 + , x17 + , x18 + , x19 + , x20 + , x21 + , x22 + , x23 + , x24 + , x25 + , x26 + , x27 + , x28 + , x29 + , x30 + , x31 + , x32 + , x33 + , x34 + , x35 + , x36 + , x37 + , x38 + , x39 + , x40 + , x41 + , x42 + , x43 + , x44 + , x45 + , x46 + , x47 + , x48 + , x49 + , x50 + , x51 + , x52 + , x53 + , x54 + , x55 + , x56 + , x57 + , x58 + , x59 + , x60 + , x61 + , x62 + , x63 + , x64 + , x65 + , x66 + , x67 + , x68 + , x69 + , x70 + , x71 ] diff --git a/tests/examples/ghc80/ado005.hs b/tests/examples/ghc80/ado005.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ado005.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# OPTIONS_GHC -ddump-types #-} +module Test where + +-- This should fail to typecheck because it needs Monad +test :: Applicative f => (Int -> f Int) -> f Int +test f = do + x <- f 3 + y <- f x + return (x + y) diff --git a/tests/examples/ghc80/ado006.hs b/tests/examples/ghc80/ado006.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ado006.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ApplicativeDo #-} +module Test where + +-- This exposed a bug in zonking ApplicativeLastStmt +test :: IO Int +test + = do + x <- return () + h <- return (\_ -> 3) + return (h ()) diff --git a/tests/examples/ghc80/ado007.hs b/tests/examples/ghc80/ado007.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/ado007.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RebindableSyntax #-} +module Test where + +import Control.Applicative +import Control.Monad +import Prelude + +-- Caused a -dcore-lint failure with an earlier version of +-- ApplicativeDo due to the polymorphic let binding. +test :: IO [Char] +test = do + x <- return 'a' + y <- return 'b' + let f | y == 'c' = id | otherwise = id + return (map f []) diff --git a/tests/examples/ghc80/boolFormula.hs b/tests/examples/ghc80/boolFormula.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/boolFormula.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/determ004.hs b/tests/examples/ghc80/determ004.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/determ004.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE TypeOperators + , DataKinds + , PolyKinds + , TypeFamilies + , GADTs + , UndecidableInstances + , RankNTypes + , ScopedTypeVariables + #-} + +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Werror #-} +{-# OPTIONS_GHC -O1 -fspec-constr #-} + +{- + +With reversed order of allocated uniques the type variables would be in +wrong order: + +*** Core Lint errors : in result of SpecConstr *** +determ004.hs:88:12: warning: + [in body of lambda with binder m_azbFg :: a_afdP_azbON] + @ (a_afdP_azbON :: BOX) is out of scope +*** Offending Program *** + +... + +Rec { +$s$wsFoldr1_szbtK + :: forall (m_azbFg :: a_afdP_azbON) + (x_azbOM :: TyFun + a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *) + -> *) + (a_afdP_azbON :: BOX) + (ipv_szbwN :: a_afdP_azbON) + (ipv_szbwO :: [a_afdP_azbON]). + R:Sing[]z (ipv_szbwN : ipv_szbwO) + ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO) + -> Sing ipv_szbwO + -> Sing ipv_szbwN + -> (forall (t_azbNM :: a_afdP_azbON). + Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) + -> Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) +[LclId, + Arity=4, + Str=DmdType ] +$s$wsFoldr1_szbtK = + \ (@ (m_azbFg :: a_afdP_azbON)) + (@ (x_azbOM :: TyFun + a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *) + -> *)) + (@ (a_afdP_azbON :: BOX)) + (@ (ipv_szbwN :: a_afdP_azbON)) + (@ (ipv_szbwO :: [a_afdP_azbON])) + (sg_szbtL + :: R:Sing[]z (ipv_szbwN : ipv_szbwO) + ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO)) + (sc_szbtM :: Sing ipv_szbwO) + (sc_szbtN :: Sing ipv_szbwN) + (sc_szbtP + :: forall (t_azbNM :: a_afdP_azbON). + Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) -> + case (SCons + @ a_afdP_azbON + @ (ipv_szbwN : ipv_szbwO) + @ ipv_szbwO + @ ipv_szbwN + @~ (_N + :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO)) + sc_szbtN + sc_szbtM) + `cast` (sg_szbtL + ; TFCo:R:Sing[]z[0] _N _N + :: R:Sing[]z (ipv_szbwN : ipv_szbwO) + ~R# R:Sing[]z + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) + of wild_XD { + SNil dt_dzbxX -> + (lvl_szbwi @ a_afdP_azbON) + `cast` ((Sing + (Sym (TFCo:R:Foldr1[2] _N _N) + ; Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N <'[]>_N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) + (Sym dt_dzbxX))_N))_R + :: Sing (Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list") + ~R# Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); + SCons @ n_azbFh @ m_XzbGe dt_dzbxK _sX_azbOH + ds_dzbyu [Dmd=] -> + case ds_dzbyu + `cast` (TFCo:R:Sing[]z[0] _N _N + :: Sing n_azbFh ~R# R:Sing[]z n_azbFh) + of wild_Xo { + SNil dt_dzbxk -> + (lvl_szbw1 @ a_afdP_azbON @ m_XzbGe) + `cast` ((Sing + (Sym (TFCo:R:Foldr1[0] _N _N _N) + ; Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N <'[m_XzbGe]>_N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) + ((_N ': Sym dt_dzbxk)_N ; Sym dt_dzbxK))_N))_R + :: Sing m_XzbGe + ~R# Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); + SCons @ ipv_XzbxR @ ipv_XzbyV ipv_szbwM ipv_szbwL ipv_szbwK -> + case (sc_szbtP @ m_XzbGe _sX_azbOH) + `cast` (TFCo:R:Sing(->)f[0] + _N _N _N + :: Sing (Apply x_azbOM m_XzbGe) + ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe)) + of wild_X3X { SLambda ds_XzbBr [Dmd=] -> + (ds_XzbBr + @ (Foldr1 x_azbOM (ipv_XzbyV : ipv_XzbxR)) + (($wsFoldr1_szbuc + @ a_afdP_azbON + @ x_azbOM + @ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR) + sc_szbtP + ((SCons + @ a_afdP_azbON + @ (ipv_XzbyV : ipv_XzbxR) + @ ipv_XzbxR + @ ipv_XzbyV + @~ (_N + :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR)) + ipv_szbwL + ipv_szbwK) + `cast` (Sym (TFCo:R:Sing[]z[0] _N) (Sym + (TFCo:R:Apply[][]:$$i[0] + _N + _N + _N) + ; (Apply + (Sym + (TFCo:R:Applyk(->):$l[0] + _N + _N)) + _N)_N) + :: R:Sing[]z (ipv_XzbyV : ipv_XzbxR) + ~R# Sing (Apply (Apply (:$) ipv_XzbyV) ipv_XzbxR)))) + `cast` ((Sing + ((Apply + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N) + _N)_N + ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N + ((Apply + (TFCo:R:Applyk(->):$l[0] _N _N) + _N)_N + ; TFCo:R:Apply[][]:$$i[0] + _N _N _N) + _N))_R + :: Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR)) + ~R# Sing (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))))) + `cast` ((Sing + ((Apply + _N + (Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N _N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] + _N _N)) + (Sym + (TFCo:R:Apply[][]:$$i[0] + _N _N _N) + ; (Apply + (Sym + (TFCo:R:Applyk(->):$l[0] _N _N)) + _N)_N))_N))_N + ; Sym + (TFCo:R:Foldr1[1] + _N + _N + _N + _N + _N) + ; Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N _N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) + ((_N ': Sym ipv_szbwM)_N ; Sym dt_dzbxK))_N))_R + :: Sing + (Apply + (Apply x_azbOM m_XzbGe) + (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))) + ~R# Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))) + } + } + } +... +-} + +module List (sFoldr1) where + +data Proxy t + +data family Sing (a :: k) + +data TyFun (a :: *) (b :: *) + +type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2 + +data instance Sing (f :: TyFun k1 k2 -> *) = + SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } + +type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) + +type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) +singFun2 :: Proxy f -> SingFunction2 f -> Sing f +singFun2 _ f = SLambda (\x -> SLambda (f x)) + +data (:$$) (j :: a) (i :: TyFun [a] [a]) +type instance Apply ((:$$) j) i = (:) j i + +data (:$) (l :: TyFun a (TyFun [a] [a] -> *)) +type instance Apply (:$) l = (:$$) l +data instance Sing (z :: [a]) + = z ~ '[] => + SNil + | forall (m :: a) + (n :: [a]). z ~ (:) m n => + SCons (Sing m) (Sing n) + +data ErrorSym0 (t1 :: TyFun k1 k2) + +type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh + +type Let1627448493Xs f_afe9 + x_afea + wild_1627448474_afeb + wild_1627448476_afec = + Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec +type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) + -> *) + (t_afdZ :: [a_afdP]) = + Foldr1 t_afdY t_afdZ +data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) + -> *) + (l_afe2 :: TyFun [a_afdP] a_afdP) +type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 + +data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP + -> *) + -> *) (TyFun [a_afdP] a_afdP -> *)) +type instance Apply Foldr1Sym0 l = Foldr1Sym1 l + +type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP + -> *) + -> *) + (a_afe6 :: [a_afdP]) :: a_afdP where + Foldr1 z_afe7 '[x_afe8] = x_afe8 + Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) + Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" + +sFoldr1 :: + forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) + (y :: [a_afdP]). + Sing x + -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) +sFoldr1 _ (SCons _sX SNil) = undefined +sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) + = let + lambda_afeC :: + forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. + Sing f_afe9 + -> Sing x_afea + -> Sing wild_1627448474_afeb + -> Sing wild_1627448476_afec + -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) + lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG + = let + sXs :: + Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) + sXs + = applySing + (applySing + (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) + wild_1627448476_afeG + in + applySing + (applySing f_afeD x_afeE) + (applySing + (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) + sXs) + in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 +sFoldr1 _ SNil = undefined diff --git a/tests/examples/ghc80/determinism001.hs b/tests/examples/ghc80/determinism001.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/determinism001.hs @@ -0,0 +1,23 @@ +module Main where + +import Digraph + +main = mapM_ print + [ test001 + , test002 + , test003 + , test004 + ] + +-- These check that the result of SCCs doesn't depend on the order of the key +-- type (Int here). + +test001 = testSCC [("a", 1, []), ("b", 2, []), ("c", 3, [])] + +test002 = testSCC [("a", 2, []), ("b", 3, []), ("c", 1, [])] + +test003 = testSCC [("b", 1, []), ("c", 2, []), ("a", 3, [])] + +test004 = testSCC [("b", 2, []), ("c", 3, []), ("a", 1, [])] + +testSCC = flattenSCCs . stronglyConnCompFromEdgedVertices diff --git a/tests/examples/ghc80/dynamic-paper.hs b/tests/examples/ghc80/dynamic-paper.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/dynamic-paper.hs @@ -0,0 +1,341 @@ +{- This is the code extracted from "A reflection on types", by Simon PJ, +Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -} + +{-# LANGUAGE RankNTypes, PolyKinds, TypeOperators, + ScopedTypeVariables, GADTs, FlexibleInstances, + UndecidableInstances, RebindableSyntax, + DataKinds, MagicHash, AutoDeriveTypeable, TypeInType #-} +{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-redundant-constraints #-} + +module Dynamic where + +import Data.Map ( Map ) +import qualified Data.Map as Map +import Unsafe.Coerce ( unsafeCoerce ) +import Control.Monad ( (<=<) ) +import Prelude hiding ( lookup, fromInteger, replicate ) +import qualified Prelude +import qualified Data.Typeable +import qualified Data.Data +import Data.Kind + +lookupMap = Map.lookup +insertMap = Map.insert + +-- let's ignore overloaded numbers +fromInteger :: Integer -> Int +fromInteger = Prelude.fromInteger + +insertStore = undefined +schema = undefined +withTypeable = undefined +throw# = undefined + +toDynamicST = undefined +fromDynamicST = undefined + +extendStore :: Typeable a => STRef s a -> a -> Store -> Store +lookupStore :: Typeable a => STRef s a -> Store -> Maybe a + +type Key = Int +data STRef s a = STR Key +type Store = Map Key Dynamic + +extendStore (STR k) v s = insertMap k (toDynamicST v) s +lookupStore (STR k) s = case lookupMap k s of + Just d -> fromDynamicST d + Nothing -> Nothing + +toDynamicST :: Typeable a => a -> Dynamic +fromDynamicST :: Typeable a => Dynamic -> Maybe a + +eval = undefined +data Term + +data DynamicSilly = DIntSilly Int + | DBoolSilly Bool + | DCharSilly Char + | DPairSilly DynamicSilly DynamicSilly + + +toDynInt :: Int -> DynamicSilly +toDynInt = DIntSilly + +fromDynInt :: DynamicSilly -> Maybe Int +fromDynInt (DIntSilly n) = Just n +fromDynInt _ = Nothing + +toDynPair :: DynamicSilly -> DynamicSilly -> DynamicSilly +toDynPair = DPairSilly + +dynFstSilly :: DynamicSilly -> Maybe DynamicSilly +dynFstSilly (DPairSilly x1 x2) = Just x1 +dynFstSilly _ = Nothing + +eval :: Term -> DynamicSilly + +eqT = undefined + +instance Typeable (->) +instance Typeable Maybe +instance Typeable Bool +instance Typeable Int +instance (Typeable a, Typeable b) => Typeable (a b) +instance Typeable (,) + +instance Eq TypeRepX + +data Dynamic where + Dyn :: TypeRep a -> a -> Dynamic + +toDynamic :: Typeable a => a -> Dynamic +toDynamic x = Dyn typeRep x + +eqTNoKind = undefined + +eqTNoKind :: TypeRep a -> TypeRep b -> Maybe (a :***: b) + -- Primitive; implemented by compiler + +data a :***: b where + ReflNoKind :: a :***: a + +fromDynamic :: forall d. Typeable d => Dynamic -> Maybe d +fromDynamic (Dyn (ra :: TypeRep a) (x :: a)) + = case eqT ra (typeRep :: TypeRep d) of + Nothing -> Nothing + Just Refl -> Just x + +fromDynamicMonad :: forall d. Typeable d => Dynamic -> Maybe d + +fromDynamicMonad (Dyn ra x) + = do Refl <- eqT ra (typeRep :: TypeRep d) + return x + +cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b +cast x = do Refl <- eqT (typeRep :: TypeRep a) + (typeRep :: TypeRep b) + return x + +gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b) +gcast x = do Refl <- eqT (typeRep :: TypeRep a) + (typeRep :: TypeRep b) + return x + +data SameKind :: k -> k -> * +type CheckAppResult = SameKind AppResult AppResultNoKind + -- not the most thorough check +foo :: AppResult x -> AppResultNoKind x +foo (App y z) = AppNoKind y z + +splitApp :: TypeRep a -> Maybe (AppResult a) +splitApp = undefined +splitAppNoKind = undefined +splitAppNoKind :: TypeRep a -> Maybe (AppResultNoKind a) + -- Primitive; implemented by compiler + +data AppResultNoKind t where + AppNoKind :: TypeRep a -> TypeRep b -> AppResultNoKind (a b) + +dynFstNoKind :: Dynamic -> Maybe Dynamic +dynFstNoKind (Dyn rpab x) + = do AppNoKind rpa rb <- splitAppNoKind rpab + AppNoKind rp ra <- splitAppNoKind rpa + Refl <- eqT rp (typeRep :: TypeRep (,)) + return (Dyn ra (fst x)) + +dynApply :: Dynamic -> Dynamic -> Maybe Dynamic +dynApply (Dyn rf f) (Dyn rx x) = do + App ra rt2 <- splitApp rf + App rtc rt1 <- splitApp ra + Refl <- eqT rtc (typeRep :: TypeRep (->)) + Refl <- eqT rt1 rx + return (Dyn rt2 (f x)) + +data TypeRepAbstract (a :: k) -- primitive, indexed by type and kind + +class Typeable (a :: k) where + typeRep :: TypeRep a + +data AppResult (t :: k) where + App :: forall k1 k (a :: k1 -> k) (b :: k1). + TypeRep a -> TypeRep b -> AppResult (a b) + +dynFst :: Dynamic -> Maybe Dynamic +dynFst (Dyn (rpab :: TypeRep pab) (x :: pab)) + + = do App (rpa :: TypeRep pa ) (rb :: TypeRep b) <- splitApp rpab + -- introduces kind |k2|, and types |pa :: k2 -> *|, |b :: k2| + + App (rp :: TypeRep p ) (ra :: TypeRep a) <- splitApp rpa + -- introduces kind |k1|, and types |p :: k1 -> k2 -> *|, |a :: k1| + + Refl <- eqT rp (typeRep :: TypeRep (,)) + -- introduces |p ~ (,)| and |(k1 -> k2 -> *) ~ (* -> * -> *)| + + return (Dyn ra (fst x)) + +eqT :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~: b) + +data (a :: k1) :~: (b :: k2) where + Refl :: forall k (a :: k). a :~: a + +castDance :: (Typeable a, Typeable b) => a -> Maybe b +castDance = castR typeRep typeRep + +withTypeable :: TypeRep a -> (Typeable a => r) -> r + +castR :: TypeRep a -> TypeRep b -> a -> Maybe b +castR ta tb = withTypeable ta (withTypeable tb castDance) + +cmpT = undefined +compareTypeRep = undefined + +data TypeRepX where + TypeRepX :: TypeRep a -> TypeRepX + +type TyMapLessTyped = Map TypeRepX Dynamic + +insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped +insertLessTyped x = Map.insert (TypeRepX (typeRep :: TypeRep a)) (toDynamic x) + +lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a +lookupLessTyped = fromDynamic <=< Map.lookup (TypeRepX (typeRep :: TypeRep a)) + +instance Ord TypeRepX where + compare (TypeRepX tr1) (TypeRepX tr2) = compareTypeRep tr1 tr2 + +compareTypeRep :: TypeRep a -> TypeRep b -> Ordering -- primitive + +data TyMap = Empty | Node Dynamic TyMap TyMap + +lookup :: TypeRep a -> TyMap -> Maybe a +lookup tr1 (Node (Dyn tr2 v) left right) = + case compareTypeRep tr1 tr2 of + LT -> lookup tr1 left + EQ -> castR tr2 tr1 v -- know this cast will succeed + GT -> lookup tr1 right +lookup tr1 Empty = Nothing + +cmpT :: TypeRep a -> TypeRep b -> OrderingT a b + -- definition is primitive + +data OrderingT a b where + LTT :: OrderingT a b + EQT :: OrderingT t t + GTT :: OrderingT a b + +data TypeRep (a :: k) where + TrApp :: TypeRep a -> TypeRep b -> TypeRep (a b) + TrTyCon :: TyCon -> TypeRep k -> TypeRep (a :: k) + +data TyCon = TyCon { tc_module :: Module, tc_name :: String } +data Module = Module { mod_pkg :: String, mod_name :: String } + +tcMaybe :: TyCon +tcMaybe = TyCon { tc_module = Module { mod_pkg = "base" + , mod_name = "Data.Maybe" } + , tc_name = "Maybe" } + +rt = undefined + +delta1 :: Dynamic -> Dynamic +delta1 dn = case fromDynamic dn of + Just f -> f dn + Nothing -> dn +loop1 = delta1 (toDynamic delta1) + +data Rid = MkT (forall a. TypeRep a -> a -> a) +rt :: TypeRep Rid +delta :: forall a. TypeRep a -> a -> a +delta ra x = case (eqT ra rt) of + Just Refl -> case x of MkT y -> y rt x + Nothing -> x +loop = delta rt (MkT delta) + +throw# :: SomeException -> a + +data SomeException where + SomeException :: Exception e => e -> SomeException + +class (Typeable e, Show e) => Exception e where { } + +data Company +data Salary +incS :: Float -> Salary -> Salary +incS = undefined + +-- some impedance matching with SYB +instance Data.Data.Data Company +instance {-# INCOHERENT #-} Data.Typeable.Typeable a => Typeable a + +mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a +mkT f x = case (cast f) of + Just g -> g x + Nothing -> x + +data Expr a +frontEnd = undefined + +data DynExp where + DE :: TypeRep a -> Expr a -> DynExp + +frontEnd :: String -> DynExp + +data TyConOld + +typeOf = undefined +eqTOld = undefined +funTcOld = undefined :: TyConOld +splitTyConApp = undefined +mkTyCon3 = undefined +boolTcOld = undefined +tupleTc = undefined +mkTyConApp = undefined +instance Eq TypeRepOld +instance Eq TyConOld + +data TypeRepOld -- Abstract + +class TypeableOld a where + typeRepOld :: proxy a -> TypeRepOld + +data DynamicOld where + DynOld :: TypeRepOld -> a -> DynamicOld + +data Proxy a = Proxy + +fromDynamicOld :: forall d. TypeableOld d => DynamicOld -> Maybe d +fromDynamicOld (DynOld trx x) + | typeRepOld (Proxy :: Proxy d) == trx = Just (unsafeCoerce x) + | otherwise = Nothing + +dynApplyOld :: DynamicOld -> DynamicOld -> Maybe DynamicOld +dynApplyOld (DynOld trf f) (DynOld trx x) = + case splitTyConApp trf of + (tc, [t1,t2]) | tc == funTcOld && t1 == trx -> + Just (DynOld t2 ((unsafeCoerce f) x)) + _ -> Nothing + +data DynamicClosed where + DynClosed :: TypeRepClosed a -> a -> DynamicClosed + +data TypeRepClosed (a :: *) where + TBool :: TypeRepClosed Bool + TFun :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a -> b) + TProd :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a, b) + + +lookupPil = undefined + +lookupPil :: Typeable a => [Dynamic] -> Maybe a + +data Dyn1 = Dyn1 Int + | DynFun (Dyn1 -> Dyn1) + | DynPair (Dyn1, Dyn1) + +data TypeEnum = IntType | FloatType | BoolType | DateType | StringType +data Schema = Object [Schema] | + Field TypeEnum | + Array Schema + +schema :: Typeable a => a -> Schema diff --git a/tests/examples/ghc80/export-class.hs b/tests/examples/ghc80/export-class.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/export-class.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Foo (MyClass(.., P)) where + +pattern P = Nothing + +class MyClass a where + foo :: a -> Int diff --git a/tests/examples/ghc80/export-ps-rec-sel.hs b/tests/examples/ghc80/export-ps-rec-sel.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/export-ps-rec-sel.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} +module Foo( R(P,x)) where + +data Q = Q Int + +data R = R + +pattern P{x} = Q x diff --git a/tests/examples/ghc80/export-record-selector.hs b/tests/examples/ghc80/export-record-selector.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/export-record-selector.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Foo ( A(foo) ) where + +data A a = A a + +pattern P :: Int -> A Int +pattern P{foo} = A foo diff --git a/tests/examples/ghc80/export-super-class-fail.hs b/tests/examples/ghc80/export-super-class-fail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/export-super-class-fail.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ViewPatterns #-} + +module Foo ( B(P) ) where + +class (f ~ A) => C f a where + build :: a -> f a + destruct :: f a -> a + +data A a = A a + +data B a = B a + +instance C A Int where + build n = A n + destruct (A n) = n + + +pattern P :: C f a => a -> f a +pattern P x <- (destruct -> x) + where + P x = build x diff --git a/tests/examples/ghc80/export-super-class.hs b/tests/examples/ghc80/export-super-class.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/export-super-class.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ViewPatterns #-} + +module Foo ( A(P) ) where + +class (f ~ A) => C f a where + build :: a -> f a + destruct :: f a -> a + +data A a = A a + +instance C A Int where + build n = A n + destruct (A n) = n + + +pattern P :: C f a => a -> f a +pattern P x <- (destruct -> x) + where + P x = build x diff --git a/tests/examples/ghc80/export-syntax.hs b/tests/examples/ghc80/export-syntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/export-syntax.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} +module Foo(A(.., B)) where + +data A = A | B diff --git a/tests/examples/ghc80/export-type-synonym.hs b/tests/examples/ghc80/export-type-synonym.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/export-type-synonym.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Foo ( A(P) ) where + +data A = A +data B = B + +type C = B + +pattern P :: C +pattern P = B diff --git a/tests/examples/ghc80/export-type.hs b/tests/examples/ghc80/export-type.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/export-type.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Export (A(..,MyB), B(MyA), C(MyC)) where + +data A = A + +data B = B + +pattern MyB = B + +pattern MyA = A + +data C a = C + +pattern MyC = B diff --git a/tests/examples/ghc80/frontend01.hs b/tests/examples/ghc80/frontend01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/frontend01.hs @@ -0,0 +1,1 @@ +main = putStrLn "hello world" diff --git a/tests/examples/ghc80/haddockA034.hs b/tests/examples/ghc80/haddockA034.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/haddockA034.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs #-} + +module Hi where + +-- | This is a GADT. +data Hi where + -- | This is a GADT constructor. + Hi :: () -> Hi diff --git a/tests/examples/ghc80/listcomps.hs b/tests/examples/ghc80/listcomps.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/listcomps.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE RankNTypes #-} + +-- This program must be called with GHC's libdir as the single command line +-- argument. +module Main where + +-- import Data.Generics +import Data.Data +import Data.List +import System.IO +import GHC +import BasicTypes +import DynFlags +import MonadUtils +import Outputable +import ApiAnnotation +import Bag (filterBag,isEmptyBag) +import System.Directory (removeFile) +import System.Environment( getArgs ) +import System.Exit +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Dynamic ( fromDynamic,Dynamic ) + +main::IO() +main = do + [libdir] <- getArgs + testOneFile libdir "ListComprehensions" + exitSuccess + +testOneFile libdir fileName = do + ((anns,cs),p) <- runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags + let mn =mkModuleName fileName + addTarget Target { targetId = TargetModule mn + , targetAllowObjCode = True + , targetContents = Nothing } + load LoadAllTargets + modSum <- getModSummary mn + p <- parseModule modSum + t <- typecheckModule p + d <- desugarModule t + l <- loadModule d + let ts=typecheckedSource l + r =renamedSource l + return (pm_annotations p,p) + + let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p) + + putStrLn (pp spans) + putStrLn "--------------------------------" + putStrLn (intercalate "\n" [showAnns anns]) + + where + getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))] + getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns + + getAllSrcSpans :: (Data t) => t -> [SrcSpan] + getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast + where + getSrcSpan :: SrcSpan -> [SrcSpan] + getSrcSpan ss = [ss] + +showAnns anns = "[\n" ++ (intercalate "\n" + $ map (\((s,k),v) + -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) + $ Map.toList anns) + ++ "]\n" + +pp a = showPpr unsafeGlobalDynFlags a + + +-- --------------------------------------------------------------------- + +-- Copied from syb for the test + + +-- | Generic queries of type \"r\", +-- i.e., take any \"a\" and return an \"r\" +-- +type GenericQ r = forall a. Data a => a -> r + + +-- | Make a generic query; +-- start from a type-specific case; +-- return a constant otherwise +-- +mkQ :: ( Typeable a + , Typeable b + ) + => r + -> (b -> r) + -> a + -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + + + +-- | Summarise all nodes in top-down, left-to-right order +everything :: (r -> r -> r) -> GenericQ r -> GenericQ r + +-- Apply f to x to summarise top-level node; +-- use gmapQ to recurse into immediate subterms; +-- use ordinary foldl to reduce list of intermediate results + +everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/tests/examples/ghc80/mixed-pat-syn-record-sels.hs b/tests/examples/ghc80/mixed-pat-syn-record-sels.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/mixed-pat-syn-record-sels.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +module Foo where + + +pattern A { a } = Just a +pattern B { b } = Just b + +foo :: Maybe a -> Maybe Bool +foo x = x { a = True, b = False } diff --git a/tests/examples/ghc80/mkGADTVars.hs b/tests/examples/ghc80/mkGADTVars.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/mkGADTVars.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs, TypeInType #-} + +module GADTVars where + +import Data.Kind +import Data.Proxy + +data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where + MkT :: T x1 * (Proxy (y :: x1), z) z diff --git a/tests/examples/ghc80/multi-export.hs b/tests/examples/ghc80/multi-export.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/multi-export.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Foo (A(B, C)) where + +data A a = A + +pattern B :: A Int +pattern B = A + +pattern C :: A String +pattern C = A diff --git a/tests/examples/ghc80/overloadedlabelsfail01.hs b/tests/examples/ghc80/overloadedlabelsfail01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedlabelsfail01.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedLabels, DataKinds, FlexibleContexts #-} + +import GHC.OverloadedLabels + +-- No instance for (OverloadedLabel "x" t0) +a = #x + +-- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0) +b = #x #y + +-- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t) +c :: IsLabel "x" t => t +c = #y + +main = return () diff --git a/tests/examples/ghc80/overloadedlabelsrun01.hs b/tests/examples/ghc80/overloadedlabelsrun01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedlabelsrun01.hs @@ -0,0 +1,29 @@ +-- Basic tests of overloaded labels + +{-# LANGUAGE OverloadedLabels + , DataKinds + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , NoMonomorphismRestriction + #-} + +import GHC.OverloadedLabels + +instance IsLabel "true" Bool where + fromLabel _ = True + +instance IsLabel "false" Bool where + fromLabel _ = False + +a :: IsLabel "true" t => t +a = #true + +b = #false + +c :: Bool +c = #true + +main = do print (a :: Bool) + print (b :: Bool) + print c diff --git a/tests/examples/ghc80/overloadedlabelsrun02.hs b/tests/examples/ghc80/overloadedlabelsrun02.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedlabelsrun02.hs @@ -0,0 +1,61 @@ +-- Using overloaded labels to provide nice syntactic sugar for a +-- term representation using de Bruijn indices + +{-# LANGUAGE OverloadedLabels + , DataKinds + , FlexibleContexts + , FlexibleInstances + , GADTs + , KindSignatures + , MultiParamTypeClasses + , NoMonomorphismRestriction + , OverlappingInstances + , ScopedTypeVariables + , StandaloneDeriving + , TypeOperators + #-} + +import GHC.OverloadedLabels +import Data.Proxy ( Proxy(..) ) +import GHC.TypeLits ( Symbol ) + +instance x ~ y => IsLabel x (Proxy y) where + fromLabel _ = Proxy + +data Elem (x :: Symbol) g where + Top :: Elem x (x ': g) + Pop :: Elem x g -> Elem x (y ': g) +deriving instance Show (Elem x g) + + +class IsElem x g where + which :: Elem x g + +instance IsElem x (x ': g) where + which = Top + +instance IsElem x g => IsElem x (y ': g) where + which = Pop which + + +data Tm g where + Var :: Elem x g -> Tm g + App :: Tm g -> Tm g -> Tm g + Lam :: Tm (x ': g) -> Tm g +deriving instance Show (Tm g) + +instance IsElem x g => IsLabel x (Tm g) where + fromLabel _ = Var (which :: Elem x g) + +lam :: Proxy x -> Tm (x ': g) -> Tm g +lam _ = Lam + +s = lam #x #x +t = lam #x (lam #y (#x `App` #y)) + +u :: IsElem "z" g => Tm g +u = #z `App` #z + +main = do print s + print t + print (u :: Tm '["z"]) diff --git a/tests/examples/ghc80/overloadedlabelsrun03.hs b/tests/examples/ghc80/overloadedlabelsrun03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedlabelsrun03.hs @@ -0,0 +1,21 @@ +-- Using overloaded labels as strings, slightly pointlessly + +{-# LANGUAGE OverloadedLabels + , DataKinds + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , ScopedTypeVariables + , TypeFamilies + , TypeSynonymInstances + #-} + +import GHC.OverloadedLabels +import Data.Proxy ( Proxy(..) ) +import GHC.TypeLits ( KnownSymbol, symbolVal ) + +instance (KnownSymbol x, c ~ Char) => IsLabel x [c] where + fromLabel _ = symbolVal (Proxy :: Proxy x) + +main = do putStrLn #x + print $ #x ++ #y diff --git a/tests/examples/ghc80/overloadedrecflds_generics.hs b/tests/examples/ghc80/overloadedrecflds_generics.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecflds_generics.hs @@ -0,0 +1,50 @@ +-- Test that DuplicateRecordFields doesn't affect the metadata +-- generated by GHC.Generics or Data.Data + +-- Based on a Stack Overflow post by bennofs +-- (http://stackoverflow.com/questions/24474581) +-- licensed under cc by-sa 3.0 + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +import GHC.Generics +import Data.Data +import Data.Proxy + +type family FirstSelector (f :: * -> *) :: Meta +type instance FirstSelector (M1 D x f) = FirstSelector f +type instance FirstSelector (M1 C x f) = FirstSelector f +type instance FirstSelector (a :*: b) = FirstSelector a +type instance FirstSelector (M1 S s f) = s + +data SelectorProxy (s :: Meta) (f :: * -> *) a = SelectorProxy +type SelectorProxy' (s :: Meta) = SelectorProxy s Proxy () + +-- Extract the first selector name using GHC.Generics +firstSelectorName :: forall a. Selector (FirstSelector (Rep a)) + => Proxy a -> String +firstSelectorName _ = + selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a))) + +-- Extract the list of selector names for a constructor using Data.Data +selectorNames :: Data a => a -> [String] +selectorNames = constrFields . toConstr + +data T = MkT { foo :: Int } deriving (Data, Generic) +data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic) + +main = do -- This should yield "foo", not "$sel:foo:MkT" + print (firstSelectorName (Proxy :: Proxy T)) + -- Similarly this should yield "foo" + print (firstSelectorName (Proxy :: Proxy U)) + -- This should yield ["foo"] + print (selectorNames (MkT 3)) + -- And this should yield ["foo","bar"] + print (selectorNames (MkU 3 True)) diff --git a/tests/examples/ghc80/overloadedrecfldsfail01.hs b/tests/examples/ghc80/overloadedrecfldsfail01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail01.hs @@ -0,0 +1,19 @@ +-- Test ambiguous updates are rejected with appropriate error messages + +{-# LANGUAGE DuplicateRecordFields #-} + +data R = MkR { w :: Bool, x :: Int, y :: Bool } +data S = MkS { w :: Bool, x :: Int, y :: Bool } +data T = MkT { x :: Int, z :: Bool } +data U = MkU { y :: Bool } + +-- Straightforward ambiguous update +upd1 r = r { x = 3 } + +-- No type has all these fields +upd2 r = r { x = 3, y = True, z = False } + +-- User-specified type does not have these fields +upd3 r = r { w = True, x = 3, y = True } :: U + +main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail02.hs b/tests/examples/ghc80/overloadedrecfldsfail02.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail02.hs @@ -0,0 +1,9 @@ +-- Test selectors cannot be used ambiguously + +{-# LANGUAGE DuplicateRecordFields #-} + +data R = MkR { x :: Int, y :: Bool } +data S = MkS { x :: Int } + +main = do print (x (MkS 42)) + print (y (MkR 42 42)) diff --git a/tests/examples/ghc80/overloadedrecfldsfail03.hs b/tests/examples/ghc80/overloadedrecfldsfail03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail03.hs @@ -0,0 +1,10 @@ +-- Test that a top-level definition with the same name as a record +-- field is rejected + +{-# LANGUAGE DuplicateRecordFields #-} + +foo = True + +data T = MkT { foo :: Int } + +main = print foo diff --git a/tests/examples/ghc80/overloadedrecfldsfail04.hs b/tests/examples/ghc80/overloadedrecfldsfail04.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail04.hs @@ -0,0 +1,14 @@ +-- Test that importing an overloaded field and using it as a selector +-- leads to a suitable error + +{-# LANGUAGE DuplicateRecordFields #-} + +import OverloadedRecFldsFail04_A as I + +-- Qualified overloaded fields are not allowed here +x' = I.x + +-- But this is okay +f e = e { I.x = True, I.y = False } + +main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail05.hs b/tests/examples/ghc80/overloadedrecfldsfail05.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail05.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -fwarn-unused-binds -Werror #-} + +module Main (main, T(MkT)) where + +data S = MkS { foo :: Int } +data T = MkT { foo :: Int } + +-- This should count as a use of S(foo) but not T(foo) +main = print ((\ MkS{foo=foo} -> foo) (MkS 3)) diff --git a/tests/examples/ghc80/overloadedrecfldsfail06.hs b/tests/examples/ghc80/overloadedrecfldsfail06.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail06.hs @@ -0,0 +1,18 @@ +-- Check that unused imports are reported correctly in the presence of +-- DuplicateRecordFields + +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -Werror -fwarn-unused-imports #-} + +import OverloadedRecFldsFail06_A (U(x, y), V(MkV, MkV2, x, y), Unused(unused), u, getY) +import qualified OverloadedRecFldsFail06_A as M (U(x)) +import qualified OverloadedRecFldsFail06_A as N (V(x, y)) +import qualified OverloadedRecFldsFail06_A as P (U(x), V(x)) + +v = MkV2 True + +-- Check that this counts a use of U(x) and V(y) but not U(y) or V(x)... +main = do print (u { x = True } :: U) + print ((\ MkV2{y=y} -> y) v) + print (N.x v) + print (getY (v { P.x = 3 })) diff --git a/tests/examples/ghc80/overloadedrecfldsfail07.hs b/tests/examples/ghc80/overloadedrecfldsfail07.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail07.hs @@ -0,0 +1,9 @@ +-- Test type errors contain field names, not selector names + +{-# LANGUAGE DuplicateRecordFields #-} + +data T = MkT { x :: Int } + +y = x x + +main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail08.hs b/tests/examples/ghc80/overloadedrecfldsfail08.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail08.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} + +data family F a +data instance F Int = MkFInt { x :: Int } +data instance F Bool = MkFBool { y :: Bool } + +-- No data type has both these fields, but they belong to the same +-- lexical parent (F). This used to confuse DuplicateRecordFields. +foo e = e { x = 3, y = True } + +main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail09.hs b/tests/examples/ghc80/overloadedrecfldsfail09.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail09.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} + +data S = MkS { x :: Int } +data T = MkT { x :: Int } + +-- This tests what happens when an ambiguous record update is used in +-- a splice: since it can't be represented in TH, it should error +-- cleanly, rather than panicking or silently using one field. +foo = [e| (MkS 3) { x = 3 } |] + +main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail10.hs b/tests/examples/ghc80/overloadedrecfldsfail10.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail10.hs @@ -0,0 +1,11 @@ +-- Modules A and B both declare F(foo) +-- Module C declares F($sel:foo:MkFChar) but exports A.F(foo) as well +-- Thus we can't export F(..) even with DuplicateRecordFields enabled + +{-# LANGUAGE DuplicateRecordFields #-} +module Main (main, F(..)) where + +import OverloadedRecFldsFail10_B +import OverloadedRecFldsFail10_C + +main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail11.hs b/tests/examples/ghc80/overloadedrecfldsfail11.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail11.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -Werror #-} +import OverloadedRecFldsFail11_A + +main = print (foo (MkS True :: S)) diff --git a/tests/examples/ghc80/overloadedrecfldsfail12.hs b/tests/examples/ghc80/overloadedrecfldsfail12.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail12.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -Werror #-} + +import OverloadedRecFldsFail12_A + +data S = MkS { foo :: Bool } + +-- Use of foo and bar should give deprecation warnings +f :: T -> T +f e = e { foo = 3, bar = 3 } + +s :: T -> Int +s = foo + +main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail13.hs b/tests/examples/ghc80/overloadedrecfldsfail13.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail13.hs @@ -0,0 +1,20 @@ +-- Test that giving a stupid type annotation to an ambiguous field +-- yields a sensible error message + +{-# LANGUAGE DuplicateRecordFields #-} + +data S = MkS { x :: Int } +data T = MkT { x :: Bool } +data U = MkU + +a = x (MkU :: U) + +b = x (MkU :: a) + +c :: U -> Int +c = x + +d :: a -> Int +d = x + +main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail14.hs b/tests/examples/ghc80/overloadedrecfldsfail14.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsfail14.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +-- Test that we deal gracefully with non-fields in updates + +data S = MkS { x :: Int } +data T = MkT { x :: Int } + +y :: Bool +y = True + +-- y isn't a field +f r = r { x = 3, y = False } + +main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsrun01.hs b/tests/examples/ghc80/overloadedrecfldsrun01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsrun01.hs @@ -0,0 +1,28 @@ +-- Test that unambiguous constructions remain valid when +-- DuplicateRecordFields is enabled + +{-# LANGUAGE DuplicateRecordFields #-} + +data S = MkS { x :: Int } + deriving Show + +data T = MkT { x :: Bool, y :: Bool -> Bool, tField :: Bool } + +data U a = MkU { x :: a, y :: a } + +-- Construction is unambiguous +s = MkS { x = 42 } +t = MkT { x = True, y = id, tField = False } + +-- Pattern matching is unambiguous +get_x MkS{x=x} = x + +-- Resolving ambiguous monomorphic updates +a = t { x = False, y = not, tField = True } -- only T has all these fields +b = s { x = 3 } :: S -- type being pushed in +c = (t :: T) { x = False } -- type signature on record expression + +-- Unambiguous selectors are in scope normally +z = tField t + +main = print (get_x b) diff --git a/tests/examples/ghc80/overloadedrecfldsrun02.hs b/tests/examples/ghc80/overloadedrecfldsrun02.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsrun02.hs @@ -0,0 +1,6 @@ +-- This module does not enable -XDuplicateRecordFields, but it should +-- still be able to refer to non-overloaded fields like `y` + +import OverloadedRecFldsRun02_A + +main = print (y u) diff --git a/tests/examples/ghc80/overloadedrecfldsrun03.hs b/tests/examples/ghc80/overloadedrecfldsrun03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsrun03.hs @@ -0,0 +1,25 @@ +-- Test that DuplicateRecordFields can be used along with +-- TypeFamilies (with selectors only if unambiguous) + +{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} + +data family F a + +data instance F Int = MkFInt { foo :: Int } +data instance F Bool = MkFBool { bar :: Bool, baz :: Bool } + + +data family G a + +data instance G Int = MkGInt { foo :: Int } +data instance G Bool = MkGBool { bar :: Bool } + +x = MkFBool { bar = False, baz = True } + +y :: F Bool +y = x { bar = True } + +get_bar MkFBool{bar=bar} = bar + +main = do print (baz y) + print (get_bar y) diff --git a/tests/examples/ghc80/overloadedrecfldsrun04.hs b/tests/examples/ghc80/overloadedrecfldsrun04.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsrun04.hs @@ -0,0 +1,30 @@ +-- Test that DuplicateRecordFields works with TemplateHaskell + +{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +-- Splice in a datatype with field... +$(return [DataD [] (mkName "R") [] [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []]) + +-- New TH story means reify only sees R if we do this: +$(return []) + +-- ... and check that we can inspect it +main = do putStrLn $(do { info <- reify ''R + ; case info of + TyConI (DataD _ _ _ [RecC _ [(n, _, _)]] _) -> + do { info' <- reify n + ; lift (pprint info ++ "\n" ++ pprint info') + } + _ -> error "unexpected result of reify" + }) + putStrLn $(do { info <- reify 'foo + ; case info of + VarI n _ _ -> + do { info' <- reify n + ; lift (pprint info ++ "\n" ++ pprint info') + } + }) + print (foo (MkR { foo = 42 })) diff --git a/tests/examples/ghc80/overloadedrecfldsrun05.hs b/tests/examples/ghc80/overloadedrecfldsrun05.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsrun05.hs @@ -0,0 +1,27 @@ +-- Test that DuplicateRecordFields works with NamedFieldPuns and +-- RecordWildCards + +{-# LANGUAGE DuplicateRecordFields, NamedFieldPuns, RecordWildCards #-} + +data S = MkS { foo :: Int } + deriving Show +data T = MkT { foo :: Int } + deriving Show + +f MkS{foo} = MkT{foo} + +g MkT{..} = MkS{..} + +h e = let foo = 6 in e { foo } :: S + +main = do print a + print b + print c + print d + where + foo = 42 + + a = MkS{foo} + b = f a + c = g b + d = h c diff --git a/tests/examples/ghc80/overloadedrecfldsrun06.hs b/tests/examples/ghc80/overloadedrecfldsrun06.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/overloadedrecfldsrun06.hs @@ -0,0 +1,21 @@ +-- Test that ambiguous selectors can be disambiguated by providing +-- type signatures in various places + +{-# LANGUAGE DuplicateRecordFields #-} + +data S = MkS { x :: Int } +data T = MkT { x :: Bool } +data U a = MkU { x :: a } + +x_for_s :: S -> Int +x_for_s = x + +x_for_t = x :: T -> Bool + +x_for_u u = x (u :: U Int) + +k :: (T -> Bool) -> Bool +k f = f (MkT True) + +main = do print (x_for_s (MkS 42)) + print (k x) diff --git a/tests/examples/ghc80/performGC.hs b/tests/examples/ghc80/performGC.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/performGC.hs @@ -0,0 +1,24 @@ +module Main (main) where + +-- Test for #10545 + +import System.Environment +import Control.Concurrent +import Control.Exception +import Control.Monad +import RandomPGC +import System.Mem +import qualified Data.Set as Set + +main = do + [n] <- getArgs + forkIO $ doSomeWork + forM [1..read n] $ \n -> do print n; threadDelay 1000; performMinorGC + +doSomeWork :: IO () +doSomeWork = forever $ do + ns <- replicateM 10000 randomIO :: IO [Int] + ms <- replicateM 1000 randomIO + let set = Set.fromList ns + elems = filter (`Set.member` set) ms + evaluate $ sum elems diff --git a/tests/examples/ghc80/plugins07.hs b/tests/examples/ghc80/plugins07.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/plugins07.hs @@ -0,0 +1,6 @@ +module Main where + +{-# NOINLINE x #-} +x = "foo" + +main = putStrLn (show x) diff --git a/tests/examples/ghc80/pmc001.hs b/tests/examples/ghc80/pmc001.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/pmc001.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeFamilies, GADTs #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module PMC001 where + +data family T a + +data instance T [a] where + MkT1 :: T [Int] + MkT2 :: Char -> T [Char] + MkT3 :: T [a] + +f :: T [a] -> T [a] -> Bool +f MkT1 MkT1 = True +f (MkT2 _) (MkT2 _) = True +f MkT3 MkT3 = True + +g :: T [a] -> T [a] -> Bool +g x y + | MkT1 <- x, MkT1 <- y = True + | (MkT2 _) <- x, (MkT2 _) <- y = True + | MkT3 <- x, MkT3 <- y = True diff --git a/tests/examples/ghc80/pmc002.hs b/tests/examples/ghc80/pmc002.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/pmc002.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module PMC002 where + +f :: [a] -> Bool +f [] = True +f x | (_:_) <- x = False -- exhaustive diff --git a/tests/examples/ghc80/pmc003.hs b/tests/examples/ghc80/pmc003.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/pmc003.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module PMC003 where + +f :: Bool -> Bool -> () +f _ False = () +f True False = () +f _ _ = () + diff --git a/tests/examples/ghc80/pmc004.hs b/tests/examples/ghc80/pmc004.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/pmc004.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} +{-# LANGUAGE GADTs #-} + +module PMC004 where + +data F a where + F1 :: F Int + F2 :: F Bool + +data G a where + G1 :: G Int + G2 :: G Char + +h :: F a -> G a -> () +h F1 G1 = () +h _ G1 = () diff --git a/tests/examples/ghc80/pmc005.hs b/tests/examples/ghc80/pmc005.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/pmc005.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} +{-# LANGUAGE GADTs #-} + +module PMC005 where + +data T a where + TList :: T [a] + TBool :: T Bool + +foo :: T c -> T c -> () +foo TList _ = () +foo _ TList = () diff --git a/tests/examples/ghc80/pmc006.hs b/tests/examples/ghc80/pmc006.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/pmc006.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module PMC006 where + +len :: [a] -> Int +len xs = case xs of + [] -> 0 + (_:ys) -> case () of + () | (_:_) <- xs -> 1 + len ys + +-- -- we would like these to work too but they don't yet +-- +-- len :: [a] -> Int +-- len [] = 0 +-- len xs = case xs of +-- (_:ys) -> 1 + len ys +-- +-- len :: [a] -> Int +-- len xs = case xs of +-- [] -> 0 +-- ys -> case ys of +-- (_:zs) -> 1 + len zs diff --git a/tests/examples/ghc80/pmc007.hs b/tests/examples/ghc80/pmc007.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/pmc007.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module PMC007 where + +-- overloaded +f "ab" = () +f "ac" = () + +-- non-overloaded +g :: String -> () +g "ab" = () +g "ac" = () + +-- non-overloaded due to type inference +h :: String -> () +h s = let s' = s + in case s' of + "ab" -> () + "ac" -> () diff --git a/tests/examples/ghc80/poly-export-fail2.hs b/tests/examples/ghc80/poly-export-fail2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/poly-export-fail2.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +module Foo (A(P)) where + +data A = A + +data B = B + +pattern P :: () => (f ~ B) => f +pattern P = B diff --git a/tests/examples/ghc80/poly-export.hs b/tests/examples/ghc80/poly-export.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/poly-export.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +module Foo (Foo(P)) where + +data Foo a = Foo a + +instance C Foo where + build a = Foo a + destruct (Foo a) = a + +class C f where + build :: a -> f a + destruct :: f a -> a + +pattern P :: C f => a -> f a +pattern P x <- (destruct -> x) + where + P x = build x diff --git a/tests/examples/ghc80/poly-export2.hs b/tests/examples/ghc80/poly-export2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/poly-export2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleInstances #-} +module Foo (A(P,Q)) where + +data A a = A a + +pattern P :: Show a => a -> A a +pattern P a = A a + +pattern Q :: (A ~ f) => a -> f a +pattern Q a = A a diff --git a/tests/examples/ghc80/poly-export3.hs b/tests/examples/ghc80/poly-export3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/poly-export3.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} + +-- Testing polykindedness + +module Foo ( A(P) ) where + +data A a = A + +pattern P = A diff --git a/tests/examples/ghc80/records-check-sels.hs b/tests/examples/ghc80/records-check-sels.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-check-sels.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms #-} +module Qux where + +-- Make sure selectors aren't generated for normal synonyms + +pattern Uni a = Just a + +pattern a :+: b = (a, b) + +qux = a (Just True) diff --git a/tests/examples/ghc80/records-compile.hs b/tests/examples/ghc80/records-compile.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-compile.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} +module ShouldCompile where + +pattern Single{x} = [x] + +-- Selector +selector :: Int +selector = x [5] + +update :: [String] +update = ["String"] { x = "updated" } diff --git a/tests/examples/ghc80/records-exquant.hs b/tests/examples/ghc80/records-exquant.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-exquant.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms, ExistentialQuantification #-} +module ExQuant where + +data Showable = forall a . Show a => Showable a + +pattern Nasty{a} = Showable a + +qux = a (Showable True) + +foo = (Showable ()) { a = True } diff --git a/tests/examples/ghc80/records-mixing-fields.hs b/tests/examples/ghc80/records-mixing-fields.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-mixing-fields.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PatternSynonyms #-} + +data MyRec = MyRec { foo :: Int, qux :: String } + +pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} + +updater,updater1, updater2 :: MyRec -> MyRec +updater a = a {f1 = 1 } + +updater1 a = a {f1 = 1, qux = "two" } + +updater2 a = a {f1 = 1, foo = 2 } diff --git a/tests/examples/ghc80/records-no-uni-update.hs b/tests/examples/ghc80/records-no-uni-update.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-no-uni-update.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module RecordPats where + +-- No updates +pattern Uni{a,b} <- (a, b) + +foo = ("a","b") { a = "b" } diff --git a/tests/examples/ghc80/records-no-uni-update2.hs b/tests/examples/ghc80/records-no-uni-update2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-no-uni-update2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} +module RecordPats where + +-- No updates +pattern Uni{a} <- Just a + +qux = a (Just True) + +qux2 (Uni b) = b + +foo = Uni { a = "b" } diff --git a/tests/examples/ghc80/records-poly-update.hs b/tests/examples/ghc80/records-poly-update.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-poly-update.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE PatternSynonyms #-} +module Main where + +pattern ReqNoProv :: Show a => a -> Maybe a +pattern ReqNoProv{j} = Just j + +data A = A deriving Show + +p1 = Just True + +p6 = p1 {j = A} + +main = print p6 diff --git a/tests/examples/ghc80/records-poly.hs b/tests/examples/ghc80/records-poly.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-poly.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms #-} +module PolyPat where + +-- Testing whether type changing updates work correctly. + +pattern MyTuple :: a -> b -> (a, b) +pattern MyTuple{mfst, msnd} = (mfst, msnd) + + +expr1 :: (Int, String) -> (Int, Int) +expr1 a = a { msnd = 2} + +expr3 a = a { msnd = 2} + +expr2 :: (a, b) -> a +expr2 a = mfst a diff --git a/tests/examples/ghc80/records-prov-req.hs b/tests/examples/ghc80/records-prov-req.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-prov-req.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns, GADTs, RankNTypes, + StandaloneDeriving, FlexibleInstances #-} +module ShouldCompile where + +-- Testing that selectors work properly with prov and req thetas + +data T a b where + MkT :: (Show b) => a -> b -> T a b + +deriving instance Show (T Int A) + +data G a b = MkG { care :: a, y :: (Show b => b) } + +pattern ExNumPat :: (Eq b) => (Show b) => b -> T Int b +pattern ExNumPat{x} = MkT 42 x + +data A = A | B deriving (Show, Eq) + +f3 :: T Int A +f3 = (MkT 42 A) { x = B } + +f5 :: T Int A +f5 = (ExNumPat A) { x = B } + + +f4 = (MkG 42 True) { y = False } diff --git a/tests/examples/ghc80/records-req-only.hs b/tests/examples/ghc80/records-req-only.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-req-only.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Main where + +import Prelude (Maybe(..), Show(..), String, Bool(..), print) + +pattern ReqNoProv :: Show a => a -> Maybe a +pattern ReqNoProv{j} = Just j + +p1 = ReqNoProv True + +p7 (ReqNoProv _) = ReqNoProv False + +p6 = p1 {j = False} + +main = print p6 diff --git a/tests/examples/ghc80/records-req.hs b/tests/examples/ghc80/records-req.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-req.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-} + +-- Pattern synonyms + +module ShouldCompile where + +data T a where + MkT :: (Eq b) => a -> b -> T a + +f :: (Show a) => a -> Bool +f = undefined + +pattern P{x} <- MkT (f -> True) x diff --git a/tests/examples/ghc80/records-run.hs b/tests/examples/ghc80/records-run.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/records-run.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Main where + +pattern Bi{a, b} = (a, b) + +foo = ("a","b") + +main = do + print foo + print (a foo) + print (b foo) + print (foo {a = "c"}) + print (foo {a = "fst", b = "snd"}) diff --git a/tests/examples/ghc80/spec-inline-determ.hs b/tests/examples/ghc80/spec-inline-determ.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/spec-inline-determ.hs @@ -0,0 +1,40 @@ +module Roman where + +-- This is a simplified version of simplCore/should_compile/spec-inline.hs +-- +-- It reproduces a problem where workers get specialized in different ways +-- depending on the values of uniques. +-- +-- Compare: +-- +-- $s$wgo_s1CN :: Int# -> Int -> Int# +-- [LclId, Arity=2, Str=DmdType ] +-- $s$wgo_s1CN = +-- \ (sc_s1CI :: Int#) (sc_s1CJ :: Int) -> +-- case tagToEnum# @ Bool (<=# sc_s1CI 0#) of _ [Occ=Dead] { +-- False -> +-- $wgo_s1BU (Just @ Int (I# (-# sc_s1CI 1#))) (Just @ Int sc_s1CJ); +-- True -> 0# +-- } +-- +-- vs +-- +-- $s$wgo_s18mTj :: Int -> Int# -> Int# +-- [LclId, Arity=2, Str=DmdType ] +-- $s$wgo_s18mTj = +-- \ (sc_s18mTn :: Int) (sc_s18mTo :: Int#) -> +-- case tagToEnum# @ Bool (<=# sc_s18mTo 0#) of _ [Occ=Dead] { +-- False -> +-- $wgo_s18mUc +-- (Just @ Int (I# (-# sc_s18mTo 1#))) (Just @ Int sc_s18mTn); +-- True -> 0# +-- } + +foo :: Int -> Int +foo n = + go (Just n) (Just (6::Int)) + where + go Nothing (Just x) = go (Just 10) (Just x) + go (Just n) (Just x) + | n <= 0 = 0 + | otherwise = go (Just (n-1)) (Just x) diff --git a/tests/examples/ghc80/stringSource.hs b/tests/examples/ghc80/stringSource.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/stringSource.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- This program must be called with GHC's libdir as the single command line +-- argument. +module Main where + +-- import Data.Generics +import Data.Data +import Data.List +import System.IO +import GHC +import BasicTypes +import DynFlags +import FastString +import ForeignCall +import MonadUtils +import Outputable +import HsDecls +import Bag (filterBag,isEmptyBag) +import System.Directory (removeFile) +import System.Environment( getArgs ) +import qualified Data.Map as Map +import Data.Dynamic ( fromDynamic,Dynamic ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName + +testOneFile libdir fileName = do + ((anns,cs),p) <- runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags + let mn =mkModuleName fileName + addTarget Target { targetId = TargetModule mn + , targetAllowObjCode = True + , targetContents = Nothing } + load LoadAllTargets + modSum <- getModSummary mn + p <- parseModule modSum + return (pm_annotations p,p) + + let tupArgs = gq (pm_parsed_source p) + + putStrLn (pp tupArgs) + -- putStrLn (intercalate "\n" [showAnns anns]) + + where + gq ast = everything (++) ([] `mkQ` doWarningTxt + `extQ` doImportDecl + `extQ` doCType + `extQ` doRuleDecl + `extQ` doCCallTarget + `extQ` doHsExpr + ) ast + + doWarningTxt :: WarningTxt -> [(String,[Located (SourceText,FastString)])] + doWarningTxt ((WarningTxt _ ss)) = [("w",map conv ss)] + doWarningTxt ((DeprecatedTxt _ ss)) = [("d",map conv ss)] + + doImportDecl :: ImportDecl RdrName + -> [(String,[Located (SourceText,FastString)])] + doImportDecl (ImportDecl _ _ Nothing _ _ _ _ _ _) = [] + doImportDecl (ImportDecl _ _ (Just ss) _ _ _ _ _ _) + = [("i",[conv (noLoc ss)])] + + doCType :: CType -> [(String,[Located (SourceText,FastString)])] + doCType (CType src (Just (Header hs hf)) c) + = [("c",[noLoc (hs,hf),noLoc c])] + doCType (CType src Nothing c) = [("c",[noLoc c])] + + doRuleDecl :: RuleDecl RdrName + -> [(String,[Located (SourceText,FastString)])] + doRuleDecl (HsRule ss _ _ _ _ _ _) = [("r",[ss])] + + doCCallTarget :: CCallTarget + -> [(String,[Located (SourceText,FastString)])] + doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])] + + doHsExpr :: HsExpr RdrName -> [(String,[Located (SourceText,FastString)])] + doHsExpr (HsCoreAnn src ss _) = [("co",[conv (noLoc ss)])] + doHsExpr (HsSCC src ss _) = [("sc",[conv (noLoc ss)])] + doHsExpr (HsTickPragma src (ss,_,_) _) = [("tp",[conv (noLoc ss)])] + doHsExpr _ = [] + + conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs) + +showAnns anns = "[\n" ++ (intercalate "\n" + $ map (\((s,k),v) + -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) + $ Map.toList anns) + ++ "]\n" + +pp a = showPpr unsafeGlobalDynFlags a + +-- --------------------------------------------------------------------- + +-- Copied from syb for the test + + +-- | Generic queries of type \"r\", +-- i.e., take any \"a\" and return an \"r\" +-- +type GenericQ r = forall a. Data a => a -> r + + +-- | Make a generic query; +-- start from a type-specific case; +-- return a constant otherwise +-- +mkQ :: ( Typeable a + , Typeable b + ) + => r + -> (b -> r) + -> a + -> r +(r `mkQ` br) a = case cast a of + Just b -> br b + Nothing -> r + +-- | Extend a generic query by a type-specific case +extQ :: ( Typeable a + , Typeable b + ) + => (a -> q) + -> (b -> q) + -> a + -> q +extQ f g a = maybe (f a) g (cast a) + + +-- | Summarise all nodes in top-down, left-to-right order +everything :: (r -> r -> r) -> GenericQ r -> GenericQ r + +-- Apply f to x to summarise top-level node; +-- use gmapQ to recurse into immediate subterms; +-- use ordinary foldl to reduce list of intermediate results + +everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/tests/examples/ghc80/t10255.hs b/tests/examples/ghc80/t10255.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10255.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10268.hs b/tests/examples/ghc80/t10268.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10268.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10269.hs b/tests/examples/ghc80/t10269.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10269.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10278.hs b/tests/examples/ghc80/t10278.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10278.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10280.hs b/tests/examples/ghc80/t10280.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10280.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10307.hs b/tests/examples/ghc80/t10307.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10307.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10309.hs b/tests/examples/ghc80/t10309.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10309.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10312.hs b/tests/examples/ghc80/t10312.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10312.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10354.hs b/tests/examples/ghc80/t10354.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10354.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10357.hs b/tests/examples/ghc80/t10357.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10357.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10358.hs b/tests/examples/ghc80/t10358.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10358.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10396.hs b/tests/examples/ghc80/t10396.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10396.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10399.hs b/tests/examples/ghc80/t10399.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/t10399.hs @@ -0,0 +1,7 @@ +import CheckUtils +import System.Environment( getArgs ) + +main::IO() +main = do + [libdir,fileName] <- getArgs + testOneFile libdir fileName diff --git a/tests/examples/ghc80/tc265.hs b/tests/examples/ghc80/tc265.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/tc265.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +module Tc265 where + +data T a = MkT (F a) +type family F a where + F (T a) = a + F (T Int) = Bool diff --git a/tests/examples/ghc80/tcfail223.hs b/tests/examples/ghc80/tcfail223.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/tcfail223.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +module ShouldFail where + +class Class1 a +class Class1 a => Class2 a +class Class2 a => Class3 a + +-- This was wrongfully accepted by ghc-7.0 to ghc-7.10. +-- It is missing a `Class1 a` constraint. +instance Class3 a => Class2 a diff --git a/tests/examples/ghc80/update-existential.hs b/tests/examples/ghc80/update-existential.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/update-existential.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE + NoImplicitPrelude + , ExistentialQuantification + #-} + +module Test where + +hGetContents handle_ = handle_{ haType=SemiClosedHandle} + +data HandleType = SemiClosedHandle + +class Show a where + show :: a -> a + +-- they have to check whether the handle has indeed been closed. +data Handle__ + = forall dev . (Show dev) => + Handle__ { + haDevice :: !dev, + haType :: HandleType -- type (read/write/append etc.) +}