diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2015-11-21 v0.5 + * Add new options to enable "rigid" layout rules. This makes the + annotations more rigid in the sense that if you move AST fragments around + it is more likely that their internal components will remain in the same + position relative to each other. + + * Fix a bug where files failed to parse if the file started with comments. + + * Fix a bug where "[e||" was turned into "[||" + + 2015-11-15 v0.4.2 * Fix round tripping of arrow notation using ">-" and ">>-". 2015-09-28 v0.4.1 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.4.2.0 +version: 0.5.0.0 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 @@ -27,10 +27,13 @@ category: Development build-type: Simple extra-source-files: ChangeLog - tests/examples/*.hs - tests/examples/*.hs.bad - tests/examples/*.hs.expected - tests/examples/*.hs-boot + tests/examples/failing/*.hs + tests/examples/ghc710/*.hs + tests/examples/ghc8/*.hs + tests/examples/transform/*.hs + tests/examples/failing/*.hs.bad + tests/examples/transform/*.hs.expected + tests/examples/ghc710/*.hs-boot cabal-version: >=1.10 source-repository head 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 @@ -111,7 +111,7 @@ CountAnns :: GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next WithSortKey :: [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next - SetLayoutFlag :: Annotated () -> next -> AnnotationF next + SetLayoutFlag :: Rigidity -> Annotated () -> next -> AnnotationF next -- Required to work around deficiencies in the GHC AST StoreOriginalSrcSpan :: AnnKey -> (AnnKey -> next) -> AnnotationF next @@ -138,11 +138,16 @@ makeFreeCon 'GetSrcSpanForKw makeFreeCon 'StoreString makeFreeCon 'AnnotationsToComments -makeFreeCon 'SetLayoutFlag makeFreeCon 'WithSortKey -- --------------------------------------------------------------------- +setLayoutFlag :: Annotated () -> Annotated () +setLayoutFlag action = liftF (SetLayoutFlag NormalLayout action ()) + +setRigidFlag :: Annotated () -> Annotated () +setRigidFlag action = liftF (SetLayoutFlag RigidLayout action ()) + -- | Construct a syntax tree which represent which KeywordIds must appear -- where. annotate :: (Annotate ast) => GHC.Located ast -> Annotated () @@ -431,8 +436,9 @@ "()" -> do mark GHC.AnnOpenP -- '(' mark GHC.AnnCloseP -- ')' - "(##)" -> do + ('(':'#':_) -> do markWithString GHC.AnnOpen "(#" -- '(#' + markMany GHC.AnnCommaTuple markWithString GHC.AnnClose "#)"-- '#)' "[::]" -> do markWithString GHC.AnnOpen "[:" -- '[:' @@ -1672,7 +1678,7 @@ else markWithString GHC.AnnClose "#)" - markAST l (GHC.HsCase e1 matches) = do + markAST l (GHC.HsCase e1 matches) = setRigidFlag $ do mark GHC.AnnCase markLocated e1 mark GHC.AnnOf @@ -1685,7 +1691,7 @@ -- when moving these expressions it's useful that they maintain "internal -- integrity", that is to say the subparts remain indented relative to each -- other. - markAST _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do + markAST _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do mark GHC.AnnIf markLocated e1 markOffset GHC.AnnSemi 0 @@ -1860,7 +1866,13 @@ markLocated e markWithString GHC.AnnClose "|]" markAST _ (GHC.HsBracket (GHC.TExpBr e)) = do - markWithString GHC.AnnOpen "[||" + -- markWithString GHC.AnnOpen "[||" + -- This exists like this as the lexer collapses [e|| and [|| into the + -- same construtor + workOutString GHC.AnnOpen + (\ss -> if spanLength ss == 3 + then "[||" + else "[e||") markLocated e markWithString GHC.AnnClose "||]" markAST _ (GHC.HsBracket (GHC.TypBr e)) = do 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 @@ -51,6 +51,12 @@ module Language.Haskell.GHC.ExactPrint.Delta ( relativiseApiAnns , relativiseApiAnnsWithComments + , relativiseApiAnnsWithOptions + + -- * Configuration + , DeltaOptions(drRigidity) + , deltaOptions + , normalLayout ) where import Control.Monad.RWS @@ -94,18 +100,30 @@ -> GHC.Located ast -> GHC.ApiAnns -> Anns -relativiseApiAnnsWithComments cs modu ghcAnns - = runDeltaWithComments cs (annotate modu) ghcAnns (ss2pos $ GHC.getLoc modu) +relativiseApiAnnsWithComments = + relativiseApiAnnsWithOptions normalLayout +relativiseApiAnnsWithOptions :: + Annotate ast + => DeltaOptions + -> [Comment] + -> GHC.Located ast + -> GHC.ApiAnns + -> Anns +relativiseApiAnnsWithOptions opts cs modu ghcAnns + = runDeltaWithComments + opts cs (annotate modu) ghcAnns + (ss2pos $ GHC.getLoc modu) + -- --------------------------------------------------------------------- -- -- | Type used in the Delta Monad. -type Delta a = RWS DeltaReader DeltaWriter DeltaState a +type Delta a = RWS DeltaOptions DeltaWriter DeltaState a -runDeltaWithComments :: [Comment] -> Annotated () -> GHC.ApiAnns -> Pos -> Anns -runDeltaWithComments cs action ga priorEnd = +runDeltaWithComments :: DeltaOptions -> [Comment] -> Annotated () -> GHC.ApiAnns -> Pos -> Anns +runDeltaWithComments opts cs action ga priorEnd = mkAnns . snd - . (\next -> execRWS next initialDeltaReader (defaultDeltaState cs priorEnd ga)) + . (\next -> execRWS next opts (defaultDeltaState cs priorEnd ga)) . deltaInterpret $ action where mkAnns :: DeltaWriter -> Anns @@ -115,7 +133,7 @@ -- --------------------------------------------------------------------- -data DeltaReader = DeltaReader +data DeltaOptions = DeltaOptions { -- | Current `SrcSpan, part of current AnnKey` curSrcSpan :: !GHC.SrcSpan @@ -123,6 +141,9 @@ -- | Constuctor of current AST element, part of current AnnKey , annConName :: !AnnConName + -- | Whether to use rigid or normal layout rules + , drRigidity :: Rigidity + } data DeltaWriter = DeltaWriter @@ -153,13 +174,17 @@ -- --------------------------------------------------------------------- -initialDeltaReader :: DeltaReader -initialDeltaReader = - DeltaReader +deltaOptions :: Rigidity -> DeltaOptions +deltaOptions ridigity = + DeltaOptions { curSrcSpan = GHC.noSrcSpan , annConName = annGetConstr () + , drRigidity = ridigity } +normalLayout :: DeltaOptions +normalLayout = deltaOptions NormalLayout + defaultDeltaState :: [Comment] -> Pos -> GHC.ApiAnns -> DeltaState defaultDeltaState injectedComments priorEnd ga = DeltaState @@ -214,7 +239,10 @@ go (MarkOffsetPrim 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 action next) = setLayoutFlag (deltaInterpret action) >> next + go (SetLayoutFlag r action next) = do + rigidity <- asks drRigidity + (if (r <= rigidity) then setLayoutFlag else id) (deltaInterpret action) + next go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt ss akwid >> next go (StoreOriginalSrcSpan key next) = storeOriginalSrcSpanDelta key >>= next go (GetSrcSpanForKw kw next) = getSrcSpanForKw kw >>= next @@ -374,8 +402,8 @@ l <- ask tellFinalAnn (getAnnKey l,ann) -getAnnKey :: DeltaReader -> AnnKey -getAnnKey DeltaReader {curSrcSpan, annConName} +getAnnKey :: DeltaOptions -> AnnKey +getAnnKey DeltaOptions {curSrcSpan, annConName} = AnnKey curSrcSpan annConName -- ------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs --- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs @@ -17,6 +17,7 @@ -- * Module Parsers , parseModule + , parseModuleWithOptions , parseModuleWithCpp -- * Basic Parsers @@ -28,6 +29,10 @@ , parseStmt , parseWith + + -- * Internal + + , parseModuleApiAnnsWithCpp ) where import Language.Haskell.GHC.ExactPrint.Annotate @@ -143,44 +148,69 @@ -- @ -- -- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GHC.RdrName') -parseModule :: FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, (GHC.Located (GHC.HsModule GHC.RdrName)))) -parseModule = parseModuleWithCpp defaultCppOptions +parseModule :: FilePath + -> IO (Either (GHC.SrcSpan, String) + (Anns, GHC.ParsedSource)) +parseModule = parseModuleWithCpp defaultCppOptions normalLayout +parseModuleWithOptions :: DeltaOptions + -> FilePath + -> IO (Either (GHC.SrcSpan, String) + (Anns, GHC.ParsedSource)) +parseModuleWithOptions opts fp = + parseModuleWithCpp defaultCppOptions opts fp + + -- | Parse a module with specific instructions for the C pre-processor. parseModuleWithCpp :: CppOptions + -> DeltaOptions -> FilePath - -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.Located (GHC.HsModule GHC.RdrName))) -parseModuleWithCpp cppOptions file = + -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) +parseModuleWithCpp cpp opts fp = do + res <- parseModuleApiAnnsWithCpp cpp fp + return (either Left mkAnns res) + where + mkAnns (apianns, cs, _, m) = + Right (relativiseApiAnnsWithOptions opts cs m apianns, m) + +-- | Low level function which is used in the internal tests. +-- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of +-- this function. +parseModuleApiAnnsWithCpp :: CppOptions + -> FilePath + -> IO (Either (GHC.SrcSpan, String) + (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource)) +parseModuleApiAnnsWithCpp cppOptions file = GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ GHC.runGhc (Just libdir) $ do dflags <- initDynFlags file let useCpp = GHC.xopt GHC.Opt_Cpp dflags - (fileContents, injectedComments) <- + (fileContents, injectedComments, dflags') <- if useCpp then do - contents <- getPreprocessedSrcDirect cppOptions file + (contents,dflags1) <- getPreprocessedSrcDirect cppOptions file cppComments <- getCppTokensAsComments cppOptions file - return (contents,cppComments) + return (contents,cppComments,dflags1) else do txt <- GHC.liftIO $ readFile file let (contents1,lp) = stripLinePragmas txt - return (contents1,lp) + return (contents1,lp,dflags) return $ - case parseFile dflags file fileContents of + case parseFile dflags' file fileContents of GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m)) GHC.POk (mkApiAnns -> apianns) pmod -> - let as = relativiseApiAnnsWithComments injectedComments pmod apianns in - Right $ (as, pmod) + Right $ (apianns, injectedComments, dflags', pmod) -- --------------------------------------------------------------------- initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags initDynFlags file = do dflags0 <- GHC.getSessionDynFlags - let dflags1 = GHC.gopt_set dflags0 GHC.Opt_KeepRawTokenStream - src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags1 file - (dflags2, _, _) - <- GHC.parseDynamicFilePragma dflags1 src_opts + src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file + (dflags1, _, _) + <- GHC.parseDynamicFilePragma dflags0 src_opts + -- Turn this on last to avoid T10942 + let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream void $ GHC.setSessionDynFlags dflags2 return dflags2 diff --git a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs --- a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs @@ -21,6 +21,7 @@ import qualified Lexer as GHC import qualified MonadUtils as GHC import qualified SrcLoc as GHC +import qualified DriverPhases as GHC import qualified StringBuffer as GHC import SrcLoc (mkSrcSpan, mkSrcLoc) @@ -87,7 +88,7 @@ -- See bug getCppTokensAsComments :: GHC.GhcMonad m => CppOptions -- ^ Preprocessor Options - -> FilePath -- ^ Path to source file + -> FilePath -- ^ Path to source file -> m [Comment] getCppTokensAsComments cppOptions sourceFile = do source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile @@ -173,9 +174,12 @@ sbufToString sb@(GHC.StringBuffer _buf len _cur) = GHC.lexemeToString sb len -- --------------------------------------------------------------------- -getPreprocessedSrcDirect :: (GHC.GhcMonad m) => CppOptions -> FilePath -> m String +getPreprocessedSrcDirect :: (GHC.GhcMonad m) + => CppOptions + -> FilePath + -> m (String, GHC.DynFlags) getPreprocessedSrcDirect cppOptions src = - (\(a,_,_) -> a) <$> getPreprocessedSrcDirectPrim cppOptions src + (\(s,_,d) -> (s,d)) <$> getPreprocessedSrcDirectPrim cppOptions src getPreprocessedSrcDirectPrim :: (GHC.GhcMonad m) => CppOptions @@ -185,7 +189,8 @@ hsc_env <- GHC.getSession let dfs = GHC.extractDynFlags hsc_env new_env = GHC.replaceDynFlags hsc_env (injectCppOptions cppOptions dfs) - (dflags', hspp_fn) <- GHC.liftIO $ GHC.preprocess new_env (src_fn, Nothing) + (dflags', hspp_fn) <- + GHC.liftIO $ GHC.preprocess new_env (src_fn, Just (GHC.Cpp GHC.HsSrcFile)) buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn txt <- GHC.liftIO $ readFile hspp_fn return (txt, buf, dflags') 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 @@ -15,9 +15,13 @@ module Language.Haskell.GHC.ExactPrint.Print ( exactPrint - , semanticPrint - , semanticPrintM + , exactPrintWithOptions + -- * Configuration + , PrintOptions(epRigidity, epAstPrint, epTokenPrint, epWhitespacePrint) + , stringOptions + , printOptions + ) where import Language.Haskell.GHC.ExactPrint.Types @@ -47,43 +51,50 @@ => GHC.Located ast -> Anns -> String -exactPrint = semanticPrint (\_ b -> b) id id - --- | A more general version of `semanticPrint`. -semanticPrintM :: (Annotate ast, Monoid b, Monad m) => - (forall a . Data a => GHC.Located a -> b -> m b) -- ^ How to surround an AST fragment - -> (String -> m b) -- ^ How to output a token - -> (String -> m b) -- ^ How to output whitespace - -> GHC.Located ast - -> Anns - -> m b -semanticPrintM astOut tokenOut whiteOut ast as = runEP astOut tokenOut whiteOut (annotate ast) as - - --- | A more general version of 'exactPrint' which allows the customisation --- of the output whilst retaining the original source formatting. This is --- useful for smarter syntax highlighting. -semanticPrint :: (Annotate ast, Monoid b) => - (forall a . Data a => GHC.Located a -> b -> b) -- ^ How to surround an AST fragment - -> (String -> b) -- ^ How to output a token - -> (String -> b) -- ^ How to output whitespace - -> GHC.Located ast - -> Anns - -> b -semanticPrint a b c d e = runIdentity (semanticPrintM (\ast s -> Identity (a ast s)) (return . b) (return . c) d e) +exactPrint ast as = runIdentity (exactPrintWithOptions stringOptions ast as) +-- | The additional option to specify the rigidity and printing +-- configuration. +exactPrintWithOptions :: (Annotate ast, Monoid b, Monad m) + => PrintOptions m b + -> GHC.Located ast + -> Anns + -> m b +exactPrintWithOptions r ast as = + runEP r (annotate ast) as ------------------------------------------------------ -- The EP monad and basic combinators -data EPReader m a = EPReader +data PrintOptions m a = PrintOptions { epAnn :: !Annotation , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a , epTokenPrint :: String -> m a , epWhitespacePrint :: String -> m a + , epRigidity :: Rigidity } +-- | Helper to create a 'PrintOptions' +printOptions :: + (forall ast . Data ast => GHC.Located ast -> a -> m a) + -> (String -> m a) + -> (String -> m a) + -> Rigidity + -> PrintOptions m a +printOptions astPrint tokenPrint wsPrint rigidity = PrintOptions + { + epAnn = annNone + , epAstPrint = astPrint + , epWhitespacePrint = wsPrint + , epTokenPrint = tokenPrint + , epRigidity = rigidity + } + +-- | Options which can be used to print as a normal String. +stringOptions :: PrintOptions Identity String +stringOptions = printOptions (\_ b -> return b) return return NormalLayout + data EPWriter a = EPWriter { output :: !a } @@ -101,18 +112,17 @@ --------------------------------------------------------- -type EP w m a = RWST (EPReader m w) (EPWriter w) EPState m a +type EP w m a = RWST (PrintOptions m w) (EPWriter w) EPState m a -runEP :: (Monad m, Monoid a) => - (forall ast . Data ast => GHC.Located ast -> a -> m a) - -> (String -> m a) - -> (String -> m a) +runEP :: (Monad m, Monoid a) + => PrintOptions m a -> Annotated () -> Anns -> m a -runEP astPrint wsPrint tokenPrint action ans = +runEP epReader action ans = fmap (output . snd) . - (\next -> execRWST next (initialEPReader astPrint tokenPrint wsPrint) (defaultEPState ans)) + (\next -> execRWST next epReader + (defaultEPState ans)) . printInterpret $ action -- --------------------------------------------------------------------- @@ -126,18 +136,6 @@ , epMarkLayout = False } -initialEPReader :: - (forall ast . Data ast => GHC.Located ast -> a -> m a) - -> (String -> m a) - -> (String -> m a) - -> EPReader m a -initialEPReader astPrint tokenPrint wsPrint = EPReader - { - epAnn = annNone - , epAstPrint = astPrint - , epWhitespacePrint = wsPrint - , epTokenPrint = tokenPrint - } -- --------------------------------------------------------------------- @@ -167,8 +165,10 @@ exactPC lss (printInterpret action) >> next go (CountAnns kwid next) = countAnnsEP (G kwid) >>= next - go (SetLayoutFlag action next) = - setLayout (printInterpret action) >> next + go (SetLayoutFlag r action next) = do + rigidity <- asks epRigidity + (if (r <= rigidity) then setLayout else id) (printInterpret action) + next go (MarkExternal _ akwid s next) = printStringAtMaybeAnn (G akwid) s >> next go (StoreOriginalSrcSpan _ next) = storeOriginalSrcSpanPrint >>= next @@ -229,7 +229,7 @@ , annFollowingComments=fcomments , annsDP=kds } = fromMaybe annNone ma - EPReader{epAstPrint} <- ask + PrintOptions{epAstPrint} <- ask r <- withContext kds an (mapM_ (uncurry printQueuedComment) comments >> advance edp @@ -415,7 +415,7 @@ printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () printString layout str = do EPState{epPos = (l,c), epMarkLayout} <- get - EPReader{epTokenPrint, epWhitespacePrint} <- ask + PrintOptions{epTokenPrint, epWhitespacePrint} <- ask when (epMarkLayout && layout) ( modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } )) setPos (l, c + length str) diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs --- a/src/Language/Haskell/GHC/ExactPrint/Types.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs @@ -22,10 +22,16 @@ , mkAnnKey , AnnConName(..) , annGetConstr + + -- * Other + + , Rigidity(..) + -- * Internal Types , LayoutStartCol(..) , declFun + ) where import Data.Data (Data, Typeable, toConstr,cast) @@ -193,6 +199,9 @@ ppr a = GHC.text (show a) -- --------------------------------------------------------------------- +-- +-- Flag used to control whether we use rigid or normal layout rules. +data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GHC.RdrName -> b declFun f (GHC.L l de) = diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,12 +1,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} -- | Use "runhaskell Setup.hs test" or "cabal test" to run these tests. module Main where import Language.Haskell.GHC.ExactPrint.Utils (showGhc) -import qualified FastString as GHC -import qualified GHC as GHC +-- import qualified FastString as GHC +-- import qualified GHC as GHC -- import qualified Data.Generics as SYB -- import qualified GHC.SYB.Utils as SYB @@ -29,10 +30,28 @@ -- import Debug.Trace +data GHCVersion = GHC710 | GHC8 deriving (Eq, Ord, Show) + +ghcVersion :: GHCVersion +ghcVersion = +#if __GLASGOW_HASKELL__ >= 711 + GHC8 +#else + GHC710 +#endif + +-- | Directories to automatically find roundtrip tests +testDirs :: [FilePath] +testDirs = + "ghc710" : ["ghc8" | ghcVersion >= GHC8] + + -- --------------------------------------------------------------------- main :: IO () main = hSilence [stderr] $ do + print ghcVersion + tests <- mkTests cnts <- fst <$> runTestText (putTextToHandle stdout True) tests putStrLn $ show cnts if errors cnts > 0 || failures cnts > 0 @@ -41,7 +60,7 @@ transform :: IO () transform = hSilence [stderr] $ do - cnts <- fst <$> runTestText (putTextToHandle stdout True) (TestList transformTests) + cnts <- fst <$> runTestText (putTextToHandle stdout True) transformTests putStrLn $ show cnts if errors cnts > 0 || failures cnts > 0 then exitFailure @@ -49,245 +68,52 @@ -- --------------------------------------------------------------------- -tests :: Test -tests = TestList $ - [ - mkTestMod "AddAndOr3.hs" "AddAndOr3" - , mkTestMod "AltsSemis.hs" "Main" - , mkTestMod "Ann01.hs" "Ann01" - , mkTestMod "Annotations.hs" "Annotations" - , mkTestMod "Arrow.hs" "Arrow" - , mkParserTest "Arrows.hs" - , mkParserTest "Arrow2.hs" - , mkTestMod "Associated.hs" "Main" - , mkTestMod "B.hs" "Main" - , mkTestMod "C.hs" "C" - , mkTestMod "BCase.hs" "Main" - , mkTestMod "BangPatterns.hs" "Main" - , mkTestMod "Cg008.hs" "Cg008" - , mkTestMod "DataDecl.hs" "Main" - , mkTestMod "DataFamilies.hs" "DataFamilies" - , mkTestMod "Dead1.hs" "Dead1" - , mkTestMod "Default.hs" "Main" - , mkTestMod "Deriving.hs" "Main" - , mkParserTest "DerivingOC.hs" - , mkTestMod "DocDecls.hs" "DocDecls" - , mkTestMod "DocDecls.hs" "DocDecls" - , mkTestMod "EmptyMostly.hs" "EmptyMostly" - , mkTestMod "EmptyMostlyInst.hs" "EmptyMostlyInst" - , mkTestMod "EmptyMostlyNoSemis.hs" "EmptyMostlyNoSemis" - , mkTestMod "Existential.hs" "Main" - , mkTestMod "ExprPragmas.hs" "ExprPragmas" - , mkTestMod "ExtraConstraints1.hs" "ExtraConstraints1" - , mkTestMod "ForAll.hs" "ForAll" - , mkTestMod "ForeignDecl.hs" "ForeignDecl" - , mkTestMod "FromUtils.hs" "Main" - , mkTestMod "FunDeps.hs" "Main" - , mkTestMod "FunctionalDeps.hs" "Main" - , mkTestMod "GenericDeriving.hs" "Main" - , mkTestMod "Guards.hs" "Main" - , mkTestMod "HsDo.hs" "HsDo" - , mkTestMod "IfThenElse1.hs" "Main" - , mkTestMod "IfThenElse2.hs" "Main" - , mkTestMod "IfThenElse3.hs" "Main" - , mkTestMod "ImplicitParams.hs" "Main" - , mkTestMod "ImportsSemi.hs" "ImportsSemi" - , mkTestMod "Infix.hs" "Main" - , mkTestMod "LayoutIn1.hs" "LayoutIn1" - , mkTestMod "LayoutIn3.hs" "LayoutIn3" - , mkTestMod "LayoutIn3a.hs" "LayoutIn3a" - , mkTestMod "LayoutIn3b.hs" "LayoutIn3b" - , mkTestMod "LayoutIn4.hs" "LayoutIn4" - , mkTestMod "LayoutLet.hs" "Main" - , mkTestMod "LayoutLet2.hs" "LayoutLet2" - , mkTestMod "LayoutLet3.hs" "LayoutLet3" - , mkTestMod "LayoutLet4.hs" "LayoutLet4" - , mkTestMod "LayoutWhere.hs" "Main" - , mkTestMod "LetExpr.hs" "LetExpr" - , mkTestMod "LetExprSemi.hs" "LetExprSemi" - , mkTestMod "LetIn1.hs" "LetIn1" - , mkTestMod "LetStmt.hs" "Layout.LetStmt" - , mkTestMod "ListComprehensions.hs" "Main" - , mkTestMod "LocToName.hs" "LocToName" - , mkTestMod "Mixed.hs" "Main" - , mkTestMod "MonadComprehensions.hs" "Main" - , mkTestMod "Move1.hs" "Move1" - , mkTestMod "MultiParamTypeClasses.hs" "Main" - , mkTestMod "NullaryTypeClasses.hs" "Main" - , mkTestMod "OverloadedStrings.hs" "Main" - , mkTestMod "PArr.hs" "PArr" - , mkTestMod "PatSynBind.hs" "Main" - , mkTestMod "ParensAroundContext.hs" "ParensAroundContext" - , mkTestMod "RankNTypes.hs" "Main" - , mkTestMod "RdrNames.hs" "RdrNames" - , mkTestMod "RebindableSyntax.hs" "Main" - , mkTestMod "RecordUpdate.hs" "Main" - , mkParserTest "RecursiveDo.hs" - , mkTestMod "Roles.hs" "Roles" - , mkTestMod "Rules.hs" "Rules" - , mkTestMod "ScopedTypeVariables.hs" "Main" - , mkTestMod "Sigs.hs" "Sigs" - , mkTestMod "Simple.hs" "Main" - , mkTestMod "Splice.hs" "Splice" - , mkTestMod "StaticPointers.hs" "Main" - , mkTestMod "Stmts.hs" "Stmts" - , mkTestMod "Stream.hs" "Stream" - , mkTestMod "StrictLet.hs" "Main" - , mkTestMod "T2388.hs" "T2388" - , mkTestMod "T3132.hs" "T3132" - , mkTestMod "TH.hs" "Main" - , mkTestMod "Trit.hs" "Trit" - , mkTestMod "TransformListComp.hs" "Main" - , mkTestMod "Tuple.hs" "Main" - , mkTestMod "TypeFamilies.hs" "Main" - , mkTestMod "TypeOperators.hs" "Main" - , mkTestMod "Utils2.hs" "Utils2" - , mkTestMod "Vect.hs" "Vect" - , mkTestMod "ViewPatterns.hs" "Main" - , mkTestMod "Warning.hs" "Warning" - , mkTestMod "WhereIn4.hs" "WhereIn4" - , mkTestMod "Zipper.hs" "Zipper" - , mkTestMod "QuasiQuote.hs" "QuasiQuote" - , mkTestMod "Pseudonym.hs" "Main" - , mkTestMod "Obscure.hs" "Main" - , mkTestMod "Remorse.hs" "Main" - , mkTestMod "Jon.hs" "Main" - , mkTestMod "RSA.hs" "Main" - , mkTestMod "WhereIn3.hs" "WhereIn3" - , mkTestMod "Backquote.hs" "Main" - , mkTestMod "PatternGuards.hs" "Main" - , mkParserTest "Minimal.hs" - , mkParserTest "Undefined2.hs" - , mkParserTest "Undefined3.hs" - , mkParserTest "Undefined4.hs" - , mkParserTest "Undefined5.hs" - , mkParserTest "Undefined6.hs" - , mkParserTest "Undefined7.hs" - , mkParserTest "Undefined8.hs" - , mkParserTest "Undefined9.hs" - , mkParserTest "Undefined10.hs" - , mkParserTest "Undefined11.hs" - , mkParserTest "Undefined13.hs" - , mkParserTest "TypeSynOperator.hs" - , mkParserTest "TemplateHaskell.hs" - , mkParserTest "TypeBrackets.hs" - , mkParserTest "SlidingDoClause.hs" - , mkParserTest "SlidingListComp.hs" - , mkParserTest "LiftedConstructors.hs" - , mkParserTest "LambdaCase.hs" - , mkParserTest "PuncFunctions.hs" - , mkParserTest "TupleSections.hs" - , mkParserTest "TypeSynParens.hs" - , mkParserTest "SlidingRecordSetter.hs" - , mkParserTest "MultiLineCommentWithPragmas.hs" - , mkParserTest "GHCOrig.hs" - , mkParserTest "DoubleForall.hs" - , mkParserTest "AnnPackageName.hs" - , mkParserTest "NestedLambda.hs" - , mkParserTest "DefaultTypeInstance.hs" - , mkParserTest "RecordWildcard.hs" - , mkParserTest "MagicHash.hs" - , mkParserTest "GADTRecords.hs" - , mkParserTest "MangledSemiLet.hs" - , mkParserTest "MultiImplicitParams.hs" - , mkParserTest "UnicodeSyntaxFailure.hs" - - , mkParserTest "HangingRecord.hs" - , mkParserTest "InfixPatternSynonyms.hs" - , mkParserTest "LiftedInfixConstructor.hs" - , mkParserTest "MultiWayIf.hs" - , mkParserTest "OptSig.hs" - , mkParserTest "StrangeTypeClass.hs" - , mkParserTest "TypeSignatureParens.hs" - , mkParserTest "Cpp.hs" - - , mkParserTest "Shebang.hs" - , mkParserTest "PatSigBind.hs" - , mkParserTest "ProcNotation.hs" - , mkParserTest "DroppedDoSpace.hs" - , mkParserTest "IndentedDo.hs" - , mkParserTest "BracesSemiDataDecl.hs" - , mkParserTest "SpacesSplice.hs" - , mkParserTest "SemiWorkout.hs" - , mkParserTest "ShiftingLambda.hs" - , mkParserTest "NestedDoLambda.hs" - , mkParserTest "DoPatBind.hs" - - , mkParserTest "LinePragma.hs" - , mkParserTest "Hang.hs" - - , mkParserTest "HashQQ.hs" - , mkParserTest "TypeBrackets2.hs" - , mkParserTest "ExplicitNamespaces.hs" - , mkParserTest "CorePragma.hs" - , mkParserTest "GADTContext.hs" - , mkParserTest "THMonadInstance.hs" --- , mkParserTest "TypeBrackets3.hs" -- I think this test is junk but it parses? - , mkParserTest "TypeBrackets4.hs" - , mkParserTest "SlidingTypeSyn.hs" - , mkParserTest "RecordSemi.hs" - , mkParserTest "SlidingLambda.hs" - , mkParserTest "DroppedComma.hs" - , mkParserTest "TypeInstance.hs" - , mkParserTest "ImplicitTypeSyn.hs" - , mkParserTest "OveridingPrimitives.hs" - , mkParserTest "SlidingDataClassDecl.hs" - , mkParserTest "SemiInstance.hs" - , mkParserTest "ImplicitSemi.hs" - , mkParserTest "RulesSemi.hs" - , mkParserTest "InlineSemi.hs" - , mkParserTest "SpliceSemi.hs" - , mkParserTest "Imports.hs" - , mkParserTest "Internals.hs" - , mkParserTest "Control.hs" - , mkParserTest "T10196.hs" - , mkParserTest "StringGap.hs" - , mkParserTest "RedundantDo.hs" - , mkParserTest "TypeSignature.hs" - ] - - ++ transformTests +findTests :: IO Test +findTests = testList "Round-trip tests" <$> mapM findTestsDir testDirs - ++ failingTests +findTestsDir :: FilePath -> IO Test +findTestsDir dir = do + let fp = testPrefix dir + fs <- getDirectoryContents fp + let testFiles = filter (".hs" `isSuffixOf`) fs + return $ testList dir (map (mkParserTest dir) testFiles) +mkTests :: IO Test +mkTests = do + roundTripTests <- findTests + return $ TestList [roundTripTests, transformTests, failingTests] -- Tests that will fail until https://phabricator.haskell.org/D907 lands in a -- future GHC -failingTests :: [Test] -failingTests = +failingTests :: Test +failingTests = testList "Failing tests" [ -- Require current master #10313 / Phab:D907 - mkTestModBad "Deprecation.hs" "Deprecation" - , mkTestModBad "MultiLineWarningPragma.hs" "Main" - , mkTestModBad "UnicodeRules.hs" "Main" + mkTestModBad "Deprecation.hs" + , mkTestModBad "MultiLineWarningPragma.hs" + , mkTestModBad "UnicodeRules.hs" -- Tests requiring future GHC modifications - , mkTestModBad "UnicodeSyntax.hs" "Tutorial" - , mkTestModBad "InfixOperator.hs" "Main" + , mkTestModBad "UnicodeSyntax.hs" + , mkTestModBad "InfixOperator.hs" ] -mkParserTest :: FilePath -> Test -mkParserTest fp = - let basename = "tests" "examples" fp +mkParserTest :: FilePath -> FilePath -> Test +mkParserTest dir fp = + let basename = testPrefix dir fp writeFailure = writeFile (basename <.> "out") writeHsPP = writeFile (basename <.> "hspp") writeIncons s = writeFile (basename <.> "incons") (showGhc s) in - TestCase (do r <- either (\(ParseFailure _ s) -> error s) id - <$> roundTripTest ("tests" "examples" fp) + TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id + <$> roundTripTest basename writeFailure (debugTxt r) forM_ (inconsistent r) writeIncons forM_ (cppStatus r) writeHsPP assertBool fp (status r == Success)) - -mkTestMod :: FilePath -> String -> Test -mkTestMod fileName _modName - = mkParserTest fileName - - -- --------------------------------------------------------------------- formatTT :: ([([Char], Bool)], [([Char], Bool)]) -> IO () @@ -300,216 +126,34 @@ putStrLn "Fail" mapM_ (putStrLn . fst) fs) -tt' :: IO () -tt' = formatTT =<< partition snd <$> sequence [ return ("", True) - -- , manipulateAstTestWFname "ExprPragmas.hs" "ExprPragmas" - -- , manipulateAstTestWFname "MonadComprehensions.hs" "Main" - -- , manipulateAstTestWFname "RecursiveDo.hs" "Main" - -- , manipulateAstTestWFname "MultiParamTypeClasses.hs" "Main" - -- , manipulateAstTestWFname "DataFamilies.hs" "DataFamilies" - -- , manipulateAstTestWFname "Deriving.hs" "Main" - -- , manipulateAstTestWFname "Default.hs" "Main" - -- , manipulateAstTestWFname "ForeignDecl.hs" "ForeignDecl" - -- , manipulateAstTestWFname "Warning.hs" "Warning" - -- , manipulateAstTestWFname "Annotations.hs" "Annotations" - -- -- , manipulateAstTestWFnameTH "QuasiQuote.hs" "QuasiQuote" - -- , manipulateAstTestWFname "Roles.hs" "Roles" - -- , manipulateAstTestWFname "ImportsSemi.hs" "ImportsSemi" - -- , manipulateAstTestWFname "Stmts.hs" "Stmts" - -- , manipulateAstTestWFname "Mixed.hs" "Main" - -- , manipulateAstTestWFname "Arrow.hs" "Arrow" - -- , manipulateAstTestWFname "PatSynBind.hs" "Main" - -- , manipulateAstTestWFname "HsDo.hs" "HsDo" - -- , manipulateAstTestWFname "ForAll.hs" "ForAll" - -- , manipulateAstTestWFname "BangPatterns.hs" "Main" - -- , manipulateAstTestWFname "Move1.hs" "Move1" - -- , manipulateAstTestWFname "TypeOperators.hs" "Main" - -- , manipulateAstTestWFname "NullaryTypeClasses.hs" "Main" - -- , manipulateAstTestWFname "FunctionalDeps.hs" "Main" - -- , manipulateAstTestWFname "DerivingOC.hs" "Main" - -- , manipulateAstTestWFname "GenericDeriving.hs" "Main" - -- , manipulateAstTestWFname "OverloadedStrings.hs" "Main" - -- , manipulateAstTestWFname "RankNTypes.hs" "Main" - -- , manipulateAstTestWFname "Arrows.hs" "Main" - -- , manipulateAstTestWFname "TH.hs" "Main" - -- , manipulateAstTestWFname "StaticPointers.hs" "Main" - -- , manipulateAstTestWFname "Guards.hs" "Main" - -- , manipulateAstTestWFname "Vect.hs" "Vect" - -- , manipulateAstTestWFname "Tuple.hs" "Main" - -- , manipulateAstTestWFname "ExtraConstraints1.hs" "ExtraConstraints1" - -- , manipulateAstTestWFname "AddAndOr3.hs" "AddAndOr3" - -- , manipulateAstTestWFname "Ann01.hs" "Ann01" - -- , manipulateAstTestWFname "StrictLet.hs" "Main" - -- , manipulateAstTestWFname "Cg008.hs" "Cg008" - -- , manipulateAstTestWFname "T2388.hs" "T2388" - -- , manipulateAstTestWFname "T3132.hs" "T3132" - -- , manipulateAstTestWFname "Stream.hs" "Stream" - -- , manipulateAstTestWFname "Trit.hs" "Trit" - -- , manipulateAstTestWFname "Zipper.hs" "Zipper" - -- , manipulateAstTestWFname "Sigs.hs" "Sigs" - -- , manipulateAstTestWFname "Utils2.hs" "Utils2" - -- , manipulateAstTestWFname "EmptyMostlyInst.hs" "EmptyMostlyInst" - -- , manipulateAstTestWFname "EmptyMostlyNoSemis.hs" "EmptyMostlyNoSemis" - -- , manipulateAstTestWFname "EmptyMostly.hs" "EmptyMostly" - -- , manipulateAstTestWFname "FromUtils.hs" "Main" - -- , manipulateAstTestWFname "DocDecls.hs" "DocDecls" - -- , manipulateAstTestWFname "RecordUpdate.hs" "Main" - -- -- manipulateAstTestWFname "Unicode.hs" "Main" - -- , manipulateAstTestWFname "B.hs" "Main" - -- , manipulateAstTestWFname "LayoutWhere.hs" "Main" - -- , manipulateAstTestWFname "Deprecation.hs" "Deprecation" - -- , manipulateAstTestWFname "UnicodeRules.hs" "Main" - -- , manipulateAstTestWFname "Infix.hs" "Main" - -- , manipulateAstTestWFname "BCase.hs" "Main" - -- , manipulateAstTestWFname "LetExprSemi.hs" "LetExprSemi" - -- , manipulateAstTestWFname "LetExpr2.hs" "Main" - -- , manipulateAstTestWFname "LetStmt.hs" "Layout.LetStmt" - -- , manipulateAstTestWFname "RebindableSyntax.hs" "Main" - -- -- , manipulateAstTestWithMod changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4" - -- -- , manipulateAstTestWithMod changeLayoutLet5 "LayoutLet5.hs" "LayoutLet5" - -- , manipulateAstTestWFname "EmptyMostly2.hs" "EmptyMostly2" - -- , manipulateAstTestWFname "Dead1.hs" "Dead1" - -- , manipulateAstTestWFname "DocDecls.hs" "DocDecls" - -- , manipulateAstTestWFname "ViewPatterns.hs" "Main" - -- , manipulateAstTestWFname "FooExpected.hs" "Main" - -- -- , manipulateAstTestWithMod changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2" - -- , manipulateAstTestWFname "LayoutIn1.hs" "LayoutIn1" - -- -- , manipulateAstTestWithMod changeLayoutIn1 "LayoutIn1.hs" "LayoutIn1" - -- , manipulateAstTestWFname "LocToName.hs" "LocToName" - -- -- , manipulateAstTestWithMod changeLayoutIn4 "LayoutIn4.hs" "LayoutIn4" - -- -- , manipulateAstTestWithMod changeLocToName "LocToName.hs" "LocToName" - -- -- , manipulateAstTestWithMod changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3" - -- -- , manipulateAstTestWithMod changeRename1 "Rename1.hs" "Main" - -- , manipulateAstTestWFname "Rename1.hs" "Main" - -- , manipulateAstTestWFname "AltsSemis.hs" "Main" - -- , manipulateAstTestWFname "LetExpr.hs" "LetExpr" - -- , manipulateAstTestWFname "Rules.hs" "Rules" - -- , manipulateAstTestWFname "LayoutLet2.hs" "LayoutLet2" - -- , manipulateAstTestWFname "LayoutIn3.hs" "LayoutIn3" - -- , manipulateAstTestWFname "LayoutIn3a.hs" "LayoutIn3a" - -- -- , manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3a.hs" "LayoutIn3a" - -- , manipulateAstTestWFname "LetIn1.hs" "LetIn1" - -- -- , manipulateAstTestWFnameMod changeLetIn1 "LetIn1.hs" "LetIn1" - -- -- , manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3b.hs" "LayoutIn3b" - -- -- , manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3.hs" "LayoutIn3" - -- , manipulateAstTestWFname "LayoutLet2.hs" "LayoutLet2" - -- , manipulateAstTestWFname "LayoutLet.hs" "Main" - -- , manipulateAstTestWFname "Simple.hs" "Main" - -- , manipulateAstTestWFname "FunDeps.hs" "Main" - -- , manipulateAstTestWFname "IfThenElse3.hs" "Main" - -- , manipulateAstTestWFname "ImplicitParams.hs" "Main" - -- , manipulateAstTestWFname "ListComprehensions.hs" "Main" - -- , manipulateAstTestWFname "TransformListComp.hs" "Main" - -- , manipulateAstTestWFname "PArr.hs" "PArr" - -- , manipulateAstTestWFname "DataDecl.hs" "Main" - -- , manipulateAstTestWFname "WhereIn4.hs" "WhereIn4" - -- , manipulateAstTestWFname "Pseudonym.hs" "Main" - -- , manipulateAstTestWFname "Obscure.hs" "Main" - -- , manipulateAstTestWFname "Remorse.hs" "Main" - -- , manipulateAstTestWFname "Jon.hs" "Main" - -- , manipulateAstTestWFname "RSA.hs" "Main" - -- , manipulateAstTestWFname "CExpected.hs" "CExpected" - -- , manipulateAstTestWFname "C.hs" "C" - -- -- , manipulateAstTestWFnameMod changeCifToCase "C.hs" "C" - -- -- , manipulateAstTestWFnameMod changeWhereIn3 "WhereIn3.hs" "WhereIn3" - -- , manipulateAstTestWFname "DoParens.hs" "Main" - -- , manipulateAstTestWFname "SimpleComplexTuple.hs" "Main" - -- , manipulateAstTestWFname "Backquote.hs" "Main" - -- , manipulateAstTestWFname "HangingRecord.hs" "Main" - -- , manipulateAstTestWFname "PatternGuards.hs" "Main" - -- -- , manipulateAstTestWFnameMod (changeWhereIn3 2) "WhereIn3.hs" "WhereIn3" - -- -- , manipulateAstTestWFnameMod (changeWhereIn3 2) "WhereIn3.hs" "WhereIn3" - -- , manipulateAstTestWFname "DoParens.hs" "Main" - - -- -- Future tests to pass, after appropriate dev is done - -- -- , manipulateAstTestWFname "MultipleInferredContexts.hs" "Main" - -- -- , manipulateAstTestWFname "ArgPuncParens.hs" "Main" - -- -- , manipulateAstTestWFname "SimpleComplexTuple.hs" "Main" - -- -- , manipulateAstTestWFname "DoPatBind.hs" "Main" - -- , manipulateAstTestWFname "DroppedDoSpace.hs" "Main" - -- , manipulateAstTestWFname "DroppedDoSpace2.hs" "Main" - -- , manipulateAstTestWFname "GHCOrig.hs" "GHC.Tuple" - - -- , manipulateAstTestWFname "Cpp.hs" "Main" - -- , manipulateAstTestWFname "MangledSemiLet.hs" "Main" - -- , manipulateAstTestWFname "ListComprehensions.hs" "Main" - -- , manipulateAstTestWFname "ParensAroundContext.hs" "ParensAroundContext" - -- , manipulateAstTestWFname "TypeFamilies.hs" "Main" - -- , manipulateAstTestWFname "Associated.hs" "Main" - -- , manipulateAstTestWFname "RdrNames.hs" "RdrNames" - -- , manipulateAstTestWFname "StrangeTypeClass.hs" "Main" - -- , manipulateAstTestWFname "TypeSignatureParens.hs" "Main" - -- , manipulateAstTestWFname "DoubleForall.hs" "Main" - -- , manipulateAstTestWFname "GADTRecords.hs" "Main" - -- , manipulateAstTestWFname "Existential.hs" "Main" - -- , manipulateAstTestWFname "ScopedTypeVariables.hs" "Main" - -- , manipulateAstTestWFname "T5951.hs" "T5951" - -- , manipulateAstTestWFname "Zipper2.hs" "Zipper2" - -- , manipulateAstTestWFname "RdrNames2.hs" "RdrNames2" - -- , manipulateAstTestWFname "Unicode.hs" "Unicode" - -- , manipulateAstTestWFname "OptSig2.hs" "Main" - -- , manipulateAstTestWFname "Minimal.hs" "Main" - -- , manipulateAstTestWFname "DroppedComma.hs" "Main" - -- , manipulateAstTestWFname "SlidingTypeSyn.hs" "Main" - -- , manipulateAstTestWFname "TupleSections.hs" "Main" - -- , manipulateAstTestWFname "CorePragma.hs" "Main" - -- , manipulateAstTestWFname "Splice.hs" "Splice" - -- , manipulateAstTestWFname "TemplateHaskell.hs" "Main" - -- , manipulateAstTestWFname "GADTContext.hs" "Main" - -- , manipulateAstTestWFnameBad "UnicodeSyntax.hs" "Tutorial" - -- , manipulateAstTestWFname "DataDecl.hs" "Main" - - -- , manipulateAstTestWFname "TypeBrackets.hs" "Main" - -- , manipulateAstTestWFname "TypeBrackets2.hs" "Main" - -- , manipulateAstTestWFname "TypeBrackets4.hs" "Main" - -- , manipulateAstTestWFname "NestedLambda.hs" "Main" - -- , manipulateAstTestWFname "ShiftingLambda.hs" "Main" - -- , manipulateAstTestWFname "SlidingLambda.hs" "Main" --- , manipulateAstTestWFnameMod changeAddDecl "AddDecl.hs" "AddDecl" - -- , manipulateAstTestWFnameMod changeLocalDecls "LocalDecls.hs" "LocalDecls" - -- , manipulateAstTestWFname "LocalDecls2Expected.hs" "LocalDecls2Expected" - -- , manipulateAstTestWFname "LocalDecls2.hs" "LocalDecls2" - -- , manipulateAstTestWFnameMod changeLocalDecls2 "LocalDecls2.hs" "LocalDecls2" - -- , manipulateAstTestWFname "WhereIn3.hs" "WhereIn3" - -- , manipulateAstTestWFnameMod changeWhereIn3a "WhereIn3a.hs" "WhereIn3a" - -- , manipulateAstTestWFname "Imports.hs" "Imports" - -- , manipulateAstTestWFname "T10196.hs" "T10196" - , manipulateAstTestWFnameMod addLocaLDecl1 "AddLocalDecl1.hs" "AddLocaLDecl1" - -- , manipulateAstTestWFnameMod addLocaLDecl2 "AddLocalDecl2.hs" "AddLocaLDecl2" - -- , manipulateAstTestWFnameMod addLocaLDecl3 "AddLocalDecl3.hs" "AddLocaLDecl3" - -- , manipulateAstTestWFnameMod addLocaLDecl4 "AddLocalDecl4.hs" "AddLocaLDecl4" - -- , manipulateAstTestWFnameMod addLocaLDecl5 "AddLocalDecl5.hs" "AddLocaLDecl5" - -- , manipulateAstTestWFnameMod addLocaLDecl6 "AddLocalDecl6.hs" "AddLocaLDecl6" - -- , manipulateAstTestWFnameMod rmDecl1 "RmDecl1.hs" "RmDecl1" - -- , manipulateAstTestWFname "RmDecl2.hs" "RmDecl2" - -- , manipulateAstTestWFnameMod rmDecl2 "RmDecl2.hs" "RmDecl2" - -- , manipulateAstTestWFnameMod rmDecl3 "RmDecl3.hs" "RmDecl3" - -- , manipulateAstTestWFnameMod rmDecl4 "RmDecl4.hs" "RmDecl4" - -- , manipulateAstTestWFnameMod rmDecl5 "RmDecl5.hs" "RmDecl5" - -- , manipulateAstTestWFname "RmDecl5.hs" "RmDecl5" - -- , manipulateAstTestWFnameMod rmDecl6 "RmDecl6.hs" "RmDecl6" - -- , manipulateAstTestWFnameMod rmDecl7 "RmDecl7.hs" "RmDecl7" - -- , manipulateAstTestWFname "TypeSignature.hs" "TypeSignature" - -- , manipulateAstTestWFnameMod rmTypeSig1 "RmTypeSig1.hs" "RmTypeSig1" - -- , manipulateAstTestWFnameMod rmTypeSig2 "RmTypeSig2.hs" "RmTypeSig2" - -- , manipulateAstTestWFname "StringGap.hs" "StringGap" - -- , manipulateAstTestWFnameMod addHiding1 "AddHiding1.hs" "AddHiding1" - -- , manipulateAstTestWFnameMod addHiding2 "AddHiding2.hs" "AddHiding2" - -- , manipulateAstTestWFnameMod cloneDecl1 "CloneDecl1.hs" "CloneDecl1" - -- , manipulateAstTestWFname "SimpleDo.hs" "Main" - -- , manipulateAstTestWFnameMod changeRename2 "Rename2.hs" "Main" - , manipulateAstTestWFname "Arrow2.hs" "Arrow2" - {- - , manipulateAstTestWFname "Lhs.lhs" "Main" - , manipulateAstTestWFname "Foo.hs" "Main" - -} +tt' :: IO (Counts,Int) +tt' = runTestText (putTextToHandle stdout True) $ TestList [ + -- , mkTestModChange changeLayoutLet2 "LayoutLet2.hs" + -- , mkTestModChange changeLayoutLet3 "LayoutLet3.hs" + -- , mkTestModChange changeLayoutLet3 "LayoutLet4.hs" + -- , mkTestModChange changeRename1 "Rename1.hs" + -- , mkTestModChange changeRename2 "Rename2.hs" + -- , mkTestModChange changeLayoutIn1 "LayoutIn1.hs" + -- , mkTestModChange changeLayoutIn3 "LayoutIn3.hs" + -- , mkTestModChange changeLayoutIn3 "LayoutIn3a.hs" + -- , mkTestModChange changeLayoutIn3 "LayoutIn3b.hs" + -- , mkTestModChange changeLayoutIn4 "LayoutIn4.hs" + -- , mkTestModChange changeLocToName "LocToName.hs" + -- , mkTestModChange changeLetIn1 "LetIn1.hs" + -- , mkTestModChange changeWhereIn4 "WhereIn4.hs" + -- , mkTestModChange changeAddDecl "AddDecl.hs" + mkTestModChange changeLocalDecls "LocalDecls.hs" + -- , mkTestModChange changeLocalDecls2 "LocalDecls2.hs" + -- , mkTestModChange changeWhereIn3a "WhereIn3a.hs" + , mkTestModChange changeRenameCase1 "RenameCase1.hs" + , mkTestModChange changeRenameCase2 "RenameCase2.hs" ] testsTT :: Test testsTT = TestList [ - mkParserTest "Cpp.hs" - , mkParserTest "DroppedDoSpace.hs" + mkParserTest "ghc710" "Cpp.hs" + , mkParserTest "ghc710" "DroppedDoSpace.hs" ] tt :: IO () @@ -522,28 +166,8 @@ else return () -- exitSuccess --- | Where all the tests are to be found -examplesDir :: FilePath -examplesDir = "tests" "examples" - -examplesDir2 :: FilePath -examplesDir2 = "examples" - - - --- --------------------------------------------------------------------- - pwd :: IO FilePath pwd = getCurrentDirectory cd :: FilePath -> IO () cd = setCurrentDirectory - --- --------------------------------------------------------------------- - -mkSs :: (Int,Int) -> (Int,Int) -> GHC.SrcSpan -mkSs (sr,sc) (er,ec) - = GHC.mkSrcSpan (GHC.mkSrcLoc (GHC.mkFastString "examples/PatBind.hs") sr sc) - (GHC.mkSrcLoc (GHC.mkFastString "examples/PatBind.hs") er ec) - --- --------------------------------------------------------------------- diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs --- a/tests/Test/Common.hs +++ b/tests/Test/Common.hs @@ -12,12 +12,19 @@ , ReportType(..) , roundTripTest , getModSummaryForFile + + , testList + , testPrefix + , Changer + , genTest + , noChange ) where import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleApiAnnsWithCpp) import Language.Haskell.GHC.ExactPrint.Preprocess import GHC.Paths (libdir) @@ -43,10 +50,16 @@ import Test.Consistency -import Control.Arrow (first) +import Test.HUnit +import System.FilePath -- import Debug.Trace +testPrefix :: FilePath +testPrefix = "tests" "examples" +testList :: String -> [Test] -> Test +testList s ts = TestLabel s (TestList ts) + -- --------------------------------------------------------------------- -- Roundtrip machinery @@ -83,59 +96,45 @@ removeSpaces :: String -> String removeSpaces = map (\case {'\160' -> ' '; s -> s}) -initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags -initDynFlags file = do - dflags0 <- GHC.getSessionDynFlags - let dflags1 = GHC.gopt_set dflags0 GHC.Opt_KeepRawTokenStream - src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags1 file - (!dflags2, _, _) - <- GHC.parseDynamicFilePragma dflags1 src_opts - void $ GHC.setSessionDynFlags dflags2 - return dflags2 - roundTripTest :: FilePath -> IO Report -roundTripTest file = - GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ - GHC.runGhc (Just libdir) $ do - dflags <- initDynFlags file - let useCpp = GHC.xopt GHC.Opt_Cpp dflags - (fileContents, injectedComments) <- - if useCpp - then do - contents <- getPreprocessedSrcDirect defaultCppOptions file - cppComments <- getCppTokensAsComments defaultCppOptions file - return (contents,cppComments) - else do - txt <- GHC.liftIO $ readFile file - let (contents1,lp) = stripLinePragmas txt - return (contents1,lp) +roundTripTest f = genTest noChange f f - orig <- GHC.liftIO $ readFile file - let origContents = removeSpaces fileContents - pristine = removeSpaces orig - return $ - case parseFile dflags file origContents of - GHC.PFailed ss m -> Left $ ParseFailure ss (GHC.showSDoc dflags m) - GHC.POk (mkApiAnns -> apianns) pmod -> - let (printed, anns) = first trimPrinted $ runRoundTrip apianns pmod injectedComments - -- Clang cpp adds an extra newline character - -- Do not remove this line! - trimPrinted p = if useCpp - then unlines $ take (length (lines pristine)) (lines p) - else p - debugTxt = mkDebugOutput file printed pristine apianns anns pmod - consistency = checkConsistency apianns pmod - inconsistent = if null consistency then Nothing else Just consistency - status = if printed == pristine then Success else RoundTripFailure - cppStatus = if useCpp then Just origContents else Nothing - in - Right Report {..} +type Changer = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource)) +noChange :: Changer +noChange ans parsed = return (ans,parsed) +genTest :: Changer -> FilePath -> FilePath -> IO Report +genTest f origFile expectedFile = do + res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile + expected <- GHC.liftIO $ readFile expectedFile + orig <- GHC.liftIO $ readFile origFile + let pristine = removeSpaces expected + + case res of + Left (ss, m) -> return . Left $ ParseFailure ss m + Right (apianns, injectedComments, dflags, pmod) -> do + (printed', anns, pmod') <- GHC.liftIO (runRoundTrip f apianns pmod injectedComments) + let useCpp = GHC.xopt GHC.Opt_Cpp dflags + printed = trimPrinted printed' + -- let (printed, anns) = first trimPrinted $ runRoundTrip apianns pmod injectedComments + -- Clang cpp adds an extra newline character + -- Do not remove this line! + trimPrinted p = if useCpp + then unlines $ take (length (lines pristine)) (lines p) + else p + debugTxt = mkDebugOutput origFile printed pristine apianns anns pmod' + consistency = checkConsistency apianns pmod + inconsistent = if null consistency then Nothing else Just consistency + status = if printed == pristine then Success else RoundTripFailure + cppStatus = if useCpp then Just orig else Nothing + return $ Right Report {..} + + mkDebugOutput :: FilePath -> String -> String -> GHC.ApiAnns -> Anns - -> GHC.Located (GHC.HsModule GHC.RdrName) -> String + -> GHC.ParsedSource -> String mkDebugOutput filename printed original apianns anns parsed = intercalate sep [ printed , filename @@ -149,14 +148,15 @@ -runRoundTrip :: GHC.ApiAnns -> GHC.Located (GHC.HsModule GHC.RdrName) +runRoundTrip :: Changer + -> GHC.ApiAnns -> GHC.Located (GHC.HsModule GHC.RdrName) -> [Comment] - -> (String, Anns) -runRoundTrip !anns !parsedOrig cs = - let - !relAnns = relativiseApiAnnsWithComments cs parsedOrig anns - !printed = exactPrint parsedOrig relAnns - in (printed, relAnns) + -> IO (String, Anns, GHC.ParsedSource) +runRoundTrip f !anns !parsedOrig cs = do + let !relAnns = relativiseApiAnnsWithComments cs parsedOrig anns + (annsMod, pmod) <- f relAnns parsedOrig + let !printed = exactPrint pmod annsMod + return (printed, relAnns, pmod) -- ---------------------------------------------------------------------` diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -2,15 +2,11 @@ module Test.Transform where import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Preprocess import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Parsers -import GHC.Paths ( libdir ) import qualified Bag as GHC -import qualified DynFlags as GHC import qualified GHC as GHC import qualified OccName as GHC import qualified RdrName as GHC @@ -20,21 +16,17 @@ import qualified Data.Generics as SYB -- import qualified GHC.SYB.Utils as SYB -import Control.Monad import System.FilePath -import System.IO import qualified Data.Map as Map -- import Data.List import Data.Maybe -import System.IO.Silently - import Test.Common import Test.HUnit -transformTests :: [Test] -transformTests = +transformTests :: Test +transformTests = TestLabel "transformation tests" $ TestList [ TestLabel "Low level transformations" (TestList transformLowLevelTests) @@ -44,33 +36,46 @@ transformLowLevelTests :: [Test] transformLowLevelTests = [ - mkTestModChange changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2" - , mkTestModChange changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3" - , mkTestModChange changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4" - , mkTestModChange changeRename1 "Rename1.hs" "Main" - , mkTestModChange changeRename2 "Rename2.hs" "Main" - , mkTestModChange changeLayoutIn1 "LayoutIn1.hs" "LayoutIn1" - , mkTestModChange changeLayoutIn3 "LayoutIn3.hs" "LayoutIn3" - , mkTestModChange changeLayoutIn3 "LayoutIn3a.hs" "LayoutIn3a" - , mkTestModChange changeLayoutIn3 "LayoutIn3b.hs" "LayoutIn3b" - , mkTestModChange changeLayoutIn4 "LayoutIn4.hs" "LayoutIn4" - , mkTestModChange changeLocToName "LocToName.hs" "LocToName" - , mkTestModChange changeLetIn1 "LetIn1.hs" "LetIn1" - , mkTestModChange changeWhereIn4 "WhereIn4.hs" "WhereIn4" - , mkTestModChange changeAddDecl "AddDecl.hs" "AddDecl" - , mkTestModChange changeLocalDecls "LocalDecls.hs" "LocalDecls" - , mkTestModChange changeLocalDecls2 "LocalDecls2.hs" "LocalDecls2" - , mkTestModChange changeWhereIn3a "WhereIn3a.hs" "WhereIn3a" + mkTestModChange changeRenameCase1 "RenameCase1.hs" + , mkTestModChange changeLayoutLet2 "LayoutLet2.hs" + , mkTestModChange changeLayoutLet3 "LayoutLet3.hs" + , mkTestModChange changeLayoutLet3 "LayoutLet4.hs" + , mkTestModChange changeRename1 "Rename1.hs" + , mkTestModChange changeRename2 "Rename2.hs" + , mkTestModChange changeLayoutIn1 "LayoutIn1.hs" + , mkTestModChange changeLayoutIn3 "LayoutIn3.hs" + , mkTestModChange changeLayoutIn3 "LayoutIn3a.hs" + , mkTestModChange changeLayoutIn3 "LayoutIn3b.hs" + , mkTestModChange changeLayoutIn4 "LayoutIn4.hs" + , mkTestModChange changeLocToName "LocToName.hs" + , mkTestModChange changeLetIn1 "LetIn1.hs" + , mkTestModChange changeWhereIn4 "WhereIn4.hs" + , mkTestModChange changeAddDecl "AddDecl.hs" + , mkTestModChange changeLocalDecls "LocalDecls.hs" + , mkTestModChange changeLocalDecls2 "LocalDecls2.hs" + , mkTestModChange changeWhereIn3a "WhereIn3a.hs" -- , mkTestModChange changeCifToCase "C.hs" "C" ] -mkTestModChange :: Changer -> FilePath -> String -> Test -mkTestModChange change fileName modName - = TestCase (do r <- manipulateAstTestWithMod change "expected" fileName modName - assertBool fileName r ) +mkTestModChange :: Changer -> FilePath -> Test +mkTestModChange = mkTestMod "expected" "transform" -type Changer = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource)) +mkTestModBad :: FilePath -> Test +mkTestModBad = mkTestMod "bad" "failing" noChange + +mkTestMod :: String -> FilePath -> Changer -> FilePath -> Test +mkTestMod suffix dir f fp = + let basename = testPrefix dir fp + expected = basename <.> suffix + writeFailure = writeFile (basename <.> "out") + in + TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id + <$> genTest f basename expected + writeFailure (debugTxt r) + assertBool fp (status r == Success)) + + -- --------------------------------------------------------------------- changeWhereIn3a :: Changer @@ -199,111 +204,12 @@ -- error $ "doRmDecl:decls2=" ++ showGhc (length decls,decls1,decls2) -- --------------------------------------------------------------------- -{- --- |Convert the if statement in C.hs to a case, adjusting layout appropriately. -changeCifToCase :: Changer -changeCifToCase ans p = return (ans',p') - where - (p',(ans',_),_) = runTransform ans doTransform - doTransform = SYB.everywhereM (SYB.mkM ifToCaseTransform) p - ifToCaseTransform :: GHC.Located (GHC.HsExpr GHC.RdrName) - -> Transform (GHC.Located (GHC.HsExpr GHC.RdrName)) - ifToCaseTransform li@(GHC.L l (GHC.HsIf _se e1 e2 e3)) = do - caseLoc <- uniqueSrcSpanT -- HaRe:-1:1 - trueMatchLoc <- uniqueSrcSpanT -- HaRe:-1:2 - trueLoc1 <- uniqueSrcSpanT -- HaRe:-1:3 - trueLoc <- uniqueSrcSpanT -- HaRe:-1:4 - trueRhsLoc <- uniqueSrcSpanT -- HaRe:-1:5 - falseLoc1 <- uniqueSrcSpanT -- HaRe:-1:6 - falseLoc <- uniqueSrcSpanT -- HaRe:-1:7 - falseMatchLoc <- uniqueSrcSpanT -- HaRe:-1:8 - falseRhsLoc <- uniqueSrcSpanT -- HaRe:-1:9 - caseVirtualLoc <- uniqueSrcSpanT -- HaRe:-1:10 - let trueName = mkRdrName "True" - let falseName = mkRdrName "False" - let ret = GHC.L caseLoc (GHC.HsCase e1 - (GHC.MG - [ - (GHC.L trueMatchLoc $ GHC.Match - Nothing - [ - GHC.L trueLoc1 $ GHC.ConPatIn (GHC.L trueLoc trueName) (GHC.PrefixCon []) - ] - Nothing - (GHC.GRHSs - [ - GHC.L trueRhsLoc $ GHC.GRHS [] e2 - ] GHC.EmptyLocalBinds) - ) - , (GHC.L falseMatchLoc $ GHC.Match - Nothing - [ - GHC.L falseLoc1 $ GHC.ConPatIn (GHC.L falseLoc falseName) (GHC.PrefixCon []) - ] - Nothing - (GHC.GRHSs - [ - GHC.L falseRhsLoc $ GHC.GRHS [] e3 - ] GHC.EmptyLocalBinds) - ) - ] [] GHC.placeHolderType GHC.FromSource)) - - oldAnns <- getAnnsT - let annIf = gfromJust "Case.annIf" $ getAnnotationEP li NotNeeded oldAnns - let annCond = gfromJust "Case.annCond" $ getAnnotationEP e1 NotNeeded oldAnns - let annThen = gfromJust "Case.annThen" $ getAnnotationEP e2 NotNeeded oldAnns - let annElse = gfromJust "Case.annElse" $ getAnnotationEP e3 NotNeeded oldAnns - logTr $ "Case:annIf=" ++ show annIf - logTr $ "Case:annThen=" ++ show annThen - logTr $ "Case:annElse=" ++ show annElse - - -- let ((_ifr, ifc), ifDP) = getOriginalPos oldAnns li (G GHC.AnnIf) - -- let ((_thenr,thenc),thenDP) = getOriginalPos oldAnns li (G GHC.AnnThen) - -- let ((_elser,elsec),elseDP) = getOriginalPos oldAnns li (G GHC.AnnElse) - -- let newCol = ifc + 2 - let newCol = 6 - - -- AZ:TODO: under some circumstances the GRHS annotations need LineSame, in others LineChanged. - let ifDelta = gfromJust "Case.ifDelta" $ lookup (G GHC.AnnIf) (annsDP annIf) - -- let ifSpanEntry = gfromJust "Case.ifSpanEntry" $ lookup AnnSpanEntry (annsDP annIf) - -- let ifSpanEntry = annEntryDelta annIf - let anne2' = - [ ( AnnKey caseLoc (CN "HsCase") NotNeeded, annIf { annsDP = [ (G GHC.AnnCase, ifDelta) - , (G GHC.AnnOf, DP (0,1))] - , annCapturedSpan = Just (AnnKey caseVirtualLoc (CN "(:)") NotNeeded) - } ) - , ( AnnKey caseVirtualLoc (CN "(:)") NotNeeded, Ann (DP (1,newCol)) (ColDelta newCol) (DP (1,newCol)) [] [] [(AnnSpanEntry,DP (1,0))] Nothing Nothing) - , ( AnnKey trueMatchLoc (CN "Match") NotNeeded, annNone ) - , ( AnnKey trueLoc1 (CN "ConPatIn") NotNeeded, annNone ) - , ( AnnKey trueLoc (CN "Unqual") NotNeeded, annNone ) - , ( AnnKey trueRhsLoc (CN "GRHS") NotNeeded, Ann (DP (0,2)) 6 (DP (0,0)) [] [] [(AnnSpanEntry,DP (0,2)),(G GHC.AnnRarrow, DP (0,0))] Nothing Nothing ) - - , ( AnnKey falseMatchLoc (CN "Match") NotNeeded, Ann (DP (1,0)) 0 (DP (0,0)) [] [] [(AnnSpanEntry,DP (1,0))] Nothing Nothing ) - , ( AnnKey falseLoc1 (CN "ConPatIn") NotNeeded, annNone ) - , ( AnnKey falseLoc (CN "Unqual") NotNeeded, annNone ) - , ( AnnKey falseRhsLoc (CN "GRHS") NotNeeded, Ann (DP (0,1)) 6 (DP (0,0)) [] [] [(AnnSpanEntry,DP (0,1)),(G GHC.AnnRarrow, DP (0,0))] Nothing Nothing ) - ] - - let annThen' = adjustAnnOffset (ColDelta 6) annThen - let anne1 = modifyKeywordDeltas (Map.delete (AnnKey l (CN "HsIf") NotNeeded)) oldAnns - final = modifyKeywordDeltas (\s -> Map.union s (Map.fromList anne2')) anne1 - anne3 = setLocatedAnns final - [ (e1, annCond) - , (e2, annThen') - , (e3, annElse) - ] - putAnnsT anne3 - return ret - ifToCaseTransform x = return x - - mkRdrName :: String -> GHC.RdrName - mkRdrName s = GHC.mkVarUnqual (GHC.mkFastString s) --} --- --------------------------------------------------------------------- +changeRenameCase1 :: Changer +changeRenameCase1 ans parsed = return (ans,rename "bazLonger" [((3,15),(3,18))] parsed) -noChange :: Changer -noChange ans parsed = return (ans,parsed) +changeRenameCase2 :: Changer +changeRenameCase2 ans parsed = return (ans,rename "fooLonger" [((3,1),(3,4))] parsed) changeLayoutLet2 :: Changer changeLayoutLet2 ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed) @@ -398,183 +304,31 @@ -- --------------------------------------------------------------------- - -manipulateAstTestWithMod :: Changer -> String -> FilePath -> String -> IO Bool -manipulateAstTestWithMod change suffix file modname = manipulateAstTest' (Just (change, suffix)) False file modname - -manipulateAstTestWFnameMod :: Changer -> FilePath -> String -> IO (FilePath,Bool) -manipulateAstTestWFnameMod change fileName modname - = do r <- manipulateAstTestWithMod change "expected" fileName modname - return (fileName,r) - -manipulateAstTestWFnameBad :: FilePath -> String -> IO (FilePath,Bool) -manipulateAstTestWFnameBad fileName modname - = do r <- manipulateAstTestWithMod noChange "bad" fileName modname - return (fileName,r) - -manipulateAstTest :: FilePath -> String -> IO Bool -manipulateAstTest file modname = manipulateAstTest' Nothing False file modname - -manipulateAstTestWFname :: FilePath -> String -> IO (FilePath, Bool) -manipulateAstTestWFname file modname = (file,) <$> manipulateAstTest file modname - - -mkTestModBad :: FilePath -> String -> Test -mkTestModBad fileName modName - = TestCase (do r <- manipulateAstTestWithMod noChange "bad" fileName modName - assertBool fileName r ) - -manipulateAstTest' :: Maybe (Changer, String) - -> Bool -> FilePath -> String -> IO Bool -manipulateAstTest' mchange useTH file' modname = do - let testpath = "./tests/examples/" - file = testpath file' - out = file <.> "out" - - contents <- case mchange of - Nothing -> readFile file - Just (_,expectedSuffix) -> readFile (file <.> expectedSuffix) - (ghcAnns',p,cppComments) <- hSilence [stderr] $ parsedFileGhc file modname useTH - -- (ghcAnns',p,cppComments) <- parsedFileGhc file modname useTH - let - parsedOrig = GHC.pm_parsed_source $ p - (ghcAnns,parsed) = (ghcAnns', parsedOrig) - parsedAST = showAnnData emptyAnns 0 parsed - -- cppComments = map (tokComment . commentToAnnotation . fst) cppCommentToks - -- parsedAST = showGhc parsed - -- `debug` ("getAnn:=" ++ (show (getAnnotationValue (snd ann) (GHC.getLoc parsed) :: Maybe AnnHsModule))) - -- try to pretty-print; summarize the test result - ann = relativiseApiAnnsWithComments cppComments parsedOrig ghcAnns' - `debug` ("ghcAnns:" ++ showGhc ghcAnns) - - (ann',parsed') <- case mchange of - Nothing -> return (ann,parsed) - Just (change,_) -> change ann parsed - - let - printed = exactPrint parsed' ann' -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann)) - outcome = if printed == contents - then "Match\n" - else "Fail\n" - result = printed ++ "\n==============\n" - ++ outcome ++ "\n==============\n" - ++ "lengths:" ++ show (length printed,length contents) ++ "\n" - ++ showAnnData ann' 0 parsed' - ++ "\n========================\n" - ++ showGhc ann' - ++ "\n========================\n" - ++ showGhc ghcAnns - ++ "\n========================\n" - ++ parsedAST - ++ "\n========================\n" - ++ showGhc ann - -- putStrLn $ "Test:ann :" ++ showGhc ann - writeFile out $ result - -- putStrLn $ "Test:contents' :" ++ contents - -- putStrLn $ "Test:parsed=" ++ parsedAST - -- putStrLn $ "Test:showdata:parsedOrig" ++ SYB.showData SYB.Parser 0 parsedOrig - -- putStrLn $ "Test:ann :" ++ showGhc ann - -- putStrLn $ "Test:ghcAnns :" ++ showGhc ghcAnns - -- putStrLn $ "Test:ghcAnns' :" ++ showGhc ghcAnns' - -- putStrLn $ "Test:showdata:" ++ showAnnData ann 0 parsed - -- putStrLn $ "Test:showdata:parsed'" ++ SYB.showData SYB.Parser 0 parsed' - -- putStrLn $ "Test:showdata:parsed'" ++ showAnnData ann 0 parsed' - -- putStrLn $ "Test:outcome' :" ++ outcome - return (printed == contents) - - --- --------------------------------------------------------------------- --- |Result of parsing a Haskell source file. It is simply the --- TypeCheckedModule produced by GHC. -type ParseResult = GHC.ParsedModule - -parsedFileGhc :: String -> String -> Bool -> IO (GHC.ApiAnns,ParseResult,[Comment]) -parsedFileGhc fileName _modname useTH = do - -- putStrLn $ "parsedFileGhc:" ++ show fileName - GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ do - GHC.runGhc (Just libdir) $ do - dflags <- GHC.getSessionDynFlags - let dflags2 = dflags { GHC.importPaths = ["./tests/examples/","../tests/examples/", - "./src/","../src/"] } - tgt = if useTH then GHC.HscInterpreted - else GHC.HscNothing -- allows FFI - dflags3 = dflags2 { GHC.hscTarget = tgt - , GHC.ghcLink = GHC.LinkInMemory - } - - dflags4 = GHC.gopt_set dflags3 GHC.Opt_KeepRawTokenStream - - (dflags5,_args,_warns) <- GHC.parseDynamicFlagsCmdLine dflags4 [GHC.noLoc "-package ghc"] - -- GHC.liftIO $ putStrLn $ "dflags set:(args,warns)" ++ show (map GHC.unLoc _args,map GHC.unLoc _warns) - void $ GHC.setSessionDynFlags dflags5 - -- GHC.liftIO $ putStrLn $ "dflags set" - - -- hsc_env <- GHC.getSession - -- (dflags6,fn_pp) <- GHC.liftIO $ GHC.preprocess hsc_env (fileName,Nothing) - -- GHC.liftIO $ putStrLn $ "preprocess got:" ++ show fn_pp - - - target <- GHC.guessTarget fileName Nothing - GHC.setTargets [target] - -- GHC.liftIO $ putStrLn $ "target set:" ++ showGhc (GHC.targetId target) - void $ GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling make - -- GHC.liftIO $ putStrLn $ "targets loaded" - -- g <- GHC.getModuleGraph - -- let showStuff ms = show (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod ms,GHC.ms_location ms) - -- GHC.liftIO $ putStrLn $ "module graph:" ++ (intercalate "," (map showStuff g)) - - -- modSum <- GHC.getModSummary $ GHC.mkModuleName modname - Just modSum <- getModSummaryForFile fileName - -- GHC.liftIO $ putStrLn $ "got modSum" - -- let modSum = head g - cppComments <- if (GHC.xopt GHC.Opt_Cpp dflags5) - then getCppTokensAsComments defaultCppOptions fileName - else return [] - -- let cppComments = [] :: [(GHC.Located GHC.Token, String)] --- GHC.liftIO $ putStrLn $ "\ncppTokensAsComments for:" ++ fileName ++ "=========\n" --- ++ showGhc cppComments ++ "\n================\n" -{- - (sourceFile, source, flags) <- getModuleSourceAndFlags (GHC.ms_mod modSum) - strSrcBuf <- getPreprocessedSrc sourceFile - GHC.liftIO $ putStrLn $ "preprocessedSrc====\n" ++ strSrcBuf ++ "\n================\n" --} - p <- GHC.parseModule modSum - -- GHC.liftIO $ putStrLn $ "got parsedModule" --- t <- GHC.typecheckModule p - -- GHC.liftIO $ putStrLn $ "typechecked" - -- toks <- GHC.getRichTokenStream (GHC.ms_mod modSum) - -- GHC.liftIO $ putStrLn $ "toks" ++ show toks - let anns = GHC.pm_annotations p - -- GHC.liftIO $ putStrLn $ "anns" - return (anns,p,cppComments) - --- --------------------------------------------------------------------- - transformHighLevelTests :: [Test] transformHighLevelTests = [ - mkTestModChange addLocaLDecl1 "AddLocalDecl1.hs" "AddLocalDecl1" - , mkTestModChange addLocaLDecl2 "AddLocalDecl2.hs" "AddLocalDecl2" - , mkTestModChange addLocaLDecl3 "AddLocalDecl3.hs" "AddLocalDecl3" - , mkTestModChange addLocaLDecl4 "AddLocalDecl4.hs" "AddLocalDecl4" - , mkTestModChange addLocaLDecl5 "AddLocalDecl5.hs" "AddLocalDecl5" - , mkTestModChange addLocaLDecl6 "AddLocalDecl6.hs" "AddLocalDecl6" + mkTestModChange addLocaLDecl1 "AddLocalDecl1.hs" + , mkTestModChange addLocaLDecl2 "AddLocalDecl2.hs" + , mkTestModChange addLocaLDecl3 "AddLocalDecl3.hs" + , mkTestModChange addLocaLDecl4 "AddLocalDecl4.hs" + , mkTestModChange addLocaLDecl5 "AddLocalDecl5.hs" + , mkTestModChange addLocaLDecl6 "AddLocalDecl6.hs" - , mkTestModChange rmDecl1 "RmDecl1.hs" "RmDecl1" - , mkTestModChange rmDecl2 "RmDecl2.hs" "RmDecl2" - , mkTestModChange rmDecl3 "RmDecl3.hs" "RmDecl3" - , mkTestModChange rmDecl4 "RmDecl4.hs" "RmDecl4" - , mkTestModChange rmDecl5 "RmDecl5.hs" "RmDecl5" - , mkTestModChange rmDecl6 "RmDecl6.hs" "RmDecl6" - , mkTestModChange rmDecl7 "RmDecl7.hs" "RmDecl7" + , mkTestModChange rmDecl1 "RmDecl1.hs" + , mkTestModChange rmDecl2 "RmDecl2.hs" + , mkTestModChange rmDecl3 "RmDecl3.hs" + , mkTestModChange rmDecl4 "RmDecl4.hs" + , mkTestModChange rmDecl5 "RmDecl5.hs" + , mkTestModChange rmDecl6 "RmDecl6.hs" + , mkTestModChange rmDecl7 "RmDecl7.hs" - , mkTestModChange rmTypeSig1 "RmTypeSig1.hs" "RmTypeSig1" - , mkTestModChange rmTypeSig2 "RmTypeSig2.hs" "RmTypeSig2" + , mkTestModChange rmTypeSig1 "RmTypeSig1.hs" + , mkTestModChange rmTypeSig2 "RmTypeSig2.hs" - , mkTestModChange addHiding1 "AddHiding1.hs" "AddHiding1" - , mkTestModChange addHiding2 "AddHiding2.hs" "AddHiding2" + , mkTestModChange addHiding1 "AddHiding1.hs" + , mkTestModChange addHiding2 "AddHiding2.hs" - , mkTestModChange cloneDecl1 "CloneDecl1.hs" "CloneDecl1" + , mkTestModChange cloneDecl1 "CloneDecl1.hs" ] -- --------------------------------------------------------------------- diff --git a/tests/examples/AddAndOr3.hs b/tests/examples/AddAndOr3.hs deleted file mode 100644 --- a/tests/examples/AddAndOr3.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -module AddAndOr3 where - -addAndOr3 :: _ -> _ -> _ -addAndOr3 (a, b) (c, d) = (a `plus` d, b || c) - where plus :: Int -> Int -> Int - x `plus` y = x + y diff --git a/tests/examples/AddDecl.hs b/tests/examples/AddDecl.hs deleted file mode 100644 --- a/tests/examples/AddDecl.hs +++ /dev/null @@ -1,9 +0,0 @@ -module AddDecl where - --- Adding a declaration to an existing file - --- | Do foo -foo a b = a + b - --- | Do bar -bar x y = foo (x+y) x diff --git a/tests/examples/AddDecl.hs.expected b/tests/examples/AddDecl.hs.expected deleted file mode 100644 --- a/tests/examples/AddDecl.hs.expected +++ /dev/null @@ -1,11 +0,0 @@ -module AddDecl where - -nn = n2 - --- Adding a declaration to an existing file - --- | Do foo -foo a b = a + b - --- | Do bar -bar x y = foo (x+y) x diff --git a/tests/examples/AddHiding1.hs b/tests/examples/AddHiding1.hs deleted file mode 100644 --- a/tests/examples/AddHiding1.hs +++ /dev/null @@ -1,7 +0,0 @@ -module AddHiding1 where - -import Data.Maybe - -import Data.Maybe hiding (n1,n2) - -f = 1 diff --git a/tests/examples/AddHiding1.hs.expected b/tests/examples/AddHiding1.hs.expected deleted file mode 100644 --- a/tests/examples/AddHiding1.hs.expected +++ /dev/null @@ -1,7 +0,0 @@ -module AddHiding1 where - -import Data.Maybe hiding (n1,n2) - -import Data.Maybe hiding (n1,n2) - -f = 1 diff --git a/tests/examples/AddHiding2.hs b/tests/examples/AddHiding2.hs deleted file mode 100644 --- a/tests/examples/AddHiding2.hs +++ /dev/null @@ -1,5 +0,0 @@ -module AddHiding2 where - -import Data.Maybe hiding (f1,f2) - -f = 1 diff --git a/tests/examples/AddHiding2.hs.expected b/tests/examples/AddHiding2.hs.expected deleted file mode 100644 --- a/tests/examples/AddHiding2.hs.expected +++ /dev/null @@ -1,5 +0,0 @@ -module AddHiding2 where - -import Data.Maybe hiding (f1,f2,n1,n2) - -f = 1 diff --git a/tests/examples/AddLocalDecl1.hs b/tests/examples/AddLocalDecl1.hs deleted file mode 100644 --- a/tests/examples/AddLocalDecl1.hs +++ /dev/null @@ -1,9 +0,0 @@ -module AddLocalDecl1 where - --- |This is a function -foo = x -- comment1 - --- |Another fun -x = a -- comment2 - where - a = 3 diff --git a/tests/examples/AddLocalDecl1.hs.expected b/tests/examples/AddLocalDecl1.hs.expected deleted file mode 100644 --- a/tests/examples/AddLocalDecl1.hs.expected +++ /dev/null @@ -1,11 +0,0 @@ -module AddLocalDecl1 where - --- |This is a function -foo = x -- comment1 - where - nn = 2 - --- |Another fun -x = a -- comment2 - where - a = 3 diff --git a/tests/examples/AddLocalDecl2.hs b/tests/examples/AddLocalDecl2.hs deleted file mode 100644 --- a/tests/examples/AddLocalDecl2.hs +++ /dev/null @@ -1,10 +0,0 @@ -module AddLocalDecl2 where - --- |This is a function -foo = x -- comment 0 - where p = 2 -- comment 1 - --- |Another fun -bar = a -- comment 2 - where nn = 2 - p = 2 -- comment 3 diff --git a/tests/examples/AddLocalDecl2.hs.expected b/tests/examples/AddLocalDecl2.hs.expected deleted file mode 100644 --- a/tests/examples/AddLocalDecl2.hs.expected +++ /dev/null @@ -1,11 +0,0 @@ -module AddLocalDecl2 where - --- |This is a function -foo = x -- comment 0 - where nn = 2 - p = 2 -- comment 1 - --- |Another fun -bar = a -- comment 2 - where nn = 2 - p = 2 -- comment 3 diff --git a/tests/examples/AddLocalDecl3.hs b/tests/examples/AddLocalDecl3.hs deleted file mode 100644 --- a/tests/examples/AddLocalDecl3.hs +++ /dev/null @@ -1,10 +0,0 @@ -module AddLocalDecl2 where - --- |This is a function -foo = x -- comment 0 - where p = 2 -- comment 1 - --- |Another fun -bar = a -- comment 2 - where p = 2 -- comment 3 - nn = 2 diff --git a/tests/examples/AddLocalDecl3.hs.expected b/tests/examples/AddLocalDecl3.hs.expected deleted file mode 100644 --- a/tests/examples/AddLocalDecl3.hs.expected +++ /dev/null @@ -1,11 +0,0 @@ -module AddLocalDecl2 where - --- |This is a function -foo = x -- comment 0 - where p = 2 -- comment 1 - nn = 2 - --- |Another fun -bar = a -- comment 2 - where p = 2 -- comment 3 - nn = 2 diff --git a/tests/examples/AddLocalDecl4.hs b/tests/examples/AddLocalDecl4.hs deleted file mode 100644 --- a/tests/examples/AddLocalDecl4.hs +++ /dev/null @@ -1,3 +0,0 @@ -module AddLocalDecl4 where - -toplevel x = c * x diff --git a/tests/examples/AddLocalDecl4.hs.expected b/tests/examples/AddLocalDecl4.hs.expected deleted file mode 100644 --- a/tests/examples/AddLocalDecl4.hs.expected +++ /dev/null @@ -1,6 +0,0 @@ -module AddLocalDecl4 where - -toplevel x = c * x - where - nn :: Int - nn = 2 diff --git a/tests/examples/AddLocalDecl5.hs b/tests/examples/AddLocalDecl5.hs deleted file mode 100644 --- a/tests/examples/AddLocalDecl5.hs +++ /dev/null @@ -1,8 +0,0 @@ -module AddLocalDecl5 where - -toplevel :: Integer -> Integer -toplevel x = c * x - --- c,d :: Integer -c = 7 -d = 9 diff --git a/tests/examples/AddLocalDecl5.hs.expected b/tests/examples/AddLocalDecl5.hs.expected deleted file mode 100644 --- a/tests/examples/AddLocalDecl5.hs.expected +++ /dev/null @@ -1,9 +0,0 @@ -module AddLocalDecl5 where - -toplevel :: Integer -> Integer -toplevel x = c * x - where - -- c,d :: Integer - c = 7 - -d = 9 diff --git a/tests/examples/AddLocalDecl6.hs b/tests/examples/AddLocalDecl6.hs deleted file mode 100644 --- a/tests/examples/AddLocalDecl6.hs +++ /dev/null @@ -1,9 +0,0 @@ -module AddLocalDecl6 where - -foo [] = 1 -- comment 0 -foo xs = 2 -- comment 1 - -bar [] = 1 -- comment 2 - where - x = 3 -bar xs = 2 -- comment 3 diff --git a/tests/examples/AddLocalDecl6.hs.expected b/tests/examples/AddLocalDecl6.hs.expected deleted file mode 100644 --- a/tests/examples/AddLocalDecl6.hs.expected +++ /dev/null @@ -1,11 +0,0 @@ -module AddLocalDecl6 where - -foo [] = 1 -- comment 0 - where - x = 3 -foo xs = 2 -- comment 1 - -bar [] = 1 -- comment 2 - where - x = 3 -bar xs = 2 -- comment 3 diff --git a/tests/examples/AddLocalDecl7.hs b/tests/examples/AddLocalDecl7.hs deleted file mode 100644 --- a/tests/examples/AddLocalDecl7.hs +++ /dev/null @@ -1,9 +0,0 @@ -module AddLocalDecl7 where - -toplevel :: Integer -> Integer -toplevel x = c * x - --- c,d :: Integer -c = 7 -d = 9 - diff --git a/tests/examples/AddLocalDecl7.hs.expected b/tests/examples/AddLocalDecl7.hs.expected deleted file mode 100644 --- a/tests/examples/AddLocalDecl7.hs.expected +++ /dev/null @@ -1,11 +0,0 @@ -module AddLocalDecl7 where - -toplevel :: Integer -> Integer -toplevel x = c * x - where - nn = nn2 - --- c,d :: Integer -c = 7 -d = 9 - diff --git a/tests/examples/AltsSemis.hs b/tests/examples/AltsSemis.hs deleted file mode 100644 --- a/tests/examples/AltsSemis.hs +++ /dev/null @@ -1,11 +0,0 @@ - - -foo x = - case x of - { ;;; -- leading - 0 -> 'a'; -- case 0 - 1 -> 'b' -- case 1 - ; 2 -> 'c' ; -- case 2 - ; 3 -> 'd' -- case 3 - ;;; -- case 4 - } diff --git a/tests/examples/Ann01.hs b/tests/examples/Ann01.hs deleted file mode 100644 --- a/tests/examples/Ann01.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Ann01 where - -{-# ANN module (1 :: Int) #-} -{-# ANN module (1 :: Integer) #-} -{-# ANN module (1 :: Double) #-} -{-# ANN module $([| 1 :: Int |]) #-} -{-# ANN module "Hello" #-} -{-# ANN module (Just (1 :: Int)) #-} -{-# ANN module [1 :: Int, 2, 3] #-} -{-# ANN module ([1..10] :: [Integer]) #-} -{-# ANN module ''Foo #-} -{-# ANN module (-1 :: Int) #-} - -{-# ANN type Foo (1 :: Int) #-} -{-# ANN type Foo (1 :: Integer) #-} -{-# ANN type Foo (1 :: Double) #-} -{-# ANN type Foo $([| 1 :: Int |]) #-} -{-# ANN type Foo "Hello" #-} -{-# ANN type Foo (Just (1 :: Int)) #-} -{-# ANN type Foo [1 :: Int, 2, 3] #-} -{-# ANN type Foo ([1..10] :: [Integer]) #-} -{-# ANN type Foo ''Foo #-} -{-# ANN type Foo (-1 :: Int) #-} -data Foo = Bar Int - -{-# ANN f (1 :: Int) #-} -{-# ANN f (1 :: Integer) #-} -{-# ANN f (1 :: Double) #-} -{-# ANN f $([| 1 :: Int |]) #-} -{-# ANN f "Hello" #-} -{-# ANN f (Just (1 :: Int)) #-} -{-# ANN f [1 :: Int, 2, 3] #-} -{-# ANN f ([1..10] :: [Integer]) #-} -{-# ANN f 'f #-} -{-# ANN f (-1 :: Int) #-} -f x = x diff --git a/tests/examples/AnnPackageName.hs b/tests/examples/AnnPackageName.hs deleted file mode 100644 --- a/tests/examples/AnnPackageName.hs +++ /dev/null @@ -1,4 +0,0 @@ - - -import "base" Prelude -import "base" Data.Data diff --git a/tests/examples/Annotations.hs b/tests/examples/Annotations.hs deleted file mode 100644 --- a/tests/examples/Annotations.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Annotations where - -{-# ANN module (1 :: Int) #-} -{-# ANN module (1 :: Integer) #-} -{-# ANN module (1 :: Double) #-} -{-# ANN module $([| 1 :: Int |]) #-} -{-# ANN module "Hello" #-} -{-# ANN module (Just (1 :: Int)) #-} -{-# ANN module [1 :: Int, 2, 3] #-} -{-# ANN module ([1..10] :: [Integer]) #-} -{-# ANN module ''Foo #-} -{-# ANN module (-1 :: Int) #-} - -{-# ANN type Foo (1 :: Int) #-} -{-# ANN type Foo (1 :: Integer) #-} -{-# ANN type Foo (1 :: Double) #-} -{-# ANN type Foo $([| 1 :: Int |]) #-} -{-# ANN type Foo "Hello" #-} -{-# ANN type Foo (Just (1 :: Int)) #-} -{-# ANN type Foo [1 :: Int, 2, 3] #-} -{-# ANN type Foo ([1..10] :: [Integer]) #-} -{-# ANN type Foo ''Foo #-} -{-# ANN type Foo (-1 :: Int) #-} -data Foo = Bar Int - -{-# ANN f (1 :: Int) #-} -{-# ANN f (1 :: Integer) #-} -{-# ANN f (1 :: Double) #-} -{-# ANN f $([| 1 :: Int |]) #-} -{-# ANN f "Hello" #-} -{-# ANN f (Just (1 :: Int)) #-} -{-# ANN f [1 :: Int, 2, 3] #-} -{-# ANN f ([1..10] :: [Integer]) #-} -{-# ANN f 'f #-} -{-# ANN f (-1 :: Int) #-} -f x = x - -{-# ANN foo "HLint: ignore" #-};foo = map f (map g x) diff --git a/tests/examples/Arrow.hs b/tests/examples/Arrow.hs deleted file mode 100644 --- a/tests/examples/Arrow.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE Arrows #-} -module Arrow where - -import Control.Arrow -import qualified Control.Category as Cat - -addA :: Arrow a => a b Int -> a b Int -> a b Int -addA f g = proc x -> do - y <- f -< x - z <- g -< x - returnA -< y + z - -newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) } - -instance Cat.Category Circuit where - id = Circuit $ \a -> (Cat.id, a) - (.) = dot - where - (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a -> - let (cir1', b) = cir1 a - (cir2', c) = cir2 b - in (cir2' `dot` cir1', c) - -instance Arrow Circuit where - arr f = Circuit $ \a -> (arr f, f a) - first (Circuit cir) = Circuit $ \(b, d) -> - let (cir', c) = cir b - in (first cir', (c, d)) - --- | Accumulator that outputs a value determined by the supplied function. -accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b -accum acc f = Circuit $ \input -> - let (output, acc') = input `f` acc - in (accum acc' f, output) - --- | Accumulator that outputs the accumulator value. -accum' :: b -> (a -> b -> b) -> Circuit a b -accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b')) - -total :: Num a => Circuit a a -total = accum' 0 (+) - -mean3 :: Fractional a => Circuit a a -mean3 = proc value -> do - (t, n) <- (| (&&&) (total -< value) (total -< 1) |) - returnA -< t / n diff --git a/tests/examples/Arrow2.hs b/tests/examples/Arrow2.hs deleted file mode 100644 --- a/tests/examples/Arrow2.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -module Arrow2 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 ∷ ★ → ★) -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/Arrows.hs b/tests/examples/Arrows.hs deleted file mode 100644 --- a/tests/examples/Arrows.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE Arrows #-} --- from https://ocharles.org.uk/blog/guest-posts/2014-12-21-arrows.html - -import Control.Monad (guard) -import Control.Monad.Identity (Identity, runIdentity) -import Control.Arrow (returnA, Kleisli(Kleisli), runKleisli) - -f :: Int -> (Int, Int) -f = \x -> - let y = 2 * x - z1 = y + 3 - z2 = y - 5 - in (z1, z2) - --- ghci> f 10 --- (23, 15) - -fM :: Int -> Identity (Int, Int) -fM = \x -> do - y <- return (2 * x) - z1 <- return (y + 3) - z2 <- return (y - 5) - return (z1, z2) - --- ghci> runIdentity (fM 10) --- (23,15) - - -fA :: Int -> (Int, Int) -fA = proc x -> do - y <- (2 *) -< x - z1 <- (+ 3) -< y - z2 <- (subtract 5) -< y - returnA -< (z1, z2) - --- ghci> fA 10 --- (23,15) - -range :: Int -> [Int] -range r = [-r..r] - -cM :: Int -> [(Int, Int)] -cM = \r -> do - x <- range 5 - y <- range 5 - guard (x*x + y*y <= r*r) - return (x, y) - --- ghci> take 10 (cM 5) --- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)] - - -type K = Kleisli - -k :: (a -> m b) -> Kleisli m a b -k = Kleisli - -runK :: Kleisli m a b -> (a -> m b) -runK = runKleisli - -cA :: Kleisli [] Int (Int, Int) -cA = proc r -> do - x <- k range -< 5 - y <- k range -< 5 - k guard -< (x*x + y*y <= r*r) - returnA -< (x, y) - --- ghci> take 10 (runK cA 5) --- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)] - -getLineM :: String -> IO String -getLineM prompt = do - print prompt - getLine - -printM :: String -> IO () -printM = print - -writeFileM :: (FilePath, String) -> IO () -writeFileM (filePath, string) = writeFile filePath string - -procedureM :: String -> IO () -procedureM = \prompt -> do - input <- getLineM prompt - if input == "Hello" - then printM "You said 'Hello'" - else writeFileM ("/tmp/output", "The user said '" ++ input ++ "'") diff --git a/tests/examples/Associated.hs b/tests/examples/Associated.hs deleted file mode 100644 --- a/tests/examples/Associated.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} - --- From https://www.haskell.org/haskellwiki/GHC/Type_families#An_associated_data_type_example - -import qualified Data.IntMap -import Prelude hiding (lookup) -import Data.Char (ord) - -class GMapKey k where - data GMap k :: * -> * - empty :: GMap k v - lookup :: k -> GMap k v -> Maybe v - insert :: k -> v -> GMap k v -> GMap k v - --- An Int instance -instance GMapKey Int where - data GMap Int v = GMapInt (Data.IntMap.IntMap v) - empty = GMapInt Data.IntMap.empty - lookup k (GMapInt m) = Data.IntMap.lookup k m - insert k v (GMapInt m) = GMapInt (Data.IntMap.insert k v m) - --- A Char instance -instance GMapKey Char where - data GMap Char v = GMapChar (GMap Int v) - empty = GMapChar empty - lookup k (GMapChar m) = lookup (ord k) m - insert k v (GMapChar m) = GMapChar (insert (ord k) v m) - --- A Unit instance -instance GMapKey () where - data GMap () v = GMapUnit (Maybe v) - empty = GMapUnit Nothing - lookup () (GMapUnit v) = v - insert () v (GMapUnit _) = GMapUnit $ Just v - --- Product and sum instances -instance (GMapKey a, GMapKey b) => GMapKey (a, b) where - data GMap (a, b) v = GMapPair (GMap a (GMap b v)) - empty = GMapPair empty - lookup (a, b) (GMapPair gm) = lookup a gm >>= lookup b - insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of - Nothing -> insert a (insert b v empty) gm - Just gm2 -> insert a (insert b v gm2 ) gm - -instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where - data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) - empty = GMapEither empty empty - lookup (Left a) (GMapEither gm1 _gm2) = lookup a gm1 - lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2 - insert (Left a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2 - insert (Right b) v (GMapEither gm1 gm2) = GMapEither gm1 (insert b v gm2) - -myGMap :: GMap (Int, Either Char ()) String -myGMap = insert (5, Left 'c') "(5, Left 'c')" $ - insert (4, Right ()) "(4, Right ())" $ - insert (5, Right ()) "This is the one!" $ - insert (5, Right ()) "This is the two!" $ - insert (6, Right ()) "(6, Right ())" $ - insert (5, Left 'a') "(5, Left 'a')" $ - empty - -main = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap - --- (Type) Synonym Family - -type family Elem c - -type instance Elem [e] = e - --- type instance Elem BitSet = Char - - -data family T a -data instance T Int = T1 Int | T2 Bool -newtype instance T Char = TC Bool - -data family G a b -data instance G [a] b where - G1 :: c -> G [Int] b - G2 :: G [a] Bool diff --git a/tests/examples/AssociatedType.hs b/tests/examples/AssociatedType.hs deleted file mode 100644 --- a/tests/examples/AssociatedType.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -class Foldable t where - type FoldableConstraint t x :: * - type FoldableConstraint t x = () - diff --git a/tests/examples/B.hs b/tests/examples/B.hs deleted file mode 100644 --- a/tests/examples/B.hs +++ /dev/null @@ -1,4 +0,0 @@ - -foo x = case (odd x) of - True -> "Odd" - False -> "Even" diff --git a/tests/examples/BCase.hs b/tests/examples/BCase.hs deleted file mode 100644 --- a/tests/examples/BCase.hs +++ /dev/null @@ -1,8 +0,0 @@ - - -main = - case 1 > 10 of - True -> do putStrLn "hello" - putStrLn "there" - False -> do putStrLn "blah" - putStrLn "blah" diff --git a/tests/examples/BIf.hs b/tests/examples/BIf.hs deleted file mode 100644 --- a/tests/examples/BIf.hs +++ /dev/null @@ -1,8 +0,0 @@ - - -main = - if 1 > 10 - then do putStrLn "hello" - putStrLn "there" - else do putStrLn "blah" - putStrLn "blah" diff --git a/tests/examples/Backquote.hs b/tests/examples/Backquote.hs deleted file mode 100644 --- a/tests/examples/Backquote.hs +++ /dev/null @@ -1,11 +0,0 @@ -import Data.List - -foo = do - let genOut (f,st) = putStrLn (f ++ "\t"++go [e`div`4,e`div`2,3*e`div`4] (scanl1 (+) $ sort st)) - Just 5 - -f = undefined -go = undefined -e = undefined - - diff --git a/tests/examples/BangPatterns.hs b/tests/examples/BangPatterns.hs deleted file mode 100644 --- a/tests/examples/BangPatterns.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - --- From https://ocharles.org.uk/blog/posts/2014-12-05-bang-patterns.html - -import Data.Function (fix) -import Data.List (foldl') - -hello3 :: Bool -> String -hello3 !loud = "Hello." - -mean :: [Double] -> Double -mean xs = s / fromIntegral l - where - (s, l) = foldl' step (0, 0) xs - step (!s, !l) a = (s + a, l + 1) - diff --git a/tests/examples/BootImport.hs b/tests/examples/BootImport.hs deleted file mode 100644 --- a/tests/examples/BootImport.hs +++ /dev/null @@ -1,3 +0,0 @@ -module BootImport where - -data Foo = Foo Int diff --git a/tests/examples/BootImport.hs-boot b/tests/examples/BootImport.hs-boot deleted file mode 100644 --- a/tests/examples/BootImport.hs-boot +++ /dev/null @@ -1,3 +0,0 @@ -module BootImport where - -data Foo diff --git a/tests/examples/BracesSemiDataDecl.hs b/tests/examples/BracesSemiDataDecl.hs deleted file mode 100644 --- a/tests/examples/BracesSemiDataDecl.hs +++ /dev/null @@ -1,7 +0,0 @@ - - -data Nat (t :: NatKind) where -{ - ZeroNat :: Nat Zero; - SuccNat :: Nat t -> Nat (Succ t); -}; diff --git a/tests/examples/C.hs b/tests/examples/C.hs deleted file mode 100644 --- a/tests/examples/C.hs +++ /dev/null @@ -1,12 +0,0 @@ -module C where --- Test for refactor of if to case --- The comments on the then and else legs should be preserved - -foo x = if (odd x) - then -- This is an odd result - bob x 1 - else -- This is an even result - bob x 2 - -bob x y = x + y - diff --git a/tests/examples/C.hs.expected b/tests/examples/C.hs.expected deleted file mode 100644 --- a/tests/examples/C.hs.expected +++ /dev/null @@ -1,12 +0,0 @@ -module C where --- Test for refactor of if to case --- The comments on the then and else legs should be preserved - -foo x = case (odd x) of - True -> -- This is an odd result - bob x 1 - False -> -- This is an even result - bob x 2 - -bob x y = x + y - diff --git a/tests/examples/CExpected.hs b/tests/examples/CExpected.hs deleted file mode 100644 --- a/tests/examples/CExpected.hs +++ /dev/null @@ -1,12 +0,0 @@ -module CExpected where --- Test for refactor of if to case --- The comments on the then and else legs should be preserved - -foo x = case (odd x) of - True -> -- This is an odd result - bob x 1 - False -> -- This is an even result - bob x 2 - -bob x y = x + y - diff --git a/tests/examples/Cg008.hs b/tests/examples/Cg008.hs deleted file mode 100644 --- a/tests/examples/Cg008.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE MagicHash, BangPatterns #-} -{-# OPTIONS_GHC -O0 #-} - --- Variant of cgrun066; compilation as a module is different. - -module Cg008 (hashStr) where - -import Foreign.C -import Data.Word -import Foreign.Ptr -import GHC.Exts - -import Control.Exception - -hashStr :: Ptr Word8 -> Int -> Int -hashStr (Ptr a#) (I# len#) = loop 0# 0# - where - loop h n | isTrue# (n GHC.Exts.==# len#) = I# h - | otherwise = loop h2 (n GHC.Exts.+# 1#) - where !c = ord# (indexCharOffAddr# a# n) - !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` 4091# diff --git a/tests/examples/CloneDecl1.hs b/tests/examples/CloneDecl1.hs deleted file mode 100644 --- a/tests/examples/CloneDecl1.hs +++ /dev/null @@ -1,10 +0,0 @@ -module CloneDecl1 where - -z = 3 - -foo a b = - let - x = a + b + z - y = a * b - z - in - x + y diff --git a/tests/examples/CloneDecl1.hs.expected b/tests/examples/CloneDecl1.hs.expected deleted file mode 100644 --- a/tests/examples/CloneDecl1.hs.expected +++ /dev/null @@ -1,17 +0,0 @@ -module CloneDecl1 where - -z = 3 - -foo a b = - let - x = a + b + z - y = a * b - z - in - x + y - -foo a b = - let - x = a + b + z - y = a * b - z - in - x + y diff --git a/tests/examples/Commands.hs b/tests/examples/Commands.hs deleted file mode 100644 --- a/tests/examples/Commands.hs +++ /dev/null @@ -1,257 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -commands :: [Command] -commands = [ - command "help" "display a list of all commands, and their current keybindings" $ do - macroGuesses <- Macro.guessCommands commandNames <$> getMacros - addTab (Other "Help") (makeHelpWidget commands macroGuesses) AutoClose - - , command "log" "show the error log" $ do - messages <- gets logMessages - let widget = ListWidget.moveLast (ListWidget.new $ reverse messages) - addTab (Other "Log") (AnyWidget . LogWidget $ widget) AutoClose - - , command "map" "display a list of all commands that are currently bound to keys" $ do - showMappings - - , command "map" "display the command that is currently bound to the key {name}" $ do - showMapping - - , command "map" [help| - Bind the command {expansion} to the key {name}. The same command may - be bound to different keys. - |] $ do - addMapping - - , command "unmap" "remove the binding currently bound to the key {name}" $ do - \(MacroName m) -> removeMacro m - - , command "mapclear" "" $ do - clearMacros - - , command "exit" "exit vimus" $ do - eval "quit" - - , command "quit" "exit vimus" $ do - liftIO exitSuccess :: Vimus () - - , command "close" "close the current window (not all windows can be closed)" $ do - void closeTab - - , command "source" "read the file {path} and interprets all lines found there as if they were entered as commands." $ do - \(Path p) -> liftIO (expandHome p) >>= either printError source_ - - , command "runtime" "" $ - \(Path p) -> liftIO (getDataFileName p) >>= source_ - - , command "color" "define the fore- and background color for a thing on the screen." $ do - \color fg bg -> liftIO (defineColor color fg bg) :: Vimus () - - , command "repeat" "set the playlist option *repeat*. When *repeat* is set, the playlist will start over when the last song has finished playing." $ do - MPD.repeat True :: Vimus () - - , command "norepeat" "Unset the playlist option *repeat*." $ do - MPD.repeat False :: Vimus () - - , command "consume" "set the playlist option *consume*. When *consume* is set, songs that have finished playing are automatically removed from the playlist." $ do - MPD.consume True :: Vimus () - - , command "noconsume" "Unset the playlist option *consume*." $ do - MPD.consume False :: Vimus () - - , command "random" "set the playlist option *random*. When *random* is set, songs in the playlist are played in random order." $ do - MPD.random True :: Vimus () - - , command "norandom" "Unset the playlist option *random*." $ do - MPD.random False :: Vimus () - - , command "single" "Set the playlist option *single*. When *single* is set, playback does not advance automatically to the next item in the playlist. Combine with *repeat* to repeatedly play the same song." $ do - MPD.single True :: Vimus () - - , command "nosingle" "Unset the playlist option *single*." $ do - MPD.single False :: Vimus () - - , command "autotitle" "Set the *autotitle* option. When *autotitle* is set, the console window title is automatically set to the currently playing song." $ do - setAutoTitle True - - , command "noautotitle" "Unset the *autotitle* option." $ do - setAutoTitle False - - , command "volume" "[+-] set volume to or adjust by [+-] num" $ do - volume :: Volume -> Vimus () - - , command "toggle-repeat" "Toggle the *repeat* option." $ do - MPD.status >>= MPD.repeat . not . MPD.stRepeat :: Vimus () - - , command "toggle-consume" "Toggle the *consume* option." $ do - MPD.status >>= MPD.consume . not . MPD.stConsume :: Vimus () - - , command "toggle-random" "Toggle the *random* option." $ do - MPD.status >>= MPD.random . not . MPD.stRandom :: Vimus () - - , command "toggle-single" "Toggle the *single* option." $ do - MPD.status >>= MPD.single . not . MPD.stSingle :: Vimus () - - , command "set-library-path" "While MPD knows where your songs are stored, vimus doesn't. If you want to use the *%* feature of the command :! you need to tell vimus where your songs are stored." $ do - \(Path p) -> setLibraryPath p - - , command "next" "stop playing the current song, and starts the next one" $ do - MPD.next :: Vimus () - - , command "previous" "stop playing the current song, and starts the previous one" $ do - MPD.previous :: Vimus () - - , command "toggle" "toggle between play and pause" $ do - MPDE.toggle :: Vimus () - - , command "stop" "stop playback" $ do - MPD.stop :: Vimus () - - , command "update" "tell MPD to update the music database. You must update your database when you add or delete files in your music directory, or when you edit the metadata of a song. MPD will only rescan a file already in the database if its modification time has changed." $ do - void (MPD.update Nothing) :: Vimus () - - , command "rescan" "" $ do - void (MPD.rescan Nothing) :: Vimus () - - , command "clear" "delete all songs from the playlist" $ do - MPD.clear :: Vimus () - - , command "search-next" "jump to the next occurrence of the search string in the current window" - searchNext - - , command "search-prev" "jump to the previous occurrence of the search string in the current window" - searchPrev - - - , command "window-library" "open the *Library* window" $ - selectTab Library - - , command "window-playlist" "open the *Playlist* window" $ - selectTab Playlist - - , command "window-search" "open the *SearchResult* window" $ - selectTab SearchResult - - , command "window-browser" "open the *Browser* window" $ - selectTab Browser - - , command "window-next" "open the window to the right of the current one" - nextTab - - , command "window-prev" "open the window to the left of the current one" - previousTab - - , command "!" "execute {cmd} on the system shell. See chapter \"Using an external tag editor\" for an example." - runShellCommand - - , command "seek" "jump to the given position in the current song" - seek - - , command "visual" "start visual selection" $ - sendEventCurrent EvVisual - - , command "novisual" "cancel visual selection" $ - sendEventCurrent EvNoVisual - - -- Remove current song from playlist - , command "remove" "remove the song under the cursor from the playlist" $ - sendEventCurrent EvRemove - - , command "paste" "add the last deleted song after the selected song in the playlist" $ - sendEventCurrent EvPaste - - , command "paste-prev" "" $ - sendEventCurrent EvPastePrevious - - , command "copy" "" $ - sendEventCurrent EvCopy - - , command "shuffle" "shuffle the current playlist" $ do - MPD.shuffle Nothing :: Vimus () - - , command "add" "append selected songs to the end of the playlist" $ do - sendEventCurrent EvAdd - - -- insert a song right after the current song - , command "insert" [help| - inserts a song to the playlist. The song is inserted after the currently - playing song. - |] $ do - st <- MPD.status - case MPD.stSongPos st of - Just n -> do - -- there is a current song, insert after - sendEventCurrent (EvInsert (n + 1)) - _ -> do - -- there is no current song, just add - sendEventCurrent EvAdd - - -- Playlist: play selected song - -- Library: add song to playlist and play it - -- Browse: either add song to playlist and play it, or :move-in - , command "default-action" [help| - depending on the item under the cursor, somthing different happens: - - - *Playlist* start playing the song under the cursor - - - *Library* append the song under the cursor to the playlist and start playing it - - - *Browser* on a song: append the song to the playlist and play it. On a directory: go down to that directory. - |] $ do - sendEventCurrent EvDefaultAction - - , command "add-album" "add all songs of the album of the selected song to the playlist" $ do - songs <- fromCurrent MPD.Album [MPD.Disc, MPD.Track] - maybe (printError "Song has no album metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs - - , command "add-artist" "add all songs of the artist of the selected song to the playlist" $ do - songs <- fromCurrent MPD.Artist [MPD.Date, MPD.Album, MPD.Disc, MPD.Track] - maybe (printError "Song has no artist metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs - - -- movement - , command "move-up" "move the cursor one line up" $ - sendEventCurrent EvMoveUp - - , command "move-down" "move the cursor one line down" $ - sendEventCurrent EvMoveDown - - , command "move-album-prev" "move the cursor up to the first song of an album" $ - sendEventCurrent EvMoveAlbumPrev - - , command "move-album-next" "move the cursor down to the first song of an album" $ - sendEventCurrent EvMoveAlbumNext - - , command "move-in" "go down one level the directory hierarchy in the *Browser* window" $ - sendEventCurrent EvMoveIn - - , command "move-out" "go up one level in the directory hierarchy in the *Browser* window" $ - sendEventCurrent EvMoveOut - - , command "move-first" "go to the first line in the current window" $ - sendEventCurrent EvMoveFirst - - , command "move-last" "go to the last line in the current window" $ - sendEventCurrent EvMoveLast - - , command "scroll-up" "scroll the contents of the current window up one line" $ - sendEventCurrent (EvScroll (-1)) - - , command "scroll-down" "scroll the contents of the current window down one line" $ - sendEventCurrent (EvScroll 1) - - , command "scroll-page-up" "scroll the contents of the current window up one page" $ - pageScroll >>= sendEventCurrent . EvScroll . negate - - , command "scroll-half-page-up" "scroll the contents of the current window up one half page" $ - pageScroll >>= sendEventCurrent . EvScroll . negate . (`div` 2) - - , command "scroll-page-down" "scroll the contents of the current window down one page" $ - pageScroll >>= sendEventCurrent . EvScroll - - , command "scroll-half-page-down" "scroll the contents of the current window down one half page" $ - pageScroll >>= sendEventCurrent . EvScroll . (`div` 2) - - , command "song-format" "set song rendering format" $ - sendEvent . EvChangeSongFormat - ] - diff --git a/tests/examples/Control.hs b/tests/examples/Control.hs deleted file mode 100644 --- a/tests/examples/Control.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE Unsafe #-} -{-# LANGUAGE CPP - , NoImplicitPrelude - , ScopedTypeVariables - , BangPatterns - #-} - -module GHC.Event.Control - ( - -- * Managing the IO manager - Signal - , ControlMessage(..) - , Control - , newControl - , closeControl - -- ** Control message reception - , readControlMessage - -- *** File descriptors - , controlReadFd - , controlWriteFd - , wakeupReadFd - -- ** Control message sending - , sendWakeup - , sendDie - -- * Utilities - , setNonBlockingFD - ) where - -#include "EventConfig.h" - -import Foreign.ForeignPtr (ForeignPtr) -import GHC.Base -import GHC.Conc.Signal (Signal) -import GHC.Real (fromIntegral) -import GHC.Show (Show) -import GHC.Word (Word8) -import Foreign.C.Error (throwErrnoIfMinus1_) -import Foreign.C.Types (CInt(..), CSize(..)) -import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr) -import Foreign.Marshal (alloca, allocaBytes) -import Foreign.Marshal.Array (allocaArray) -import Foreign.Ptr (castPtr) -import Foreign.Storable (peek, peekElemOff, poke) -import System.Posix.Internals (c_close, c_pipe, c_read, c_write, - setCloseOnExec, setNonBlockingFD) -import System.Posix.Types (Fd) - -#if defined(HAVE_EVENTFD) -import Foreign.C.Error (throwErrnoIfMinus1) -import Foreign.C.Types (CULLong(..)) -#else -import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno) -#endif - -data ControlMessage = CMsgWakeup - | CMsgDie - | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) - {-# UNPACK #-} !Signal - deriving (Eq, Show) - --- | The structure used to tell the IO manager thread what to do. -data Control = W { - controlReadFd :: {-# UNPACK #-} !Fd - , controlWriteFd :: {-# UNPACK #-} !Fd -#if defined(HAVE_EVENTFD) - , controlEventFd :: {-# UNPACK #-} !Fd -#else - , wakeupReadFd :: {-# UNPACK #-} !Fd - , wakeupWriteFd :: {-# UNPACK #-} !Fd -#endif - , didRegisterWakeupFd :: !Bool - } deriving (Show) - -#if defined(HAVE_EVENTFD) -wakeupReadFd :: Control -> Fd -wakeupReadFd = controlEventFd -{-# INLINE wakeupReadFd #-} -#endif - --- | Create the structure (usually a pipe) used for waking up the IO --- manager thread from another thread. -newControl :: Bool -> IO Control -newControl shouldRegister = allocaArray 2 $ \fds -> do - let createPipe = do - throwErrnoIfMinus1_ "pipe" $ c_pipe fds - rd <- peekElemOff fds 0 - wr <- peekElemOff fds 1 - -- The write end must be non-blocking, since we may need to - -- poke the event manager from a signal handler. - setNonBlockingFD wr True - setCloseOnExec rd - setCloseOnExec wr - return (rd, wr) - (ctrl_rd, ctrl_wr) <- createPipe -#if defined(HAVE_EVENTFD) - ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0 - setNonBlockingFD ev True - setCloseOnExec ev - when shouldRegister $ c_setIOManagerWakeupFd ev -#else - (wake_rd, wake_wr) <- createPipe - when shouldRegister $ c_setIOManagerWakeupFd wake_wr -#endif - return W { controlReadFd = fromIntegral ctrl_rd - , controlWriteFd = fromIntegral ctrl_wr -#if defined(HAVE_EVENTFD) - , controlEventFd = fromIntegral ev -#else - , wakeupReadFd = fromIntegral wake_rd - , wakeupWriteFd = fromIntegral wake_wr -#endif - , didRegisterWakeupFd = shouldRegister - } - --- | Close the control structure used by the IO manager thread. --- N.B. If this Control is the Control whose wakeup file was registered with --- the RTS, then *BEFORE* the wakeup file is closed, we must call --- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup --- file after it has been closed. -closeControl :: Control -> IO () -closeControl w = do - _ <- c_close . fromIntegral . controlReadFd $ w - _ <- c_close . fromIntegral . controlWriteFd $ w - when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1) -#if defined(HAVE_EVENTFD) - _ <- c_close . fromIntegral . controlEventFd $ w -#else - _ <- c_close . fromIntegral . wakeupReadFd $ w - _ <- c_close . fromIntegral . wakeupWriteFd $ w -#endif - return () - -io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8 -io_MANAGER_WAKEUP = 0xff -io_MANAGER_DIE = 0xfe - -foreign import ccall "__hscore_sizeof_siginfo_t" - sizeof_siginfo_t :: CSize - -readControlMessage :: Control -> Fd -> IO ControlMessage -readControlMessage ctrl fd - | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do - throwErrnoIfMinus1_ "readWakeupMessage" $ - c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize) - return CMsgWakeup - | otherwise = - alloca $ \p -> do - throwErrnoIfMinus1_ "readControlMessage" $ - c_read (fromIntegral fd) p 1 - s <- peek p - case s of - -- Wakeup messages shouldn't be sent on the control - -- file descriptor but we handle them anyway. - _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup - _ | s == io_MANAGER_DIE -> return CMsgDie - _ -> do -- Signal - fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t) - withForeignPtr fp $ \p_siginfo -> do - r <- c_read (fromIntegral fd) (castPtr p_siginfo) - sizeof_siginfo_t - when (r /= fromIntegral sizeof_siginfo_t) $ - error "failed to read siginfo_t" - let !s' = fromIntegral s - return $ CMsgSignal fp s' - - where wakeupBufferSize = -#if defined(HAVE_EVENTFD) - 8 -#else - 4096 -#endif - -sendWakeup :: Control -> IO () -#if defined(HAVE_EVENTFD) -sendWakeup c = - throwErrnoIfMinus1_ "sendWakeup" $ - c_eventfd_write (fromIntegral (controlEventFd c)) 1 -#else -sendWakeup c = do - n <- sendMessage (wakeupWriteFd c) CMsgWakeup - case n of - _ | n /= -1 -> return () - | otherwise -> do - errno <- getErrno - when (errno /= eAGAIN && errno /= eWOULDBLOCK) $ - throwErrno "sendWakeup" -#endif - -sendDie :: Control -> IO () -sendDie c = throwErrnoIfMinus1_ "sendDie" $ - sendMessage (controlWriteFd c) CMsgDie - -sendMessage :: Fd -> ControlMessage -> IO Int -sendMessage fd msg = alloca $ \p -> do - case msg of - CMsgWakeup -> poke p io_MANAGER_WAKEUP - CMsgDie -> poke p io_MANAGER_DIE - CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS" - fromIntegral `fmap` c_write (fromIntegral fd) p 1 - -#if defined(HAVE_EVENTFD) -foreign import ccall unsafe "sys/eventfd.h eventfd" - c_eventfd :: CInt -> CInt -> IO CInt - -foreign import ccall unsafe "sys/eventfd.h eventfd_write" - c_eventfd_write :: CInt -> CULLong -> IO CInt -#endif - -foreign import ccall unsafe "setIOManagerWakeupFd" - c_setIOManagerWakeupFd :: CInt -> IO () diff --git a/tests/examples/CorePragma.hs b/tests/examples/CorePragma.hs deleted file mode 100644 --- a/tests/examples/CorePragma.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# INLINE strictStream #-} -strictStream (Bitstream l v) - = {-# CORE "Strict Bitstream stream" #-} - S.concatMap stream (GV.stream v) - `S.sized` - Exact l diff --git a/tests/examples/Cpp.hs b/tests/examples/Cpp.hs deleted file mode 100644 --- a/tests/examples/Cpp.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# Language CPP #-} - -#if __GLASGOW_HASKELL__ > 704 -foo :: Int -#else -foo :: Integer -#endif -foo = 3 - -bar :: ( -#if __GLASGOW_HASKELL__ > 704 - Int) -#else - Integer) -#endif -bar = 4 - diff --git a/tests/examples/DataDecl.hs b/tests/examples/DataDecl.hs deleted file mode 100644 --- a/tests/examples/DataDecl.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# Language DatatypeContexts #-} -{-# Language ExistentialQuantification #-} -{-# LAnguage GADTs #-} -{-# LAnguage KindSignatures #-} - -data Foo = A - | B - | C - --- | data_or_newtype capi_ctype tycl_hdr constrs deriving -data {-# Ctype "Foo" "bar" #-} F1 = F1 -data {-# Ctype "baz" #-} Eq a => F2 a = F2 a - -data (Eq a,Ord a) => F3 a = F3 Int a - -data F4 a = forall x y. (Eq x,Eq y) => F4 a x y - | forall x y. (Eq x,Eq y) => F4b a x y - - -data G1 a :: * where - G1A, G1B :: Int -> G1 a - G1C :: Double -> G1 a - -data G2 a :: * where - G2A { g2a :: a, g2b :: Int } :: G2 a - G2C :: Double -> G2 a - - - -data (Eq a,Ord a) => G3 a = G3 - { g3A :: Int - , g3B :: Bool - , g3a :: a - } deriving (Eq,Ord) diff --git a/tests/examples/DataFamilies.hs b/tests/examples/DataFamilies.hs deleted file mode 100644 --- a/tests/examples/DataFamilies.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- Based on https://www.haskell.org/haskellwiki/GHC/Type_families#Detailed_definition_of_data_families - -module DataFamilies - ( - GMap - , GMapKey(type GMapK) - ) where - --- Type 1, Top level - -data family GMap k :: * -> * - -data family Array e - -data family ArrayK :: * -> * - - --- Type 2, associated types - -class GMapKey k where - data GMapK k :: * -> * - -class C a b c where { data T1 c a :: * } -- OK --- class C a b c where { data T a a :: * } -- Bad: repeated variable --- class D a where { data T a x :: * } -- Bad: x is not a class variable -class D a where { data T2 a :: * -> * } -- OK - --- Instances - -data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) - -data family T3 a -data instance T3 Int = A -data instance T3 Char = B -nonsense :: T3 a -> Int --- nonsense A = 1 -- WRONG: These two equations together... --- nonsense B = 2 -- ...will produce a type error. -nonsense = undefined - - -instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where - data GMapK (Either a b) v = GMapEitherK (GMap a v) (GMap b v) - --- data GMap () v = GMapUnit (Maybe v) --- deriving Show - - diff --git a/tests/examples/Dead1.hs b/tests/examples/Dead1.hs deleted file mode 100644 --- a/tests/examples/Dead1.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# OPTIONS -O -ddump-stranal #-} - -module Dead1(foo) where - -foo :: Int -> Int -foo n = baz (n+1) (bar1 n) - -{-# NOINLINE bar1 #-} -bar1 n = 1 + bar n - -bar :: Int -> Int -{-# NOINLINE bar #-} -{-# RULES -"bar/foo" forall n. bar (foo n) = n - #-} -bar n = n-1 - -baz :: Int -> Int -> Int -{-# INLINE [0] baz #-} -baz m n = m - - -{- Ronam writes (Feb08) - - Note that bar becomes dead as soon as baz gets inlined. But strangely, - the simplifier only deletes it after full laziness and CSE. That is, it - is not deleted in the phase in which baz gets inlined. In fact, it is - still there after w/w and the subsequent simplifier run. It gets deleted - immediately if I comment out the rule. - - I stumbled over this when I removed one simplifier run after SpecConstr - (at the moment, it runs twice at the end but I don't think that should - be necessary). With this change, the original version of a specialised - loop (the one with the rules) is not longer deleted even if it isn't - used any more. I'll reenable the second simplifier run for now but - should this really be necessary? - -No, it should not be necessary. A refactoring in OccurAnal makes -this work right. Look at the simplifier output just before strictness -analysis; there should be a binding for 'foo', but for nothing else. - --} diff --git a/tests/examples/Default.hs b/tests/examples/Default.hs deleted file mode 100644 --- a/tests/examples/Default.hs +++ /dev/null @@ -1,8 +0,0 @@ -default (Integer, Double) -- "default default" - -mag :: Float -> Float -> Float -mag x y = sqrt( x^2 + y^2 ) - -main = do - -print $ mag 1 1 diff --git a/tests/examples/DefaultTypeInstance.hs b/tests/examples/DefaultTypeInstance.hs deleted file mode 100644 --- a/tests/examples/DefaultTypeInstance.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - - -class Foldable t where - type FoldableConstraint t x :: Constraint - type FoldableConstraint t x = () diff --git a/tests/examples/Deprecation.hs b/tests/examples/Deprecation.hs deleted file mode 100644 --- a/tests/examples/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/Deprecation.hs.bad b/tests/examples/Deprecation.hs.bad deleted file mode 100644 --- a/tests/examples/Deprecation.hs.bad +++ /dev/null @@ -1,16 +0,0 @@ - -module Deprecation -{-# Deprecated ["This is a module \"deprecation\"", - "multi-line", - "with unicode: Fr\232re" ] #-} - ( 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/Deriving.hs b/tests/examples/Deriving.hs deleted file mode 100644 --- a/tests/examples/Deriving.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} - -import Data.Data - -data Foo = FooA | FooB - -deriving instance Show Foo - -deriving instance {-# Overlappable #-} Eq Foo -deriving instance {-# Overlapping #-} Ord Foo -deriving instance {-# Overlaps #-} Typeable Foo -deriving instance {-# Incoherent #-} Data Foo - diff --git a/tests/examples/DerivingOC.hs b/tests/examples/DerivingOC.hs deleted file mode 100644 --- a/tests/examples/DerivingOC.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- from https://ocharles.org.uk/blog/guest-posts/2014-12-15-deriving.html - -import Data.Data -import Control.Monad.IO.Class -import Control.Monad.Reader -import Control.Monad.State - -data MiniIoF a = Terminate - | PrintLine String a - | ReadLine (String -> a) - deriving (Functor) - - --- data List a = Nil | Cons a (List a) --- deriving (Eq, Show, Functor, Foldable, Traversable) - - - -data List a = Nil | Cons a (List a) - deriving ( Eq, Show - , Functor, Foldable, Traversable - , Typeable, Data) - -data Config = C String String -data AppState = S Int Bool - -newtype App a = App { unApp :: ReaderT Config (StateT AppState IO) a } - deriving (Monad, MonadReader Config, - MonadState AppState, MonadIO, - Applicative,Functor) diff --git a/tests/examples/DoParens.hs b/tests/examples/DoParens.hs deleted file mode 100644 --- a/tests/examples/DoParens.hs +++ /dev/null @@ -1,4 +0,0 @@ - -foo = do - (-) <- Just 5 - return () diff --git a/tests/examples/DoPatBind.hs b/tests/examples/DoPatBind.hs deleted file mode 100644 --- a/tests/examples/DoPatBind.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -bar = do - foo :: String <- baz diff --git a/tests/examples/DocDecls.hs b/tests/examples/DocDecls.hs deleted file mode 100644 --- a/tests/examples/DocDecls.hs +++ /dev/null @@ -1,7 +0,0 @@ -module DocDecls where - --- | A document before -data Foo = A Int | B Char - deriving (Show) - - diff --git a/tests/examples/DoubleForall.hs b/tests/examples/DoubleForall.hs deleted file mode 100644 --- a/tests/examples/DoubleForall.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - - -extremumNewton :: (Eq a, Fractional a) => - (forall tag. forall tag1. - Tower tag1 (Tower tag a) - -> Tower tag1 (Tower tag a)) - -> a -> [a] -extremumNewton f x0 = zeroNewton (diffUU f) x0 diff --git a/tests/examples/DroppedComma.hs b/tests/examples/DroppedComma.hs deleted file mode 100644 --- a/tests/examples/DroppedComma.hs +++ /dev/null @@ -1,5 +0,0 @@ - - -foo = - let (xs, ys) = ([1,2..3], [4,5..6]) in - bar diff --git a/tests/examples/DroppedDoSpace.hs b/tests/examples/DroppedDoSpace.hs deleted file mode 100644 --- a/tests/examples/DroppedDoSpace.hs +++ /dev/null @@ -1,26 +0,0 @@ -import FooBarBaz -- non-existent import, check that we can still parse - -save :: C -> IO () -save state = saveFileDialog "Save file " (maybe Nothing (Just . (++) "*.") (filesuffix state)) $ - do \fileName -> - case onSaveCB state of - Nothing -> - return () - Just callback -> - do - c <- callback - case c of - Nothing -> - return () - Just c' -> - let realfn = maybe - fileName - (extendFileName fileName) - (filesuffix state) - in do - L.writeFile realfn c' - postGUIAsync $ labelSetText (View.statusL $ gui state) $ realfn ++ " Saved." - where - extendFileName fileName suffix = if isSuffixOf suffix fileName - then fileName - else fileName ++ "." ++ suffix diff --git a/tests/examples/DroppedDoSpace2.hs b/tests/examples/DroppedDoSpace2.hs deleted file mode 100644 --- a/tests/examples/DroppedDoSpace2.hs +++ /dev/null @@ -1,6 +0,0 @@ - - -save state = do \fileName -> - 4 - - diff --git a/tests/examples/EmptyMostly.hs b/tests/examples/EmptyMostly.hs deleted file mode 100644 --- a/tests/examples/EmptyMostly.hs +++ /dev/null @@ -1,13 +0,0 @@ -module EmptyMostly where - { ;;; - ;;x=let{;;;;;y=2;;z=3;;;;}in y; - -- ;;;; - class Foo a where {;;;;;; - (--<>--) :: a -> a -> Int ; - infixl 5 --<>-- ; - (--<>--) _ _ = 2 ; -- empty decl at the end. -}; --- ;;;;;;;;;;;; --- foo = a where {;;;;;;;;;;;;;;;;;;;;;;;a=1;;;;;;;;} --- ;; - } diff --git a/tests/examples/EmptyMostly2.hs b/tests/examples/EmptyMostly2.hs deleted file mode 100644 --- a/tests/examples/EmptyMostly2.hs +++ /dev/null @@ -1,8 +0,0 @@ -module EmptyMostly2 where - { -;;;;;;;;;;;; -; -class Baz a where {;;;;;;;;; - ; baz :: a -> Int;;; -} - } diff --git a/tests/examples/EmptyMostlyInst.hs b/tests/examples/EmptyMostlyInst.hs deleted file mode 100644 --- a/tests/examples/EmptyMostlyInst.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -module EmptyMostlyInst where - { -;;;;;;;;;;;; -; -instance Eq (Int,Integer) where {;;;;;;;;; -;;;;;;; a == b = False;;;;;;;;;;; -} - } diff --git a/tests/examples/EmptyMostlyNoSemis.hs b/tests/examples/EmptyMostlyNoSemis.hs deleted file mode 100644 --- a/tests/examples/EmptyMostlyNoSemis.hs +++ /dev/null @@ -1,8 +0,0 @@ -module EmptyMostlyNoSemis where - -x=let{y=2}in y -class Foo a where { - (--<>--) :: a -> a -> Int; - infixl 5 --<>--; - (--<>--) _ _ = 2 ; -- empty decl at the end. - } diff --git a/tests/examples/Existential.hs b/tests/examples/Existential.hs deleted file mode 100644 --- a/tests/examples/Existential.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - --- from https://ocharles.org.uk/blog/guest-posts/2014-12-19-existential-quantification.html - -data HashMap k v = HM -- ... -- actual implementation - -class Hashable v where - h :: v -> Int - -data HashMapM hm = HashMapM - { empty :: forall k v . hm k v - , lookup :: Hashable k => k -> hm k v -> Maybe v - , insert :: Hashable k => k -> v -> hm k v -> hm k v - , union :: Hashable k => hm k v -> hm k v -> hm k v - } - - -data HashMapE = forall hm . HashMapE (HashMapM hm) - --- public -mkHashMapE :: Int -> HashMapE -mkHashMapE = HashMapE . mkHashMapM - --- private -mkHashMapM :: Int -> HashMapM HashMap -mkHashMapM salt = HashMapM { {- implementation -} } - -instance Hashable String where - -type Name = String -data Gift = G String - -giraffe :: Gift -giraffe = G "giraffe" - -addGift :: HashMapM hm -> hm Name Gift -> hm Name Gift -addGift mod gifts = - let - HashMapM{..} = mod - in - insert "Ollie" giraffe gifts - --- ------------------------------- - -santa'sSecretSalt = undefined -sendGiftToOllie = undefined -traverse_ = undefined - -sendGifts = - case mkHashMapE santa'sSecretSalt of - HashMapE (mod@HashMapM{..}) -> - let - gifts = addGift mod empty - in - traverse_ sendGiftToOllie $ lookup "Ollie" gifts diff --git a/tests/examples/ExplicitNamespaces.hs b/tests/examples/ExplicitNamespaces.hs deleted file mode 100644 --- a/tests/examples/ExplicitNamespaces.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} - -module CLaSH.Prelude.BitIndex where - -import GHC.TypeLits (KnownNat, type (+), type (-)) diff --git a/tests/examples/Expr.hs b/tests/examples/Expr.hs deleted file mode 100644 --- a/tests/examples/Expr.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Expr where - -import Data.Generics -import Language.Haskell.TH as TH -import Language.Haskell.TH.Quote - --- import Text.ParserCombinators.Parsec --- import Text.ParserCombinators.Parsec.Char - -data Expr = IntExpr Integer - | AntiIntExpr String - | BinopExpr BinOp Expr Expr - | AntiExpr String - deriving(Typeable, Data,Show) - -data BinOp = AddOp - | SubOp - | MulOp - | DivOp - deriving(Typeable, Data,Show) - -eval :: Expr -> Integer -eval (IntExpr n) = n -eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y) - where - opToFun AddOp = (+) - opToFun SubOp = (-) - opToFun MulOp = (*) - opToFun DivOp = (div) - -small = lower <|> char '_' -large = upper -idchar = small <|> large <|> digit <|> char '\'' - -lexeme p = do{ x <- p; spaces; return x } -symbol name = lexeme (string name) -parens p = undefined -- between (symbol "(") (symbol ")") p - -_expr :: CharParser st Expr -_expr = term `chainl1` mulop - -term :: CharParser st Expr -term = factor `chainl1` addop - -factor :: CharParser st Expr -factor = parens _expr <|> integer <|> anti - -mulop = undefined -{- - do{ symbol "*"; return $ BinopExpr MulOp } - <|> do{ symbol "/"; return $ BinopExpr DivOp } --} -addop = undefined -{- - do{ symbol "+"; return $ BinopExpr AddOp } - <|> do{ symbol "-"; return $ BinopExpr SubOp } --} - -integer :: CharParser st Expr -integer = lexeme $ do{ ds <- many1 digit ; return $ IntExpr (read ds) } - -anti = undefined -{- - lexeme $ - do symbol "$" - c <- small - cs <- many idchar - return $ AntiIntExpr (c : cs) --} - -parseExpr :: Monad m => TH.Loc -> String -> m Expr -parseExpr (Loc {loc_filename = file, loc_start = (line,col)}) s = - case runParser p () "" s of - Left err -> fail $ "baz" - Right e -> return e - where - p = do pos <- getPosition - setPosition $ setSourceName (setSourceLine (setSourceColumn pos col) line) file - spaces - e <- _expr - eof - return e - -expr = QuasiQuoter { quoteExp = parseExprExp, quotePat = parseExprPat } - -parseExprExp :: String -> Q Exp -parseExprExp s = do loc <- location - expr <- parseExpr loc s - dataToExpQ (const Nothing `extQ` antiExprExp) expr - -antiExprExp :: Expr -> Maybe (Q Exp) -antiExprExp (AntiIntExpr v) = Just $ appE (conE (mkName "IntExpr")) - (varE (mkName v)) -antiExprExp (AntiExpr v) = Just $ varE (mkName v) -antiExprExp _ = Nothing - -parseExprPat :: String -> Q Pat -parseExprPat s = do loc <- location - expr <- parseExpr loc s - dataToPatQ (const Nothing `extQ` antiExprPat) expr - -antiExprPat :: Expr -> Maybe (Q Pat) -antiExprPat (AntiIntExpr v) = Just $ conP (mkName "IntExpr") - [varP (mkName v)] -antiExprPat (AntiExpr v) = Just $ varP (mkName v) -antiExprPat _ = Nothing - --- keep parser happy -runParser = undefined -getPosition = undefined -setPosition = undefined -setSourceName = undefined -setSourceLine = undefined -setSourceColumn = undefined -spaces = undefined -eof = undefined -many = undefined -digit = undefined -many1 = undefined -data CharParser a b = F a b -(<|>) = undefined -chainl1 = undefined -string = undefined -char = undefined -lower = undefined -upper = undefined -between = undefined -instance Monad (CharParser a) where -instance Applicative (CharParser a) where -instance Functor (CharParser a) where - diff --git a/tests/examples/ExprPragmas.hs b/tests/examples/ExprPragmas.hs deleted file mode 100644 --- a/tests/examples/ExprPragmas.hs +++ /dev/null @@ -1,7 +0,0 @@ -module ExprPragmas where - -a = {-# SCC "name" #-} 0x5 - -b = {-# SCC foo #-} 006 - -c = {-# GENERATED "foobar" 1 : 2 - 3 : 4 #-} 0.00 diff --git a/tests/examples/ExtraConstraints1.hs b/tests/examples/ExtraConstraints1.hs deleted file mode 100644 --- a/tests/examples/ExtraConstraints1.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -module ExtraConstraints1 where - -arbitCs1 :: _ => a -> String -arbitCs1 x = show (succ x) ++ show (x == x) - -arbitCs2 :: (Show a, _) => a -> String -arbitCs2 x = arbitCs1 x - -arbitCs3 :: (Show a, Enum a, _) => a -> String -arbitCs3 x = arbitCs1 x - -arbitCs4 :: (Eq a, _) => a -> String -arbitCs4 x = arbitCs1 x - -arbitCs5 :: (Eq a, Enum a, Show a, _) => a -> String -arbitCs5 x = arbitCs1 x diff --git a/tests/examples/FooExpected.hs b/tests/examples/FooExpected.hs deleted file mode 100644 --- a/tests/examples/FooExpected.hs +++ /dev/null @@ -1,8 +0,0 @@ - - -main = - case 1 > 10 of - True -> do putStrLn "hello" - putStrLn "there" - False -> do putStrLn "blah" - putStrLn "blah" diff --git a/tests/examples/ForAll.hs b/tests/examples/ForAll.hs deleted file mode 100644 --- a/tests/examples/ForAll.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module ForAll where - -import Data.Data - -foo :: (forall a. Data a => a -> a) -> forall a. Data a => a -> a -foo a = a diff --git a/tests/examples/ForeignDecl.hs b/tests/examples/ForeignDecl.hs deleted file mode 100644 --- a/tests/examples/ForeignDecl.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE MagicHash, UnliftedFFITypes #-} -{-# LANGUAGE ForeignFunctionInterface #-} - --- Based on ghc/testsuite/tests/ffi/should_compile contents -module ForeignDecl where - -import Foreign -import GHC.Exts -import Data.Int -import Data.Word - --- simple functions - -foreign import ccall unsafe "a" a :: IO Int - -foreign import ccall unsafe "b" b :: Int -> IO Int - -foreign import ccall unsafe "c" - c :: Int -> Char -> Float -> Double -> IO Float - --- simple monadic code - -d = a >>= \ x -> - b x >>= \ y -> - c y 'f' 1.0 2.0 - --- We can't import the same function using both stdcall and ccall --- calling conventions in the same file when compiling via C (this is a --- restriction in the C backend caused by the need to emit a prototype --- for stdcall functions). -foreign import stdcall "p" m_stdcall :: StablePtr a -> IO (StablePtr b) -foreign import ccall unsafe "q" m_ccall :: ByteArray# -> IO Int - --- We can't redefine the calling conventions of certain functions (those from --- math.h). -foreign import stdcall "my_sin" my_sin :: Double -> IO Double -foreign import stdcall "my_cos" my_cos :: Double -> IO Double - -foreign import stdcall "m1" m8 :: IO Int8 -foreign import stdcall "m2" m16 :: IO Int16 -foreign import stdcall "m3" m32 :: IO Int32 -foreign import stdcall "m4" m64 :: IO Int64 - -foreign import stdcall "dynamic" d8 :: FunPtr (IO Int8) -> IO Int8 -foreign import stdcall "dynamic" d16 :: FunPtr (IO Int16) -> IO Int16 -foreign import stdcall "dynamic" d32 :: FunPtr (IO Int32) -> IO Int32 -foreign import stdcall "dynamic" d64 :: FunPtr (IO Int64) -> IO Int64 - -foreign import ccall unsafe "safe_qd.h safe_qd_add" c_qd_add :: Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO (); - -foreign import ccall unsafe "kitchen" - sink :: Ptr a - -> ByteArray# - -> MutableByteArray# RealWorld - -> Int - -> Int8 - -> Int16 - -> Int32 - -> Int64 - -> Word8 - -> Word16 - -> Word32 - -> Word64 - -> Float - -> Double - -> IO () - - -type Sink2 b = Ptr b - -> ByteArray# - -> MutableByteArray# RealWorld - -> Int - -> Int8 - -> Int16 - -> Int32 - -> Word8 - -> Word16 - -> Word32 - -> Float - -> Double - -> IO () - -foreign import ccall unsafe "dynamic" - sink2 :: Ptr (Sink2 b) -> Sink2 b - --- exports -foreign export ccall "plusInt" (+) :: Int -> Int -> Int - -listToJSArray :: ToJSRef a => [a] -> IO (JSArray a) -listToJSArray = toJSArray deconstr - where deconstr (x : xs) = Just (x, xs) - deconstr [] = Nothing - -foreign import javascript unsafe "$r = new Float32Array($1);" - float32Array :: JSArray Float -> IO Float32Array - -foreign import javascript unsafe "$r = new Int32Array($1);" - int32Array :: JSArray Int32 -> IO Int32Array - -foreign import javascript unsafe "$r = new Uint16Array($1);" - uint16Array :: JSArray Word16 -> IO Uint16Array - -foreign import javascript unsafe "$r = new Uint8Array($1);" - uint8Array :: JSArray Word8 -> IO Uint8Array - -foreign import javascript unsafe "$r = $1.getContext(\"webgl\");" - getCtx :: JSRef a -> IO Ctx diff --git a/tests/examples/FromUtils.hs b/tests/examples/FromUtils.hs deleted file mode 100644 --- a/tests/examples/FromUtils.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - -import Data.Data - - --- --------------------------------------------------------------------- - -instance AnnotateP RdrName where - annotateP l n = do - case rdrName2String n of - "[]" -> do - addDeltaAnnotation AnnOpenS -- '[' - addDeltaAnnotation AnnCloseS -- ']' - --- --------------------------------------------------------------------- - -class (Typeable ast) => AnnotateP ast where - annotateP :: SrcSpan -> ast -> IO () - - -type SrcSpan = Int -rdrName2String = undefined -type RdrName = String - -data A = AnnOpenS | AnnCloseS - -addDeltaAnnotation = undefined diff --git a/tests/examples/FunDeps.hs b/tests/examples/FunDeps.hs deleted file mode 100644 --- a/tests/examples/FunDeps.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} - --- FunDeps example -class Foo a b c | a b -> c where - bar :: a -> b -> c - diff --git a/tests/examples/FunctionalDeps.hs b/tests/examples/FunctionalDeps.hs deleted file mode 100644 --- a/tests/examples/FunctionalDeps.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} - --- from https://ocharles.org.uk/blog/posts/2014-12-14-functional-dependencies.html - -import Data.Foldable (forM_) -import Data.IORef - -class Store store m | store -> m where - new :: a -> m (store a) - get :: store a -> m a - put :: store a -> a -> m () - -instance Store IORef IO where - new = newIORef - get = readIORef - put ioref a = modifyIORef ioref (const a) - diff --git a/tests/examples/GADTContext.hs b/tests/examples/GADTContext.hs deleted file mode 100644 --- a/tests/examples/GADTContext.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} - -data StackItem a where - Snum :: forall a. Fractional a => a -> StackItem a - Sop :: OpDesc -> StackItem a -deriving instance Show a => Show (StackItem a) - --- AZ added to test Trac #10399 -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]) diff --git a/tests/examples/GADTRecords.hs b/tests/examples/GADTRecords.hs deleted file mode 100644 --- a/tests/examples/GADTRecords.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GADTRecords (H1(..)) where - --- | h1 -data H1 a b where - C1 :: H1 a b - C2 :: Ord a => [a] -> H1 a a - C3 :: { field :: Int -- ^ hello docs - } -> H1 Int Int - C4 :: { field2 :: a -- ^ hello2 docs - } -> H1 Int a - - FwdDataflowAnalysis :: (Eq f, Monad m) => { analysisTop :: f - , analysisMeet :: f -> f -> f - , analysisTransfer :: f -> Instruction -> m f - , analysisFwdEdgeTransfer :: Maybe (f -> Instruction -> m [(BasicBlock, f)]) - } -> DataflowAnalysis m f - -data GADT :: * -> * where - Ctor :: { gadtField :: A } -> GADT A diff --git a/tests/examples/GADTRecords2.hs b/tests/examples/GADTRecords2.hs deleted file mode 100644 --- a/tests/examples/GADTRecords2.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GADTRecords2 (H1(..)) where - --- | h1 -data H1 a b where - C3 :: (Num a) => { field :: a -- ^ hello docs - } -> H1 Int Int diff --git a/tests/examples/GHCOrig.hs b/tests/examples/GHCOrig.hs deleted file mode 100644 --- a/tests/examples/GHCOrig.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : GHC.Tuple --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/ghc-prim/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- The tuple data types --- ------------------------------------------------------------------------------ - -module GHC.Tuple where - - -default () -- Double and Integer aren't available yet - --- | The unit datatype @()@ has one non-undefined member, the nullary --- constructor @()@. -data () = () - -data (,) a b = (,) a b -data (,,) a b c = (,,) a b c -data (,,,) a b c d = (,,,) a b c d -data (,,,,) a b c d e = (,,,,) a b c d e -data (,,,,,) a b c d e f = (,,,,,) a b c d e f -data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g -data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h -data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i -data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j -data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k -data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l -data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m -data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n -data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o -data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p -data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q - = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q -data (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r - = (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r -data (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s - = (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s -data (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t - = (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t -data (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u - = (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u -data (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v - = (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v -data (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w - = (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w -data (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x - = (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x -data (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y - = (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y -data (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z - = (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z -data (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ - -{- Manuel says: Including one more declaration gives a segmentation fault. -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___ --} diff --git a/tests/examples/GenericDeriving.hs b/tests/examples/GenericDeriving.hs deleted file mode 100644 --- a/tests/examples/GenericDeriving.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -import GHC.Generics - --- from https://ocharles.org.uk/blog/posts/2014-12-16-derive-generic.html - -data Valid e a = Error e | OK a - deriving (Generic) - -toEither :: Valid e a -> Either e a -toEither (Error e) = Left e -toEither (OK a) = Right a - -fromEither :: Either e a -> Valid e a -fromEither (Left e) = Error e -fromEither (Right a) = OK a - --- --------------------------------------------------------------------- - -class GetError rep e | rep -> e where - getError' :: rep a -> Maybe e - -instance GetError f e => GetError (M1 i c f) e where - getError' (M1 m1) = getError' m1 - -instance GetError l e => GetError (l :+: r) e where - getError' (L1 l) = getError' l - getError' (R1 _) = Nothing - -instance GetError (K1 i e) e where - getError' (K1 e) = Just e - -getError :: (Generic (errorLike e a), GetError (Rep (errorLike e a)) e) => errorLike e a -> Maybe e -getError = getError' . from - diff --git a/tests/examples/Guards.hs b/tests/examples/Guards.hs deleted file mode 100644 --- a/tests/examples/Guards.hs +++ /dev/null @@ -1,6 +0,0 @@ - - -f x | x > 0, x /= 10 = 1 / x - | x == 0 = undefined - where - y = 4 diff --git a/tests/examples/Hang.hs b/tests/examples/Hang.hs deleted file mode 100644 --- a/tests/examples/Hang.hs +++ /dev/null @@ -1,1 +0,0 @@ -(~>) = forall diff --git a/tests/examples/HangingRecord.hs b/tests/examples/HangingRecord.hs deleted file mode 100644 --- a/tests/examples/HangingRecord.hs +++ /dev/null @@ -1,5 +0,0 @@ - -data Foo = Foo - { r1 :: Int - , r2 :: Int - } diff --git a/tests/examples/HashQQ.hs b/tests/examples/HashQQ.hs deleted file mode 100644 --- a/tests/examples/HashQQ.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} - -module Web.Maid.ApacheMimeTypes where - - -import qualified Data.Text as T -import Air.TH - - - -apache_mime_types :: T.Text -apache_mime_types = [here| - -# This file maps Internet media types to unique file extension(s). -# Although created for httpd, this file is used by many software systems -# and has been placed in the public domain for unlimited redisribution. -# -# The table below contains both registered and (common) unregistered types. -# A type that has no unique extension can be ignored -- they are listed -# here to guide configurations toward known types and to make it easier to -# identify "new" types. File extensions are also commonly used to indicate -# content languages and encodings, so choose them carefully. -# -# Internet media types should be registered as described in RFC 4288. -# The registry is at . -# -# MIME type (lowercased) Extensions -# ============================================ ========== -# application/1d-interleaved-parityfec -# application/3gpp-ims+xml -# application/activemessage -application/andrew-inset ez |] - - -testComplex = assertBool "" ([$istr| - ok -#{Foo 4 "Great!" : [Foo 3 "Scott!"]} - then -|] == ("\n" ++ - " ok\n" ++ - "[Foo 4 \"Great!\",Foo 3 \"Scott!\"]\n" ++ - " then\n")) - diff --git a/tests/examples/HsDo.hs b/tests/examples/HsDo.hs deleted file mode 100644 --- a/tests/examples/HsDo.hs +++ /dev/null @@ -1,22 +0,0 @@ -module HsDo where - -import qualified Data.Map as Map - -moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) - where - numbered_summaries = zip summaries [1..] - - node_map :: NodeMap SummaryNode - node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) - | node@(s, _, _) <- nodes ] - - -graphFromEdgedVertices = undefined -nodes = undefined -lookup_node = undefined -type NodeMap a = Map.Map (Int,Int) (Int,Int,Int) -data SummaryNode = SummaryNode -moduleName = undefined -ms_mod = undefined -ms_hsc_src = undefined - diff --git a/tests/examples/IfThenElse1.hs b/tests/examples/IfThenElse1.hs deleted file mode 100644 --- a/tests/examples/IfThenElse1.hs +++ /dev/null @@ -1,7 +0,0 @@ --- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai -main = do - cs <- if True - then getLine - else return "computer input" - putStrLn cs - diff --git a/tests/examples/IfThenElse2.hs b/tests/examples/IfThenElse2.hs deleted file mode 100644 --- a/tests/examples/IfThenElse2.hs +++ /dev/null @@ -1,5 +0,0 @@ --- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai -main = if True -then print 12 -else print 42 - diff --git a/tests/examples/IfThenElse3.hs b/tests/examples/IfThenElse3.hs deleted file mode 100644 --- a/tests/examples/IfThenElse3.hs +++ /dev/null @@ -1,6 +0,0 @@ --- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai -main = do - print 3 - if True then do - print 5 - else print 7 diff --git a/tests/examples/ImplicitParams.hs b/tests/examples/ImplicitParams.hs deleted file mode 100644 --- a/tests/examples/ImplicitParams.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} - --- From https://ocharles.org.uk/blog/posts/2014-12-11-implicit-params.html - -import Data.Char - - -type LogFunction = String -> IO () - -type Present = String - -queueNewChristmasPresents :: LogFunction -> [Present] -> IO () -queueNewChristmasPresents logMessage presents = do - mapM (logMessage . ("Queueing present for delivery: " ++)) presents - return () - -queueNewChristmasPresents2 :: (?logMessage :: LogFunction) => [Present] -> IO () -queueNewChristmasPresents2 presents = do - mapM (?logMessage . ("Queueing present for delivery: " ++)) presents - return () - - -ex1 :: IO () -ex1 = - let ?logMessage = \t -> putStrLn ("[XMAS LOG]: " ++ t) - in queueNewChristmasPresents2 ["Cuddly Lambda", "Gamma Christmas Pudding"] - - -ex2 :: IO () -ex2 = do - -- Specifies its own logger - ex1 - - -- We can locally define a new logging function - let ?logMessage = \t -> putStrLn (zipWith (\i c -> if even i - then c - else toUpper c) - [0..] - t) - queueNewChristmasPresents2 ["Category Theory Books"] - diff --git a/tests/examples/ImplicitSemi.hs b/tests/examples/ImplicitSemi.hs deleted file mode 100644 --- a/tests/examples/ImplicitSemi.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} - -explicit :: ((?above :: q, ?below :: a -> q) => b) -> q -> (a -> q) -> b -explicit x ab be = x where ?above = ab; ?below = be diff --git a/tests/examples/ImplicitTypeSyn.hs b/tests/examples/ImplicitTypeSyn.hs deleted file mode 100644 --- a/tests/examples/ImplicitTypeSyn.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnicodeSyntax #-} - -type MPI = ?mpi_secret :: MPISecret diff --git a/tests/examples/Imports.hs b/tests/examples/Imports.hs deleted file mode 100644 --- a/tests/examples/Imports.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/ImportsSemi.hs b/tests/examples/ImportsSemi.hs deleted file mode 100644 --- a/tests/examples/ImportsSemi.hs +++ /dev/null @@ -1,6 +0,0 @@ -module ImportsSemi where -{ -; ; ; ; ; ; -import Data.List -;;; -} diff --git a/tests/examples/IndentedDo.hs b/tests/examples/IndentedDo.hs deleted file mode 100644 --- a/tests/examples/IndentedDo.hs +++ /dev/null @@ -1,12 +0,0 @@ - - - -foo = - parseTestFile "gitlogo-double.ppm" "a multi-image file" $ do - \res -> case res of - Right ([ PPM { ppmHeader = h1 } - , PPM { ppmHeader = h2 }], rest) -> do h1 `shouldBe` PPMHeader P6 220 92 - h2 `shouldBe` PPMHeader P6 220 92 - rest `shouldBe` Nothing - Right r -> assertFailure $ "parsed unexpected: " ++ show r - Left e -> assertFailure $ "did not parse: " ++ e diff --git a/tests/examples/Infix.hs b/tests/examples/Infix.hs deleted file mode 100644 --- a/tests/examples/Infix.hs +++ /dev/null @@ -1,8 +0,0 @@ - -infix 3 &&& - -(&&&) :: (Eq a) => [a] -> [a] -> [a] -(&&& ) [] [] = [] -xs &&& [] = xs -( &&&) [] ys = ys - diff --git a/tests/examples/InfixOperator.hs b/tests/examples/InfixOperator.hs deleted file mode 100644 --- a/tests/examples/InfixOperator.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} - -#define BACKSLASH 92 -#define CLOSE_CURLY 125 -#define CLOSE_SQUARE 93 -#define COMMA 44 -#define DOUBLE_QUOTE 34 -#define OPEN_CURLY 123 -#define OPEN_SQUARE 91 -#define C_0 48 -#define C_9 57 -#define C_A 65 -#define C_F 70 -#define C_a 97 -#define C_f 102 -#define C_n 110 -#define C_t 116 - -json_ :: Parser Value -> Parser Value -> Parser Value -json_ obj ary = do - w <- skipSpace *> A.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE) - if w == OPEN_CURLY - then obj - else ary -{-# INLINE json_ #-} - diff --git a/tests/examples/InfixOperator.hs.bad b/tests/examples/InfixOperator.hs.bad deleted file mode 100644 --- a/tests/examples/InfixOperator.hs.bad +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} - - - - - - - - - - - - - - - - - -json_ :: Parser Value -> Parser Value -> Parser Value -json_ obj ary = do - w <- skipSpace *> A.satisfy (\w -> w == 123 || w == 91) - if w == 123 - then obj - else ary -{-# INLINE json_ #-} - diff --git a/tests/examples/InfixPatternSynonyms.hs b/tests/examples/InfixPatternSynonyms.hs deleted file mode 100644 --- a/tests/examples/InfixPatternSynonyms.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - --- | The pattern synonym equivalent of 'destIff'. -pattern l :<=> r <- Comb (Comb (Const "=" (TyBool :-> TyBool :-> TyBool)) l) r - --- | Destructor for boolean conjunctions. -destConj :: HOLTerm -> Maybe (HOLTerm, HOLTerm) -destConj = destBinary "/\\" - --- | The pattern synonym equivalent of 'destConj'. -pattern l :/\ r <- Binary "/\\" l r - --- | Destructor for boolean implications. -destImp :: HOLTerm -> Maybe (HOLTerm, HOLTerm) -destImp = destBinary "==>" - --- | The pattern synonym equivalent of 'destImp'. -pattern l :==> r <- Binary "==>" l r diff --git a/tests/examples/InlineSemi.hs b/tests/examples/InlineSemi.hs deleted file mode 100644 --- a/tests/examples/InlineSemi.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# INLINE (|.) #-}; (|.)::Storable a=>Ptr a -> Int -> IO a ; (|.) a i = peekElemOff a i diff --git a/tests/examples/Internals.hs b/tests/examples/Internals.hs deleted file mode 100644 --- a/tests/examples/Internals.hs +++ /dev/null @@ -1,427 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, - CPP #-} -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE RoleAnnotations #-} -#endif - -{-# OPTIONS_HADDOCK hide #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Array.IO.Internal --- Copyright : (c) The University of Glasgow 2001-2012 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : non-portable (uses Data.Array.Base) --- --- Mutable boxed and unboxed arrays in the IO monad. --- ------------------------------------------------------------------------------ - -module Data.Array.IO.Internals ( - IOArray(..), -- instance of: Eq, Typeable - IOUArray(..), -- instance of: Eq, Typeable - castIOUArray, -- :: IOUArray ix a -> IO (IOUArray ix b) - unsafeThawIOUArray, - ) where - -import Data.Int -import Data.Word -import Data.Typeable - -import Control.Monad.ST ( RealWorld, stToIO ) -import Foreign.Ptr ( Ptr, FunPtr ) -import Foreign.StablePtr ( StablePtr ) - -#if __GLASGOW_HASKELL__ < 711 -import Data.Ix -#endif -import Data.Array.Base - -import GHC.IOArray (IOArray(..)) - ------------------------------------------------------------------------------ --- Flat unboxed mutable arrays (IO monad) - --- | Mutable, unboxed, strict arrays in the 'IO' monad. The type --- arguments are as follows: --- --- * @i@: the index type of the array (should be an instance of 'Ix') --- --- * @e@: the element type of the array. Only certain element types --- are supported: see "Data.Array.MArray" for a list of instances. --- -newtype IOUArray i e = IOUArray (STUArray RealWorld i e) - deriving Typeable -#if __GLASGOW_HASKELL__ >= 708 --- Both parameters have class-based invariants. See also #9220. -type role IOUArray nominal nominal -#endif - -instance Eq (IOUArray i e) where - IOUArray s1 == IOUArray s2 = s1 == s2 - -instance MArray IOUArray Bool IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Char IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Int IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Word IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray (Ptr a) IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray (FunPtr a) IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Float IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Double IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray (StablePtr a) IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Int8 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Int16 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Int32 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Int64 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Word8 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Word16 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Word32 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - -instance MArray IOUArray Word64 IO where - {-# INLINE getBounds #-} - getBounds (IOUArray arr) = stToIO $ getBounds arr - {-# INLINE getNumElements #-} - getNumElements (IOUArray arr) = stToIO $ getNumElements arr - {-# INLINE newArray #-} - newArray lu initialValue = stToIO $ do - marr <- newArray lu initialValue; return (IOUArray marr) - {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ lu = stToIO $ do - marr <- unsafeNewArray_ lu; return (IOUArray marr) - {-# INLINE newArray_ #-} - newArray_ = unsafeNewArray_ - {-# INLINE unsafeRead #-} - unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) - {-# INLINE unsafeWrite #-} - unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) - --- | Casts an 'IOUArray' with one element type into one with a --- different element type. All the elements of the resulting array --- are undefined (unless you know what you\'re doing...). -castIOUArray :: IOUArray ix a -> IO (IOUArray ix b) -castIOUArray (IOUArray marr) = stToIO $ do - marr' <- castSTUArray marr - return (IOUArray marr') - -{-# INLINE unsafeThawIOUArray #-} -#if __GLASGOW_HASKELL__ >= 711 -unsafeThawIOUArray :: UArray ix e -> IO (IOUArray ix e) -#else -unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) -#endif -unsafeThawIOUArray arr = stToIO $ do - marr <- unsafeThawSTUArray arr - return (IOUArray marr) - -{-# RULES -"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray - #-} - -#if __GLASGOW_HASKELL__ >= 711 -thawIOUArray :: UArray ix e -> IO (IOUArray ix e) -#else -thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) -#endif -thawIOUArray arr = stToIO $ do - marr <- thawSTUArray arr - return (IOUArray marr) - -{-# RULES -"thaw/IOUArray" thaw = thawIOUArray - #-} - -{-# INLINE unsafeFreezeIOUArray #-} -#if __GLASGOW_HASKELL__ >= 711 -unsafeFreezeIOUArray :: IOUArray ix e -> IO (UArray ix e) -#else -unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) -#endif -unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr) - -{-# RULES -"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray - #-} - -#if __GLASGOW_HASKELL__ >= 711 -freezeIOUArray :: IOUArray ix e -> IO (UArray ix e) -#else -freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) -#endif -freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr) - -{-# RULES -"freeze/IOUArray" freeze = freezeIOUArray - #-} diff --git a/tests/examples/Jon.hs b/tests/examples/Jon.hs deleted file mode 100644 --- a/tests/examples/Jon.hs +++ /dev/null @@ -1,4 +0,0 @@ -{- ___ -}import Data.Char;main=putStr$do{c<-"/1 AA A A;9+ )11929 )1191A 2C9A ";e -{- | -} .(`divMod`8).(+(-32)).ord$c};e(0,0)="\n";e(m,n)=m?" "++n?"_/" -{- | -}n?x=do{[1..n];x} --- obfuscated -{-\_/ on Fairbairn, with apologies to Chris Brown. Above is / Haskell 98 -} diff --git a/tests/examples/LambdaCase.hs b/tests/examples/LambdaCase.hs deleted file mode 100644 --- a/tests/examples/LambdaCase.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -foo = f >>= \case - Just h -> loadTestDB (h ++ "/.testdb") - Nothing -> fmap S.Right initTestDB - -{-| Is the alarm set - i.e. will it go off at some point in the future even if `setAlarm` is not called? -} -isAlarmSetSTM :: AlarmClock -> STM Bool -isAlarmSetSTM AlarmClock{..} = readTVar acNewSetting - >>= \case { AlarmNotSet -> readTVar acIsSet; _ -> return True } diff --git a/tests/examples/LayoutIn1.hs b/tests/examples/LayoutIn1.hs deleted file mode 100644 --- a/tests/examples/LayoutIn1.hs +++ /dev/null @@ -1,9 +0,0 @@ -module LayoutIn1 where - ---Layout rule applies after 'where','let','do' and 'of' - ---In this Example: rename 'sq' to 'square'. - -sumSquares x y= sq x + sq y where sq x= x^pow - --There is a comment. - pow=2 diff --git a/tests/examples/LayoutIn1.hs.expected b/tests/examples/LayoutIn1.hs.expected deleted file mode 100644 --- a/tests/examples/LayoutIn1.hs.expected +++ /dev/null @@ -1,9 +0,0 @@ -module LayoutIn1 where - ---Layout rule applies after 'where','let','do' and 'of' - ---In this Example: rename 'sq' to 'square'. - -sumSquares x y= square x + square y where sq x= x^pow - --There is a comment. - pow=2 diff --git a/tests/examples/LayoutIn3.hs b/tests/examples/LayoutIn3.hs deleted file mode 100644 --- a/tests/examples/LayoutIn3.hs +++ /dev/null @@ -1,13 +0,0 @@ -module LayoutIn3 where - ---Layout rule applies after 'where','let','do' and 'of' - ---In this Example: rename 'x' after 'let' to 'anotherX'. - -foo x = let x = 12 in (let y = 3 - z = 2 in x * y * z * w) where y = 2 - --there is a comment. - w = x - where - x = let y = 5 in y + 3 - diff --git a/tests/examples/LayoutIn3.hs.expected b/tests/examples/LayoutIn3.hs.expected deleted file mode 100644 --- a/tests/examples/LayoutIn3.hs.expected +++ /dev/null @@ -1,13 +0,0 @@ -module LayoutIn3 where - ---Layout rule applies after 'where','let','do' and 'of' - ---In this Example: rename 'x' after 'let' to 'anotherX'. - -foo x = let anotherX = 12 in (let y = 3 - z = 2 in anotherX * y * z * w) where y = 2 - --there is a comment. - w = x - where - x = let y = 5 in y + 3 - diff --git a/tests/examples/LayoutIn3a.hs b/tests/examples/LayoutIn3a.hs deleted file mode 100644 --- a/tests/examples/LayoutIn3a.hs +++ /dev/null @@ -1,13 +0,0 @@ -module LayoutIn3a where - ---Layout rule applies after 'where','let','do' and 'of' - ---In this Example: rename 'x' after 'let' to 'anotherX'. - -foo x = let x = 12 in ( - x ) where y = 2 - --there is a comment. - w = x - where - x = let y = 5 in y + 3 - diff --git a/tests/examples/LayoutIn3a.hs.expected b/tests/examples/LayoutIn3a.hs.expected deleted file mode 100644 --- a/tests/examples/LayoutIn3a.hs.expected +++ /dev/null @@ -1,13 +0,0 @@ -module LayoutIn3a where - ---Layout rule applies after 'where','let','do' and 'of' - ---In this Example: rename 'x' after 'let' to 'anotherX'. - -foo x = let anotherX = 12 in ( - anotherX ) where y = 2 - --there is a comment. - w = x - where - x = let y = 5 in y + 3 - diff --git a/tests/examples/LayoutIn3b.hs b/tests/examples/LayoutIn3b.hs deleted file mode 100644 --- a/tests/examples/LayoutIn3b.hs +++ /dev/null @@ -1,12 +0,0 @@ -module LayoutIn3b where - ---Layout rule applies after 'where','let','do' and 'of' - ---In this Example: rename 'x' after 'let' to 'anotherX'. - -foo x = let x = 12 in ( x ) where y = 2 - --there is a comment. - w = x - where - x = let y = 5 in y + 3 - diff --git a/tests/examples/LayoutIn3b.hs.expected b/tests/examples/LayoutIn3b.hs.expected deleted file mode 100644 --- a/tests/examples/LayoutIn3b.hs.expected +++ /dev/null @@ -1,12 +0,0 @@ -module LayoutIn3b where - ---Layout rule applies after 'where','let','do' and 'of' - ---In this Example: rename 'x' after 'let' to 'anotherX'. - -foo x = let anotherX = 12 in ( anotherX ) where y = 2 - --there is a comment. - w = x - where - x = let y = 5 in y + 3 - diff --git a/tests/examples/LayoutIn4.hs b/tests/examples/LayoutIn4.hs deleted file mode 100644 --- a/tests/examples/LayoutIn4.hs +++ /dev/null @@ -1,13 +0,0 @@ -module LayoutIn4 where - ---Layout rule applies after 'where','let','do' and 'of' - ---In this Example: rename 'ioFun' to 'io' - -main = ioFun "hello" where ioFun s= do let k = reverse s - --There is a comment - s <- getLine - let q = (k ++ s) - putStr q - putStr "foo" - diff --git a/tests/examples/LayoutIn4.hs.expected b/tests/examples/LayoutIn4.hs.expected deleted file mode 100644 --- a/tests/examples/LayoutIn4.hs.expected +++ /dev/null @@ -1,13 +0,0 @@ -module LayoutIn4 where - ---Layout rule applies after 'where','let','do' and 'of' - ---In this Example: rename 'ioFun' to 'io' - -main = io "hello" where io s= do let k = reverse s ---There is a comment - s <- getLine - let q = (k ++ s) - putStr q - putStr "foo" - diff --git a/tests/examples/LayoutLet.hs b/tests/examples/LayoutLet.hs deleted file mode 100644 --- a/tests/examples/LayoutLet.hs +++ /dev/null @@ -1,7 +0,0 @@ - -foo x = - let - a = 1 - b = 2 - in x + a + b - diff --git a/tests/examples/LayoutLet2.hs b/tests/examples/LayoutLet2.hs deleted file mode 100644 --- a/tests/examples/LayoutLet2.hs +++ /dev/null @@ -1,9 +0,0 @@ -module LayoutLet2 where - --- Simple let expression, rename xxx to something longer or shorter --- and the let/in layout should adjust accordingly --- In this case the tokens for xxx + a + b should also shift out - -foo xxx = let a = 1 - b = 2 in xxx + a + b - diff --git a/tests/examples/LayoutLet2.hs.expected b/tests/examples/LayoutLet2.hs.expected deleted file mode 100644 --- a/tests/examples/LayoutLet2.hs.expected +++ /dev/null @@ -1,9 +0,0 @@ -module LayoutLet2 where - --- Simple let expression, rename xxx to something longer or shorter --- and the let/in layout should adjust accordingly --- In this case the tokens for xxx + a + b should also shift out - -foo xxxlonger = let a = 1 - b = 2 in xxxlonger + a + b - diff --git a/tests/examples/LayoutLet3.hs b/tests/examples/LayoutLet3.hs deleted file mode 100644 --- a/tests/examples/LayoutLet3.hs +++ /dev/null @@ -1,10 +0,0 @@ -module LayoutLet3 where - --- Simple let expression, rename xxx to something longer or shorter --- and the let/in layout should adjust accordingly --- In this case the tokens for xxx + a + b should also shift out - -foo xxx = let a = 1 - b = 2 - in xxx + a + b - diff --git a/tests/examples/LayoutLet3.hs.expected b/tests/examples/LayoutLet3.hs.expected deleted file mode 100644 --- a/tests/examples/LayoutLet3.hs.expected +++ /dev/null @@ -1,10 +0,0 @@ -module LayoutLet3 where - --- Simple let expression, rename xxx to something longer or shorter --- and the let/in layout should adjust accordingly --- In this case the tokens for xxx + a + b should also shift out - -foo xxxlonger = let a = 1 - b = 2 - in xxxlonger + a + b - diff --git a/tests/examples/LayoutLet4.hs b/tests/examples/LayoutLet4.hs deleted file mode 100644 --- a/tests/examples/LayoutLet4.hs +++ /dev/null @@ -1,11 +0,0 @@ -module LayoutLet4 where - --- Simple let expression, rename xxx to something longer or shorter --- and the let/in layout should adjust accordingly --- In this case the tokens for xxx + a + b should also shift out - -foo xxx = let a = 1 - b = 2 - in xxx + a + b - -bar = 3 diff --git a/tests/examples/LayoutLet4.hs.expected b/tests/examples/LayoutLet4.hs.expected deleted file mode 100644 --- a/tests/examples/LayoutLet4.hs.expected +++ /dev/null @@ -1,11 +0,0 @@ -module LayoutLet4 where - --- Simple let expression, rename xxx to something longer or shorter --- and the let/in layout should adjust accordingly --- In this case the tokens for xxx + a + b should also shift out - -foo xxxlonger = let a = 1 - b = 2 - in xxxlonger + a + b - -bar = 3 diff --git a/tests/examples/LayoutLet5.hs b/tests/examples/LayoutLet5.hs deleted file mode 100644 --- a/tests/examples/LayoutLet5.hs +++ /dev/null @@ -1,11 +0,0 @@ -module LayoutLet5 where - --- Simple let expression, rename xxx to something longer or shorter --- and the let/in layout should adjust accordingly --- In this case the tokens for xxx + a + b should also shift out - -foo xxx = let a = 1 - b = 2 - in xxx + a + b - -bar = 3 diff --git a/tests/examples/LayoutLet5.hs.expected b/tests/examples/LayoutLet5.hs.expected deleted file mode 100644 --- a/tests/examples/LayoutLet5.hs.expected +++ /dev/null @@ -1,11 +0,0 @@ -module LayoutLet5 where - --- Simple let expression, rename xxx to something longer or shorter --- and the let/in layout should adjust accordingly --- In this case the tokens for xxx + a + b should also shift out - -foo x = let a = 1 - b = 2 - in x + a + b - -bar = 3 diff --git a/tests/examples/LayoutWhere.hs b/tests/examples/LayoutWhere.hs deleted file mode 100644 --- a/tests/examples/LayoutWhere.hs +++ /dev/null @@ -1,6 +0,0 @@ - -foo x = r - where - a = 3 - b = 4 - r = a + a + b diff --git a/tests/examples/LetExpr.hs b/tests/examples/LetExpr.hs deleted file mode 100644 --- a/tests/examples/LetExpr.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# Language DeriveFoldable #-} -{-# LANGUAGE Safe #-} -{-# options_ghc -w #-} - --- | A simple let expression, to ensure the layout is detected --- With some haddock in the top -{- And a normal - multiline comment too -} - module {- brah -} LetExpr ( foo -- foo does .. - , bar -- bar does .. - , Baz () -- baz does .. - , Ba ( ..),Ca(Cc,Cd) , - bbb , aaa - , module Data.List - , pattern Bar - ) - where - -import Data.List --- A comment in the middle -import {-# SOURCE #-} BootImport ( Foo(..) ) -import {-# SoURCE #-} safe qualified BootImport as BI -import qualified Data.Map as {- blah -} Foo.Map - -import Control.Monad ( ) -import Data.Word (Word8) -import Data.Tree hiding ( drawTree ) - -import qualified Data.Maybe as M hiding ( maybe , isJust ) - - --- comment -foo = let x = 1 - y = 2 - in x + y - -bar = 3 -bbb x - | x == 1 = () - | otherwise = () - - -aaa [ ] _ = 0 -aaa x _unk = 1 - -aba () = 0 - -x `ccc` 1 = x + 1 -x `ccc` y = x + y - -x !@# y = x + y - -data Baz = Baz1 | Baz2 - -data Ba = Ba | Bb - -data Ca = Cc | Cd - -pattern Foo a <- RealFoo a -pattern Bar a <- RealBar a - -data Thing = RealFoo Thing | RealBar Int diff --git a/tests/examples/LetExpr2.hs b/tests/examples/LetExpr2.hs deleted file mode 100644 --- a/tests/examples/LetExpr2.hs +++ /dev/null @@ -1,4 +0,0 @@ -l z = - let - ll = 34 - in ll + z diff --git a/tests/examples/LetExprSemi.hs b/tests/examples/LetExprSemi.hs deleted file mode 100644 --- a/tests/examples/LetExprSemi.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# Language DeriveFoldable #-} -{-# LANGUAGE Safe #-} -{-# options_ghc -w #-} - --- | A simple let expression, to ensure the layout is detected --- With some haddock in the top -{- And a normal - multiline comment too -} - module {- brah -} LetExprSemi ( foo -- foo does .. - , bar -- bar does .. - , Baz () -- baz does .. - , Ba ( ..),Ca(Cc,Cd) , - bbb , aaa - , module Data.List - , pattern Bar - ) - where -{ -import Data.List --- A comment in the middle -; import {-# SOURCE #-} BootImport ( Foo(..) ) ; -import {-# SOURCE #-} safe qualified BootImport as BI -;;; import qualified Data.Map as {- blah -} Foo.Map; - -import Control.Monad ( ) ; -import Data.Word (Word8); -import Data.Tree hiding ( drawTree ) ; - - ; import qualified Data.Maybe as M hiding ( maybe , isJust ) -; - --- comment -foo = let x = 1 - y = 2 - in x + y -; -bar = 3; -bbb x - | x == 1 = () - | otherwise = () - -; -aaa [] _ = 0; -aaa x _unk = 1 -; -x `ccc` 1 = x + 1; -x `ccc` y = x + y -; -x !@# y = x + y -; -data Baz = Baz1 | Baz2 -; -data Ba = Ba | Bb -; -data Ca = Cc | Cd -; -pattern Foo a <- RealFoo a ; -pattern Bar a <- RealBar a -; -data Thing = RealFoo Thing | RealBar Int -} - - diff --git a/tests/examples/LetIn1.hs b/tests/examples/LetIn1.hs deleted file mode 100644 --- a/tests/examples/LetIn1.hs +++ /dev/null @@ -1,19 +0,0 @@ -module LetIn1 where - ---A definition can be demoted to the local 'where' binding of a friend declaration, ---if it is only used by this friend declaration. - ---Demoting a definition narrows down the scope of the definition. ---In this example, demote the local 'pow' to 'sq' ---This example also aims to test the demoting a local declaration in 'let'. - -sumSquares x y = let sq 0=0 - sq z=z^pow - pow=2 - in sq x + sq y - - -anotherFun 0 y = sq y - where sq x = x^2 - - diff --git a/tests/examples/LetIn1.hs.expected b/tests/examples/LetIn1.hs.expected deleted file mode 100644 --- a/tests/examples/LetIn1.hs.expected +++ /dev/null @@ -1,18 +0,0 @@ -module LetIn1 where - ---A definition can be demoted to the local 'where' binding of a friend declaration, ---if it is only used by this friend declaration. - ---Demoting a definition narrows down the scope of the definition. ---In this example, demote the local 'pow' to 'sq' ---This example also aims to test the demoting a local declaration in 'let'. - -sumSquares x y = let sq 0=0 - sq z=z^pow - in sq x + sq y - - -anotherFun 0 y = sq y - where sq x = x^2 - - diff --git a/tests/examples/LetStmt.hs b/tests/examples/LetStmt.hs deleted file mode 100644 --- a/tests/examples/LetStmt.hs +++ /dev/null @@ -1,9 +0,0 @@ --- A simple let statement, to ensure the layout is detected - -module Layout.LetStmt where - -foo = do -{- ffo -}let x = 1 - y = 2 -- baz - x+y - diff --git a/tests/examples/LiftedConstructors.hs b/tests/examples/LiftedConstructors.hs deleted file mode 100644 --- a/tests/examples/LiftedConstructors.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DataKinds, TypeOperators, GADTs #-} - -give :: b -> Pattern '[b] a -give b = Pattern (const (Just $ oneT b)) - - -pfail :: Pattern '[] a -pfail = is (const False) - -(/\) :: Pattern vs1 a -> Pattern vs2 a -> Pattern (vs1 :++: vs2) a -(/\) = mk2 (\a -> Just (a,a)) - -data Pattern :: [*] -> * where - Nil :: Pattern '[] - Cons :: Maybe h -> Pattern t -> Pattern (h ': t) - -type Pos = '("vpos", V3 GLfloat) -type Tag = '("tagByte", V1 Word8) - --- | Alias for the 'In' type from the 'Direction' kind, allows users to write --- the 'BroadcastChan In a' type without enabling DataKinds. -type In = 'In --- | Alias for the 'Out' type from the 'Direction' kind, allows users to write --- the 'BroadcastChan Out a' type without enabling DataKinds. -type Out = 'Out diff --git a/tests/examples/LiftedInfixConstructor.hs b/tests/examples/LiftedInfixConstructor.hs deleted file mode 100644 --- a/tests/examples/LiftedInfixConstructor.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE DataKinds, TemplateHaskell #-} - -applicate :: Bool -> [Stmt] -> ExpQ -applicate rawPatterns stmt = do - return $ foldl (\g e -> VarE '(<**>) `AppE` e `AppE` g) - (VarE 'pure `AppE` f') - es - -tuple :: Int -> ExpQ -tuple n = do - ns <- replicateM n (newName "x") - lamE [foldr (\x y -> conP '(:) [varP x,y]) wildP ns] (tupE $ map varE ns) diff --git a/tests/examples/LinePragma.hs b/tests/examples/LinePragma.hs deleted file mode 100644 --- a/tests/examples/LinePragma.hs +++ /dev/null @@ -1,36 +0,0 @@ -module UHC.Light.Compiler.Core.SysF.AsTy -( Ty -, ty2TySysfWithEnv, ty2TyC -, ty2TyCforFFI ) -where -import UHC.Light.Compiler.Base.Common -import UHC.Light.Compiler.Opts.Base -import UHC.Light.Compiler.Error -import qualified UHC.Light.Compiler.Core as C -import qualified UHC.Light.Compiler.Ty as T -import UHC.Light.Compiler.FinalEnv - -{-# LINE 50 "src/ehc/Core/SysF/AsTy.chs" #-} --- | The type, represented by a term CExpr -type Ty = C.SysfTy -- base ty - --- | Binding the bound -type TyBind = C.SysfTyBind -type TyBound = C.SysfTyBound - --- | A sequence of parameters (for now just a single type) -type TySeq = C.SysfTySeq - - -{-# LINE 67 "src/ehc/Core/SysF/AsTy.chs" #-} -ty2TySysfWithEnv :: ToSysfEnv -> T.Ty -> Ty -ty2TySysfWithEnv _ t = t - --- | Construct a type for use by AbstractCore -ty2TyC :: EHCOpts -> ToSysfEnv -> T.Ty -> C.CTy -ty2TyC o env t = C.mkCTy o t (ty2TySysfWithEnv env t) - -{-# LINE 93 "src/ehc/Core/SysF/AsTy.chs" #-} --- | Construct a type for use by AbstractCore, specifically for use by FFI -ty2TyCforFFI :: EHCOpts -> T.Ty -> C.CTy -ty2TyCforFFI o t = C.mkCTy o t t diff --git a/tests/examples/ListComprehensions.hs b/tests/examples/ListComprehensions.hs deleted file mode 100644 --- a/tests/examples/ListComprehensions.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE ParallelListComp, - TransformListComp, - RecordWildCards #-} --- MonadComprehensions, - --- 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 ] - -legendres :: [Poly Rational] -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 - ] - -fromGroups' :: (Ord k) => a -> [a] -> Maybe (W.Stack k) -> Groups k -> [a] - -> [(Bool,(a, W.Stack k))] -fromGroups' defl defls st gs sls = - [ (isNew,fromMaybe2 (dl, single w) (l, M.lookup w gs)) - | l <- map Just sls ++ repeat Nothing, let isNew = isNothing l - | dl <- defls ++ repeat defl - | w <- W.integrate' $ W.filter (`notElem` unfocs) =<< st ] diff --git a/tests/examples/LocToName.hs b/tests/examples/LocToName.hs deleted file mode 100644 --- a/tests/examples/LocToName.hs +++ /dev/null @@ -1,24 +0,0 @@ -module LocToName where - -{- - - - - - - - - --} - - - - - - - -sumSquares (x:xs) = x ^2 + sumSquares xs - -- where sq x = x ^pow - -- pow = 2 - -sumSquares [] = 0 diff --git a/tests/examples/LocToName.hs.expected b/tests/examples/LocToName.hs.expected deleted file mode 100644 --- a/tests/examples/LocToName.hs.expected +++ /dev/null @@ -1,24 +0,0 @@ -module LocToName where - -{- - - - - - - - - --} - - - - - - - -LocToName.newPoint (x:xs) = x ^2 + LocToName.newPoint xs - -- where sq x = x ^pow - -- pow = 2 - -LocToName.newPoint [] = 0 diff --git a/tests/examples/LocalDecls.hs b/tests/examples/LocalDecls.hs deleted file mode 100644 --- a/tests/examples/LocalDecls.hs +++ /dev/null @@ -1,8 +0,0 @@ -module LocalDecls where - -foo a = bar a - where - bar :: Int -> Int - bar x = x + 2 - - baz = 4 diff --git a/tests/examples/LocalDecls.hs.expected b/tests/examples/LocalDecls.hs.expected deleted file mode 100644 --- a/tests/examples/LocalDecls.hs.expected +++ /dev/null @@ -1,11 +0,0 @@ -module LocalDecls where - -foo a = bar a - where - nn :: Int - nn = 2 - - bar :: Int -> Int - bar x = x + 2 - - baz = 4 diff --git a/tests/examples/LocalDecls2.hs b/tests/examples/LocalDecls2.hs deleted file mode 100644 --- a/tests/examples/LocalDecls2.hs +++ /dev/null @@ -1,3 +0,0 @@ -module LocalDecls2 where - -foo a = bar a diff --git a/tests/examples/LocalDecls2.hs.expected b/tests/examples/LocalDecls2.hs.expected deleted file mode 100644 --- a/tests/examples/LocalDecls2.hs.expected +++ /dev/null @@ -1,6 +0,0 @@ -module LocalDecls2 where - -foo a = bar a - where - nn :: Int - nn = 2 diff --git a/tests/examples/LocalDecls2Expected.hs b/tests/examples/LocalDecls2Expected.hs deleted file mode 100644 --- a/tests/examples/LocalDecls2Expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -module LocalDecls2Expected where - -foo a = bar a - where - nn :: Int - nn = 2 diff --git a/tests/examples/MagicHash.hs b/tests/examples/MagicHash.hs deleted file mode 100644 --- a/tests/examples/MagicHash.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE MagicHash #-} - -module Data.Text.Internal.Builder.Functions - ( - (<>) - , i2d - ) where - -import Data.Monoid (mappend) -import Data.Text.Lazy.Builder (Builder) -import GHC.Base - --- | Unsafe conversion for decimal digits. -{-# INLINE i2d #-} -i2d :: Int -> Char -i2d (I# i#) = C# (chr# (ord# '0'# +# i#)) - -main = - print (F# (expFloat# 3.45#)) - --- | The normal 'mappend' function with right associativity instead of --- left. -(<>) :: Builder -> Builder -> Builder -(<>) = mappend -{-# INLINE (<>) #-} - -infixr 4 <> - - diff --git a/tests/examples/MangledSemiLet.hs b/tests/examples/MangledSemiLet.hs deleted file mode 100644 --- a/tests/examples/MangledSemiLet.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE - BangPatterns - #-} - - -mtGamma a b = - 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/Minimal.hs b/tests/examples/Minimal.hs deleted file mode 100644 --- a/tests/examples/Minimal.hs +++ /dev/null @@ -1,37 +0,0 @@ -class AwsType a where - toText :: a -> b - - - {-# MINIMAL toText #-} - -class Minimal a where - toText :: a -> b - {-# MINIMAL decimal, hexadecimal, realFloat, scientific #-} - -class Minimal a where - toText :: a -> b - {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-} - -class Minimal a where - toText :: a -> b - {-# MINIMAL (toSample | toSamples) #-} - -class ManyOps a where - aOp :: a -> a -> Bool - bOp :: a -> a -> Bool - cOp :: a -> a -> Bool - dOp :: a -> a -> Bool - eOp :: a -> a -> Bool - fOp :: a -> a -> Bool - {-# MINIMAL ( aOp) - | ( bOp , cOp) - | ((dOp | eOp) , fOp) - #-} - -class Foo a where - bar :: a -> a -> Bool - foo :: a -> a -> Bool - baq :: a -> a -> Bool - baz :: a -> a -> Bool - quux :: a -> a -> Bool - {-# MINIMAL bar, (foo, baq | foo, quux) #-} diff --git a/tests/examples/Mixed.hs b/tests/examples/Mixed.hs deleted file mode 100644 --- a/tests/examples/Mixed.hs +++ /dev/null @@ -1,48 +0,0 @@ - -import Data.List () -import Data.List hiding () - -infixl 1 `f` --- infixr 2 `\\\` -infix 3 :==> -infix 4 `MkFoo` - -data Foo = MkFoo Int | Float :==> Double - -x `f` y = x - -(\\\) :: (Eq a) => [a] -> [a] -> [a] -(\\\) xs ys = xs - -g x = x + if True then 1 else 2 -h x = x + 1::Int - -{-# SPECIALISe j :: Int -> Int #-} -j n = n + 1 - -test = let k x y = x+y in 1 `k` 2 `k` 3 - -data Rec = (:<-:) { a :: Int, b :: Float } - -ng1 x y = negate y - -instance (Num a, Num b) => Num (a,b) - where - negate (a,b) = (ng 'c' a, ng1 'c' b) where ng x y = negate y - - - -class Foo1 a where - -class Foz a - -x = 2 where -y = 3 - -instance Foo1 Int where - -ff = ff where g = g where -type T = Int - - - diff --git a/tests/examples/MonadComprehensions.hs b/tests/examples/MonadComprehensions.hs deleted file mode 100644 --- a/tests/examples/MonadComprehensions.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE ParallelListComp, - TransformListComp, - RecordWildCards #-} -{-# LANGUAGE MonadComprehensions #-} - --- 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) - - --- Monad Comprehensions - -sqrts :: M.Map Int Int -sqrts = M.fromList $ [ (x, sx) - | x <- map (^2) [1..100] - | sx <- [1..100] - ] - -sumIntSqrts :: Int -> Int -> Maybe Int -sumIntSqrts a b = [ x + y - | x <- M.lookup a sqrts - , y <- M.lookup b sqrts - ] - -greet :: IO String -greet = [ name - | name <- getLine - , _ <- putStrLn $ unwords ["Hello, ", name, "!"] - ] - diff --git a/tests/examples/Move1.hs b/tests/examples/Move1.hs deleted file mode 100644 --- a/tests/examples/Move1.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Move1 where - -data Located a = L Int a -type Name = String -hsBinds = undefined -divideDecls = undefined -definingDeclsNames = undefined -nub = undefined -definedPNs :: a -> [b] -definedPNs = undefined -logm = undefined -showGhc = undefined -pnsNeedRenaming = undefined -concatMap1 = undefined - --- liftToTopLevel' :: ModuleName -- -> (ParseResult,[PosToken]) -> FilePath --- -> Located Name --- -> RefactGhc [a] -liftToTopLevel' :: Int -> Located Name -> IO [a] -liftToTopLevel' modName pn@(L _ n) = do - liftToMod - return [] - where - {-step1: divide the module's top level declaration list into three parts: - 'parent' is the top level declaration containing the lifted declaration, - 'before' and `after` are those declarations before and after 'parent'. - step2: get the declarations to be lifted from parent, bind it to liftedDecls - step3: remove the lifted declarations from parent and extra arguments may be introduce. - step4. test whether there are any names need to be renamed. - -} - liftToMod :: IO () - liftToMod = do - -- renamed <- getRefactRenamed - let renamed = undefined - let declsr = hsBinds renamed - let (before,parent,after) = divideDecls declsr pn - -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ++ - {- ++AZ++ : hsBinds does not return class or instance definitions - when (isClassDecl $ ghead "liftToMod" parent) - $ error "Sorry, the refactorer cannot lift a definition from a class declaration!" - when (isInstDecl $ ghead "liftToMod" parent) - $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!" - -} - let liftedDecls = definingDeclsNames [n] parent True True - declaredPns = nub $ concatMap1 definedPNs liftedDecls - - -- TODO: what about declarations between this - -- one and the top level that are used in this one? - - logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns)) - -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns - -- pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns - return () diff --git a/tests/examples/MultiImplicitParams.hs b/tests/examples/MultiImplicitParams.hs deleted file mode 100644 --- a/tests/examples/MultiImplicitParams.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} - -foo = do - ev <- let ?mousePosition = relative<$>Reactive (Size 1 1) _size<|*>_mousePos - ?buttonChanges = _button - in sink - return baz diff --git a/tests/examples/MultiLineCommentWithPragmas.hs b/tests/examples/MultiLineCommentWithPragmas.hs deleted file mode 100644 --- a/tests/examples/MultiLineCommentWithPragmas.hs +++ /dev/null @@ -1,18 +0,0 @@ - -{- --- this is ugly too: can't use Data.Complex because the qd bindings do --- not implement some low-level functions properly, leading to obscure --- crashes inside various Data.Complex functions... -data Complex c = {-# UNPACK #-} !c :+ {-# UNPACK #-} !c deriving (Read, Show, Eq) - --- complex number arithmetic, with extra strictness and cost-centres -instance Num c => Num (Complex c) where - (!(a :+ b)) + (!(c :+ d)) = {-# SCC "C+" #-} ((a + c) :+ (b + d)) - (!(a :+ b)) - (!(c :+ d)) = {-# SCC "C-" #-} ((a - c) :+ (b - d)) - (!(a :+ b)) * (!(c :+ d)) = {-# SCC "C*" #-} ((a * c - b * d) :+ (a * d + b * c)) - negate !(a :+ b) = (-a) :+ (-b) - abs x = error $ "Complex.abs: " ++ show x - signum x = error $ "Complex.signum: " ++ show x - fromInteger !x = fromInteger x :+ 0 --} - diff --git a/tests/examples/MultiLineWarningPragma.hs b/tests/examples/MultiLineWarningPragma.hs deleted file mode 100644 --- a/tests/examples/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/MultiLineWarningPragma.hs.bad b/tests/examples/MultiLineWarningPragma.hs.bad deleted file mode 100644 --- a/tests/examples/MultiLineWarningPragma.hs.bad +++ /dev/null @@ -1,17 +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/MultiParamTypeClasses.hs b/tests/examples/MultiParamTypeClasses.hs deleted file mode 100644 --- a/tests/examples/MultiParamTypeClasses.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- From https://ocharles.org.uk/blog/posts/2014-12-13-multi-param-type-classes.html - -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ReaderT) -import Data.Foldable (forM_) -import Data.IORef - -class Store store m where - new :: a -> m (store a) - get :: store a -> m a - put :: store a -> a -> m () - -type Present = String -storePresents :: (Store store m, Monad m) => [Present] -> m (store [Present]) -storePresents xs = do - store <- new [] - forM_ xs $ \x -> do - old <- get store - put store (x : old) - return store - -instance Store IORef IO where - new = newIORef - get = readIORef - put ioref a = modifyIORef ioref (const a) - --- ex ps = do --- store <- storePresents ps --- get (store :: IORef [Present]) diff --git a/tests/examples/MultiWayIf.hs b/tests/examples/MultiWayIf.hs deleted file mode 100644 --- a/tests/examples/MultiWayIf.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} - - -instance Animatable Double where - interpolate ease from to t = - if | t <= 0 -> from - | t >= 1 -> to - | otherwise -> from + easeDouble ease t * (to - from) - animAdd = (+) - animSub = (-) - animZero = 0 diff --git a/tests/examples/MultipleInferredContexts.hs b/tests/examples/MultipleInferredContexts.hs deleted file mode 100644 --- a/tests/examples/MultipleInferredContexts.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} - -f :: (Eq a, _, _) => a -> a -> Bool -f x y = x == y diff --git a/tests/examples/NestedDoLambda.hs b/tests/examples/NestedDoLambda.hs deleted file mode 100644 --- a/tests/examples/NestedDoLambda.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE Arrows #-} - -operator = describe "Operators on ProcessA"$ - do - describe "feedback" $ - do - it "acts like local variable with hold." $ - do - let - pa = proc evx -> - do - (\evy -> hold 10 -< evy) - `feedback` \y -> - do - returnA -< ((+y) <$> evx, (y+1) <$ evx) - run pa [1, 2, 3] `shouldBe` [11, 13, 15] - - it "correctly handles stream end." $ - do - let - pa = proc x -> - (\asx -> returnA -< asx) - `feedback` - (\asy -> returnA -< (asy::Event Int, x)) - comp = mkProc (PgPush PgStop) >>> pa - stateProc comp [0, 0] `shouldBe` ([], [0]) - - it "correctly handles stream end.(2)" $ - do - pendingWith "now many utilities behave incorrectly at the end of stream." - diff --git a/tests/examples/NestedLambda.hs b/tests/examples/NestedLambda.hs deleted file mode 100644 --- a/tests/examples/NestedLambda.hs +++ /dev/null @@ -1,8 +0,0 @@ - - - -getPath :: [String] -> Filter -getPath names elms = - let follow = foldl (\f n -> \els-> subElems n $ f els) id' names :: Filter - id' = id :: Filter - in follow elms diff --git a/tests/examples/NullaryTypeClasses.hs b/tests/examples/NullaryTypeClasses.hs deleted file mode 100644 --- a/tests/examples/NullaryTypeClasses.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE NullaryTypeClasses #-} - --- From https://ocharles.org.uk/blog/posts/2014-12-10-nullary-type-classes.html - -class Logger where - logMessage :: String -> IO () - -type Present = String -queueNewChristmasPresents :: Logger => [Present] -> IO () -queueNewChristmasPresents presents = do - mapM (logMessage . ("Queueing present for delivery: " ++)) presents - return () - -instance Logger where - logMessage t = putStrLn ("[XMAS LOG]: " ++ t) - diff --git a/tests/examples/Obscure.hs b/tests/examples/Obscure.hs deleted file mode 100644 --- a/tests/examples/Obscure.hs +++ /dev/null @@ -1,29 +0,0 @@ -type A = Integer -data B = B { u :: !B, j :: B, r :: !A, i :: [A] } | Y -c=head -k=tail -b x y=x(y)y -n=map(snd)h -m=2:3:5:[7] -f=s(flip(a))t -s x y z=x(y(z)) -e=filter(v)[2..221] -z=s(s(s((s)b)(s(s)flip)))s -main=mapM_(print)(m++map(fst)h) -v=s(flip(all)m)(s((.)(/=0))mod) -t=(s(s(s(b))flip)((s)s))(s(B(Y)Y)c)k -g=z(:)(z(,)c(b(s((s)map(*))c)))(s(g)k) -h=c(q):c(k(q)):d(p(t((c)n))(k(n)))(k((k)q)) -q=g(scanl1(+)(11:cycle(zipWith(-)((k)e)e))) -a x Y = x -a Y x = x -a x y = case compare((r)x)(r(y)) of - GT -> a(y)x - _ -> B(a((j)x)y)(u(x))((r)x)(i(x)) -p x y = case compare((r)x)(c(c(y))) of - GT -> p(f((c)y)x)(k(y)) - _ -> r(x):p(f((i)x)(a(u(x))(j(x))))y -d x y = case compare((c)x)(fst(c(y))) of - GT -> c(y):(d)x((k)y) - LT -> d(k(x))y - EQ -> d((k)x)(k(y)) diff --git a/tests/examples/OptSig.hs b/tests/examples/OptSig.hs deleted file mode 100644 --- a/tests/examples/OptSig.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -errors= do - let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]" - return () - --- This can be seen as the definition of accumFilter -accumFilter2 :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) -accumFilter2 f c_init = - switch (never &&& attach c_init) afAux - where - afAux (c, a) = - case f c a of - (c', Nothing) -> switch (never &&& (notYet>>>attach c')) afAux - (c', Just b) -> switch (now b &&& (notYet>>>attach c')) afAux - - attach :: b -> SF (Event a) (Event (b, a)) - attach c = arr (fmap (\a -> (c, a))) diff --git a/tests/examples/OptSig2.hs b/tests/examples/OptSig2.hs deleted file mode 100644 --- a/tests/examples/OptSig2.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -errors= do - let ls :: Int = undefined - return () diff --git a/tests/examples/OveridingPrimitives.hs b/tests/examples/OveridingPrimitives.hs deleted file mode 100644 --- a/tests/examples/OveridingPrimitives.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} - -(~#) :: Comonad w => CascadeW w (t ': ts) -> w t -> Last (t ': ts) -(~#) = cascadeW -infixr 0 ~# diff --git a/tests/examples/OverloadedStrings.hs b/tests/examples/OverloadedStrings.hs deleted file mode 100644 --- a/tests/examples/OverloadedStrings.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# Language OverloadedStrings #-} --- from https://ocharles.org.uk/blog/posts/2014-12-17-overloaded-strings.html - -import Data.String - -n :: Num a => a -n = 43 - -f :: Fractional a => a -f = 03.1420 - --- foo :: Text -foo :: Data.String.IsString a => a -foo = "hello\n there" - diff --git a/tests/examples/PArr.hs b/tests/examples/PArr.hs deleted file mode 100644 --- a/tests/examples/PArr.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} - -module PArr where - -blah xs ys = [ (x, y) | x <- xs | y <- ys ] - --- bar = [: 1, 2 .. 3 :] - - --- entry point for desugaring a parallel array comprehension - --- parr = [:e | qss:] = <<[:e | qss:]>> () [:():] - -{- -ary = let arr1 = toP [1..10] - arr2 = toP [1..10] - f = [: i1 + i2 | i1 <- arr1 | i2 <- arr2 :] - in f !: 1 --} - - -foo = 'a' - diff --git a/tests/examples/ParensAroundContext.hs b/tests/examples/ParensAroundContext.hs deleted file mode 100644 --- a/tests/examples/ParensAroundContext.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -module ParensAroundContext where - -f :: ((Eq a, _)) => a -> a -> Bool -f x y = x == y diff --git a/tests/examples/PatBind.hs b/tests/examples/PatBind.hs deleted file mode 100644 --- a/tests/examples/PatBind.hs +++ /dev/null @@ -1,34 +0,0 @@ -module Layout.PatBind where - -a,b :: Int -a = 1 -b = 2 - -c :: Maybe (a -> b) -c = Nothing - -f :: (Num a1, Num a) => a -> a1 -> ( a, a1 ) -f x y = ( x+1, y-1 ) - --- Chris done comment attachment problem -foo = x - where -- do stuff - doStuff = do stuff -x = 1 -stuff = 4 - - -- Pattern bind -tup :: (Int, Int) -h :: Int -t :: Int -tup@(h,t) = head $ zip [1..10] [3..ff] - where - ff :: Int - ff = 15 - -blah = do { - ; print "a" - ; print "b" - } - - diff --git a/tests/examples/PatSigBind.hs b/tests/examples/PatSigBind.hs deleted file mode 100644 --- a/tests/examples/PatSigBind.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -runCoreRunIO - :: EHCOpts -- ^ options, e.g. for turning on tracing (if supported by runner) - -> Mod -- ^ the module to run - -> IO (Either Err RVal) -runCoreRunIO opts mod = do - catch - (runCoreRun opts [] mod $ cmodRun opts mod) - (\(e :: SomeException) -> hFlush stdout >> (return $ Left $ strMsg $ "runCoreRunIO: " ++ show e)) - - -foo = do - (a :: Int) <- baz - return grue diff --git a/tests/examples/PatSynBind.hs b/tests/examples/PatSynBind.hs deleted file mode 100644 --- a/tests/examples/PatSynBind.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- From https://ocharles.org.uk/blog/posts/2014-12-03-pattern-synonyms.html - -import Foreign.C - -{- - -data BlendMode = NoBlending -- | AlphaBlending | AdditiveBlending | ColourModulatedBlending - -toBlendMode :: BlendMode -> CInt -toBlendMode NoBlending = 0 -- #{const SDL_BLENDMODE_NONE} --- toBlendMode AlphaBlending = #{const SDL_BLENDMODE_BLEND} - -fromBlendMode :: CInt -> Maybe BlendMode -fromBlendMode 0 = Just NoBlending - --} - -{- - -pattern AlphaBlending = (1) :: CInt -- #{const SDL_BLENDMODE_BLEND} :: CInt - -setUpBlendMode :: CInt -> IO () -setUpBlendMode AlphaBlending = do - putStrLn "Enabling Alpha Blending" - activateAlphaBlendingForAllTextures - activateRenderAlphaBlending - --} - -newtype BlendMode = MkBlendMode { unBlendMode :: CInt } - -pattern NoBlending = MkBlendMode 0 -- #{const SDL_BLENDMODE_NONE} -pattern AlphaBlending = MkBlendMode 1 -- #{const SDL_BLENDMODE_BLEND} - -setUpBlendMode :: BlendMode -> IO () -setUpBlendMode AlphaBlending = do - putStrLn "Enabling Alpha Blending" - activateAlphaBlendingForAllTextures - activateRenderAlphaBlending - -data Renderer - -setRenderAlphaBlending :: Renderer -> IO () -setRenderAlphaBlending r = - sdlSetRenderDrawBlendMode r (unBlendMode AlphaBlending) - -activateAlphaBlendingForAllTextures = return () -activateRenderAlphaBlending = return () - -sdlSetRenderDrawBlendMode _ _ = return () - --- And from https://www.fpcomplete.com/user/icelandj/Pattern%20synonyms - -data Date = Date { month :: Int, day :: Int } deriving Show - --- Months -pattern January day = Date { month = 1, day = day } -pattern February day = Date { month = 2, day = day } -pattern March day = Date { month = 3, day = day } --- elided -pattern December day = Date { month = 12, day = day } - --- Holidays -pattern Christmas = Date { month = 12, day = 25 } - -describe :: Date -> String -describe (January 1) = "First day of year" -describe (February n) = show n ++ "th of February" -describe Christmas = "Presents!" -describe _ = "meh" - -pattern Christmas2 = December 25 - -pattern BeforeChristmas <- December (compare 25 -> GT) -pattern Christmas3 <- December (compare 25 -> EQ) -pattern AfterChristmas <- December (compare 25 -> LT) - -react :: Date -> String -react BeforeChristmas = "Waiting :(" -react Christmas = "Presents!" -react AfterChristmas = "Have to wait a whole year :(" -react _ = "It's not even December..." - -isItNow :: Int -> (Ordering, Int) -isItNow day = (compare 25 day, day) - -pattern BeforeChristmas4 day <- December (isItNow -> (GT, day)) -pattern Christmas4 <- December (isItNow -> (EQ, _)) -pattern AfterChristmas4 day <- December (isItNow -> (LT, day)) - -days'tilChristmas :: Date -> Int -days'tilChristmas (BeforeChristmas4 n) = 25 - n -days'tilChristmas Christmas4 = 0 -days'tilChristmas (AfterChristmas4 n) = 365 + 25 - n diff --git a/tests/examples/PatternGuards.hs b/tests/examples/PatternGuards.hs deleted file mode 100644 --- a/tests/examples/PatternGuards.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PatternGuards #-} - -match n - | Just 5 <- Just n - , Just 6 <- Nothing - , Just 7 <- Just 9 - = Just 8 diff --git a/tests/examples/ProcNotation.hs b/tests/examples/ProcNotation.hs deleted file mode 100644 --- a/tests/examples/ProcNotation.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-#LANGUAGE Arrows, RankNTypes, ScopedTypeVariables, FlexibleContexts, - TypeSynonymInstances, NoMonomorphismRestriction, FlexibleInstances #-} - -valForm initVal vtor label = withInput $ - proc ((),nm,fi) -> do - s_curr <- keepState initVal -< fi - valid <- vtor -< s_curr - case valid of - Left err -> returnA -< (textField label (Just err) s_curr nm, - Nothing) - Right x -> returnA -< (textField label Nothing s_curr nm, - Just x) diff --git a/tests/examples/Pseudonym.hs b/tests/examples/Pseudonym.hs deleted file mode 100644 --- a/tests/examples/Pseudonym.hs +++ /dev/null @@ -1,41 +0,0 @@ -default(Int);q s=s++ss s;ss ""=" \"\"";ss s=" "++show(take 50 s)++"++\n"++ - ss(dd 50 s);t3=" ";z n=t3++" xo"!!n:t3;zl n = z(l n);j=head$[m| - (m,0)<-zip[0..]p]++[-1];l s = if j==s then 2 else p!!s;m= - "default(Int);q s=s++ss s;ss \"\"=\" \\\"\\\"\";ss s=\" \"++s"++ - "how(take 50 s)++\"++\\n\"++\n ss(dd 50 s);t3=\" \";z n"++ - "=t3++\" xo\"!!n:t3;zl n = z(l n);j=head$[m|\n (m,0)<-"++ - "zip[0..]p]++[-1];l s = if j==s then 2 else p!!s;m=\n" -vv="\n "++z0++";z0=z"++z0++"0 ;a=\n "++zl 4++"-0;b="++zl 7++"-0;c="++zl 1++ - "\n "++z0++"-0;ms"++z0++"=[[4,\n 7,1],[6,0,5],[2,8,3],[4,6,2],[7\n ,0,8],[1, 5,3],[4,0,3],[1,0,2]]\n ;main=putStr(unlines[q m,q y,vv\n "++z0++"]);x=" - ++z0++"1; d=\n "++zl 6++"-0;e="++zl 0++"-0;f="++zl 5++"\n "++z0++"-0" - ++";o="++z0++"2;p=[\n e,c,g,i,a,f,d,b,h];r=[\"\",\"You \"\n ++\"win\",\"I win\"]!!head([w|w<-[1\n ,2],x<-ms,all(\\x->w==l x)x]++[0\n "++z0++"]);n="++z0++"1" - ++"9;g=\n "++zl 2++"-0;h="++zl 8++"-0;i="++zl 3++"\n "++z0++"-0;dd"++z0++ - "=drop\n\n"++r -;y= "vv=\"\\n \"++z0++\";z0=z\"++z0++\"0 ;a=\\n \"++zl 4++\"-0;b"++ - "=\"++zl 7++\"-0;c=\"++zl 1++\n \"\\n \"++z0++\"-0;ms\"++z0+"++ - "+\"=[[4,\\n 7,1],[6,0,5],[2,8,3],[4,6,2],[7\\n ,0,8],"++ - "[1, 5,3],[4,0,3],[1,0,2]]\\n ;main=putStr(unlines[q"++ - " m,q y,vv\\n \"++z0++\"]);x=\"\n ++z0++\"1; d=\\n \"++zl 6"++ - "++\"-0;e=\"++zl 0++\"-0;f=\"++zl 5++\"\\n \"++z0++\"-0\"\n +"++ - "+\";o=\"++z0++\"2;p=[\\n e,c,g,i,a,f,d,b,h];r=[\\\"\\\",\\\""++ - "You \\\"\\n ++\\\"win\\\",\\\"I win\\\"]!!head([w|w<-[1\\n ,2]"++ - ",x<-ms,all(\\\\x->w==l x)x]++[0\\n \"++z0++\"]);n=\"++z0"++ - "++\"1\"\n ++\"9;g=\\n \"++zl 2++\"-0;h=\"++zl 8++\"-0;i=\"++"++ - "zl 3++\"\\n \"++z0++\"-0;dd\"++z0++\n \"=drop\\n\\n\"++r\n;y=" - - ;z0=z 0 ;a= - -0;b= -0;c= - -0;ms =[[4, - 7,1],[6,0,5],[2,8,3],[4,6,2],[7 - ,0,8],[1, 5,3],[4,0,3],[1,0,2]] - ;main=putStr(unlines[q m,q y,vv - ]);x= 1; d= - -0;e= -0;f= - -0;o= 2;p=[ - e,c,g,i,a,f,d,b,h];r=["","You " - ++"win","I win"]!!head([w|w<-[1 - ,2],x<-ms,all(\x->w==l x)x]++[0 - ]);n= 19;g= - -0;h= -0;i= - -0;dd =drop - diff --git a/tests/examples/PuncFunctions.hs b/tests/examples/PuncFunctions.hs deleted file mode 100644 --- a/tests/examples/PuncFunctions.hs +++ /dev/null @@ -1,25 +0,0 @@ --- | Compares two functions taking one container -(=*=) :: (Eq' a b) => (f -> a) -> (g -> b) - -> SameAs f g r -> r -> Property -(f =*= g) sa i = f (toF sa i) =^= g (toG sa i) - --- | Compares two functions taking one scalar and one container -(=?*=) :: (Eq' a b) => (t -> f -> a) -> (t -> g -> b) - -> SameAs f g r -> r -> t -> Property -(f =?*= g) sa i t = (f t =*= g t) sa i - --- | Compares functions taking two scalars and one container -(=??*=) :: (Eq' a b) => (t -> s -> f -> a) -> (t -> s -> g -> b) - -> SameAs f g r -> r -> t -> s -> Property -(f =??*= g) sa i t s = (f t s =*= g t s) sa i - --- | Compares two functions taking two containers -(=**=) :: (Eq' a b) => (f -> f -> a) -> (g -> g -> b) - -> SameAs f g r -> r -> r -> Property -(f =**= g) sa i = (f (toF sa i) =*= g (toG sa i)) sa - --- | Compares two functions taking one container with preprocessing -(=*==) :: (Eq' f g) => (z -> f) -> (z -> g) -> (p -> z) - -> SameAs f g r -> p -> Property -(f =*== g) p _ i = f i' =^= g i' - where i' = p i diff --git a/tests/examples/QuasiQuote.hs b/tests/examples/QuasiQuote.hs deleted file mode 100644 --- a/tests/examples/QuasiQuote.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module QuasiQuote where - -import T7918A - -ex1 = [qq|e1|] -ex2 = [qq|e2|] -ex3 = [qq|e3|] -ex4 = [qq|e4|] - -tx1 = undefined :: [qq|t1|] -tx2 = undefined :: [qq|t2|] -tx3 = undefined :: [qq|t3|] -tx4 = undefined :: [qq|t4|] - -px1 [qq|p1|] = undefined -px2 [qq|p2|] = undefined -px3 [qq|p3|] = undefined -px4 [qq|p4|] = undefined - -{-# LANGUAGE QuasiQuotes #-} - -testComplex = assertBool "" ([$istr| - ok -#{Foo 4 "Great!" : [Foo 3 "Scott!"]} - then -|] == ("\n" ++ - " ok\n" ++ - "[Foo 4 \"Great!\",Foo 3 \"Scott!\"]\n" ++ - " then\n")) - diff --git a/tests/examples/RSA.hs b/tests/examples/RSA.hs deleted file mode 100644 --- a/tests/examples/RSA.hs +++ /dev/null @@ -1,19 +0,0 @@ -import Data.Char -e=181021504832735228091659724090293195791121747536890433 - -u(f,m)x=i(m(x), [],let(a,b)=f(x) in(a:u(f,m)b)) -(v,h)=(foldr(\x(y )->00+128*y+x)0,u( sp(25),((==)""))) -p::(Integer,Integer )->Integer -> Integer --NotInt -p(n,m)x =i(n==0 ,1,i(z n ,q(n,m)x, r(n,m)x)) -i(n,e,d )=if(n) then(e) else (d) --23+3d4f -(g,main ,s,un)= (\x->x, y(j),\x->x*x,unlines)--) -j(o)=i(take(2)o== "e=","e="++t (drop(4-2)o),i(d>e,k,l)o) -l=un.map (show.p (e,n).v.map( fromIntegral{-g-}.ord)).h -k=co.map(map(chr .fromIntegral ).w.p(d,n). read).lines -(t,y)=(\ (o:q)-> i(o=='-' ,'1','-' ): q,interact) -q(n,m)x= mod(s( p( div(n)2, m{-jl-})x) )m--hd&&gdb -(r,z,co) =(\(n, m)x->mod(x*p(n-1, m)x)m,even ,concat)--6 -(w,sp)=( u(\x->( mod(x)128,div(x )128),(==0 )),splitAt) - -d=563347325936+1197371806136556985877790097-563347325936 -n=351189532146914946493104395525009571831256157560461451 diff --git a/tests/examples/RankNTypes.hs b/tests/examples/RankNTypes.hs deleted file mode 100644 --- a/tests/examples/RankNTypes.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} - --- from https://ocharles.org.uk/blog/guest-posts/2014-12-18-rank-n-types.html - -import System.Random -import Control.Monad.State -import Data.Char - - -id' :: forall a. a -> a -id' x = x - -f = print (id' (3 :: Integer), - id' "blah") - --- rank 2 polymorphism -type IdFunc = forall a. a -> a - -id'' :: IdFunc -id'' x = x - -someInt :: IdFunc -> Integer -someInt id' = id' 3 - --- rank 3 polymorphism -type SomeInt = IdFunc -> Integer - -someOtherInt :: SomeInt -> Integer -someOtherInt someInt' = - someInt' id + someInt' id - --- random numbers - -data Player = - Player { - playerName :: String, - playerPos :: (Double, Double) - } - deriving (Eq, Ord, Show) - - -{- -randomPlayer - :: (MonadIO m, MonadState g m, RandomGen g) - => m Player --} - -type GenAction m = forall a. (Random a) => m a - -type GenActionR m = forall a. (Random a) => (a, a) -> m a - --- genRandom :: (RandomGen g) => GenAction (State g) --- genRandom = state random - -genRandomR :: (RandomGen g) => GenActionR (State g) -genRandomR range = state (randomR range) - -genRandom :: (Random a, RandomGen g) => State g a -genRandom = state random - - -randomPlayer :: (MonadIO m) => GenActionR m -> m Player -randomPlayer genR = do - liftIO (putStrLn "Generating random player...") - - len <- genR (8, 12) - name <- replicateM len (genR ('a', 'z')) - x <- genR (-100, 100) - y <- genR (-100, 100) - - liftIO (putStrLn "Done.") - return (Player name (x, y)) - -main :: IO () -main = randomPlayer randomRIO >>= print - --- scott encoding - -data List a - = Cons a (List a) - | Nil - -uncons :: (a -> List a -> r) -> r -> List a -> r -uncons co ni (Cons x xs) = co x xs -uncons co ni Nil = ni - -listNull :: List a -> Bool -listNull = uncons (\_ _ -> False) True - -listMap :: (a -> b) -> List a -> List b -listMap f = - uncons (\x xs -> Cons (f x) (listMap f xs)) - Nil - -newtype ListS a = - ListS { - unconsS :: forall r. (a -> ListS a -> r) -> r -> r - } - -nilS :: ListS a -nilS = ListS (\co ni -> ni) - -consS :: a -> ListS a -> ListS a -consS x xs = ListS (\co ni -> co x xs) - -unconsS' :: (a -> ListS a -> r) -> r -> ListS a -> r -unconsS' co ni (ListS f) = f co ni - -instance Functor ListS where - fmap f = - unconsS' (\x xs -> consS (f x) (fmap f xs)) - nilS - --- Church Encoding -newtype ListC a = - ListC { - foldC :: forall r. (a -> r -> r) -> r -> r - } - -foldC' :: (a -> r -> r) -> r -> ListC a -> r -foldC' co ni (ListC f) = f co ni - -instance Functor ListC where - fmap f = foldC' (\x xs -> consC (f x) xs) nilC - -consC = undefined -nilC = undefined - --- GADTs and continuation passing style -data Some :: * -> * where - SomeInt :: Int -> Some Int - SomeChar :: Char -> Some Char - Anything :: a -> Some a - - -unSome :: Some a -> a -unSome (SomeInt x) = x + 3 -unSome (SomeChar c) = toLower c -unSome (Anything x) = x - - -newtype SomeC a = - SomeC { - runSomeC :: - forall r. - ((a ~ Int) => Int -> r) -> - ((a ~ Char) => Char -> r) -> - (a -> r) -> - r - } - --- dependent types - -idk :: forall (a :: *). a -> a -idk x = x - diff --git a/tests/examples/RdrNames.hs b/tests/examples/RdrNames.hs deleted file mode 100644 --- a/tests/examples/RdrNames.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples #-} -module RdrNames where - -import Data.Monoid - --- --------------------------------------------------------------------- - --- | 'type' qcname {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2))) --- [mj AnnType $1,mj AnnVal $2] } - --- Tested in DataFamilies.hs - --- --------------------------------------------------------------------- - --- | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) --- [mo $1,mj AnnVal $2,mc $3] } -ff = (RdrNames.:::) 0 1 - - --- --------------------------------------------------------------------- - --- | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) --- [mo $1,mj AnnVal $2,mc $3] } -data FF = ( ::: ) Int Int - --- --------------------------------------------------------------------- - --- | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) --- [mj AnnBackquote $1,mj AnnVal $2 --- ,mj AnnBackquote $3] } -data GG = GG Int Int -gg = 0 ` GG ` 1 - --- --------------------------------------------------------------------- - --- | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) --- [mj AnnBackquote $1,mj AnnVal $2 --- ,mj AnnBackquote $3] } -vv = "a" ` mappend ` "b" - --- --------------------------------------------------------------------- - --- | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) --- [mj AnnBackquote $1,mj AnnVal $2 --- ,mj AnnBackquote $3] } -vvq = "a" ` Data.Monoid.mappend ` "b" - --- --------------------------------------------------------------------- - --- | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) --- [mo $1,mc $2] } --- Tested in Vect.hs - --- --------------------------------------------------------------------- - --- | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) --- [mo $1,mc $2] } --- Tested in Vect.hs - --- --------------------------------------------------------------------- - --- | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple --- (snd $2 + 1))) --- (mo $1:mc $3:(mcommas (fst $2))) } -ng :: (, , ,) Int Int Int Int -ng = undefined - --- --------------------------------------------------------------------- - --- | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple --- (snd $2 + 1))) --- (mo $1:mc $3:(mcommas (fst $2))) } --- Tested in Unboxed.hs - --- --------------------------------------------------------------------- - --- | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) --- [mo $1,mj AnnRarrow $2,mc $3] } - -ft :: (->) a b -ft = undefined - -fp :: ( -> ) a b -fp = undefined - -type family F a :: * -> * -> * -type instance F Int = (->) -type instance F Char = ( , ) - --- --------------------------------------------------------------------- - --- | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mo $1,mc $2] } -lt :: [] a -lt = undefined - --- --------------------------------------------------------------------- - --- | '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] } - --- GHC source indicates this constuctor is only available in PrelPArr --- ltp :: [::] a --- ltp = undefined - --- --------------------------------------------------------------------- - --- | '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon) --- [mo $1,mj AnnTildehsh $2,mc $3] } - --- primitive type? --- Refl Int :: ~# * Int Int --- Refl Maybe :: ~# (* -> *) Maybe Maybe - --- | A data constructor used to box up all unlifted equalities --- --- The type constructor is special in that GHC pretends that it --- has kind (? -> ? -> Fact) rather than (* -> * -> *) -data (~) a b = Eq# ((~#) a b) - -data Coercible a b = MkCoercible ((~#) a b) - - --- --------------------------------------------------------------------- - --- | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) --- [mo $1,mj AnnVal $2,mc $3] } --- TBD - --- --------------------------------------------------------------------- - --- | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) --- [mo $1,mj AnnTilde $2,mc $3] } - --- --------------------------------------------------------------------- - --- tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) --- [mj AnnBackquote $1,mj AnnVal $2 --- ,mj AnnBackquote $3] } - --- --------------------------------------------------------------------- - - - diff --git a/tests/examples/RebindableSyntax.hs b/tests/examples/RebindableSyntax.hs deleted file mode 100644 --- a/tests/examples/RebindableSyntax.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE RebindableSyntax, NoMonomorphismRestriction #-} - --- From https://ocharles.org.uk/blog/guest-posts/2014-12-06-rebindable-syntax.html - -import Prelude hiding ((>>), (>>=), return) -import Data.Monoid -import Control.Monad ((<=<)) -import Data.Map as M - -addNumbers = do - 80 - 60 - 10 - where (>>) = (+) - return = return - -(>>) = mappend -return = mempty - --- We can perform the same computation as above using the Sum wrapper: - -someSum :: Sum Int -someSum = do - Sum 80 - Sum 60 - Sum 10 - return - -someProduct :: Product Int -someProduct = do - Product 10 - Product 30 - --- Why not try something non-numeric? - -tummyMuscle :: String -tummyMuscle = do - "a" - "b" - - -ff = let - (>>) = flip (.) - return = id - - arithmetic = do - (+1) - (*100) - (/300) - return - - -- Here, the input is numeric and all functions operate on a number. - -- What if we want to take a list and output a string? No problem: - - check = do - sum - sqrt - floor - show - in 4 diff --git a/tests/examples/RecordSemi.hs b/tests/examples/RecordSemi.hs deleted file mode 100644 --- a/tests/examples/RecordSemi.hs +++ /dev/null @@ -1,15 +0,0 @@ --- | Generate a generate statement for the builtin function "fst" -genFst :: BuiltinBuilder -genFst = genNoInsts genFst' -genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm] -genFst' res f args@[(arg,argType)] = do { - ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType - ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg] - ; let { - ; labels = getFieldLabels arg_htype 0 - ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0) - ; assign = mkUncondAssign res argexprA - } ; - -- Return the generate functions - ; return [assign] - } diff --git a/tests/examples/RecordUpdate.hs b/tests/examples/RecordUpdate.hs deleted file mode 100644 --- a/tests/examples/RecordUpdate.hs +++ /dev/null @@ -1,6 +0,0 @@ - -data Foo = F { f1 :: Int, f2 :: String } - -foo :: Int -> Foo -> Foo -foo v f = f { f1 = v } - diff --git a/tests/examples/RecordWildcard.hs b/tests/examples/RecordWildcard.hs deleted file mode 100644 --- a/tests/examples/RecordWildcard.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - - -parseArgs = - Args - { equalProb = E `elem` opts - , .. - } diff --git a/tests/examples/RecursiveDo.hs b/tests/examples/RecursiveDo.hs deleted file mode 100644 --- a/tests/examples/RecursiveDo.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} --- From https://ocharles.org.uk/blog/posts/2014-12-09-recursive-do.html - -import Control.Monad.Fix - -data RoseTree a = RoseTree a [RoseTree a] - deriving (Show) - -exampleTree :: RoseTree Int -exampleTree = RoseTree 5 [RoseTree 4 [], RoseTree 6 []] - -pureMax :: Ord a => RoseTree a -> RoseTree (a, a) -pureMax tree = - let (t, largest) = go largest tree - in t - where - go :: Ord a => a -> RoseTree a -> (RoseTree (a, a), a) - go biggest (RoseTree x []) = (RoseTree (x, biggest) [], x) - go biggest (RoseTree x xs) = - let sub = map (go biggest) xs - (xs', largests) = unzip sub - in (RoseTree (x, biggest) xs', max x (maximum largests)) - -t = pureMax exampleTree - --- --------------------------------------------------------------------- - -impureMin :: (MonadFix m, Ord b) => (a -> m b) -> RoseTree a -> m (RoseTree (a, b)) -impureMin f tree = do - rec (t, largest) <- go largest tree - return t - where - go smallest (RoseTree x []) = do - b <- f x - return (RoseTree (x, smallest) [], b) - - go smallest (RoseTree x xs) = do - sub <- mapM (go smallest) xs - b <- f x - let (xs', bs) = unzip sub - return (RoseTree (x, smallest) xs', min b (minimum bs)) - -budget :: String -> IO Int -budget "Ada" = return 10 -- A struggling startup programmer -budget "Curry" = return 50 -- A big-earner in finance -budget "Dijkstra" = return 20 -- Teaching is the real reward -budget "Howard" = return 5 -- An frugile undergraduate! - -inviteTree = RoseTree "Ada" [ RoseTree "Dijkstra" [] - , RoseTree "Curry" [ RoseTree "Howard" []] - ] - -ti = impureMin budget inviteTree - -simplemdo = mdo - return 5 - diff --git a/tests/examples/RedundantDo.hs b/tests/examples/RedundantDo.hs deleted file mode 100644 --- a/tests/examples/RedundantDo.hs +++ /dev/null @@ -1,4 +0,0 @@ -foo = - case x of - True -> foo - False -> foo diff --git a/tests/examples/Remorse.hs b/tests/examples/Remorse.hs deleted file mode 100644 --- a/tests/examples/Remorse.hs +++ /dev/null @@ -1,88 +0,0 @@ -import Prelude as P;import Data.Char as C;import Data.List;import System.Environment as S; -main = do - (.--.)<-(--.|.--.+);(.-)<-(--.|.-+) - case (.-) of ["+",(.-)]->(-|---|--+) (.-);["-",(.-)]->(..-.|.-.|--+) (.-);_->(.|.-.)("Usage: "++(.--.)++" (+/-) F.hs") - where - (-|---|--+) (.-)=do (..-.)<-(.-.|..-.+) (.-);(.--.|...+)(((-.-.|--+) (.--).(--.).(-..-))(..-.)) - (..-.|.-.|--+) (.-)=do (..-.)<-(.-.|..-.+) (.-);(.--.|...+)(((-.-.|--+) (.--|=).(--.|=).(-..-))(..-.)) - --- | (--| ): (-.-.|---|-.|...-|.|.-.|-) (-.-.|....|.-|.-.) -> (--|---|.-.|...|.) -_--| 'a'=".-";_--| 'b'="-...";_--| 'c'="-.-.";_--| 'd'= "-..";_--| 'e'="."; -_--| 'f'="..-.";_--| 'g'="--.";_--| 'h'="....";_--| 'i'="..";_--| 'j'=".---"; -_--| 'k'="-.-";_--| 'l'=".-..";_--| 'm'="--";_--| 'n'="-.";_--| 'o'="---"; -_--| 'p'=".--.";_--| 'q'="--.-";_--| 'r'=".-.";_--| 's'="...";_--| 't'="-"; -_--| 'u'="..-";_--| 'v'="...-";_--| 'w'=".--";_--| 'x'="-..-";_--| 'y'="-.--"; -_--| 'z'="--..";_--| '0'="-----";_--| '1'=".----";_--| '2'="..---"; -_--| '3'="...--";_--| '4'="....-";_--| '5'=".....";_--| '6'="-...."; -_--| '7'="--...";_--| '8'="---..";_--| '9'="----.";_--| '_'="!";_--| '\''="="; -_--| (-.-.) - |'A'<=(-.-.)&&(-.-.)<='Z'=(()--| (-|.-..+) (-.-.))++"+" - |(-..|.|..-.)=[(-.-.)] - --- | (--|=): (..|-.|...-) of (--| ) -(--|=) (...)=(..-.)[(-.-.)|(-.-.)<-['a'..'z']++['0'..'9']++['A'..'Z']++['_','\''],()--| (-.-.)==(...)] - where (..-.)[]=(....|-..) (...);(..-.) (-.-.|...)=(....|-..) (-.-.|...) - --- | (.--): (-.-.|---|-.|...-|.|.-.|-) (.--|---|.-.|-..) -(.--) (...) - |(...).|.-..["e","i","m","o","t"]=(.--)((...)++" ") -- (...|---|--|.) (..-|-.|-|..|-..|-.--) (.|-..-|-.-.|.|.--.|-|..|---|-.|...): - -- .=(-.-.|---|--|.--.|---|...|..|-|..|---|-.), ..=(-.|..-|--|.|.-.|..|-.-.) (.-.|.-|-.|--.|.), --/---=(.|-.|-..)-of-(.-..|..|-.|.) (-.-.|---|--|--|.|-.|-), -=(...|..-|-...|-|.-.|.-|-.-.|-|..|---|-.) - |(...).|.-..(-.-|.|-.--|...)=(...) - |(..|-..) (...)=(('(':).(++")").(-.-.|-.-.).(..|.--.) "|".(--|.--.)((--| )()))(...) - |(..|-.|..-.|-..-) (...)=((-|.-..).(..|-).(.--).(-|.-..).(..|-))(...) - |(-..|.|..-.)=(...) - where - (..|-..)((-..-):_)=(..|.-..+) (-..-)||(-..-)=='_' - (..|-.|..-.|-..-)((-..-):_)=(-..-)=='`' - --- | (.--|=): do (..|-.|...-) of (.--) -(.--|=) (...) - |(...)=="|"="|" - |(..|-..) (...)=((--|.--.) (--|=).(-.-.|....|.-.|...).(-|.-..).(..|-))(...) - |(---|-.|.) (...)='`':((--|=).(..|-))(...):"`" - |(..|-.|..-.|-..-) (...)='`':((--|.--.) (--|=).(-.-.|....|.-.|...))(...)++"`" - |(-..|.|..-.)=(...) - where - (..|-..)('(':(....):(-| ))=(.--.|.-.|.) (....)&&(.-..|.-) (-| )==')'&&(.-|.-..)(??)((..|-) (-| )) - (..|-..) _=False - (.--.|.-.|.) (-.-.)=(-.-.).|.-..".-" - (..|-.|..-.|-..-) (...)=(.--.|.-.|.) ((....|-..) (...))&&(.-|.-..)(??)((-|.-..) (...))&&(.-|-.)(=='|')(...) - (---|-.|.) (...)=(.-|.-..) (.--.|.-.|.) ((..|-) (...))&&(.-..|.-) (...)=='|' - (-.-.|....|.-.|...) (...)=case (-..|.--+)(=='|')(...) of []->[];(...)->let ((.--),(...|...))=(-...|.-.)(=='|')(...) in (.--):(-.-.|....|.-.|...) (...|...) - --- | (.--.|.-.|.|-..) (---|-.) (-.-.|....|.-|.-.|...) -(??)(-.-.)=(-.-.).|.-..".-+/=!|" - --- | (.-..|.|-..-) (...|.-.|-.-.) -> (-|---|-.-) (...|-|.-.|.|.-|--) -(-..-)[]=[] -(-..-)((-.-.):(...))|(..|...+) (-.-.)=((-.-.):(...|...)):(-..-) (.-.|--) where ((...|...),(.-.|--))=(...|.--.) (..|...+) (...) -(-..-) (...)=(-|---|-.-):(-..-) (.-.|--) where ((-|---|-.-),(.-.|--))=(....|-..)((.--.|.-..|.|-..-) (...)) - --- | (--.): (--.|.-..|..-|.) (...|.|--.-) (-|---|-.-|...) -> (...|..|-.|--.|.-..|.) (-|---|-.-) -(--.)((--.-):".":(-.):(.-.|--))|(..|..-+)((....|-..) (--.-))=(--.)(((--.-)++"."++(-.)):(.-.|--)) -(--.)("`":(.-.|--))=case (--.) (.-.|--) of ((--.-|-.):"`":(.-.|--))->("`"++(--.-|-.)++"`"):(--.) (.-.|--);_->("`":(.-.|--)) -(--.)((...):(...|...))=(...):(--.) (...|...) -(--.)[]=[] - --- | (--.|=): (.-..|..|-.-|.) (--.) in (.-.|.|...-) -(--.|=)("(":(-.):")":(.-.|--))|(.-|.-..)(??)(-.)=("("++(-.)++")"):(--.|=) (.-.|--) -(--.|=)("(":(-.):" ":")":(.-.|--))|(.-|.-..)(??)(-.)=("("++(-.)++")"):(--.|=) (.-.|--) -(--.|=)("|":(.-.|--))="|":(--.|=) (.-.|--) -(--.|=)((-.):(...|...):(.-.|--))|(.-|.-..)(.|.-..".-")((..|-) (-.))&&(.-..|.-) (-.)=='|'&&(.-|.-..) (..|...+) (...|...)=(-.):(--.|=) (.-.|--) -(--.|=)((-.):(.-.|--))=(-.):(--.|=) (.-.|--) -(--.|=)[]=[] - --- | (....|.-|...|-.-|.|.-..|.-..) (-.-|.|-.--|.--|---|.-.|-..|...) -(-.-|.|-.--|...)= - ["case","class","data","default","deriving","do","else" - ,"if","import","in","infix","infixl","infixr","instance","let","module" - ,"newtype","of","then","type","where","_","main","foreign","ccall","as"] - --- | (.-|-...|-...|.-.|.|...-) (.-..|..|-...) (..-.|-.|...) -(-.-.|-.-.)=P.concat;(.|.-..) (-..-)=P.elem (-..-);(--|.--.)=P.map;(-.-.|--+)=P.concatMap; -(...|.--.)=P.span;(-...|.-.)=P.break;(..|.--.)=intersperse;(-..|.--+)=P.dropWhile; -(....|-..)=P.head;(-|.-..)=P.tail;(..|-)=P.init;(.-..|.-)=P.last; -(-|.-..+)=C.toLower;(..|.-..+)=C.isLower;(..|...+)=C.isSpace;(..|..-+)=C.isUpper; -(.-.|..-.+)=P.readFile;(.--.|...+)=P.putStr;(.|.-.)=P.error; -(--.|.-+)=S.getArgs;(--.|.--.+)=S.getProgName; -(.-|.-..)=P.all;(.-|-.)=P.any;(-..|.|..-.)=P.otherwise;(.--.|.-..|.|-..-)=P.lex; diff --git a/tests/examples/Rename1.hs b/tests/examples/Rename1.hs deleted file mode 100644 --- a/tests/examples/Rename1.hs +++ /dev/null @@ -1,6 +0,0 @@ - - -foo x y = - do c <- getChar - return c - diff --git a/tests/examples/Rename1.hs.expected b/tests/examples/Rename1.hs.expected deleted file mode 100644 --- a/tests/examples/Rename1.hs.expected +++ /dev/null @@ -1,6 +0,0 @@ - - -bar2 x y = - do c <- getChar - return c - diff --git a/tests/examples/Rename2.hs b/tests/examples/Rename2.hs deleted file mode 100644 --- a/tests/examples/Rename2.hs +++ /dev/null @@ -1,4 +0,0 @@ - -foo' x = case (odd x) of - True -> "Odd" - False -> "Even" diff --git a/tests/examples/Rename2.hs.expected b/tests/examples/Rename2.hs.expected deleted file mode 100644 --- a/tests/examples/Rename2.hs.expected +++ /dev/null @@ -1,4 +0,0 @@ - -joe x = case (odd x) of - True -> "Odd" - False -> "Even" diff --git a/tests/examples/RmDecl1.hs b/tests/examples/RmDecl1.hs deleted file mode 100644 --- a/tests/examples/RmDecl1.hs +++ /dev/null @@ -1,12 +0,0 @@ -module RmDecl1 where - -sumSquares x = x * p - where p=2 {-There is a comment-} - -sq :: Int -> Int -> Int -sq pow 0 = 0 -sq pow z = z^pow --there is a comment - -{- foo bar -} -anotherFun 0 y = sq y - where sq x = x^2 diff --git a/tests/examples/RmDecl1.hs.expected b/tests/examples/RmDecl1.hs.expected deleted file mode 100644 --- a/tests/examples/RmDecl1.hs.expected +++ /dev/null @@ -1,8 +0,0 @@ -module RmDecl1 where - -sumSquares x = x * p - where p=2 {-There is a comment-} - -{- foo bar -} -anotherFun 0 y = sq y - where sq x = x^2 diff --git a/tests/examples/RmDecl2.hs b/tests/examples/RmDecl2.hs deleted file mode 100644 --- a/tests/examples/RmDecl2.hs +++ /dev/null @@ -1,10 +0,0 @@ -module RmDecl2 where - -sumSquares x y = let sq 0=0 - sq z=z^pow - pow=2 - in sq x + sq y - -anotherFun 0 y = sq y - where sq x = x^2 - diff --git a/tests/examples/RmDecl2.hs.expected b/tests/examples/RmDecl2.hs.expected deleted file mode 100644 --- a/tests/examples/RmDecl2.hs.expected +++ /dev/null @@ -1,9 +0,0 @@ -module RmDecl2 where - -sumSquares x y = let sq 0=0 - sq z=z^pow - in sq x + sq y - -anotherFun 0 y = sq y - where sq x = x^2 - diff --git a/tests/examples/RmDecl3.hs b/tests/examples/RmDecl3.hs deleted file mode 100644 --- a/tests/examples/RmDecl3.hs +++ /dev/null @@ -1,9 +0,0 @@ -module RmDecl3 where - --- Remove last declaration from a where clause, where should disappear too -ff y = y + zz - where - zz = 1 - -foo = 3 --- EOF diff --git a/tests/examples/RmDecl3.hs.expected b/tests/examples/RmDecl3.hs.expected deleted file mode 100644 --- a/tests/examples/RmDecl3.hs.expected +++ /dev/null @@ -1,9 +0,0 @@ -module RmDecl3 where - --- Remove last declaration from a where clause, where should disappear too -ff y = y + zz - -zz = 1 - -foo = 3 --- EOF diff --git a/tests/examples/RmDecl4.hs b/tests/examples/RmDecl4.hs deleted file mode 100644 --- a/tests/examples/RmDecl4.hs +++ /dev/null @@ -1,9 +0,0 @@ -module RmDecl4 where - --- Remove first declaration from a where clause, last should still be indented -ff y = y + zz + xx - where - zz = 1 - xx = 2 - --- EOF diff --git a/tests/examples/RmDecl4.hs.expected b/tests/examples/RmDecl4.hs.expected deleted file mode 100644 --- a/tests/examples/RmDecl4.hs.expected +++ /dev/null @@ -1,10 +0,0 @@ -module RmDecl4 where - --- Remove first declaration from a where clause, last should still be indented -ff y = y + zz + xx - where - xx = 2 - -zz = 1 - --- EOF diff --git a/tests/examples/RmDecl5.hs b/tests/examples/RmDecl5.hs deleted file mode 100644 --- a/tests/examples/RmDecl5.hs +++ /dev/null @@ -1,6 +0,0 @@ -module RmDecl5 where - -sumSquares x y = let sq 0=0 - sq z=z^pow - pow=2 - in sq x + sq y diff --git a/tests/examples/RmDecl5.hs.expected b/tests/examples/RmDecl5.hs.expected deleted file mode 100644 --- a/tests/examples/RmDecl5.hs.expected +++ /dev/null @@ -1,4 +0,0 @@ -module RmDecl5 where - -sumSquares x y = let pow=2 - in sq x + sq y diff --git a/tests/examples/RmDecl6.hs b/tests/examples/RmDecl6.hs deleted file mode 100644 --- a/tests/examples/RmDecl6.hs +++ /dev/null @@ -1,11 +0,0 @@ -module RmDecl6 where - -foo a = baz - where - baz :: Int - baz = x + a - - x = 1 - - y :: Int -> Int -> Int - y a b = undefined diff --git a/tests/examples/RmDecl6.hs.expected b/tests/examples/RmDecl6.hs.expected deleted file mode 100644 --- a/tests/examples/RmDecl6.hs.expected +++ /dev/null @@ -1,8 +0,0 @@ -module RmDecl6 where - -foo a = baz - where - x = 1 - - y :: Int -> Int -> Int - y a b = undefined diff --git a/tests/examples/RmDecl7.hs b/tests/examples/RmDecl7.hs deleted file mode 100644 --- a/tests/examples/RmDecl7.hs +++ /dev/null @@ -1,8 +0,0 @@ -module RmDecl7 where - -toplevel :: Integer -> Integer -toplevel x = c * x - --- c,d :: Integer -c = 7 -d = 9 diff --git a/tests/examples/RmDecl7.hs.expected b/tests/examples/RmDecl7.hs.expected deleted file mode 100644 --- a/tests/examples/RmDecl7.hs.expected +++ /dev/null @@ -1,6 +0,0 @@ -module RmDecl7 where - -toplevel :: Integer -> Integer -toplevel x = c * x - -d = 9 diff --git a/tests/examples/RmTypeSig1.hs b/tests/examples/RmTypeSig1.hs deleted file mode 100644 --- a/tests/examples/RmTypeSig1.hs +++ /dev/null @@ -1,7 +0,0 @@ -module RmTypeSig1 where - -sq,anotherFun :: Int -> Int -sq 0 = 0 -sq z = z^2 - -anotherFun x = x^2 diff --git a/tests/examples/RmTypeSig1.hs.expected b/tests/examples/RmTypeSig1.hs.expected deleted file mode 100644 --- a/tests/examples/RmTypeSig1.hs.expected +++ /dev/null @@ -1,7 +0,0 @@ -module RmTypeSig1 where - -anotherFun :: Int -> Int -sq 0 = 0 -sq z = z^2 - -anotherFun x = x^2 diff --git a/tests/examples/RmTypeSig2.hs b/tests/examples/RmTypeSig2.hs deleted file mode 100644 --- a/tests/examples/RmTypeSig2.hs +++ /dev/null @@ -1,7 +0,0 @@ -module RmTypeSig2 where - --- Pattern bind -tup@(h,t) = (1,ff) - where - ff :: Int - ff = 15 diff --git a/tests/examples/RmTypeSig2.hs.expected b/tests/examples/RmTypeSig2.hs.expected deleted file mode 100644 --- a/tests/examples/RmTypeSig2.hs.expected +++ /dev/null @@ -1,6 +0,0 @@ -module RmTypeSig2 where - --- Pattern bind -tup@(h,t) = (1,ff) - where - ff = 15 diff --git a/tests/examples/Roles.hs b/tests/examples/Roles.hs deleted file mode 100644 --- a/tests/examples/Roles.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE RoleAnnotations, PolyKinds #-} - -module Roles where - -data T1 a = K1 a -data T2 a = K2 a -data T3 (a :: k) = K3 -data T4 (a :: * -> *) b = K4 (a b) - -data T5 a = K5 a -data T6 a = K6 -data T7 a b = K7 b - -type role T1 nominal -type role T2 representational -type role T3 phantom -type role T4 nominal _ -type role T5 _ diff --git a/tests/examples/Rules.hs b/tests/examples/Rules.hs deleted file mode 100644 --- a/tests/examples/Rules.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Rules where - -import Data.Char - -{-# RULES "map-loop" [ ~ ] forall f . map' f = map' (id . f) #-} - -{-# NOINLINE map' #-} -map' f [] = [] -map' f (x:xs) = f x : map' f xs - -main = print (map' toUpper "Hello, World") - --- Should warn -foo1 x = x -{-# RULES "foo1" [ 1] forall x. foo1 x = x #-} - --- Should warn -foo2 x = x -{-# INLINE foo2 #-} -{-# RULES "foo2" [~ 1 ] forall x. foo2 x = x #-} - --- Should not warn -foo3 x = x -{-# NOINLINE foo3 #-} -{-# RULES "foo3" forall x. foo3 x = x #-} - -{-# NOINLINE f #-} -f :: Int -> String -f x = "NOT FIRED" - -{-# NOINLINE neg #-} -neg :: Int -> Int -neg = negate - -{-# RULES - "f" forall (c::Char->Int) (x::Char). f (c x) = "RULE FIRED" - #-} - - diff --git a/tests/examples/RulesSemi.hs b/tests/examples/RulesSemi.hs deleted file mode 100644 --- a/tests/examples/RulesSemi.hs +++ /dev/null @@ -1,9 +0,0 @@ - -{-# RULES - "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; - "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x; - "cFloatConv/Float->CFloat" forall (x::Float). cFloatConv x = CFloat x; - "cFloatConv/CFloat->Float" forall (x::Float). cFloatConv CFloat x = x; - "cFloatConv/Double->CDouble" forall (x::Double). cFloatConv x = CDouble x; - "cFloatConv/CDouble->Double" forall (x::Double). cFloatConv CDouble x = x - #-}; diff --git a/tests/examples/ScopedTypeVariables.hs b/tests/examples/ScopedTypeVariables.hs deleted file mode 100644 --- a/tests/examples/ScopedTypeVariables.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- from https://ocharles.org.uk/blog/guest-posts/2014-12-20-scoped-type-variables.html - -import qualified Data.Map as Map - -insertMany :: forall k v . Ord k => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v -insertMany f vs m = foldr f1 m vs - where - f1 :: (k, v) -> Map.Map k v -> Map.Map k v - f1 (k,v) m = Map.insertWith f k v m diff --git a/tests/examples/SemiInstance.hs b/tests/examples/SemiInstance.hs deleted file mode 100644 --- a/tests/examples/SemiInstance.hs +++ /dev/null @@ -1,11 +0,0 @@ - -instance ArrowTransformer (AbortT v) where { - lift = AbortT . (>>> arr Right); - tmap f = AbortT . f . unwrapAbortT; -}; - -instance MakeValueTuple Float where type ValueTuple Float = Value Float ; valueTupleOf = valueOf - -instance Foo where { - type ListElement Zero (a,r) = a; -} diff --git a/tests/examples/SemiWorkout.hs b/tests/examples/SemiWorkout.hs deleted file mode 100644 --- a/tests/examples/SemiWorkout.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE KindSignatures - , GADTs - , ScopedTypeVariables - , PatternSignatures - , MultiParamTypeClasses - , FunctionalDependencies - , FlexibleInstances - , UndecidableInstances - , TypeFamilies - , FlexibleContexts - #-} - -instance forall init prog prog' fromO fromI progOut progIn - sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem - keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem current current' invertedSessionsMe invertedSessionsThem . - ( ProgramToMVarsOutgoingT prog prog ~ progOut - , ProgramToMVarsOutgoingT prog' prog' ~ progIn - , SWellFormedConfig init (D0 E) prog - , SWellFormedConfig init (D0 E) prog' - , TyListIndex progOut init (MVar (ProgramCell (Cell fromO))) - , TyListIndex progIn init (MVar (ProgramCell (Cell fromI))) - , TyListIndex prog init current' - , Expand prog current' current - , MapLookup (TyMap sessionsToIdxMe idxsToPairStructsMe) init - (MVar (Map (RawPid, RawPid) (MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))))) - , TyListMember invertedSessionsThem init True - , MapSize (TyMap keyToIdxMe idxToValueMe) idxOfThem - , MapInsert (TyMap keyToIdxMe idxToValueMe) idxOfThem - (SessionState prog prog' (current, fromO, fromI)) (TyMap keyToIdxMe' idxToValueMe') - ) => - CreateSession False init prog prog' - sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem - keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem invertedSessionsMe invertedSessionsThem where - createSession init FF (Pid remotePid _) = - InterleavedChain $ - \ipid@(IPid (Pid localPid localSTMap) _) mp -> - do { let pidFuncMapMVar :: MVar (Map (RawPid, RawPid) - (MVar (PairStruct init prog prog' - ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))))) - = mapLookup localSTMap init - ; pidFuncMap <- takeMVar pidFuncMapMVar - ; emptyMVar :: MVar (TyMap keyToIdxMe' idxToValueMe') <- newEmptyMVar - ; psMVar :: MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))) - <- case Map.lookup (localPid, remotePid) pidFuncMap of - Nothing - -> do { empty <- newEmptyMVar - ; putMVar pidFuncMapMVar (Map.insert (localPid, remotePid) empty pidFuncMap) - ; return empty - } - (Just mv) - -> do { putMVar pidFuncMapMVar pidFuncMap - ; return mv - } - ; let idxOfThem :: idxOfThem = mapSize mp - ps :: PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)) - = PS localPid (f idxOfThem mp emptyMVar) - ; putMVar psMVar ps - ; mp' <- takeMVar emptyMVar - ; return (idxOfThem, mp', ipid) - } diff --git a/tests/examples/Shebang.hs b/tests/examples/Shebang.hs deleted file mode 100644 --- a/tests/examples/Shebang.hs +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/env runhaskell -{-# LANGUAGE OverloadedStrings #-} -import Aws.SSSP.App - -main = web diff --git a/tests/examples/ShiftingLambda.hs b/tests/examples/ShiftingLambda.hs deleted file mode 100644 --- a/tests/examples/ShiftingLambda.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards #-} -spec :: Spec -spec = do - describe "split4'8" $ do - it "0xabc" $ do - split4'8 0xabc `shouldBe` (0x0a, 0xbc) - it "0xfff" $ do - split4'8 0xfff `shouldBe` (0x0f, 0xff) - - describe "(x, y) = split4'8 z" $ do - prop "x <= 0x0f" $ - \z -> let (x, _) = split4'8 z in x <= 0x0f - prop "x << 8 | y == z" $ do - \z -> let (x, y) = split4'8 z in - fromIntegral x `shiftL` 8 .|. fromIntegral y == z - -match s@Status{ pos, flips, captureAt, captureLen } - | isOne ?pat = ite (pos .>= strLen) __FAIL__ one - | otherwise = ite (pos + (toEnum $ minLen ?pat) .> strLen) __FAIL__ $ case ?pat of - POr ps -> choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps - -foo = 1 diff --git a/tests/examples/Sigs.hs b/tests/examples/Sigs.hs deleted file mode 100644 --- a/tests/examples/Sigs.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Sigs where - --- TypeSig -f :: Num a => a -> a -f = undefined - -pattern Single :: () => (Show a) => a -> [a] -pattern Single x = [x] - -g :: (Show a) => [a] -> a -g (Single x) = x - --- Fixities - -infixr 6 +++ -infixr 7 ***,/// - -(+++) :: Int -> Int -> Int -a +++ b = a + 2*b - -(***) :: Int -> Int -> Int -a *** b = a - 4*b - -(///) :: Int -> Int -> Int -a /// b = 2*a - 3*b - --- Inline signatures - -{-# Inline g #-} -{-# INLINE [~34] f #-} - --- Specialise signature - --- Multiple sigs -x,y,z :: Int -x = 0 -y = 0 -z = 0 diff --git a/tests/examples/Simple.hs b/tests/examples/Simple.hs deleted file mode 100644 --- a/tests/examples/Simple.hs +++ /dev/null @@ -1,4 +0,0 @@ - --- blah -x = 1 - diff --git a/tests/examples/SimpleComplexTuple.hs b/tests/examples/SimpleComplexTuple.hs deleted file mode 100644 --- a/tests/examples/SimpleComplexTuple.hs +++ /dev/null @@ -1,3 +0,0 @@ - - -foo ((-),(.))= (5,6) diff --git a/tests/examples/SimpleDo.hs b/tests/examples/SimpleDo.hs deleted file mode 100644 --- a/tests/examples/SimpleDo.hs +++ /dev/null @@ -1,4 +0,0 @@ - -foo = do - let x = 1 -- a comment - return x diff --git a/tests/examples/SlidingDataClassDecl.hs b/tests/examples/SlidingDataClassDecl.hs deleted file mode 100644 --- a/tests/examples/SlidingDataClassDecl.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - - -instance HasTrie R2Basis where - data R2Basis :->: x = R2Trie x x - trie f = R2Trie (f XB) (f YB) - untrie (R2Trie x _y) XB = x - untrie (R2Trie _x y) YB = y - enumerate (R2Trie x y) = [(XB,x),(YB,y)] diff --git a/tests/examples/SlidingDoClause.hs b/tests/examples/SlidingDoClause.hs deleted file mode 100644 --- a/tests/examples/SlidingDoClause.hs +++ /dev/null @@ -1,13 +0,0 @@ - - --- :bounds narrowing 35 -bndCom tenv args = - do { (bound,size) <- getBounds fail args - ; let get (s,m,ref) = do { n <- readRef ref; return(s++" = "++show n++ m)} - ; if bound == "" - then do { xs <- mapM get boundRef; warnM [Dl xs "\n"]} - else case find (\ (nm,info,ref) -> nm==bound) boundRef of - Just (_,_,ref) -> writeRef ref size - Nothing -> fail ("Unknown bound '"++bound++"'") - ; return tenv - } diff --git a/tests/examples/SlidingLambda.hs b/tests/examples/SlidingLambda.hs deleted file mode 100644 --- a/tests/examples/SlidingLambda.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} - -foo = choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps diff --git a/tests/examples/SlidingListComp.hs b/tests/examples/SlidingListComp.hs deleted file mode 100644 --- a/tests/examples/SlidingListComp.hs +++ /dev/null @@ -1,8 +0,0 @@ - - -foo = - [concatMap (\(n, f) -> [findPath copts v >>= f (listArg "ghc" as) | v <- listArg n as]) [ - ("project", Update.scanProject), - ("file", Update.scanFile), - ("path", Update.scanDirectory)], - map (Update.scanCabal (listArg "ghc" as)) cabals] diff --git a/tests/examples/SlidingRecordSetter.hs b/tests/examples/SlidingRecordSetter.hs deleted file mode 100644 --- a/tests/examples/SlidingRecordSetter.hs +++ /dev/null @@ -1,4 +0,0 @@ - -selfQualify mod rsets = let defs = Set.fromList (map rs_name rsets) - in map (descend (f defs)) - (map (\RS{..} -> RS{rs_name = qualify mod rs_name, ..}) rsets) diff --git a/tests/examples/SlidingTypeSyn.hs b/tests/examples/SlidingTypeSyn.hs deleted file mode 100644 --- a/tests/examples/SlidingTypeSyn.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LiberalTypeSynonyms #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} - - -type ( f :-> g) (r :: * -> *) ix = f r ix -> g r ix - -type ( f :--> g) b ix = f b ix -> g b ix - -type ((f :---> g)) b ix = f b ix -> g b ix diff --git a/tests/examples/SpacesSplice.hs b/tests/examples/SpacesSplice.hs deleted file mode 100644 --- a/tests/examples/SpacesSplice.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -makeLenses '' PostscriptFont diff --git a/tests/examples/Splice.hs b/tests/examples/Splice.hs deleted file mode 100644 --- a/tests/examples/Splice.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE TemplateHaskell, FlexibleInstances, - MultiParamTypeClasses, TypeSynonymInstances #-} - -module Splice where - -import Language.Haskell.TH.Syntax -import Language.Haskell.TH - -foo $( return $ VarP $ mkName "x" ) = x -bar $( [p| x |] ) = x - -baz = [| \ $( return $ VarP $ mkName "x" ) -> $(dyn "x") |] - - -class Eq a => MyClass a -data Foo = Foo deriving Eq - -instance MyClass Foo - -data Bar = Bar - deriving Eq - -type Baz = Bar -instance MyClass Baz - -data Quux a = Quux a deriving Eq -data Quux2 a = Quux2 a deriving Eq -instance Eq a => MyClass (Quux a) -instance Ord a => MyClass (Quux2 a) - -class MyClass2 a b -instance MyClass2 Int Bool - -$(return []) - -main = do - putStrLn $(do { info <- reify ''MyClass; lift (pprint info) }) - print $(isInstance ''Eq [ConT ''Foo] >>= lift) - print $(isInstance ''MyClass [ConT ''Foo] >>= lift) - print $ not $(isInstance ''Show [ConT ''Foo] >>= lift) - print $(isInstance ''MyClass [ConT ''Bar] >>= lift) -- this one - print $(isInstance ''MyClass [ConT ''Baz] >>= lift) - print $(isInstance ''MyClass [AppT (ConT ''Quux) (ConT ''Int)] >>= lift) --this one - print $(isInstance ''MyClass [AppT (ConT ''Quux2) (ConT ''Int)] >>= lift) -- this one - print $(isInstance ''MyClass2 [ConT ''Int, ConT ''Bool] >>= lift) - print $(isInstance ''MyClass2 [ConT ''Bool, ConT ''Bool] >>= lift) - diff --git a/tests/examples/SpliceSemi.hs b/tests/examples/SpliceSemi.hs deleted file mode 100644 --- a/tests/examples/SpliceSemi.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -$(makePredicates ''TheType) ; $(makePredicatesNot ''TheType) diff --git a/tests/examples/StaticPointers.hs b/tests/examples/StaticPointers.hs deleted file mode 100644 --- a/tests/examples/StaticPointers.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE StaticPointers #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} - -module Main where - -import GHC.StaticPtr -import GHC.Word -import GHC.Generics -import Data.Data -import Data.Binary -import Data.ByteString - -fact :: Int -> Int -fact 0 = 1 -fact n = n * fact (n - 1) - -main = do - let sptr :: StaticPtr (Int -> Int) - sptr = static fact - print $ staticPtrInfo sptr - print $ deRefStaticPtr sptr 10 - --- --------------------------------------------------------------------- - -type StaticKey1 = Fingerprint - --- Defined in GHC.Fingerprint. -data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 - deriving (Generic, Typeable) - -staticKey :: StaticPtr a -> StaticKey1 -staticKey = undefined - - diff --git a/tests/examples/Stmts.hs b/tests/examples/Stmts.hs deleted file mode 100644 --- a/tests/examples/Stmts.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Stmts where - --- Make sure we get all the semicolons in statements - -foo :: IO () -foo = do - do { ;;;; a } - a - -bar :: IO () -bar = do - { ; - a ;; - b - } - -baz :: IO () -baz = do { ;; s ; s ; ; s ;; } - -a = undefined -b = undefined -s = undefined diff --git a/tests/examples/StrangeTypeClass.hs b/tests/examples/StrangeTypeClass.hs deleted file mode 100644 --- a/tests/examples/StrangeTypeClass.hs +++ /dev/null @@ -1,18 +0,0 @@ - - - -instance - ( - ) => Elms Z ix where - data Elm Z ix = ElmZ !ix - type Arg Z = Z - getArg !(ElmZ _) = Z - getIdx !(ElmZ ix) = ix - {-# INLINE getArg #-} - {-# INLINE getIdx #-} - -foo :: (Eq a) => a-> Bool -foo = undefined - -bar :: ( ) => a-> Bool -bar = undefined diff --git a/tests/examples/Stream.hs b/tests/examples/Stream.hs deleted file mode 100644 --- a/tests/examples/Stream.hs +++ /dev/null @@ -1,156 +0,0 @@ -module Stream (Stream, carry, addStream, rationalToStream, - streamToFloat, addFiniteStream, negate', average) where - -import Data.Ratio - - -type Digit = Integer -type Stream = [Integer] - - - --- Convert from a Rational fraction to its stream representation -rationalToStream :: Rational -> Stream -rationalToStream x - |t<1 = 0:rationalToStream t - |otherwise = 1:rationalToStream (t-1) - where t = 2*x - - - - --- Convert from a stream to the Float value -streamToFloat :: Stream -> Float -streamToFloat x = f x (1) - -f :: Stream -> Integer -> Float -f [] n = 0 -f (y:ys) n = (fromIntegral)y/(fromIntegral(2^n)) + f ys (n+1) - - - - - --- Add two stream -addStream :: Stream -> Stream -> Stream -addStream (x1:x2:x3:xs) (y1:y2:y3:ys) = (u+c):(addStream (x2:x3:xs) (y2:y3:ys)) - where u = interim x1 x2 y1 y2 - c = carry x2 x3 y2 y3 - - - --- Compute carry, the C(i) value, given x(i) and y(i) -carry :: Digit -> Digit -> Digit -> Digit -> Digit -carry x1 x2 y1 y2 - |t>1 = 1 - |t<(-1) = -1 - |t==1 && (minus1 x2 y2) = 0 - |t==1 && not (minus1 x2 y2) = 1 - |t==(-1) && (minus1 x2 y2) = -1 - |t==(-1) && not (minus1 x2 y2) = 0 - |t==0 = 0 - where t = x1+y1 - - - --- Computer the interim sum, the U(i) value, given x(i), y(i) and c(i) -interim :: Digit -> Digit -> Digit -> Digit -> Digit -interim x1 x2 y1 y2 - |t>1 = 0 - |t<(-1) = 0 - |t==1 && (minus1 x2 y2) = 1 - |t==1 && not (minus1 x2 y2) = -1 - |t==(-1) && (minus1 x2 y2) = 1 - |t==(-1) && not (minus1 x2 y2) = -1 - |t==0 = 0 - where t = x1+y1 - - - --- Check if at least one of 2 digits is -1 -minus1 :: Digit -> Digit -> Bool -minus1 x y = (x==(-1))|| (y==(-1)) - - - - - - --- Algin two stream so that they have the same length -align :: Stream -> Stream -> (Stream, Stream) -align xs ys - |x>y = (xs, (copy 0 (x-y)) ++ys) - |otherwise = ((copy 0 (y-x)) ++ xs, ys) - where x = toInteger(length xs) - y = toInteger(length ys) - - - --- Generate a list of x -copy :: Integer -> Integer -> [Integer] -copy x n = [x| i<- [1..n]] - - - - - - - --- Add two finite stream (to add the integral part) -addFiniteStream :: Stream -> Stream -> Stream -addFiniteStream xs ys = add' u v - where (u,v) = align xs ys - - - --- Utility function for addFinitieStream -add' :: Stream -> Stream -> Stream -add' u v = normalise (f u v) - where f [] [] = [] - f (x:xs) (y:ys) = (x+y):f xs ys - - --- Normalise the sum -normalise :: Stream -> Stream -normalise = foldr f [0] - where f x (y:ys) = (u:v:ys) - where u = (x+y) `div` 2 - v = (x+y) `mod` 2 - - --- Negate a stream -negate' :: Stream -> Stream -negate' = map (*(-1)) - - - --- Compute average of two stream --- Using [-2,-1,0,1,2] to add, and then divide by 2 -average :: Stream -> Stream -> Stream -average xs ys = div2 (add xs ys) - - --- Addition of two streams, using [-2,-1,0,1,2] -add :: Stream -> Stream -> Stream -add (x:xs) (y:ys) = (x+y):(add xs ys) - - --- Then divided by 2, [-2,-1,0,1,2] -> [-1,0,1] -div2 :: Stream -> Stream -div2 (2:xs) = 1:div2 xs -div2 ((-2):xs) = (-1):div2 xs -div2 (0:xs) = 0:div2 xs -div2 (1:(-2):xs) = div2 (0:0:xs) -div2 (1:(-1):xs) = div2 (0:1:xs) -div2 (1:0:xs) = div2 (0:2:xs) -div2 (1:1:xs) = div2 (2:(-1):xs) -div2 (1:2:xs) = div2 (2:0:xs) -div2 ((-1):(-2):xs) = div2 ((-2):0:xs) -div2 ((-1):(-1):xs) = div2 ((-2):1:xs) -div2 ((-1):0:xs) = div2 (0:(-2):xs) -div2 ((-1):1:xs) = div2 (0:(-1):xs) -div2 ((-1):2:xs) = div2 (0:0:xs) - - - -test = take 100 (average (rationalToStream (1%2)) (rationalToStream (1%3))) diff --git a/tests/examples/StrictLet.hs b/tests/examples/StrictLet.hs deleted file mode 100644 --- a/tests/examples/StrictLet.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE MagicHash #-} - -{- -If the (unboxed, hence strict) "let thunk =" would survive to the CallArity -stage, it might yield wrong results (eta-expanding thunk and hence "cond" would -be called multiple times). - -It does not actually happen (CallArity sees a "case"), so this test just -safe-guards against future changes here. --} - -import Debug.Trace -import GHC.Exts -import System.Environment - -cond :: Int# -> Bool -cond x = trace ("cond called with " ++ show (I# x)) True -{-# NOINLINE cond #-} - - -bar (I# x) = - let go n = let x = thunk n - in case n of - 100# -> I# x - _ -> go (n +# 1#) - in go x - where thunk = if cond x then \x -> (x +# 1#) else \x -> (x -# 1#) - - -main = do - args <- getArgs - bar (length args) `seq` return () diff --git a/tests/examples/StringGap.hs b/tests/examples/StringGap.hs deleted file mode 100644 --- a/tests/examples/StringGap.hs +++ /dev/null @@ -1,8 +0,0 @@ -module StringGap where - --- based on https://www.reddit.com/r/haskelltil/comments/3duhdf/haskell_ignores_all_whitespace_enclosed_in/ - -foo = "lorem ipsum \ - \dolor sit amet" - -bar = "lorem ipsum \ \dolor sit amet" diff --git a/tests/examples/T10196.hs b/tests/examples/T10196.hs deleted file mode 100644 --- a/tests/examples/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/T2388.hs b/tests/examples/T2388.hs deleted file mode 100644 --- a/tests/examples/T2388.hs +++ /dev/null @@ -1,14 +0,0 @@ -module T2388 where - -import Data.Bits -import Data.Word -import Data.Int - -test1 :: Word32 -> Char -test1 w | w .&. 0x80000000 /= 0 = 'a' -test1 _ = 'b' - --- this should use a testq instruction on x86_64 -test2 :: Int64 -> Char -test2 w | w .&. (-3) /= 0 = 'a' -test2 _ = 'b' diff --git a/tests/examples/T3132.hs b/tests/examples/T3132.hs deleted file mode 100644 --- a/tests/examples/T3132.hs +++ /dev/null @@ -1,6 +0,0 @@ -module T3132 where - -import Data.Array.Unboxed - -step :: UArray Int Double -> [Double] -step y = [y!1 + y!0] diff --git a/tests/examples/T5951.hs b/tests/examples/T5951.hs deleted file mode 100644 --- a/tests/examples/T5951.hs +++ /dev/null @@ -1,11 +0,0 @@ -module T5951 where - -class A a -class B b -class C c - -instance - A => - B => - C where - foo = undefined diff --git a/tests/examples/T7918A.hs b/tests/examples/T7918A.hs deleted file mode 100644 --- a/tests/examples/T7918A.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module T7918A where - -import Language.Haskell.TH -import Language.Haskell.TH.Quote - -qq = QuasiQuoter { - quoteExp = \str -> case str of - "e1" -> [| True |] - "e2" -> [| id True |] - "e3" -> [| True || False |] - "e4" -> [| False |] - , quoteType = \str -> case str of - "t1" -> [t| Bool |] - "t2" -> [t| Maybe Bool |] - "t3" -> [t| Either Bool Int |] - "t4" -> [t| Int |] - , quotePat = let x = VarP (mkName "x") - y = VarP (mkName "y") - in \str -> case str of - "p1" -> return $ x - "p2" -> return $ ConP 'Just [x] - "p3" -> return $ TupP [x, y] - "p4" -> return $ y - , quoteDec = undefined - } diff --git a/tests/examples/TH.hs b/tests/examples/TH.hs deleted file mode 100644 --- a/tests/examples/TH.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# Language TemplateHaskell #-} - --- from https://ocharles.org.uk/blog/guest-posts/2014-12-22-template-haskell.html - -import Language.Haskell.TH - -e1 :: IO Exp -e1 = runQ [| 1 + 2 |] - -e2 :: Integer -e2 = $( return (InfixE (Just (LitE (IntegerL 1))) - (VarE (mkName "+")) - (Just (LitE (IntegerL 2))) - ) - ) - -fibs :: [Integer] -fibs = 0 : 1 : zipWith (+) fibs (tail fibs) - -fibQ :: Int -> Q Exp -fibQ n = [| fibs !! n |] - --- e3 gives stage restriction, need to import this module to get it --- e3 = $(fibQ 22) - -e4 = $(runQ [| fibs !! $( [| 8 |]) |]) - -e5 :: IO Exp -e5 = runQ [| 1 + 2 |] - -e6 :: IO [Dec] -e6 = runQ [d|x = 5|] - -e7 :: IO Type -e7 = runQ [t|Int|] - -e8 :: IO Pat -e8 = runQ [p|(x,y)|] - -myExp :: Q Exp; myExp = runQ [| 1 + 2 |] - -e9 = runQ(myExp) >>= putStrLn.pprint - --- --------------------------------------------------------------------- - -isPrime :: (Integral a) => a -> Bool -isPrime k | k <=1 = False | otherwise = not $ elem 0 (map (mod k)[2..k-1]) - -nextPrime :: (Integral a) => a -> a -nextPrime n | isPrime n = n | otherwise = nextPrime (n+1) - --- returns a list of all primes between n and m, using the nextPrime function -doPrime :: (Integral a) => a -> a -> [a] -doPrime n m - | curr > m = [] - | otherwise = curr:doPrime (curr+1) m - where curr = nextPrime n - --- and our Q expression -primeQ :: Int -> Int -> Q Exp -primeQ n m = [| doPrime n m |] - --- stage restriction on e10 --- e10 = $(primeQ 0 67) - --- --------------------------------------------------------------------- - -e11 = $(stringE . show =<< reify ''Bool) - --- stage restriction e12 --- e12 = $(stringE . show =<< reify 'primeQ) diff --git a/tests/examples/THMonadInstance.hs b/tests/examples/THMonadInstance.hs deleted file mode 100644 --- a/tests/examples/THMonadInstance.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE - TemplateHaskell, - MultiParamTypeClasses, - FunctionalDependencies, - UndecidableInstances - #-} - - -genCodingInstance :: (Data c, Data h) => TypeQ -> Name -> [(c, h)] -> Q [Dec] -genCodingInstance ht ctn chs = do - let n = const Nothing - [d| - instance Monad m => EncodeM m $(ht) $(conT ctn) where - encodeM h = return $ $( - caseE [| h |] [ match (dataToPatQ n h) (normalB (dataToExpQ n c)) [] | (c,h) <- chs ] - ) - - instance Monad m => DecodeM m $(ht) $(conT ctn) where - decodeM c = return $ $( - caseE [| c |] [ match (dataToPatQ n c) (normalB (dataToExpQ n h)) [] | (c,h) <- chs ] - ) - |] diff --git a/tests/examples/TemplateHaskell.hs b/tests/examples/TemplateHaskell.hs deleted file mode 100644 --- a/tests/examples/TemplateHaskell.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} - -foo = $footemplate - -makeSplices ''Foo - -old = $(old) - -bar = $$bartemplate - -bar = [e| quasi |] - -bar = [| quasi |] - -baz = [quoter| quasi |] - -[t| Map.Map T.Text $tc |] - -{-# ANN module $([| 1 :: Int |]) #-} - -foo = [t| HT.HashTable $(varT s) Int - (Result $(varT str) $tt) |] - -objc_emit - -objc_import [""] - - -$(do - return $ foreignDecl cName ("build" ++ a) ([[t| Ptr Builder |]] ++ ats ++ [[t| CString |]]) [t| Ptr $(rt) |] - ) - -foo = do - let elemSize = [|sizeOf (undefined :: $(elemType))|] - alignment _ = alignment (undefined :: $(elemType)) - return bar - -class QQExp a b where - qqExp x = [||fst $ runState $$(qqExpM x) ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] diff --git a/tests/examples/TooManyAnnVal.hs b/tests/examples/TooManyAnnVal.hs deleted file mode 100644 --- a/tests/examples/TooManyAnnVal.hs +++ /dev/null @@ -1,518 +0,0 @@ - - --- UUAGC 0.9.38.6 (./src/SistemaL.ag) -module SistemaL where -{-# LINE 3 "./src/SistemaL.ag" #-} - -import Data.List -{-# LINE 9 "./src/SistemaL.hs" #-} - -{-# LINE 69 "./src/SistemaL.ag" #-} - -addIdentProds prods alfa - = let prods' = map (\(Simbolo e,_) -> e) prods - resto = alfa \\ prods' - iprods = map (\e -> (Simbolo e, [Simbolo e])) resto - in prods ++ iprods - -myElem _ [] = False -myElem e1 ((Simbolo e2,_):xs) = if e1 == e2 - then True - else myElem e1 xs -{-# LINE 23 "./src/SistemaL.hs" #-} - -{-# LINE 125 "./src/SistemaL.ag" #-} - -ejemplo1 = SistemaL "Koch" alfaK initK prodK -alfaK = [Simbolo "F", Simbolo "f", Simbolo "+", Simbolo "-"] -initK = [Simbolo "F", Simbolo "a"] -prodK = [ (Simbolo "F", [Simbolo "F", Simbolo "g"]) - , (Simbolo "F", []) - ] - -ejemplo2 = SistemaL "Koch" alfaK2 initK2 prodK2 -alfaK2 = [Simbolo "F", Simbolo "f", Simbolo "+", Simbolo "-"] -initK2 = [Simbolo "F", Simbolo "f"] -prodK2 = [ (Simbolo "F", [Simbolo "F", Simbolo "+"]) - , (Simbolo "f", []) - ] - -getNombre (SistemaL nm _ _ _) = nm - -testSistemaL :: SistemaL -> Either [String] SistemaL -testSistemaL = sem_SistemaL -{-# LINE 45 "./src/SistemaL.hs" #-} --- Alfabeto ---------------------------------------------------- -type Alfabeto = [Simbolo ] --- cata -sem_Alfabeto :: Alfabeto -> - T_Alfabeto -sem_Alfabeto list = - (Prelude.foldr sem_Alfabeto_Cons sem_Alfabeto_Nil (Prelude.map sem_Simbolo list) ) --- semantic domain -type T_Alfabeto = ([String]) -> - ( ([String]),([String]),Alfabeto ) -sem_Alfabeto_Cons :: T_Simbolo -> - T_Alfabeto -> - T_Alfabeto -sem_Alfabeto_Cons hd_ tl_ = - (\ _lhsIalf -> - (let _tlOalf :: ([String]) - _lhsOalf :: ([String]) - _lhsOerrores :: ([String]) - _lhsOself :: Alfabeto - _hdIself :: Simbolo - _hdIsimb :: String - _tlIalf :: ([String]) - _tlIerrores :: ([String]) - _tlIself :: Alfabeto - _verificar = - ({-# LINE 31 "./src/SistemaL.ag" #-} - elem _hdIsimb _lhsIalf - {-# LINE 73 "./src/SistemaL.hs" #-} - ) - _tlOalf = - ({-# LINE 32 "./src/SistemaL.ag" #-} - if _verificar - then _lhsIalf - else _hdIsimb : _lhsIalf - {-# LINE 80 "./src/SistemaL.hs" #-} - ) - _lhsOalf = - ({-# LINE 35 "./src/SistemaL.ag" #-} - _tlIalf - {-# LINE 85 "./src/SistemaL.hs" #-} - ) - _lhsOerrores = - ({-# LINE 93 "./src/SistemaL.ag" #-} - if _verificar - then ("El simbolo: '" ++ _hdIsimb ++ "' esta repetido mas de una ves en el alfabeto.") : _tlIerrores - else _tlIerrores - {-# LINE 92 "./src/SistemaL.hs" #-} - ) - _self = - ({-# LINE 57 "./src/SistemaL.ag" #-} - (:) _hdIself _tlIself - {-# LINE 97 "./src/SistemaL.hs" #-} - ) - _lhsOself = - ({-# LINE 57 "./src/SistemaL.ag" #-} - _self - {-# LINE 102 "./src/SistemaL.hs" #-} - ) - ( _hdIself,_hdIsimb) = - hd_ - ( _tlIalf,_tlIerrores,_tlIself) = - tl_ _tlOalf - in ( _lhsOalf,_lhsOerrores,_lhsOself))) -sem_Alfabeto_Nil :: T_Alfabeto -sem_Alfabeto_Nil = - (\ _lhsIalf -> - (let _lhsOalf :: ([String]) - _lhsOerrores :: ([String]) - _lhsOself :: Alfabeto - _lhsOalf = - ({-# LINE 36 "./src/SistemaL.ag" #-} - _lhsIalf - {-# LINE 118 "./src/SistemaL.hs" #-} - ) - _lhsOerrores = - ({-# LINE 96 "./src/SistemaL.ag" #-} - [] - {-# LINE 123 "./src/SistemaL.hs" #-} - ) - _self = - ({-# LINE 57 "./src/SistemaL.ag" #-} - [] - {-# LINE 128 "./src/SistemaL.hs" #-} - ) - _lhsOself = - ({-# LINE 57 "./src/SistemaL.ag" #-} - _self - {-# LINE 133 "./src/SistemaL.hs" #-} - ) - in ( _lhsOalf,_lhsOerrores,_lhsOself))) --- Inicio ------------------------------------------------------ -type Inicio = [Simbolo ] --- cata -sem_Inicio :: Inicio -> - T_Inicio -sem_Inicio list = - (Prelude.foldr sem_Inicio_Cons sem_Inicio_Nil (Prelude.map sem_Simbolo list) ) --- semantic domain -type T_Inicio = ([String]) -> - ( ([String]),Inicio ) -sem_Inicio_Cons :: T_Simbolo -> - T_Inicio -> - T_Inicio -sem_Inicio_Cons hd_ tl_ = - (\ _lhsIalfabeto -> - (let _lhsOerrores :: ([String]) - _lhsOself :: Inicio - _tlOalfabeto :: ([String]) - _hdIself :: Simbolo - _hdIsimb :: String - _tlIerrores :: ([String]) - _tlIself :: Inicio - _lhsOerrores = - ({-# LINE 99 "./src/SistemaL.ag" #-} - if elem _hdIsimb _lhsIalfabeto - then _tlIerrores - else ("El simbolo de inicio: '" ++ _hdIsimb ++ "' no se encuentra en el alfabeto.") : _tlIerrores - {-# LINE 163 "./src/SistemaL.hs" #-} - ) - _self = - ({-# LINE 57 "./src/SistemaL.ag" #-} - (:) _hdIself _tlIself - {-# LINE 168 "./src/SistemaL.hs" #-} - ) - _lhsOself = - ({-# LINE 57 "./src/SistemaL.ag" #-} - _self - {-# LINE 173 "./src/SistemaL.hs" #-} - ) - _tlOalfabeto = - ({-# LINE 39 "./src/SistemaL.ag" #-} - _lhsIalfabeto - {-# LINE 178 "./src/SistemaL.hs" #-} - ) - ( _hdIself,_hdIsimb) = - hd_ - ( _tlIerrores,_tlIself) = - tl_ _tlOalfabeto - in ( _lhsOerrores,_lhsOself))) -sem_Inicio_Nil :: T_Inicio -sem_Inicio_Nil = - (\ _lhsIalfabeto -> - (let _lhsOerrores :: ([String]) - _lhsOself :: Inicio - _lhsOerrores = - ({-# LINE 102 "./src/SistemaL.ag" #-} - [] - {-# LINE 193 "./src/SistemaL.hs" #-} - ) - _self = - ({-# LINE 57 "./src/SistemaL.ag" #-} - [] - {-# LINE 198 "./src/SistemaL.hs" #-} - ) - _lhsOself = - ({-# LINE 57 "./src/SistemaL.ag" #-} - _self - {-# LINE 203 "./src/SistemaL.hs" #-} - ) - in ( _lhsOerrores,_lhsOself))) --- Produccion -------------------------------------------------- -type Produccion = ( Simbolo ,Succesor ) --- cata -sem_Produccion :: Produccion -> - T_Produccion -sem_Produccion ( x1,x2) = - (sem_Produccion_Tuple (sem_Simbolo x1 ) (sem_Succesor x2 ) ) --- semantic domain -type T_Produccion = ([String]) -> - ( ([String]),Produccion ,String) -sem_Produccion_Tuple :: T_Simbolo -> - T_Succesor -> - T_Produccion -sem_Produccion_Tuple x1_ x2_ = - (\ _lhsIalfabeto -> - (let _lhsOerrores :: ([String]) - _lhsOself :: Produccion - _lhsOsimb :: String - _x2Oalfabeto :: ([String]) - _x1Iself :: Simbolo - _x1Isimb :: String - _x2Ierrores :: ([String]) - _x2Iself :: Succesor - _lhsOerrores = - ({-# LINE 114 "./src/SistemaL.ag" #-} - if elem _x1Isimb _lhsIalfabeto - then _x2Ierrores - else ("El simbolo de la produccion (izq): '" ++ _x1Isimb ++ "' no se encuentra en el alfabeto.") : _x2Ierrores - {-# LINE 234 "./src/SistemaL.hs" #-} - ) - _self = - ({-# LINE 57 "./src/SistemaL.ag" #-} - (_x1Iself,_x2Iself) - {-# LINE 239 "./src/SistemaL.hs" #-} - ) - _lhsOself = - ({-# LINE 57 "./src/SistemaL.ag" #-} - _self - {-# LINE 244 "./src/SistemaL.hs" #-} - ) - _lhsOsimb = - ({-# LINE 45 "./src/SistemaL.ag" #-} - _x1Isimb - {-# LINE 249 "./src/SistemaL.hs" #-} - ) - _x2Oalfabeto = - ({-# LINE 39 "./src/SistemaL.ag" #-} - _lhsIalfabeto - {-# LINE 254 "./src/SistemaL.hs" #-} - ) - ( _x1Iself,_x1Isimb) = - x1_ - ( _x2Ierrores,_x2Iself) = - x2_ _x2Oalfabeto - in ( _lhsOerrores,_lhsOself,_lhsOsimb))) --- Producciones ------------------------------------------------ -type Producciones = [Produccion ] --- cata -sem_Producciones :: Producciones -> - T_Producciones -sem_Producciones list = - (Prelude.foldr sem_Producciones_Cons sem_Producciones_Nil (Prelude.map sem_Produccion list) ) --- semantic domain -type T_Producciones = ([String]) -> - Producciones -> - ( ([String]),Producciones) -sem_Producciones_Cons :: T_Produccion -> - T_Producciones -> - T_Producciones -sem_Producciones_Cons hd_ tl_ = - (\ _lhsIalfabeto - _lhsIprods -> - (let _tlOprods :: Producciones - _lhsOprods :: Producciones - _lhsOerrores :: ([String]) - _hdOalfabeto :: ([String]) - _tlOalfabeto :: ([String]) - _hdIerrores :: ([String]) - _hdIself :: Produccion - _hdIsimb :: String - _tlIerrores :: ([String]) - _tlIprods :: Producciones - _verificar = - ({-# LINE 60 "./src/SistemaL.ag" #-} - myElem _hdIsimb _lhsIprods - {-# LINE 291 "./src/SistemaL.hs" #-} - ) - _tlOprods = - ({-# LINE 61 "./src/SistemaL.ag" #-} - if _verificar - then _lhsIprods - else _hdIself : _lhsIprods - {-# LINE 298 "./src/SistemaL.hs" #-} - ) - _lhsOprods = - ({-# LINE 64 "./src/SistemaL.ag" #-} - _tlIprods - {-# LINE 303 "./src/SistemaL.hs" #-} - ) - _lhsOerrores = - ({-# LINE 105 "./src/SistemaL.ag" #-} - if _verificar - then let error = "La produccion con el simb. izq.:'" - ++ _hdIsimb - ++ "' esta repetida mas de una ves en la lista de producciones." - in (error : _hdIerrores) ++ _tlIerrores - else _hdIerrores ++ _tlIerrores - {-# LINE 313 "./src/SistemaL.hs" #-} - ) - _hdOalfabeto = - ({-# LINE 39 "./src/SistemaL.ag" #-} - _lhsIalfabeto - {-# LINE 318 "./src/SistemaL.hs" #-} - ) - _tlOalfabeto = - ({-# LINE 39 "./src/SistemaL.ag" #-} - _lhsIalfabeto - {-# LINE 323 "./src/SistemaL.hs" #-} - ) - ( _hdIerrores,_hdIself,_hdIsimb) = - hd_ _hdOalfabeto - ( _tlIerrores,_tlIprods) = - tl_ _tlOalfabeto _tlOprods - in ( _lhsOerrores,_lhsOprods))) -sem_Producciones_Nil :: T_Producciones -sem_Producciones_Nil = - (\ _lhsIalfabeto - _lhsIprods -> - (let _lhsOerrores :: ([String]) - _lhsOprods :: Producciones - _lhsOerrores = - ({-# LINE 111 "./src/SistemaL.ag" #-} - [] - {-# LINE 339 "./src/SistemaL.hs" #-} - ) - _lhsOprods = - ({-# LINE 58 "./src/SistemaL.ag" #-} - _lhsIprods - {-# LINE 344 "./src/SistemaL.hs" #-} - ) - in ( _lhsOerrores,_lhsOprods))) --- Simbolo ----------------------------------------------------- -data Simbolo = Simbolo (String) - deriving ( Eq,Show) --- cata -sem_Simbolo :: Simbolo -> - T_Simbolo -sem_Simbolo (Simbolo _string ) = - (sem_Simbolo_Simbolo _string ) --- semantic domain -type T_Simbolo = ( Simbolo ,String) -sem_Simbolo_Simbolo :: String -> - T_Simbolo -sem_Simbolo_Simbolo string_ = - (let _lhsOsimb :: String - _lhsOself :: Simbolo - _lhsOsimb = - ({-# LINE 47 "./src/SistemaL.ag" #-} - string_ - {-# LINE 365 "./src/SistemaL.hs" #-} - ) - _self = - ({-# LINE 57 "./src/SistemaL.ag" #-} - Simbolo string_ - {-# LINE 370 "./src/SistemaL.hs" #-} - ) - _lhsOself = - ({-# LINE 57 "./src/SistemaL.ag" #-} - _self - {-# LINE 375 "./src/SistemaL.hs" #-} - ) - in ( _lhsOself,_lhsOsimb)) --- SistemaL ---------------------------------------------------- -data SistemaL = SistemaL (String) (Alfabeto ) (Inicio ) (Producciones ) - deriving ( Show) --- cata -sem_SistemaL :: SistemaL -> - T_SistemaL -sem_SistemaL (SistemaL _nombre _alfabeto _inicio _producciones ) = - (sem_SistemaL_SistemaL _nombre (sem_Alfabeto _alfabeto ) (sem_Inicio _inicio ) (sem_Producciones _producciones ) ) --- semantic domain -type T_SistemaL = ( (Either [String] SistemaL)) -sem_SistemaL_SistemaL :: String -> - T_Alfabeto -> - T_Inicio -> - T_Producciones -> - T_SistemaL -sem_SistemaL_SistemaL nombre_ alfabeto_ inicio_ producciones_ = - (let _alfabetoOalf :: ([String]) - _inicioOalfabeto :: ([String]) - _produccionesOalfabeto :: ([String]) - _lhsOresultado :: (Either [String] SistemaL) - _produccionesOprods :: Producciones - _alfabetoIalf :: ([String]) - _alfabetoIerrores :: ([String]) - _alfabetoIself :: Alfabeto - _inicioIerrores :: ([String]) - _inicioIself :: Inicio - _produccionesIerrores :: ([String]) - _produccionesIprods :: Producciones - _alfabetoOalf = - ({-# LINE 28 "./src/SistemaL.ag" #-} - [] - {-# LINE 409 "./src/SistemaL.hs" #-} - ) - _inicioOalfabeto = - ({-# LINE 41 "./src/SistemaL.ag" #-} - _alfabetoIalf - {-# LINE 414 "./src/SistemaL.hs" #-} - ) - _produccionesOalfabeto = - ({-# LINE 42 "./src/SistemaL.ag" #-} - _alfabetoIalf - {-# LINE 419 "./src/SistemaL.hs" #-} - ) - _lhsOresultado = - ({-# LINE 52 "./src/SistemaL.ag" #-} - if null _errores - then let producciones = addIdentProds _produccionesIprods _alfabetoIalf - in Right (SistemaL nombre_ _alfabetoIself _inicioIself producciones) - else Left _errores - {-# LINE 427 "./src/SistemaL.hs" #-} - ) - _produccionesOprods = - ({-# LINE 67 "./src/SistemaL.ag" #-} - [] - {-# LINE 432 "./src/SistemaL.hs" #-} - ) - _errores = - ({-# LINE 85 "./src/SistemaL.ag" #-} - let inicioErr = if null _inicioIself - then "La lista de simbolos de inicio no puede ser vacia" : _inicioIerrores - else _inicioIerrores - errores = map (\err -> nombre_ ++ ": " ++ err) (_alfabetoIerrores ++ inicioErr ++ _produccionesIerrores) - in errores - {-# LINE 441 "./src/SistemaL.hs" #-} - ) - ( _alfabetoIalf,_alfabetoIerrores,_alfabetoIself) = - alfabeto_ _alfabetoOalf - ( _inicioIerrores,_inicioIself) = - inicio_ _inicioOalfabeto - ( _produccionesIerrores,_produccionesIprods) = - producciones_ _produccionesOalfabeto _produccionesOprods - in ( _lhsOresultado)) --- Succesor ---------------------------------------------------- -type Succesor = [Simbolo ] --- cata -sem_Succesor :: Succesor -> - T_Succesor -sem_Succesor list = - (Prelude.foldr sem_Succesor_Cons sem_Succesor_Nil (Prelude.map sem_Simbolo list) ) --- semantic domain -type T_Succesor = ([String]) -> - ( ([String]),Succesor ) -sem_Succesor_Cons :: T_Simbolo -> - T_Succesor -> - T_Succesor -sem_Succesor_Cons hd_ tl_ = - (\ _lhsIalfabeto -> - (let _lhsOerrores :: ([String]) - _lhsOself :: Succesor - _tlOalfabeto :: ([String]) - _hdIself :: Simbolo - _hdIsimb :: String - _tlIerrores :: ([String]) - _tlIself :: Succesor - _lhsOerrores = - ({-# LINE 119 "./src/SistemaL.ag" #-} - if elem _hdIsimb _lhsIalfabeto - then _tlIerrores - else ("El simbolo de la produccion (der): '" ++ _hdIsimb ++ "' no se encuentra en el alfabeto.") : _tlIerrores - {-# LINE 477 "./src/SistemaL.hs" #-} - ) - _self = - ({-# LINE 57 "./src/SistemaL.ag" #-} - (:) _hdIself _tlIself - {-# LINE 482 "./src/SistemaL.hs" #-} - ) - _lhsOself = - ({-# LINE 57 "./src/SistemaL.ag" #-} - _self - {-# LINE 487 "./src/SistemaL.hs" #-} - ) - _tlOalfabeto = - ({-# LINE 39 "./src/SistemaL.ag" #-} - _lhsIalfabeto - {-# LINE 492 "./src/SistemaL.hs" #-} - ) - ( _hdIself,_hdIsimb) = - hd_ - ( _tlIerrores,_tlIself) = - tl_ _tlOalfabeto - in ( _lhsOerrores,_lhsOself))) -sem_Succesor_Nil :: T_Succesor -sem_Succesor_Nil = - (\ _lhsIalfabeto -> - (let _lhsOerrores :: ([String]) - _lhsOself :: Succesor - _lhsOerrores = - ({-# LINE 122 "./src/SistemaL.ag" #-} - [] - {-# LINE 507 "./src/SistemaL.hs" #-} - ) - _self = - ({-# LINE 57 "./src/SistemaL.ag" #-} - [] - {-# LINE 512 "./src/SistemaL.hs" #-} - ) - _lhsOself = - ({-# LINE 57 "./src/SistemaL.ag" #-} - _self - {-# LINE 517 "./src/SistemaL.hs" #-} - ) - in ( _lhsOerrores,_lhsOself))) diff --git a/tests/examples/TransformListComp.hs b/tests/examples/TransformListComp.hs deleted file mode 100644 --- a/tests/examples/TransformListComp.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TransformListComp #-} - -oldest :: [Int] -> [String] -oldest tbl = [ "str" - | n <- tbl - , then id - ] diff --git a/tests/examples/Trit.hs b/tests/examples/Trit.hs deleted file mode 100644 --- a/tests/examples/Trit.hs +++ /dev/null @@ -1,112 +0,0 @@ -module Trit (Trit, rationalToTrit, getIntegral, getFraction, getFraction', - neg, addTrits, subTrits, shiftLeft, shiftRight, multiply - ) where - -import Stream -import Utilities -import Data.Ratio - -type Mantissa = Stream -type Fraction = Stream -type Trit = (Mantissa, Fraction) - - --- Convert from a Rational number to its Trit representation (Integral, Fraction) -rationalToTrit :: Rational -> Trit -rationalToTrit x - |x<1 = ([0], rationalToStream x) - |otherwise = (u', rationalToStream v) - where u = n `div` d - u' = toBinary u - v = x - (toRational u) - n = numerator x - d = denominator x - - --- Get the integral part of Trit -getIntegral :: Trit -> Mantissa -getIntegral = fst - - - --- Get the fraction part of Trit, with n digit of the stream -getFraction :: Int -> Trit -> Stream -getFraction n = take n. snd - - --- Get the fraction part of Trit -getFraction' :: Trit -> Stream -getFraction' = snd - - - --- Negate a Trit -neg :: Trit -> Trit -neg (a, b) = (negate' a, negate' b) - - - --- Add two Trits -addTrits :: Trit -> Trit -> Trit -addTrits (m1, (x1:x2:xs)) (m2, (y1:y2:ys)) = (u,addStream (x1:x2:xs) (y1:y2:ys)) - where u' = addFiniteStream m1 m2 - c = [carry x1 x2 y1 y2] - u = addFiniteStream u' c - - - --- Substraction of 2 Trits -subTrits :: Trit -> Trit -> Trit -subTrits x y = addTrits x (neg y) - - - --- Shift left = *2 opertaion with Trit -shiftLeft :: Trit -> Trit -shiftLeft (x, (y:ys)) = (x++ [y], ys) - - --- Shift right = /2 operation with Trit -shiftRight :: Trit -> Integer -> Trit -shiftRight (x, xs) 1 = (init x, (u:xs)) - where u = last x -shiftRight (x, xs) n = shiftRight (init x, (u:xs)) (n-1) - where u = last x - - - --- Multiply a Trit stream by 1,0 or -1, simply return the stream -mulOneDigit :: Integer -> Stream -> Stream -mulOneDigit x xs - |x==1 = xs - |x==0 = zero' - |otherwise = negate' xs - where zero' = (0:zero') - - - - - - --- Multiplication of two streams -multiply :: Stream -> Stream -> Stream -multiply (a0:a1:x) (b0:b1:y) = average p q - where p = average (a1*b0: (average (mulOneDigit b1 x) - (mulOneDigit a1 y))) - (average (mulOneDigit b0 x) - (mulOneDigit a0 y)) - q = (a0*b0:a0*b1:a1*b1:(multiply x y)) - - - - -start0 = take 30 (multiply (rationalToStream (1%2)) zo) - -zo :: Stream -zo = 1:(-1):zero - where zero = 0:zero - -start1 = take 30 (average (rationalToStream (1%2)) (negate' (rationalToStream (1%4)))) - - - diff --git a/tests/examples/Tuple.hs b/tests/examples/Tuple.hs deleted file mode 100644 --- a/tests/examples/Tuple.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TupleSections #-} - -baz = (1, "hello", 6.5,,) 'a' (Just ()) - diff --git a/tests/examples/TupleSections.hs b/tests/examples/TupleSections.hs deleted file mode 100644 --- a/tests/examples/TupleSections.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE TupleSections #-} - -foo = do - liftIO $ atomicModifyIORef ciTokens ((,()) . f) - liftIO $ atomicModifyIORef ciTokens (((),) . f) - liftIO $ atomicModifyIORef ciTokens ((,) . f) - --- | Make bilateral dictionary from PoliMorf. -mkPoli :: [P.Entry] -> Poli -mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) - -foo = baz - where - _1 = ((,Nothing,Nothing,Nothing,Nothing,Nothing) . Just <$>) - _2 = ((Nothing,,Nothing,Nothing,Nothing,Nothing) . Just <$>) - _3 = ((Nothing,Nothing,,Nothing,Nothing,Nothing) . Just <$>) - _4 = ((Nothing,Nothing,Nothing,,Nothing,Nothing) . Just <$>) - _5 = ((Nothing,Nothing,Nothing,Nothing,,Nothing) . Just <$>) - _6 = ((Nothing,Nothing,Nothing,Nothing,Nothing,) . Just <$>) - -foo = (,,(),,,()) diff --git a/tests/examples/TypeBrackets.hs b/tests/examples/TypeBrackets.hs deleted file mode 100644 --- a/tests/examples/TypeBrackets.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -foo (f :: (Maybe t -> Int)) = - undefined - -type (((f `ObjectsFUnder` a))) = ConstF f a :/\: f -type (f `ObjectsFOver` a) = f :/\: ConstF f a - -type (c `ObjectsUnder` a) = Id c `ObjectsFUnder` a -type (c `ObjectsOver` a) = Id c `ObjectsFOver` a - diff --git a/tests/examples/TypeBrackets2.hs b/tests/examples/TypeBrackets2.hs deleted file mode 100644 --- a/tests/examples/TypeBrackets2.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} - - --- | The style and color attributes can either be the terminal defaults. Or be equivalent to the --- previously applied style. Or be a specific value. -data MaybeDefault v where - Default :: MaybeDefault v - KeepCurrent :: MaybeDefault v - SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v - SetTo2 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v - -bar :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a]) -baz :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v - -instance Dsp (S n) where - data (ASig (S n)) = S_A CVar - data (KSig (S n)) = S_K CVar - data (INum (S n)) = S_I CVar - getSr = fst <$> ask - getKsmps = snd <$> ask diff --git a/tests/examples/TypeBrackets3.hs b/tests/examples/TypeBrackets3.hs deleted file mode 100644 --- a/tests/examples/TypeBrackets3.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} - -module Network.Routing.Dict - ( -- * store - Store - , emptyStore - , type ( Members ["foo" := Int, "bar" := Double] prms == (Member "foo" Int prms, Member "bar" Double prms) --- -type family Members (kvs :: [KV *]) (prms :: [KV *]) :: Constraint -type instance Members '[] prms = () -type instance Members (k := v ': kvs) prms = (Member k v prms, Members kvs prms) diff --git a/tests/examples/TypeBrackets4.hs b/tests/examples/TypeBrackets4.hs deleted file mode 100644 --- a/tests/examples/TypeBrackets4.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} - - -type family ((a :: Bool) || (b :: Bool)) :: Bool -type instance 'True || a = 'True -type instance a || 'True = 'True -type instance 'False || a = a -type instance a || 'False = a diff --git a/tests/examples/TypeFamilies.hs b/tests/examples/TypeFamilies.hs deleted file mode 100644 --- a/tests/examples/TypeFamilies.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - --- From https://ocharles.org.uk/blog/posts/2014-12-12-type-families.html - -import Control.Concurrent.STM -import Control.Concurrent.MVar -import Data.Foldable (forM_) -import Data.IORef - -class IOStore store where - newIO :: a -> IO (store a) - getIO :: store a -> IO a - putIO :: store a -> a -> IO () - -instance IOStore MVar where - newIO = newMVar - getIO = readMVar - putIO mvar a = modifyMVar_ mvar (return . const a) - -instance IOStore IORef where - newIO = newIORef - getIO = readIORef - putIO ioref a = modifyIORef ioref (const a) - -type Present = String -storePresentsIO :: IOStore store => [Present] -> IO (store [Present]) -storePresentsIO xs = do - store <- newIO [] - forM_ xs $ \x -> do - old <- getIO store - putIO store (x : old) - return store - --- Type family version - -class Store store where - type StoreMonad store :: * -> * - new :: a -> (StoreMonad store) (store a) - get :: store a -> (StoreMonad store) a - put :: store a -> a -> (StoreMonad store) () - -instance Store IORef where - type StoreMonad IORef = IO - new = newIORef - get = readIORef - put ioref a = modifyIORef ioref (const a) - -instance Store TVar where - type StoreMonad TVar = STM - new = newTVar - get = readTVar - put ioref a = modifyTVar ioref (const a) - -storePresents :: (Store store, Monad (StoreMonad store)) - => [Present] -> (StoreMonad store) (store [Present]) -storePresents xs = do - store <- new [] - forM_ xs $ \x -> do - old <- get store - put store (x : old) - return store - -type family (++) (a :: [k]) (b :: [k]) :: [k] where - '[] ++ b = b - (a ': as) ++ b = a ': (as ++ b) - -type family (f :: * -> *) |> (s :: * -> *) :: * -> * - -type instance f |> Union s = Union (f :> s) - -type family Compare (a :: k) (b :: k') :: Ordering where - Compare '() '() = EQ - -type family (r1 :++: r2); infixr 5 :++: -type instance r :++: Nil = r -type instance r1 :++: r2 :> a = (r1 :++: r2) :> a diff --git a/tests/examples/TypeFamilies2.hs b/tests/examples/TypeFamilies2.hs deleted file mode 100644 --- a/tests/examples/TypeFamilies2.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -type family (++) (a :: [k]) (b :: [k]) :: [k] where - '[] ++ b = b - (a ': as) ++ b = a ': (as ++ b) - -type family F a :: * -> * -> * -type instance F Int = (->) -type instance F Char = ( , ) diff --git a/tests/examples/TypeInstance.hs b/tests/examples/TypeInstance.hs deleted file mode 100644 --- a/tests/examples/TypeInstance.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} - -class TrieKey k where - type instance TrieRep k = TrieRepDefault k diff --git a/tests/examples/TypeOperators.hs b/tests/examples/TypeOperators.hs deleted file mode 100644 --- a/tests/examples/TypeOperators.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} - --- From https://ocharles.org.uk/blog/posts/2014-12-08-type-operators.html - -import Data.String - -data I a = I { unI :: a } -data Var a x = Var { unK :: a } - -infixr 8 + -data ((f + g)) a = InL (f a) | InR (g a) --- data (f + g) a = InL (f a) | InR (g a) - -class sub :<: sup where - inj :: sub a -> sup a - -instance (sym :<: sym) where - inj = id - -instance (sym1 :<: (sym1 + sym2)) where inj = InL - -instance (sym1 :<: sym3) => (sym1 :<: (sym2 + sym3)) where - inj = InR . inj - -instance (I :<: g, IsString s) => IsString ((f + g) s) where - fromString = inj . I . fromString - -var :: (Var a :<: f) => a -> f e -var = inj . Var - -elim :: (I :<: f) => (a -> b) -> (Var a + f) b -> f b -elim eval f = - case f of - InL (Var xs) -> inj (I (eval xs)) - InR g -> g - --------------------------------------------------------------------------------- - -data UserVar = UserName - -data ChristmasVar = ChristmasPresent - -email :: [(Var UserVar + Var ChristmasVar + I) String] -email = [ "Dear " - , var UserName - , ", thank you for your recent email to Santa & Santa Inc." - , "You have asked for a: " - , var ChristmasPresent - ] - -main :: IO () -main = - do name <- getLine - present <- getLine - putStrLn (concatMap (unI . - (elim (\ChristmasPresent -> present) . - elim (\UserName -> name))) - email) - -{- - -*Main> main -Ollie -Lambda Necklace -Dear Ollie, thank you for your recent email to Santa & Santa Inc.You have asked for a: Lambda Necklace - --} diff --git a/tests/examples/TypeSignature.hs b/tests/examples/TypeSignature.hs deleted file mode 100644 --- a/tests/examples/TypeSignature.hs +++ /dev/null @@ -1,12 +0,0 @@ -module TypeSignature where - -{- Lifting baz to the top level should bring in xx and a as parameters, - and update the signature to include these --} -foo a = (baz xx a) - where - xx :: Int -> Int -> Int - xx p1 p2 = p1 + p2 - -baz :: (Int -> Int -> Int) -> Int ->Int -baz xx a = xx 1 a diff --git a/tests/examples/TypeSignatureParens.hs b/tests/examples/TypeSignatureParens.hs deleted file mode 100644 --- a/tests/examples/TypeSignatureParens.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -pTokenCost :: forall loc state a .((Show a, Eq a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => [a] -> Int -> P (Str a state loc) [a]) -pTokenCost as cost = 5 - -pTokenCostStr :: forall a .((Show a) => [a] -> Int -> String) -pTokenCostStr as cost = "5" diff --git a/tests/examples/TypeSynOperator.hs b/tests/examples/TypeSynOperator.hs deleted file mode 100644 --- a/tests/examples/TypeSynOperator.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - -type a :-> t = a diff --git a/tests/examples/TypeSynParens.hs b/tests/examples/TypeSynParens.hs deleted file mode 100644 --- a/tests/examples/TypeSynParens.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -class Compilable a where - type CompileResult a :: * - -instance Compilable a => Compilable [a] where - type CompileResult [a] = [CompileResult a] - -instance Compilable a => Compilable (Maybe a) where - type CompileResult (Maybe a) = Maybe (CompileResult a) - -instance Compilable InterpreterStmt where - type CompileResult InterpreterStmt = [Hask.Stmt] - -instance Compilable ModuleSpan where - type CompileResult ModuleSpan = Hask.Module - -instance Compilable StatementSpan where - type (CompileResult StatementSpan) = [Stmt] diff --git a/tests/examples/Unboxed.hs b/tests/examples/Unboxed.hs deleted file mode 100644 --- a/tests/examples/Unboxed.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE UnboxedTuples #-} -module Layout.Unboxed where - -a,b :: Int -a = 1 -b = 2 - -c :: Maybe (a -> b) -c = Nothing - -f :: (Num a1, Num a) => a -> a1 -> (# a, a1 #) -f x y = (# x+1, y-1 #) - -f1 :: (Num a1, Num a) => a -> a1 -> (# , #) a a1 -f1 x y = (# , #) x+1 y-1 - -g :: Num a => a -> a -g x = case f x x of { (# a, b #) -> a + b } - - - -- Pattern bind -tup :: (Int, Int) -h :: Int -t :: Int -tup@(h,t) = head $ zip [1..10] [3..ff] - where - ff :: Int - ff = 15 - - diff --git a/tests/examples/Undefined10.hs b/tests/examples/Undefined10.hs deleted file mode 100644 --- a/tests/examples/Undefined10.hs +++ /dev/null @@ -1,643 +0,0 @@ -{- - Copyright 2013-2015 Mario Blazevic - - License: BSD3 (see BSD3-LICENSE.txt file) --} - --- | This module defines the 'FactorialMonoid' class and some of its instances. --- - -{-# LANGUAGE Haskell2010, Trustworthy #-} - -module Data.Monoid.Factorial ( - -- * Classes - FactorialMonoid(..), StableFactorialMonoid, - -- * Monad function equivalents - mapM, mapM_ - ) -where - -import Prelude hiding (break, drop, dropWhile, foldl, foldMap, foldr, last, length, map, mapM, mapM_, max, min, - null, reverse, span, splitAt, take, takeWhile) - -import Control.Arrow (first) -import qualified Control.Monad as Monad -import Data.Monoid (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo)) -import qualified Data.Foldable as Foldable -import qualified Data.List as List -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Lazy as LazyByteString -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LazyText -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Map as Map -import qualified Data.Sequence as Sequence -import qualified Data.Set as Set -import qualified Data.Vector as Vector -import Data.Int (Int64) -import Data.Numbers.Primes (primeFactors) - -import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) - --- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of --- a 'Product' are literally its prime factors: --- --- prop> factors (Product 12) == [Product 2, Product 2, Product 3] --- --- Factors of a list are /not/ its elements but all its single-item sublists: --- --- prop> factors "abc" == ["a", "b", "c"] --- --- The methods of this class satisfy the following laws: --- --- > mconcat . factors == id --- > null == List.null . factors --- > List.all (\prime-> factors prime == [prime]) . factors --- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix) --- > reverse == mconcat . List.reverse . factors --- > primePrefix == maybe mempty fst . splitPrimePrefix --- > primeSuffix == maybe mempty snd . splitPrimeSuffix --- > inits == List.map mconcat . List.tails . factors --- > tails == List.map mconcat . List.tails . factors --- > foldl f a == List.foldl f a . factors --- > foldl' f a == List.foldl' f a . factors --- > foldr f a == List.foldr f a . factors --- > span p m == (mconcat l, mconcat r) where (l, r) = List.span p (factors m) --- > List.all (List.all (not . pred) . factors) . split pred --- > mconcat . intersperse prime . split (== prime) == id --- > splitAt i m == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors m) --- > spanMaybe () (const $ bool Nothing (Maybe ()) . p) m == (takeWhile p m, dropWhile p m, ()) --- > spanMaybe s0 (\s m-> Just $ f s m) m0 == (m0, mempty, foldl f s0 m0) --- > let (prefix, suffix, s') = spanMaybe s f m --- > foldMaybe = foldl g (Just s) --- > g s m = s >>= flip f m --- > in all ((Nothing ==) . foldMaybe) (inits prefix) --- > && prefix == last (filter (isJust . foldMaybe) $ inits m) --- > && Just s' == foldMaybe prefix --- > && m == prefix <> suffix --- --- A minimal instance definition must implement 'factors' or 'splitPrimePrefix'. Other methods are provided and should --- be implemented only for performance reasons. -class MonoidNull m => FactorialMonoid m where - -- | Returns a list of all prime factors; inverse of mconcat. - factors :: m -> [m] - -- | The prime prefix, 'mempty' if none. - primePrefix :: m -> m - -- | The prime suffix, 'mempty' if none. - primeSuffix :: m -> m - -- | Splits the argument into its prime prefix and the remaining suffix. Returns 'Nothing' for 'mempty'. - splitPrimePrefix :: m -> Maybe (m, m) - -- | Splits the argument into its prime suffix and the remaining prefix. Returns 'Nothing' for 'mempty'. - splitPrimeSuffix :: m -> Maybe (m, m) - -- | Returns the list of all prefixes of the argument, 'mempty' first. - inits :: m -> [m] - -- | Returns the list of all suffixes of the argument, 'mempty' last. - tails :: m -> [m] - -- | Like 'List.foldl' from "Data.List" on the list of 'primes'. - foldl :: (a -> m -> a) -> a -> m -> a - -- | Like 'List.foldl'' from "Data.List" on the list of 'primes'. - foldl' :: (a -> m -> a) -> a -> m -> a - -- | Like 'List.foldr' from "Data.List" on the list of 'primes'. - foldr :: (m -> a -> a) -> a -> m -> a - -- | The 'length' of the list of 'primes'. - length :: m -> Int - -- | Generalizes 'foldMap' from "Data.Foldable", except the function arguments are prime factors rather than the - -- structure elements. - foldMap :: Monoid n => (m -> n) -> m -> n - -- | Like 'List.span' from "Data.List" on the list of 'primes'. - span :: (m -> Bool) -> m -> (m, m) - -- | Equivalent to 'List.break' from "Data.List". - break :: (m -> Bool) -> m -> (m, m) - -- | Splits the monoid into components delimited by prime separators satisfying the given predicate. The primes - -- satisfying the predicate are not a part of the result. - split :: (m -> Bool) -> m -> [m] - -- | Equivalent to 'List.takeWhile' from "Data.List". - takeWhile :: (m -> Bool) -> m -> m - -- | Equivalent to 'List.dropWhile' from "Data.List". - dropWhile :: (m -> Bool) -> m -> m - -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'. - spanMaybe :: s -> (s -> m -> Maybe s) -> m -> (m, m, s) - -- | Strict version of 'spanMaybe'. - spanMaybe' :: s -> (s -> m -> Maybe s) -> m -> (m, m, s) - -- | Like 'List.splitAt' from "Data.List" on the list of 'primes'. - splitAt :: Int -> m -> (m, m) - -- | Equivalent to 'List.drop' from "Data.List". - drop :: Int -> m -> m - -- | Equivalent to 'List.take' from "Data.List". - take :: Int -> m -> m - -- | Equivalent to 'List.reverse' from "Data.List". - reverse :: m -> m - - factors = List.unfoldr splitPrimePrefix - primePrefix = maybe mempty fst . splitPrimePrefix - primeSuffix = maybe mempty snd . splitPrimeSuffix - splitPrimePrefix x = case factors x - of [] -> Nothing - prefix : rest -> Just (prefix, mconcat rest) - splitPrimeSuffix x = case factors x - of [] -> Nothing - fs -> Just (mconcat (List.init fs), List.last fs) - inits = foldr (\m l-> mempty : List.map (mappend m) l) [mempty] - tails m = m : maybe [] (tails . snd) (splitPrimePrefix m) - foldl f f0 = List.foldl f f0 . factors - foldl' f f0 = List.foldl' f f0 . factors - foldr f f0 = List.foldr f f0 . factors - length = List.length . factors - foldMap f = foldr (mappend . f) mempty - span p m0 = spanAfter id m0 - where spanAfter f m = case splitPrimePrefix m - of Just (prime, rest) | p prime -> spanAfter (f . mappend prime) rest - _ -> (f mempty, m) - break = span . (not .) - spanMaybe s0 f m0 = spanAfter id s0 m0 - where spanAfter g s m = case splitPrimePrefix m - of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest - | otherwise -> (g mempty, m, s) - Nothing -> (m0, m, s) - spanMaybe' s0 f m0 = spanAfter id s0 m0 - where spanAfter g s m = seq s $ - case splitPrimePrefix m - of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest - | otherwise -> (g mempty, m, s) - Nothing -> (m0, m, s) - split p m = prefix : splitRest - where (prefix, rest) = break p m - splitRest = case splitPrimePrefix rest - of Nothing -> [] - Just (_, tl) -> split p tl - takeWhile p = fst . span p - dropWhile p = snd . span p - splitAt n0 m0 | n0 <= 0 = (mempty, m0) - | otherwise = split' n0 id m0 - where split' 0 f m = (f mempty, m) - split' n f m = case splitPrimePrefix m - of Nothing -> (f mempty, m) - Just (prime, rest) -> split' (pred n) (f . mappend prime) rest - drop n p = snd (splitAt n p) - take n p = fst (splitAt n p) - reverse = mconcat . List.reverse . factors - {-# MINIMAL factors | splitPrimePrefix #-} - --- | A subclass of 'FactorialMonoid' whose instances satisfy this additional law: --- --- > factors (a <> b) == factors a <> factors b -class (FactorialMonoid m, PositiveMonoid m) => StableFactorialMonoid m - -instance FactorialMonoid () where - factors () = [] - primePrefix () = () - primeSuffix () = () - splitPrimePrefix () = Nothing - splitPrimeSuffix () = Nothing - length () = 0 - reverse = id - -instance FactorialMonoid a => FactorialMonoid (Dual a) where - factors (Dual a) = fmap Dual (reverse $ factors a) - length (Dual a) = length a - primePrefix (Dual a) = Dual (primeSuffix a) - primeSuffix (Dual a) = Dual (primePrefix a) - splitPrimePrefix (Dual a) = case splitPrimeSuffix a - of Nothing -> Nothing - Just (p, s) -> Just (Dual s, Dual p) - splitPrimeSuffix (Dual a) = case splitPrimePrefix a - of Nothing -> Nothing - Just (p, s) -> Just (Dual s, Dual p) - inits (Dual a) = fmap Dual (reverse $ tails a) - tails (Dual a) = fmap Dual (reverse $ inits a) - reverse (Dual a) = Dual (reverse a) - -instance (Integral a, Eq a) => FactorialMonoid (Sum a) where - primePrefix (Sum a) = Sum (signum a ) - primeSuffix = primePrefix - splitPrimePrefix (Sum 0) = Nothing - splitPrimePrefix (Sum a) = Just (Sum (signum a), Sum (a - signum a)) - splitPrimeSuffix (Sum 0) = Nothing - splitPrimeSuffix (Sum a) = Just (Sum (a - signum a), Sum (signum a)) - length (Sum a) = abs (fromIntegral a) - reverse = id - -instance Integral a => FactorialMonoid (Product a) where - factors (Product a) = List.map Product (primeFactors a) - reverse = id - -instance FactorialMonoid a => FactorialMonoid (Maybe a) where - factors Nothing = [] - factors (Just a) | null a = [Just a] - | otherwise = List.map Just (factors a) - length Nothing = 0 - length (Just a) | null a = 1 - | otherwise = length a - reverse = fmap reverse - -instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (a, b) where - factors (a, b) = List.map (\a1-> (a1, mempty)) (factors a) ++ List.map ((,) mempty) (factors b) - primePrefix (a, b) | null a = (a, primePrefix b) - | otherwise = (primePrefix a, mempty) - primeSuffix (a, b) | null b = (primeSuffix a, b) - | otherwise = (mempty, primeSuffix b) - splitPrimePrefix (a, b) = case (splitPrimePrefix a, splitPrimePrefix b) - of (Just (ap, as), _) -> Just ((ap, mempty), (as, b)) - (Nothing, Just (bp, bs)) -> Just ((a, bp), (a, bs)) - (Nothing, Nothing) -> Nothing - splitPrimeSuffix (a, b) = case (splitPrimeSuffix a, splitPrimeSuffix b) - of (_, Just (bp, bs)) -> Just ((a, bp), (mempty, bs)) - (Just (ap, as), Nothing) -> Just ((ap, b), (as, b)) - (Nothing, Nothing) -> Nothing - inits (a, b) = List.map (flip (,) mempty) (inits a) ++ List.map ((,) a) (List.tail $ inits b) - tails (a, b) = List.map (flip (,) b) (tails a) ++ List.map ((,) mempty) (List.tail $ tails b) - foldl f a0 (x, y) = foldl f2 (foldl f1 a0 x) y - where f1 a = f a . fromFst - f2 a = f a . fromSnd - foldl' f a0 (x, y) = a' `seq` foldl' f2 a' y - where f1 a = f a . fromFst - f2 a = f a . fromSnd - a' = foldl' f1 a0 x - foldr f a (x, y) = foldr (f . fromFst) (foldr (f . fromSnd) a y) x - foldMap f (x, y) = foldMap (f . fromFst) x `mappend` foldMap (f . fromSnd) y - length (a, b) = length a + length b - span p (x, y) = ((xp, yp), (xs, ys)) - where (xp, xs) = span (p . fromFst) x - (yp, ys) | null xs = span (p . fromSnd) y - | otherwise = (mempty, y) - spanMaybe s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2) - | otherwise = ((xp, mempty), (xs, y), s1) - where (xp, xs, s1) = spanMaybe s0 (\s-> f s . fromFst) x - (yp, ys, s2) = spanMaybe s1 (\s-> f s . fromSnd) y - spanMaybe' s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2) - | otherwise = ((xp, mempty), (xs, y), s1) - where (xp, xs, s1) = spanMaybe' s0 (\s-> f s . fromFst) x - (yp, ys, s2) = spanMaybe' s1 (\s-> f s . fromSnd) y - split p (x0, y0) = fst $ List.foldr combine (ys, False) xs - where xs = List.map fromFst $ split (p . fromFst) x0 - ys = List.map fromSnd $ split (p . fromSnd) y0 - combine x (~(y:rest), False) = (mappend x y : rest, True) - combine x (rest, True) = (x:rest, True) - splitAt n (x, y) = ((xp, yp), (xs, ys)) - where (xp, xs) = splitAt n x - (yp, ys) | null xs = splitAt (n - length x) y - | otherwise = (mempty, y) - reverse (a, b) = (reverse a, reverse b) - -{-# INLINE fromFst #-} -fromFst :: Monoid b => a -> (a, b) -fromFst a = (a, mempty) - -{-# INLINE fromSnd #-} -fromSnd :: Monoid a => b -> (a, b) -fromSnd b = (mempty, b) - -instance FactorialMonoid [x] where - factors xs = List.map (:[]) xs - primePrefix [] = [] - primePrefix (x:_) = [x] - primeSuffix [] = [] - primeSuffix xs = [List.last xs] - splitPrimePrefix [] = Nothing - splitPrimePrefix (x:xs) = Just ([x], xs) - splitPrimeSuffix [] = Nothing - splitPrimeSuffix xs = Just (splitLast id xs) - where splitLast f last@[_] = (f [], last) - splitLast f ~(x:rest) = splitLast (f . (x:)) rest - inits = List.inits - tails = List.tails - foldl _ a [] = a - foldl f a (x:xs) = foldl f (f a [x]) xs - foldl' _ a [] = a - foldl' f a (x:xs) = let a' = f a [x] in a' `seq` foldl' f a' xs - foldr _ f0 [] = f0 - foldr f f0 (x:xs) = f [x] (foldr f f0 xs) - length = List.length - foldMap f = mconcat . List.map (f . (:[])) - break f = List.break (f . (:[])) - span f = List.span (f . (:[])) - dropWhile f = List.dropWhile (f . (:[])) - takeWhile f = List.takeWhile (f . (:[])) - spanMaybe s0 f l = (prefix' [], suffix' [], s') - where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l - g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = (prefix . (x:), id, s2, True) - | otherwise = (prefix, suffix . (x:), s1, False) - spanMaybe' s0 f l = (prefix' [], suffix' [], s') - where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l - g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = seq s2 $ (prefix . (x:), id, s2, True) - | otherwise = (prefix, suffix . (x:), s1, False) - splitAt = List.splitAt - drop = List.drop - take = List.take - reverse = List.reverse - -instance FactorialMonoid ByteString.ByteString where - factors x = factorize (ByteString.length x) x - where factorize 0 _ = [] - factorize n xs = xs1 : factorize (pred n) xs' - where (xs1, xs') = ByteString.splitAt 1 xs - primePrefix = ByteString.take 1 - primeSuffix x = ByteString.drop (ByteString.length x - 1) x - splitPrimePrefix x = if ByteString.null x then Nothing else Just (ByteString.splitAt 1 x) - splitPrimeSuffix x = if ByteString.null x then Nothing else Just (ByteString.splitAt (ByteString.length x - 1) x) - inits = ByteString.inits - tails = ByteString.tails - foldl f = ByteString.foldl f' - where f' a byte = f a (ByteString.singleton byte) - foldl' f = ByteString.foldl' f' - where f' a byte = f a (ByteString.singleton byte) - foldr f = ByteString.foldr (f . ByteString.singleton) - break f = ByteString.break (f . ByteString.singleton) - span f = ByteString.span (f . ByteString.singleton) - spanMaybe s0 f b = case ByteString.foldr g id b (0, s0) - of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s') - where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ cont (i', s') - | otherwise = (i, s) - spanMaybe' s0 f b = case ByteString.foldr g id b (0, s0) - of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s') - where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') - | otherwise = (i, s) - dropWhile f = ByteString.dropWhile (f . ByteString.singleton) - takeWhile f = ByteString.takeWhile (f . ByteString.singleton) - length = ByteString.length - split f = ByteString.splitWith f' - where f' = f . ByteString.singleton - splitAt = ByteString.splitAt - drop = ByteString.drop - take = ByteString.take - reverse = ByteString.reverse - -instance FactorialMonoid LazyByteString.ByteString where - factors x = factorize (LazyByteString.length x) x - where factorize 0 _ = [] - factorize n xs = xs1 : factorize (pred n) xs' - where (xs1, xs') = LazyByteString.splitAt 1 xs - primePrefix = LazyByteString.take 1 - primeSuffix x = LazyByteString.drop (LazyByteString.length x - 1) x - splitPrimePrefix x = if LazyByteString.null x then Nothing - else Just (LazyByteString.splitAt 1 x) - splitPrimeSuffix x = if LazyByteString.null x then Nothing - else Just (LazyByteString.splitAt (LazyByteString.length x - 1) x) - inits = LazyByteString.inits - tails = LazyByteString.tails - foldl f = LazyByteString.foldl f' - where f' a byte = f a (LazyByteString.singleton byte) - foldl' f = LazyByteString.foldl' f' - where f' a byte = f a (LazyByteString.singleton byte) - foldr f = LazyByteString.foldr f' - where f' byte a = f (LazyByteString.singleton byte) a - length = fromIntegral . LazyByteString.length - break f = LazyByteString.break (f . LazyByteString.singleton) - span f = LazyByteString.span (f . LazyByteString.singleton) - spanMaybe s0 f b = case LazyByteString.foldr g id b (0, s0) - of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s') - where g w cont (i, s) | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ cont (i', s') - | otherwise = (i, s) - spanMaybe' s0 f b = case LazyByteString.foldr g id b (0, s0) - of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s') - where g w cont (i, s) - | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s') - | otherwise = (i, s) - dropWhile f = LazyByteString.dropWhile (f . LazyByteString.singleton) - takeWhile f = LazyByteString.takeWhile (f . LazyByteString.singleton) - split f = LazyByteString.splitWith f' - where f' = f . LazyByteString.singleton - splitAt = LazyByteString.splitAt . fromIntegral - drop n = LazyByteString.drop (fromIntegral n) - take n = LazyByteString.take (fromIntegral n) - reverse = LazyByteString.reverse - -instance FactorialMonoid Text.Text where - factors = Text.chunksOf 1 - primePrefix = Text.take 1 - primeSuffix x = if Text.null x then Text.empty else Text.singleton (Text.last x) - splitPrimePrefix = fmap (first Text.singleton) . Text.uncons - splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.init x, Text.singleton (Text.last x)) - inits = Text.inits - tails = Text.tails - foldl f = Text.foldl f' - where f' a char = f a (Text.singleton char) - foldl' f = Text.foldl' f' - where f' a char = f a (Text.singleton char) - foldr f = Text.foldr f' - where f' char a = f (Text.singleton char) a - length = Text.length - span f = Text.span (f . Text.singleton) - break f = Text.break (f . Text.singleton) - dropWhile f = Text.dropWhile (f . Text.singleton) - takeWhile f = Text.takeWhile (f . Text.singleton) - spanMaybe s0 f t = case Text.foldr g id t (0, s0) - of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') - where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ cont (i', s') - | otherwise = (i, s) - spanMaybe' s0 f t = case Text.foldr g id t (0, s0) - of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') - where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') - | otherwise = (i, s) - split f = Text.split f' - where f' = f . Text.singleton - splitAt = Text.splitAt - drop = Text.drop - take = Text.take - reverse = Text.reverse - -instance FactorialMonoid LazyText.Text where - factors = LazyText.chunksOf 1 - primePrefix = LazyText.take 1 - primeSuffix x = if LazyText.null x then LazyText.empty else LazyText.singleton (LazyText.last x) - splitPrimePrefix = fmap (first LazyText.singleton) . LazyText.uncons - splitPrimeSuffix x = if LazyText.null x - then Nothing - else Just (LazyText.init x, LazyText.singleton (LazyText.last x)) - inits = LazyText.inits - tails = LazyText.tails - foldl f = LazyText.foldl f' - where f' a char = f a (LazyText.singleton char) - foldl' f = LazyText.foldl' f' - where f' a char = f a (LazyText.singleton char) - foldr f = LazyText.foldr f' - where f' char a = f (LazyText.singleton char) a - length = fromIntegral . LazyText.length - span f = LazyText.span (f . LazyText.singleton) - break f = LazyText.break (f . LazyText.singleton) - dropWhile f = LazyText.dropWhile (f . LazyText.singleton) - takeWhile f = LazyText.takeWhile (f . LazyText.singleton) - spanMaybe s0 f t = case LazyText.foldr g id t (0, s0) - of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') - where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ cont (i', s') - | otherwise = (i, s) - spanMaybe' s0 f t = case LazyText.foldr g id t (0, s0) - of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') - where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s') - | otherwise = (i, s) - split f = LazyText.split f' - where f' = f . LazyText.singleton - splitAt = LazyText.splitAt . fromIntegral - drop n = LazyText.drop (fromIntegral n) - take n = LazyText.take (fromIntegral n) - reverse = LazyText.reverse - -instance Ord k => FactorialMonoid (Map.Map k v) where - factors = List.map (uncurry Map.singleton) . Map.toAscList - primePrefix map | Map.null map = map - | otherwise = uncurry Map.singleton $ Map.findMin map - primeSuffix map | Map.null map = map - | otherwise = uncurry Map.singleton $ Map.findMax map - splitPrimePrefix = fmap singularize . Map.minViewWithKey - where singularize ((k, v), rest) = (Map.singleton k v, rest) - splitPrimeSuffix = fmap singularize . Map.maxViewWithKey - where singularize ((k, v), rest) = (rest, Map.singleton k v) - foldl f = Map.foldlWithKey f' - where f' a k v = f a (Map.singleton k v) - foldl' f = Map.foldlWithKey' f' - where f' a k v = f a (Map.singleton k v) - foldr f = Map.foldrWithKey f' - where f' k v a = f (Map.singleton k v) a - length = Map.size - reverse = id - -instance FactorialMonoid (IntMap.IntMap a) where - factors = List.map (uncurry IntMap.singleton) . IntMap.toAscList - primePrefix map | IntMap.null map = map - | otherwise = uncurry IntMap.singleton $ IntMap.findMin map - primeSuffix map | IntMap.null map = map - | otherwise = uncurry IntMap.singleton $ IntMap.findMax map - splitPrimePrefix = fmap singularize . IntMap.minViewWithKey - where singularize ((k, v), rest) = (IntMap.singleton k v, rest) - splitPrimeSuffix = fmap singularize . IntMap.maxViewWithKey - where singularize ((k, v), rest) = (rest, IntMap.singleton k v) - foldl f = IntMap.foldlWithKey f' - where f' a k v = f a (IntMap.singleton k v) - foldl' f = IntMap.foldlWithKey' f' - where f' a k v = f a (IntMap.singleton k v) - foldr f = IntMap.foldrWithKey f' - where f' k v a = f (IntMap.singleton k v) a - length = IntMap.size - reverse = id - -instance FactorialMonoid IntSet.IntSet where - factors = List.map IntSet.singleton . IntSet.toAscList - primePrefix set | IntSet.null set = set - | otherwise = IntSet.singleton $ IntSet.findMin set - primeSuffix set | IntSet.null set = set - | otherwise = IntSet.singleton $ IntSet.findMax set - splitPrimePrefix = fmap singularize . IntSet.minView - where singularize (min, rest) = (IntSet.singleton min, rest) - splitPrimeSuffix = fmap singularize . IntSet.maxView - where singularize (max, rest) = (rest, IntSet.singleton max) - foldl f = IntSet.foldl f' - where f' a b = f a (IntSet.singleton b) - foldl' f = IntSet.foldl' f' - where f' a b = f a (IntSet.singleton b) - foldr f = IntSet.foldr f' - where f' a b = f (IntSet.singleton a) b - length = IntSet.size - reverse = id - -instance FactorialMonoid (Sequence.Seq a) where - factors = List.map Sequence.singleton . Foldable.toList - primePrefix = Sequence.take 1 - primeSuffix q = Sequence.drop (Sequence.length q - 1) q - splitPrimePrefix q = case Sequence.viewl q - of Sequence.EmptyL -> Nothing - hd Sequence.:< rest -> Just (Sequence.singleton hd, rest) - splitPrimeSuffix q = case Sequence.viewr q - of Sequence.EmptyR -> Nothing - rest Sequence.:> last -> Just (rest, Sequence.singleton last) - inits = Foldable.toList . Sequence.inits - tails = Foldable.toList . Sequence.tails - foldl f = Foldable.foldl f' - where f' a b = f a (Sequence.singleton b) - foldl' f = Foldable.foldl' f' - where f' a b = f a (Sequence.singleton b) - foldr f = Foldable.foldr f' - where f' a b = f (Sequence.singleton a) b - span f = Sequence.spanl (f . Sequence.singleton) - break f = Sequence.breakl (f . Sequence.singleton) - dropWhile f = Sequence.dropWhileL (f . Sequence.singleton) - takeWhile f = Sequence.takeWhileL (f . Sequence.singleton) - spanMaybe s0 f b = case Foldable.foldr g id b (0, s0) - of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') - where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ cont (i', s') - | otherwise = (i, s) - spanMaybe' s0 f b = case Foldable.foldr g id b (0, s0) - of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') - where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') - | otherwise = (i, s) - splitAt = Sequence.splitAt - drop = Sequence.drop - take = Sequence.take - length = Sequence.length - reverse = Sequence.reverse - -instance Ord a => FactorialMonoid (Set.Set a) where - factors = List.map Set.singleton . Set.toAscList - primePrefix set | Set.null set = set - | otherwise = Set.singleton $ Set.findMin set - primeSuffix set | Set.null set = set - | otherwise = Set.singleton $ Set.findMax set - splitPrimePrefix = fmap singularize . Set.minView - where singularize (min, rest) = (Set.singleton min, rest) - splitPrimeSuffix = fmap singularize . Set.maxView - where singularize (max, rest) = (rest, Set.singleton max) - foldl f = Foldable.foldl f' - where f' a b = f a (Set.singleton b) - foldl' f = Foldable.foldl' f' - where f' a b = f a (Set.singleton b) - foldr f = Foldable.foldr f' - where f' a b = f (Set.singleton a) b - length = Set.size - reverse = id - -instance FactorialMonoid (Vector.Vector a) where - factors x = factorize (Vector.length x) x - where factorize 0 _ = [] - factorize n xs = xs1 : factorize (pred n) xs' - where (xs1, xs') = Vector.splitAt 1 xs - primePrefix = Vector.take 1 - primeSuffix x = Vector.drop (Vector.length x - 1) x - splitPrimePrefix x = if Vector.null x then Nothing else Just (Vector.splitAt 1 x) - splitPrimeSuffix x = if Vector.null x then Nothing else Just (Vector.splitAt (Vector.length x - 1) x) - inits x0 = initsWith x0 [] - where initsWith x rest | Vector.null x = x:rest - | otherwise = initsWith (Vector.unsafeInit x) (x:rest) - tails x = x : if Vector.null x then [] else tails (Vector.unsafeTail x) - foldl f = Vector.foldl f' - where f' a byte = f a (Vector.singleton byte) - foldl' f = Vector.foldl' f' - where f' a byte = f a (Vector.singleton byte) - foldr f = Vector.foldr f' - where f' byte a = f (Vector.singleton byte) a - break f = Vector.break (f . Vector.singleton) - span f = Vector.span (f . Vector.singleton) - dropWhile f = Vector.dropWhile (f . Vector.singleton) - takeWhile f = Vector.takeWhile (f . Vector.singleton) - spanMaybe s0 f v = case Vector.ifoldr g Left v s0 - of Left s' -> (v, Vector.empty, s') - Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') - where g i x cont s | Just s' <- f s (Vector.singleton x) = cont s' - | otherwise = Right (i, s) - spanMaybe' s0 f v = case Vector.ifoldr' g Left v s0 - of Left s' -> (v, Vector.empty, s') - Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') - where g i x cont s | Just s' <- f s (Vector.singleton x) = seq s' (cont s') - | otherwise = Right (i, s) - splitAt = Vector.splitAt - drop = Vector.drop - take = Vector.take - length = Vector.length - reverse = Vector.reverse - -instance StableFactorialMonoid () -instance StableFactorialMonoid a => StableFactorialMonoid (Dual a) -instance StableFactorialMonoid [x] -instance StableFactorialMonoid ByteString.ByteString -instance StableFactorialMonoid LazyByteString.ByteString -instance StableFactorialMonoid Text.Text -instance StableFactorialMonoid LazyText.Text -instance StableFactorialMonoid (Sequence.Seq a) -instance StableFactorialMonoid (Vector.Vector a) - --- | A 'Monad.mapM' equivalent. -mapM :: (FactorialMonoid a, Monoid b, Monad m) => (a -> m b) -> a -> m b -mapM f = ($ return mempty) . appEndo . foldMap (Endo . Monad.liftM2 mappend . f) - --- | A 'Monad.mapM_' equivalent. -mapM_ :: (FactorialMonoid a, Monad m) => (a -> m b) -> a -> m () -mapM_ f = foldr ((>>) . f) (return ()) diff --git a/tests/examples/Undefined11.hs b/tests/examples/Undefined11.hs deleted file mode 100644 --- a/tests/examples/Undefined11.hs +++ /dev/null @@ -1,423 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Algebra.Additive ( - -- * Class - C, - zero, - (+), (-), - negate, subtract, - - -- * Complex functions - sum, sum1, - sumNestedAssociative, - sumNestedCommutative, - - -- * Instance definition helpers - elementAdd, elementSub, elementNeg, - (<*>.+), (<*>.-), (<*>.-$), - - -- * Instances for atomic types - propAssociative, - propCommutative, - propIdentity, - propInverse, - ) where - -import qualified Algebra.Laws as Laws - -import Data.Int (Int, Int8, Int16, Int32, Int64, ) -import Data.Word (Word, Word8, Word16, Word32, Word64, ) - -import qualified NumericPrelude.Elementwise as Elem -import Control.Applicative (Applicative(pure, (<*>)), ) -import Data.Tuple.HT (fst3, snd3, thd3, ) -import qualified Data.List.Match as Match - -import qualified Data.Complex as Complex98 -import qualified Data.Ratio as Ratio98 -import qualified Prelude as P -import Prelude (Integer, Float, Double, fromInteger, ) -import NumericPrelude.Base - - -infixl 6 +, - - -{- | -Additive a encapsulates the notion of a commutative group, specified -by the following laws: - -@ - a + b === b + a - (a + b) + c === a + (b + c) - zero + a === a - a + negate a === 0 -@ - -Typical examples include integers, dollars, and vectors. - -Minimal definition: '+', 'zero', and ('negate' or '(-)') --} - -class C a where - {-# MINIMAL zero, (+), ((-) | negate) #-} - -- | zero element of the vector space - zero :: a - -- | add and subtract elements - (+), (-) :: a -> a -> a - -- | inverse with respect to '+' - negate :: a -> a - - {-# INLINE negate #-} - negate a = zero - a - {-# INLINE (-) #-} - a - b = a + negate b - -{- | -'subtract' is @(-)@ with swapped operand order. -This is the operand order which will be needed in most cases -of partial application. --} -subtract :: C a => a -> a -> a -subtract = flip (-) - - - - -{- | -Sum up all elements of a list. -An empty list yields zero. - -This function is inappropriate for number types like Peano. -Maybe we should make 'sum' a method of Additive. -This would also make 'lengthLeft' and 'lengthRight' superfluous. --} -sum :: (C a) => [a] -> a -sum = foldl (+) zero - -{- | -Sum up all elements of a non-empty list. -This avoids including a zero which is useful for types -where no universal zero is available. --} -sum1 :: (C a) => [a] -> a -sum1 = foldl1 (+) - - -{- | -Sum the operands in an order, -such that the dependencies are minimized. -Does this have a measurably effect on speed? - -Requires associativity. --} -sumNestedAssociative :: (C a) => [a] -> a -sumNestedAssociative [] = zero -sumNestedAssociative [x] = x -sumNestedAssociative xs = sumNestedAssociative (sum2 xs) - -{- -Make sure that the last entries in the list -are equally often part of an addition. -Maybe this can reduce rounding errors. -The list that sum2 computes is a breadth-first-flattened binary tree. - -Requires associativity and commutativity. --} -sumNestedCommutative :: (C a) => [a] -> a -sumNestedCommutative [] = zero -sumNestedCommutative xs@(_:rs) = - let ys = xs ++ Match.take rs (sum2 ys) - in last ys - -_sumNestedCommutative :: (C a) => [a] -> a -_sumNestedCommutative [] = zero -_sumNestedCommutative xs@(_:rs) = - let ys = xs ++ take (length rs) (sum2 ys) - in last ys - -{- -[a,b,c, a+b,c+(a+b)] -[a,b,c,d, a+b,c+d,(a+b)+(c+d)] -[a,b,c,d,e, a+b,c+d,e+(a+b),(c+d)+e+(a+b)] -[a,b,c,d,e,f, a+b,c+d,e+f,(a+b)+(c+d),(e+f)+((a+b)+(c+d))] --} - -sum2 :: (C a) => [a] -> [a] -sum2 (x:y:rest) = (x+y) : sum2 rest -sum2 xs = xs - - - -{- | -Instead of baking the add operation into the element function, -we could use higher rank types -and pass a generic @uncurry (+)@ to the run function. -We do not do so in order to stay Haskell 98 -at least for parts of NumericPrelude. --} -{-# INLINE elementAdd #-} -elementAdd :: - (C x) => - (v -> x) -> Elem.T (v,v) x -elementAdd f = - Elem.element (\(x,y) -> f x + f y) - -{-# INLINE elementSub #-} -elementSub :: - (C x) => - (v -> x) -> Elem.T (v,v) x -elementSub f = - Elem.element (\(x,y) -> f x - f y) - -{-# INLINE elementNeg #-} -elementNeg :: - (C x) => - (v -> x) -> Elem.T v x -elementNeg f = - Elem.element (negate . f) - - --- like <*> -infixl 4 <*>.+, <*>.-, <*>.-$ - -{- | -> addPair :: (Additive.C a, Additive.C b) => (a,b) -> (a,b) -> (a,b) -> addPair = Elem.run2 $ Elem.with (,) <*>.+ fst <*>.+ snd --} -{-# INLINE (<*>.+) #-} -(<*>.+) :: - (C x) => - Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a -(<*>.+) f acc = - f <*> elementAdd acc - -{-# INLINE (<*>.-) #-} -(<*>.-) :: - (C x) => - Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a -(<*>.-) f acc = - f <*> elementSub acc - -{-# INLINE (<*>.-$) #-} -(<*>.-$) :: - (C x) => - Elem.T v (x -> a) -> (v -> x) -> Elem.T v a -(<*>.-$) f acc = - f <*> elementNeg acc - - --- * Instances for atomic types - -instance C Integer where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Float where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Double where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - - -instance C Int where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Int8 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Int16 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Int32 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Int64 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - - -instance C Word where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Word8 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Word16 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Word32 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - -instance C Word64 where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - negate = P.negate - (+) = (P.+) - (-) = (P.-) - - - - --- * Instances for composed types - -instance (C v0, C v1) => C (v0, v1) where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = (,) zero zero - (+) = Elem.run2 $ pure (,) <*>.+ fst <*>.+ snd - (-) = Elem.run2 $ pure (,) <*>.- fst <*>.- snd - negate = Elem.run $ pure (,) <*>.-$ fst <*>.-$ snd - -instance (C v0, C v1, C v2) => C (v0, v1, v2) where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = (,,) zero zero zero - (+) = Elem.run2 $ pure (,,) <*>.+ fst3 <*>.+ snd3 <*>.+ thd3 - (-) = Elem.run2 $ pure (,,) <*>.- fst3 <*>.- snd3 <*>.- thd3 - negate = Elem.run $ pure (,,) <*>.-$ fst3 <*>.-$ snd3 <*>.-$ thd3 - - -instance (C v) => C [v] where - zero = [] - negate = map negate - (+) (x:xs) (y:ys) = (+) x y : (+) xs ys - (+) xs [] = xs - (+) [] ys = ys - (-) (x:xs) (y:ys) = (-) x y : (-) xs ys - (-) xs [] = xs - (-) [] ys = negate ys - - -instance (C v) => C (b -> v) where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero _ = zero - (+) f g x = (+) (f x) (g x) - (-) f g x = (-) (f x) (g x) - negate f x = negate (f x) - --- * Properties - -propAssociative :: (Eq a, C a) => a -> a -> a -> Bool -propCommutative :: (Eq a, C a) => a -> a -> Bool -propIdentity :: (Eq a, C a) => a -> Bool -propInverse :: (Eq a, C a) => a -> Bool - -propCommutative = Laws.commutative (+) -propAssociative = Laws.associative (+) -propIdentity = Laws.identity (+) zero -propInverse = Laws.inverse (+) negate zero - - - --- legacy - -instance (P.Integral a) => C (Ratio98.Ratio a) where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - (+) = (P.+) - (-) = (P.-) - negate = P.negate - -instance (P.RealFloat a) => C (Complex98.Complex a) where - {-# INLINE zero #-} - {-# INLINE negate #-} - {-# INLINE (+) #-} - {-# INLINE (-) #-} - zero = P.fromInteger 0 - (+) = (P.+) - (-) = (P.-) - negate = P.negate diff --git a/tests/examples/Undefined13.hs b/tests/examples/Undefined13.hs deleted file mode 100644 --- a/tests/examples/Undefined13.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Network.TigHTTP.Papillon ( - ContentType(..), Type(..), Subtype(..), Parameter(..), Charset(..), - parseContentType, showContentType, -) where - -import Data.Char -import Text.Papillon - -import Data.ByteString (ByteString) -import Data.ByteString.Char8 (pack) -import qualified Data.ByteString as BS - -import Network.TigHTTP.Token - -data ContentType = ContentType Type Subtype [Parameter] - deriving (Show, Eq) - -parseContentType :: BS.ByteString -> ContentType -parseContentType ct = case runError . contentType $ parse ct of - Left _ -> error "parseContentType" - Right (r, _) -> r - -showContentType :: ContentType -> BS.ByteString -showContentType (ContentType t st ps) = showType t - `BS.append` "/" - `BS.append` showSubtype st - `BS.append` showParameters ps - -data Type - = Text - | TypeRaw BS.ByteString - deriving (Show, Eq) - -mkType :: BS.ByteString -> Type -mkType "text" = Text -mkType t = TypeRaw t - -showType :: Type -> BS.ByteString -showType Text = "text" -showType (TypeRaw t) = t - -data Subtype - = Plain - | Html - | Css - | SubtypeRaw BS.ByteString - deriving (Show, Eq) - -mkSubtype :: BS.ByteString -> Subtype -mkSubtype "html" = Html -mkSubtype "plain" = Plain -mkSubtype "css" = Css -mkSubtype s = SubtypeRaw s - -showSubtype :: Subtype -> BS.ByteString -showSubtype Plain = "plain" -showSubtype Html = "html" -showSubtype Css = "css" -showSubtype (SubtypeRaw s) = s - -data Parameter - = Charset Charset - | ParameterRaw BS.ByteString BS.ByteString - deriving (Show, Eq) - -mkParameter :: BS.ByteString -> BS.ByteString -> Parameter -mkParameter "charset" "UTF-8" = Charset Utf8 -mkParameter "charset" v = Charset $ CharsetRaw v -mkParameter a v = ParameterRaw a v - -showParameters :: [Parameter] -> BS.ByteString -showParameters [] = "" -showParameters (Charset v : ps) = "; " `BS.append` "charset" - `BS.append` "=" `BS.append` showCharset v `BS.append` showParameters ps -showParameters (ParameterRaw a v : ps) = "; " `BS.append` a - `BS.append` "=" `BS.append` v `BS.append` showParameters ps - -data Charset - = Utf8 - | CharsetRaw BS.ByteString - deriving (Show, Eq) - -showCharset :: Charset -> BS.ByteString -showCharset Utf8 = "UTF-8" -showCharset (CharsetRaw cs) = cs - -bsconcat :: [ByteString] -> ByteString -bsconcat = BS.concat - -[papillon| - -source: ByteString - -contentType :: ContentType - = c:token '/' sc:token ps:(';' ' '* p:parameter { p })* - { ContentType (mkType c) (mkSubtype sc) ps } - -token :: ByteString - = t:+ { pack t } - -quotedString :: ByteString - = '"' t:(qt:qdtext { qt } / qp:quotedPair { pack [qp] })* '"' - { bsconcat t } - -quotedPair :: Char - = '\\' c: { c } - -crlf :: () = '\r' '\n' - -lws :: () = _:crlf _:(' ' / '\t')+ - --- text :: ByteString --- = ts:(cs:+ { cs } / _:lws { " " })+ { pack $ concat ts } - -qdtext :: ByteString - = ts:(cs:+ { cs } / _:lws { " " })+ { pack $ concat ts } - -parameter :: Parameter - = a:attribute '=' v:value { mkParameter a v } - -attribute :: ByteString = t:token { t } - -value :: ByteString - = t:token { t } - / qs:quotedString { qs } - -|] diff --git a/tests/examples/Undefined2.hs b/tests/examples/Undefined2.hs deleted file mode 100644 --- a/tests/examples/Undefined2.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE Safe #-} - ------------------------------------------------------------------------------ --- | --- Module : Control.Monad.Zip --- Copyright : (c) Nils Schweinsberg 2011, --- (c) George Giorgidze 2011 --- (c) University Tuebingen 2011 --- License : BSD-style (see the file libraries/base/LICENSE) --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Monadic zipping (used for monad comprehensions) --- ------------------------------------------------------------------------------ - -module Control.Monad.Zip where - -import Prelude -import Control.Monad (liftM) - --- | `MonadZip` type class. Minimal definition: `mzip` or `mzipWith` --- --- Instances should satisfy the laws: --- --- * Naturality : --- --- > liftM (f *** g) (mzip ma mb) = mzip (liftM f ma) (liftM g mb) --- --- * Information Preservation: --- --- > liftM (const ()) ma = liftM (const ()) mb --- > ==> --- > munzip (mzip ma mb) = (ma, mb) --- -class Monad m => MonadZip m where - - mzip :: m a -> m b -> m (a,b) - mzip = mzipWith (,) - - mzipWith :: (a -> b -> c) -> m a -> m b -> m c - mzipWith f ma mb = liftM (uncurry f) (mzip ma mb) - - munzip :: m (a,b) -> (m a, m b) - munzip mab = (liftM fst mab, liftM snd mab) - -- munzip is a member of the class because sometimes - -- you can implement it more efficiently than the - -- above default code. See Trac #4370 comment by giorgidze - {-# MINIMAL mzip | mzipWith #-} - -instance MonadZip [] where - mzip = zip - mzipWith = zipWith - munzip = unzip - diff --git a/tests/examples/Undefined3.hs b/tests/examples/Undefined3.hs deleted file mode 100644 --- a/tests/examples/Undefined3.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Foldable --- Copyright : Ross Paterson 2005 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Class of data structures that can be folded to a summary value. --- --- Many of these functions generalize "Prelude", "Control.Monad" and --- "Data.List" functions of the same names from lists to any 'Foldable' --- functor. To avoid ambiguity, either import those modules hiding --- these names or qualify uses of these function names with an alias --- for this module. --- ------------------------------------------------------------------------------ - -module Data.Foldable ( - -- * Folds - Foldable(..), - -- ** Special biased folds - foldrM, - foldlM, - -- ** Folding actions - -- *** Applicative actions - traverse_, - for_, - sequenceA_, - asum, - -- *** Monadic actions - mapM_, - forM_, - sequence_, - msum, - -- ** Specialized folds - toList, - concat, - concatMap, - and, - or, - any, - all, - sum, - product, - maximum, - maximumBy, - minimum, - minimumBy, - -- ** Searches - elem, - notElem, - find - ) where - -import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_, - elem, notElem, concat, concatMap, and, or, any, all, - sum, product, maximum, minimum) -import qualified Prelude (foldl, foldr, foldl1, foldr1) -import qualified Data.List as List (foldl') -import Control.Applicative -import Control.Monad (MonadPlus(..)) -import Data.Maybe (fromMaybe, listToMaybe) -import Data.Monoid -import Data.Proxy - -import GHC.Exts (build) -import GHC.Arr - --- | Data structures that can be folded. --- --- Minimal complete definition: 'foldMap' or 'foldr'. --- --- For example, given a data type --- --- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) --- --- a suitable instance would be --- --- > instance Foldable Tree where --- > foldMap f Empty = mempty --- > foldMap f (Leaf x) = f x --- > foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r --- --- This is suitable even for abstract types, as the monoid is assumed --- to satisfy the monoid laws. Alternatively, one could define @foldr@: --- --- > instance Foldable Tree where --- > foldr f z Empty = z --- > foldr f z (Leaf x) = f x z --- > foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l --- -class Foldable t where - -- | Combine the elements of a structure using a monoid. - fold :: Monoid m => t m -> m - fold = foldMap id - - -- | Map each element of the structure to a monoid, - -- and combine the results. - foldMap :: Monoid m => (a -> m) -> t a -> m - foldMap f = foldr (mappend . f) mempty - - -- | Right-associative fold of a structure. - -- - -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@ - foldr :: (a -> b -> b) -> b -> t a -> b - foldr f z t = appEndo (foldMap (Endo . f) t) z - - -- | Right-associative fold of a structure, - -- but with strict application of the operator. - foldr' :: (a -> b -> b) -> b -> t a -> b - foldr' f z0 xs = foldl f' id xs z0 - where f' k x z = k $! f x z - - -- | Left-associative fold of a structure. - -- - -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@ - foldl :: (b -> a -> b) -> b -> t a -> b - foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z - - -- | Left-associative fold of a structure. - -- but with strict application of the operator. - -- - -- @'foldl' f z = 'List.foldl'' f z . 'toList'@ - foldl' :: (b -> a -> b) -> b -> t a -> b - foldl' f z0 xs = foldr f' id xs z0 - where f' x k z = k $! f z x - - -- | A variant of 'foldr' that has no base case, - -- and thus may only be applied to non-empty structures. - -- - -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@ - foldr1 :: (a -> a -> a) -> t a -> a - foldr1 f xs = fromMaybe (error "foldr1: empty structure") - (foldr mf Nothing xs) - where - mf x Nothing = Just x - mf x (Just y) = Just (f x y) - - -- | A variant of 'foldl' that has no base case, - -- and thus may only be applied to non-empty structures. - -- - -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@ - foldl1 :: (a -> a -> a) -> t a -> a - foldl1 f xs = fromMaybe (error "foldl1: empty structure") - (foldl mf Nothing xs) - where - mf Nothing y = Just y - mf (Just x) y = Just (f x y) - {-# MINIMAL foldMap | foldr #-} - --- instances for Prelude types - -instance Foldable Maybe where - foldr _ z Nothing = z - foldr f z (Just x) = f x z - - foldl _ z Nothing = z - foldl f z (Just x) = f z x - -instance Foldable [] where - foldr = Prelude.foldr - foldl = Prelude.foldl - foldl' = List.foldl' - foldr1 = Prelude.foldr1 - foldl1 = Prelude.foldl1 - -instance Foldable (Either a) where - foldMap _ (Left _) = mempty - foldMap f (Right y) = f y - - foldr _ z (Left _) = z - foldr f z (Right y) = f y z - -instance Foldable ((,) a) where - foldMap f (_, y) = f y - - foldr f z (_, y) = f y z - -instance Ix i => Foldable (Array i) where - foldr f z = Prelude.foldr f z . elems - foldl f z = Prelude.foldl f z . elems - foldr1 f = Prelude.foldr1 f . elems - foldl1 f = Prelude.foldl1 f . elems - -instance Foldable Proxy where - foldMap _ _ = mempty - {-# INLINE foldMap #-} - fold _ = mempty - {-# INLINE fold #-} - foldr _ z _ = z - {-# INLINE foldr #-} - foldl _ z _ = z - {-# INLINE foldl #-} - foldl1 _ _ = error "foldl1: Proxy" - {-# INLINE foldl1 #-} - foldr1 _ _ = error "foldr1: Proxy" - {-# INLINE foldr1 #-} - -instance Foldable (Const m) where - foldMap _ _ = mempty - --- | Monadic fold over the elements of a structure, --- associating to the right, i.e. from right to left. -foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b -foldrM f z0 xs = foldl f' return xs z0 - where f' k x z = f x z >>= k - --- | Monadic fold over the elements of a structure, --- associating to the left, i.e. from left to right. -foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b -foldlM f z0 xs = foldr f' return xs z0 - where f' x k z = f z x >>= k - --- | Map each element of a structure to an action, evaluate --- these actions from left to right, and ignore the results. -traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () -traverse_ f = foldr ((*>) . f) (pure ()) - --- | 'for_' is 'traverse_' with its arguments flipped. -for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f () -{-# INLINE for_ #-} -for_ = flip traverse_ - --- | Map each element of a structure to a monadic action, evaluate --- these actions from left to right, and ignore the results. -mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () -mapM_ f = foldr ((>>) . f) (return ()) - --- | 'forM_' is 'mapM_' with its arguments flipped. -forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m () -{-# INLINE forM_ #-} -forM_ = flip mapM_ - --- | Evaluate each action in the structure from left to right, --- and ignore the results. -sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f () -sequenceA_ = foldr (*>) (pure ()) - --- | Evaluate each monadic action in the structure from left to right, --- and ignore the results. -sequence_ :: (Foldable t, Monad m) => t (m a) -> m () -sequence_ = foldr (>>) (return ()) - --- | The sum of a collection of actions, generalizing 'concat'. -asum :: (Foldable t, Alternative f) => t (f a) -> f a -{-# INLINE asum #-} -asum = foldr (<|>) empty - --- | The sum of a collection of actions, generalizing 'concat'. -msum :: (Foldable t, MonadPlus m) => t (m a) -> m a -{-# INLINE msum #-} -msum = foldr mplus mzero - --- These use foldr rather than foldMap to avoid repeated concatenation. - --- | List of elements of a structure. -toList :: Foldable t => t a -> [a] -{-# INLINE toList #-} -toList t = build (\ c n -> foldr c n t) - --- | The concatenation of all the elements of a container of lists. -concat :: Foldable t => t [a] -> [a] -concat = fold - --- | Map a function over all the elements of a container and concatenate --- the resulting lists. -concatMap :: Foldable t => (a -> [b]) -> t a -> [b] -concatMap = foldMap - --- | 'and' returns the conjunction of a container of Bools. For the --- result to be 'True', the container must be finite; 'False', however, --- results from a 'False' value finitely far from the left end. -and :: Foldable t => t Bool -> Bool -and = getAll . foldMap All - --- | 'or' returns the disjunction of a container of Bools. For the --- result to be 'False', the container must be finite; 'True', however, --- results from a 'True' value finitely far from the left end. -or :: Foldable t => t Bool -> Bool -or = getAny . foldMap Any - --- | Determines whether any element of the structure satisfies the predicate. -any :: Foldable t => (a -> Bool) -> t a -> Bool -any p = getAny . foldMap (Any . p) - --- | Determines whether all elements of the structure satisfy the predicate. -all :: Foldable t => (a -> Bool) -> t a -> Bool -all p = getAll . foldMap (All . p) - --- | The 'sum' function computes the sum of the numbers of a structure. -sum :: (Foldable t, Num a) => t a -> a -sum = getSum . foldMap Sum - --- | The 'product' function computes the product of the numbers of a structure. -product :: (Foldable t, Num a) => t a -> a -product = getProduct . foldMap Product - --- | The largest element of a non-empty structure. -maximum :: (Foldable t, Ord a) => t a -> a -maximum = foldr1 max - --- | The largest element of a non-empty structure with respect to the --- given comparison function. -maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a -maximumBy cmp = foldr1 max' - where max' x y = case cmp x y of - GT -> x - _ -> y - --- | The least element of a non-empty structure. -minimum :: (Foldable t, Ord a) => t a -> a -minimum = foldr1 min - --- | The least element of a non-empty structure with respect to the --- given comparison function. -minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a -minimumBy cmp = foldr1 min' - where min' x y = case cmp x y of - GT -> y - _ -> x - --- | Does the element occur in the structure? -elem :: (Foldable t, Eq a) => a -> t a -> Bool -elem = any . (==) - --- | 'notElem' is the negation of 'elem'. -notElem :: (Foldable t, Eq a) => a -> t a -> Bool -notElem x = not . elem x - --- | The 'find' function takes a predicate and a structure and returns --- the leftmost element of the structure matching the predicate, or --- 'Nothing' if there is no such element. -find :: Foldable t => (a -> Bool) -> t a -> Maybe a -find p = listToMaybe . concatMap (\ x -> if p x then [x] else []) - diff --git a/tests/examples/Undefined4.hs b/tests/examples/Undefined4.hs deleted file mode 100644 --- a/tests/examples/Undefined4.hs +++ /dev/null @@ -1,280 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Traversable --- Copyright : Conor McBride and Ross Paterson 2005 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- Class of data structures that can be traversed from left to right, --- performing an action on each element. --- --- See also --- --- * \"Applicative Programming with Effects\", --- by Conor McBride and Ross Paterson, --- /Journal of Functional Programming/ 18:1 (2008) 1-13, online at --- . --- --- * \"The Essence of the Iterator Pattern\", --- by Jeremy Gibbons and Bruno Oliveira, --- in /Mathematically-Structured Functional Programming/, 2006, online at --- . --- --- * \"An Investigation of the Laws of Traversals\", --- by Mauro Jaskelioff and Ondrej Rypacek, --- in /Mathematically-Structured Functional Programming/, 2012, online at --- . --- --- Note that the functions 'mapM' and 'sequence' generalize "Prelude" --- functions of the same names from lists to any 'Traversable' functor. --- To avoid ambiguity, either import the "Prelude" hiding these names --- or qualify uses of these function names with an alias for this module. --- ------------------------------------------------------------------------------ - -module Data.Traversable ( - -- * The 'Traversable' class - Traversable(..), - -- * Utility functions - for, - forM, - mapAccumL, - mapAccumR, - -- * General definitions for superclass methods - fmapDefault, - foldMapDefault, - ) where - -import Prelude hiding (mapM, sequence, foldr) -import qualified Prelude (mapM, foldr) -import Control.Applicative -import Data.Foldable (Foldable()) -import Data.Monoid (Monoid) -import Data.Proxy - -import GHC.Arr - --- | Functors representing data structures that can be traversed from --- left to right. --- --- Minimal complete definition: 'traverse' or 'sequenceA'. --- --- A definition of 'traverse' must satisfy the following laws: --- --- [/naturality/] --- @t . 'traverse' f = 'traverse' (t . f)@ --- for every applicative transformation @t@ --- --- [/identity/] --- @'traverse' Identity = Identity@ --- --- [/composition/] --- @'traverse' (Compose . 'fmap' g . f) = Compose . 'fmap' ('traverse' g) . 'traverse' f@ --- --- A definition of 'sequenceA' must satisfy the following laws: --- --- [/naturality/] --- @t . 'sequenceA' = 'sequenceA' . 'fmap' t@ --- for every applicative transformation @t@ --- --- [/identity/] --- @'sequenceA' . 'fmap' Identity = Identity@ --- --- [/composition/] --- @'sequenceA' . 'fmap' Compose = Compose . 'fmap' 'sequenceA' . 'sequenceA'@ --- --- where an /applicative transformation/ is a function --- --- @t :: (Applicative f, Applicative g) => f a -> g a@ --- --- preserving the 'Applicative' operations, i.e. --- --- * @t ('pure' x) = 'pure' x@ --- --- * @t (x '<*>' y) = t x '<*>' t y@ --- --- and the identity functor @Identity@ and composition of functors @Compose@ --- are defined as --- --- > newtype Identity a = Identity a --- > --- > instance Functor Identity where --- > fmap f (Identity x) = Identity (f x) --- > --- > instance Applicative Indentity where --- > pure x = Identity x --- > Identity f <*> Identity x = Identity (f x) --- > --- > newtype Compose f g a = Compose (f (g a)) --- > --- > instance (Functor f, Functor g) => Functor (Compose f g) where --- > fmap f (Compose x) = Compose (fmap (fmap f) x) --- > --- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where --- > pure x = Compose (pure (pure x)) --- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) --- --- (The naturality law is implied by parametricity.) --- --- Instances are similar to 'Functor', e.g. given a data type --- --- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) --- --- a suitable instance would be --- --- > instance Traversable Tree where --- > traverse f Empty = pure Empty --- > traverse f (Leaf x) = Leaf <$> f x --- > traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r --- --- This is suitable even for abstract types, as the laws for '<*>' --- imply a form of associativity. --- --- The superclass instances should satisfy the following: --- --- * In the 'Functor' instance, 'fmap' should be equivalent to traversal --- with the identity applicative functor ('fmapDefault'). --- --- * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be --- equivalent to traversal with a constant applicative functor --- ('foldMapDefault'). --- -class (Functor t, Foldable t) => Traversable t where - -- | Map each element of a structure to an action, evaluate - -- these actions from left to right, and collect the results. - traverse :: Applicative f => (a -> f b) -> t a -> f (t b) - traverse f = sequenceA . fmap f - - -- | Evaluate each action in the structure from left to right, - -- and collect the results. - sequenceA :: Applicative f => t (f a) -> f (t a) - sequenceA = traverse id - - -- | Map each element of a structure to a monadic action, evaluate - -- these actions from left to right, and collect the results. - mapM :: Monad m => (a -> m b) -> t a -> m (t b) - mapM f = unwrapMonad . traverse (WrapMonad . f) - - -- | Evaluate each monadic action in the structure from left to right, - -- and collect the results. - sequence :: Monad m => t (m a) -> m (t a) - sequence = mapM id - {-# MINIMAL traverse | sequenceA #-} - --- instances for Prelude types - -instance Traversable Maybe where - traverse _ Nothing = pure Nothing - traverse f (Just x) = Just <$> f x - -instance Traversable [] where - {-# INLINE traverse #-} -- so that traverse can fuse - traverse f = Prelude.foldr cons_f (pure []) - where cons_f x ys = (:) <$> f x <*> ys - - mapM = Prelude.mapM - -instance Traversable (Either a) where - traverse _ (Left x) = pure (Left x) - traverse f (Right y) = Right <$> f y - -instance Traversable ((,) a) where - traverse f (x, y) = (,) x <$> f y - -instance Ix i => Traversable (Array i) where - traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr) - -instance Traversable Proxy where - traverse _ _ = pure Proxy - {-# INLINE traverse #-} - sequenceA _ = pure Proxy - {-# INLINE sequenceA #-} - mapM _ _ = return Proxy - {-# INLINE mapM #-} - sequence _ = return Proxy - {-# INLINE sequence #-} - -instance Traversable (Const m) where - traverse _ (Const m) = pure $ Const m - --- general functions - --- | 'for' is 'traverse' with its arguments flipped. -for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b) -{-# INLINE for #-} -for = flip traverse - --- | 'forM' is 'mapM' with its arguments flipped. -forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) -{-# INLINE forM #-} -forM = flip mapM - --- left-to-right state transformer -newtype StateL s a = StateL { runStateL :: s -> (s, a) } - -instance Functor (StateL s) where - fmap f (StateL k) = StateL $ \ s -> let (s', v) = k s in (s', f v) - -instance Applicative (StateL s) where - pure x = StateL (\ s -> (s, x)) - StateL kf <*> StateL kv = StateL $ \ s -> - let (s', f) = kf s - (s'', v) = kv s' - in (s'', f v) - --- |The 'mapAccumL' function behaves like a combination of 'fmap' --- and 'foldl'; it applies a function to each element of a structure, --- passing an accumulating parameter from left to right, and returning --- a final value of this accumulator together with the new structure. -mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) -mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s - --- right-to-left state transformer -newtype StateR s a = StateR { runStateR :: s -> (s, a) } - -instance Functor (StateR s) where - fmap f (StateR k) = StateR $ \ s -> let (s', v) = k s in (s', f v) - -instance Applicative (StateR s) where - pure x = StateR (\ s -> (s, x)) - StateR kf <*> StateR kv = StateR $ \ s -> - let (s', v) = kv s - (s'', f) = kf s' - in (s'', f v) - --- |The 'mapAccumR' function behaves like a combination of 'fmap' --- and 'foldr'; it applies a function to each element of a structure, --- passing an accumulating parameter from right to left, and returning --- a final value of this accumulator together with the new structure. -mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) -mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s - --- | This function may be used as a value for `fmap` in a `Functor` --- instance, provided that 'traverse' is defined. (Using --- `fmapDefault` with a `Traversable` instance defined only by --- 'sequenceA' will result in infinite recursion.) -fmapDefault :: Traversable t => (a -> b) -> t a -> t b -{-# INLINE fmapDefault #-} -fmapDefault f = getId . traverse (Id . f) - --- | This function may be used as a value for `Data.Foldable.foldMap` --- in a `Foldable` instance. -foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m -foldMapDefault f = getConst . traverse (Const . f) - --- local instances - -newtype Id a = Id { getId :: a } - -instance Functor Id where - fmap f (Id x) = Id (f x) - -instance Applicative Id where - pure = Id - Id f <*> Id x = Id (f x) - diff --git a/tests/examples/Undefined5.hs b/tests/examples/Undefined5.hs deleted file mode 100644 --- a/tests/examples/Undefined5.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -module Algebra.Ring.Polynomial.Parser ( monomial, expression, variable, variableWithPower - , number, integer, natural, parsePolyn) where -import Algebra.Ring.Polynomial.Monomorphic -import Control.Applicative hiding (many) -import qualified Data.Map as M -import Data.Ratio -import qualified Numeric.Algebra as NA -import Text.Peggy - -[peggy| -expression :: Polynomial Rational - = expr !. - -letter :: Char - = [a-zA-Z] - -variable :: Variable - = letter ('_' integer)? { Variable $1 (fromInteger <$> $2) } - -variableWithPower :: (Variable, Integer) - = variable "^" natural { ($1, $2) } - / variable { ($1, 1) } - -expr :: Polynomial Rational - = expr "+" term { $1 + $2 } - / expr "-" term { $1 - $2 } - / term - -term :: Polynomial Rational - = number space* monoms { injectCoeff $1 * $3 } - / number { injectCoeff $1 } - / monoms - -monoms :: Polynomial Rational - = monoms space * fact { $1 * $3 } - / fact - -fact :: Polynomial Rational - = fact "^" natural { $1 ^ $2 } - / "(" expr ")" - / monomial { toPolyn [($1, 1)] } - -monomial :: Monomial - = variableWithPower+ { M.fromListWith (+) $1 } - -number :: Rational - = integer "/" integer { $1 % $2 } - / integer '.' [0-9]+ { realToFrac (read (show $1 ++ '.' : $2) :: Double) } - / integer { fromInteger $1 } - -integer :: Integer - = "-" natural { negate $1 } - / natural - -natural :: Integer - = [1-9] [0-9]* { read ($1 : $2) } - -|] - -toPolyn :: [(Monomial, Ratio Integer)] -> Polynomial (Ratio Integer) -toPolyn = normalize . Polynomial . M.fromList - -parsePolyn :: String -> Either ParseError (Polynomial Rational) -parsePolyn = parseString expression "polynomial" diff --git a/tests/examples/Undefined6.hs b/tests/examples/Undefined6.hs deleted file mode 100644 --- a/tests/examples/Undefined6.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, MultiParamTypeClasses - , TypeFamilies #-} - -module Vision.Image.Class ( - -- * Classes - Pixel (..), MaskedImage (..), Image (..), ImageChannel, FromFunction (..) - , FunctorImage (..) - -- * Functions - , (!), (!?), nChannels, pixel - -- * Conversion - , Convertible (..), convert - ) where - -import Data.Convertible (Convertible (..), convert) -import Data.Int -import Data.Vector.Storable (Vector, generate, unfoldr) -import Data.Word -import Foreign.Storable (Storable) -import Prelude hiding (map, read) - -import Vision.Primitive ( - Z (..), (:.) (..), Point, Size - , fromLinearIndex, toLinearIndex, shapeLength - ) - --- Classes --------------------------------------------------------------------- - --- | Determines the number of channels and the type of each pixel of the image --- and how images are represented. -class Pixel p where - type PixelChannel p - - -- | Returns the number of channels of the pixel. - -- - -- Must not consume 'p' (could be 'undefined'). - pixNChannels :: p -> Int - - pixIndex :: p -> Int -> PixelChannel p - -instance Pixel Int16 where - type PixelChannel Int16 = Int16 - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Int32 where - type PixelChannel Int32 = Int32 - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Int where - type PixelChannel Int = Int - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Word8 where - type PixelChannel Word8 = Word8 - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Word16 where - type PixelChannel Word16 = Word16 - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Word32 where - type PixelChannel Word32 = Word32 - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Word where - type PixelChannel Word = Word - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Float where - type PixelChannel Float = Float - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Double where - type PixelChannel Double = Double - pixNChannels _ = 1 - pixIndex p _ = p - -instance Pixel Bool where - type PixelChannel Bool = Bool - pixNChannels _ = 1 - pixIndex p _ = p - --- | Provides an abstraction for images which are not defined for each of their --- pixels. The interface is similar to 'Image' except that indexing functions --- don't always return. --- --- Image origin (@'ix2' 0 0@) is located in the upper left corner. -class Storable (ImagePixel i) => MaskedImage i where - type ImagePixel i - - shape :: i -> Size - - -- | Returns the pixel\'s value at 'Z :. y, :. x'. - maskedIndex :: i -> Point -> Maybe (ImagePixel i) - maskedIndex img = (img `maskedLinearIndex`) . toLinearIndex (shape img) - {-# INLINE maskedIndex #-} - - -- | Returns the pixel\'s value as if the image was a single dimension - -- vector (row-major representation). - maskedLinearIndex :: i -> Int -> Maybe (ImagePixel i) - maskedLinearIndex img = (img `maskedIndex`) . fromLinearIndex (shape img) - {-# INLINE maskedLinearIndex #-} - - -- | Returns the non-masked values of the image. - values :: i -> Vector (ImagePixel i) - values !img = - unfoldr step 0 - where - !n = shapeLength (shape img) - - step !i | i >= n = Nothing - | Just p <- img `maskedLinearIndex` i = Just (p, i + 1) - | otherwise = step (i + 1) - {-# INLINE values #-} - - {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-} - -type ImageChannel i = PixelChannel (ImagePixel i) - --- | Provides an abstraction over the internal representation of an image. --- --- Image origin is located in the lower left corner. -class MaskedImage i => Image i where - -- | Returns the pixel value at 'Z :. y :. x'. - index :: i -> Point -> ImagePixel i - index img = (img `linearIndex`) . toLinearIndex (shape img) - {-# INLINE index #-} - - -- | Returns the pixel value as if the image was a single dimension vector - -- (row-major representation). - linearIndex :: i -> Int -> ImagePixel i - linearIndex img = (img `index`) . fromLinearIndex (shape img) - {-# INLINE linearIndex #-} - - -- | Returns every pixel values as if the image was a single dimension - -- vector (row-major representation). - vector :: i -> Vector (ImagePixel i) - vector img = generate (shapeLength $ shape img) (img `linearIndex`) - {-# INLINE vector #-} - - {-# MINIMAL index | linearIndex #-} - --- | Provides ways to construct an image from a function. -class FromFunction i where - type FromFunctionPixel i - - -- | Generates an image by calling the given function for each pixel of the - -- constructed image. - fromFunction :: Size -> (Point -> FromFunctionPixel i) -> i - - -- | Generates an image by calling the last function for each pixel of the - -- constructed image. - -- - -- The first function is called for each line, generating a line invariant - -- value. - -- - -- This function is faster for some image representations as some recurring - -- computation can be cached. - fromFunctionLine :: Size -> (Int -> a) - -> (a -> Point -> FromFunctionPixel i) -> i - fromFunctionLine size line f = - fromFunction size (\pt@(Z :. y :. _) -> f (line y) pt) - {-# INLINE fromFunctionLine #-} - - -- | Generates an image by calling the last function for each pixel of the - -- constructed image. - -- - -- The first function is called for each column, generating a column - -- invariant value. - -- - -- This function *can* be faster for some image representations as some - -- recurring computations can be cached. However, it may requires a vector - -- allocation for these values. If the column invariant is cheap to - -- compute, prefer 'fromFunction'. - fromFunctionCol :: Storable b => Size -> (Int -> b) - -> (b -> Point -> FromFunctionPixel i) -> i - fromFunctionCol size col f = - fromFunction size (\pt@(Z :. _ :. x) -> f (col x) pt) - {-# INLINE fromFunctionCol #-} - - -- | Generates an image by calling the last function for each pixel of the - -- constructed image. - -- - -- The two first functions are called for each line and for each column, - -- respectively, generating common line and column invariant values. - -- - -- This function is faster for some image representations as some recurring - -- computation can be cached. However, it may requires a vector - -- allocation for column values. If the column invariant is cheap to - -- compute, prefer 'fromFunctionLine'. - fromFunctionCached :: Storable b => Size - -> (Int -> a) -- ^ Line function - -> (Int -> b) -- ^ Column function - -> (a -> b -> Point - -> FromFunctionPixel i) -- ^ Pixel function - -> i - fromFunctionCached size line col f = - fromFunction size (\pt@(Z :. y :. x) -> f (line y) (col x) pt) - {-# INLINE fromFunctionCached #-} - - {-# MINIMAL fromFunction #-} - --- | Defines a class for images on which a function can be applied. The class is --- different from 'Functor' as there could be some constraints and --- transformations the pixel and image types. -class (MaskedImage src, MaskedImage res) => FunctorImage src res where - map :: (ImagePixel src -> ImagePixel res) -> src -> res - --- Functions ------------------------------------------------------------------- - --- | Alias of 'maskedIndex'. -(!?) :: MaskedImage i => i -> Point -> Maybe (ImagePixel i) -(!?) = maskedIndex -{-# INLINE (!?) #-} - --- | Alias of 'index'. -(!) :: Image i => i -> Point -> ImagePixel i -(!) = index -{-# INLINE (!) #-} - --- | Returns the number of channels of an image. -nChannels :: (Pixel (ImagePixel i), MaskedImage i) => i -> Int -nChannels img = pixNChannels (pixel img) -{-# INLINE nChannels #-} - --- | Returns an 'undefined' instance of a pixel of the image. This is sometime --- useful to satisfy the type checker as in a call to 'pixNChannels' : --- --- > nChannels img = pixNChannels (pixel img) -pixel :: MaskedImage i => i -> ImagePixel i -pixel _ = undefined diff --git a/tests/examples/Undefined7.hs b/tests/examples/Undefined7.hs deleted file mode 100644 --- a/tests/examples/Undefined7.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes, StandaloneDeriving, DeriveDataTypeable #-} - -module Test where - -import Control.Applicative -import Control.Monad -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.Binary -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.Map as M -import Data.Generics - -import Data.Binary.ISO8583 -import Data.Binary.ISO8583.TH - -[binary| - Message - 2 pan embedded 2 - 4 amount int 12 - 11 stan int 6 - 43 termAddress TermAddress 222 -|] - -deriving instance Eq Message -deriving instance Show Message - -data TermAddress = TermAddress { - tOwner :: B.ByteString, - tCity :: B.ByteString, - tOther :: L.ByteString } - deriving (Eq, Show, Typeable) - -instance Binary TermAddress where - -- NB: this implementation is smth odd and usable only for this testcase. - get = - TermAddress - <$> B.filter (/= 0x20) `fmap` getByteString 30 - <*> B.filter (/= 0x20) `fmap` getByteString 30 - <*> L.filter (/= 0x20) `fmap` getRemainingLazyByteString - - put (TermAddress owner city other) = do - putByteStringPad 30 owner - putByteStringPad 30 city - putLazyByteStringPad 162 other - -instance Binary Message where - get = do - m <- getBitmap getMessage - return $ constructMessage m - - put msg = do - putBitmap' (putMessage msg) - -testMsg :: Message -testMsg = Message { - pan = Just $ toBS "12345678", - amount = Just $ 100500, - stan = Just $ 123456, - termAddress = Just $ TermAddress { - tOwner = toBS "TestBank", - tCity = toBS "Magnitogorsk", - tOther = L.empty } -} - -test :: IO () -test = do - let bstr = encode testMsg - msg = decode bstr - if msg /= testMsg - then fail $ "Encode/decode mismatch:\n" ++ - show testMsg ++ "\n /= \n" ++ - show msg - else putStrLn "passed." - diff --git a/tests/examples/Undefined8.hs b/tests/examples/Undefined8.hs deleted file mode 100644 --- a/tests/examples/Undefined8.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, PackageImports #-} - -module Text.Markdown.Pap.Parser ( - parseMrd -) where - -import Control.Arrow -import "monads-tf" Control.Monad.State -import "monads-tf" Control.Monad.Error -import Data.Maybe -import Data.Char -import Text.Papillon - -import Text.Markdown.Pap.Text - -parseMrd :: String -> Maybe [Text] -parseMrd src = case flip runState (0, [- 1]) $ runErrorT $ markdown $ parse src of - (Right (r, _), _) -> Just r - _ -> Nothing - -clear :: State (Int, [Int]) Bool -clear = put (0, [- 1]) >> return True - -reset :: State (Int, [Int]) Bool -reset = modify (first $ const 0) >> return True - -count :: State (Int, [Int]) () -count = modify $ first (+ 1) - -deeper :: State (Int, [Int]) Bool -deeper = do - (n, n0 : ns) <- get - if n > n0 then put (n, n : n0 : ns) >> return True else return False - -same :: State (Int, [Int]) Bool -same = do - (n, n0 : _) <- get - return $ n == n0 - -shallow :: State (Int, [Int]) Bool -shallow = do - (n, n0 : ns) <- get - if n < n0 then put (n, ns) >> return True else return False - -[papillon| - -monad: State (Int, [Int]) - -markdown :: [Text] - = md:(m:markdown1 _:dmmy[clear] { return m })* { return md } - -markdown1 :: Text - = h:header { return h } - / l:link '\n'* { return l } - / i:image '\n'* { return i } - / l:list '\n'* { return $ List l } - / c:code { return $ Code c } - / p:paras { return $ Paras p } - -header :: Text - = n:sharps _:* l:line '\n'+ { return $ Header n l } - / l:line '\n' _:equals '\n'+ { return $ Header 1 l } - / l:line '\n' _:hyphens '\n'+ { return $ Header 2 l } - -sharps :: Int - = '#' n:sharps { return $ n + 1 } - / '#' { return 1 } - -equals :: () - = '=' _:equals - / '=' - -hyphens :: () - = '-' _:hyphens - / '-' - -line :: String - = l:<(`notElem` "#\n")>+ { return l } - -line' :: String - = l:<(`notElem` "\n")>+ { return l } - -code :: String - = l:fourSpacesLine c:code { return $ l ++ c } - / l:fourSpacesLine { return l } - -fourSpacesLine :: String - = _:fourSpaces l:line' ns:('\n' { return '\n' })+ { return $ l ++ ns } - -fourSpaces :: () - = ' ' ' ' ' ' ' ' - -list :: List = _:cnt _:dmmy[deeper] l:list1 ls:list1'* _:shllw { return $ l : ls } - -cnt :: () = _:dmmy[reset] _:(' ' { count })* - -list1' :: List1 - = _:cnt _:dmmy[same] l:list1 { return l } - -list1 :: List1 - = _:listHead ' ' l:line '\n' ls:list? - { return $ BulItem l $ fromMaybe [] ls } - / _:nListHead ' ' l:line '\n' ls:list? - { return $ OrdItem l $ fromMaybe [] ls } - -listHead :: () - = '*' / '-' / '+' - -nListHead :: () - = _:+ '.' - -paras :: [String] - = ps:para+ { return ps } - -para :: String - = ls:(!_:('!') !_:listHead !_:nListHead !_:header !_:fourSpaces l:line '\n' { return l })+ _:('\n' / !_ / !_:para) - { return $ unwords ls } - -shllw :: () - = _:dmmy[shallow] - / !_ - / !_:list - -dmmy :: () = - -link :: Text - = '[' t:<(/= ']')>+ ']' ' '* '(' a:<(/= ')')>+ ')' { return $ Link t a "" } - -image :: Text - = '!' '[' alt:<(/= ']')>+ ']' ' '* '(' addrs:<(`notElem` ")\" ")>+ ' '* - '"' t:<(/= '"')>+ '"' ')' - { return $ Image alt addrs t } - -|] diff --git a/tests/examples/Undefined9.hs b/tests/examples/Undefined9.hs deleted file mode 100644 --- a/tests/examples/Undefined9.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies #-} - -module Image.PNG (isPNG, pngSize) where - -import Data.Maybe -import File.Binary.PNG -import File.Binary -import File.Binary.Instances -import File.Binary.Instances.BigEndian - -isPNG :: String -> Bool -isPNG img = isJust (fromBinary () img :: Maybe (PNGHeader, String)) - -pngSize :: String -> Maybe (Double, Double) -pngSize src = case getChunks src of - Right cs -> Just - (fromIntegral $ width $ ihdr cs, fromIntegral $ height $ ihdr cs) - _ -> Nothing - -[binary| - -PNGHeader deriving Show - -1: 0x89 -3: "PNG" -2: "\r\n" -1: "\SUB" -1: "\n" - -|] diff --git a/tests/examples/Unicode.hs b/tests/examples/Unicode.hs deleted file mode 100644 --- a/tests/examples/Unicode.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE UnicodeSyntax #-} - -module Unicode where - -import Control.Monad.Trans.State.Strict - --- | 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 α - } - --- | We'll run an ABT computation by starting the variable counter at @0@. --- -runM ∷ M α → α -runM (M m) = evalState m 0 - - --- | To indicate that a term is in normal form. --- -stepsExhausted - ∷ Applicative m - ⇒ StepT m α -stepsExhausted = StepT . MaybeT $ pure Nothing - -stepsExhausted2 - ∷ Applicative m - => m α -stepsExhausted2 = undefined diff --git a/tests/examples/UnicodeRules.hs b/tests/examples/UnicodeRules.hs deleted file mode 100644 --- a/tests/examples/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/UnicodeRules.hs.bad b/tests/examples/UnicodeRules.hs.bad deleted file mode 100644 --- a/tests/examples/UnicodeRules.hs.bad +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE - BangPatterns - , FlexibleContexts - , FlexibleInstances - , ScopedTypeVariables - , UnboxedTuples - , UndecidableInstances - , UnicodeSyntax - #-} - -strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool -{-# RULES "head \8594 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/UnicodeSyntax.hs b/tests/examples/UnicodeSyntax.hs deleted file mode 100644 --- a/tests/examples/UnicodeSyntax.hs +++ /dev/null @@ -1,236 +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) - } - diff --git a/tests/examples/UnicodeSyntax.hs.bad b/tests/examples/UnicodeSyntax.hs.bad deleted file mode 100644 --- a/tests/examples/UnicodeSyntax.hs.bad +++ /dev/null @@ -1,236 +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) - } - diff --git a/tests/examples/UnicodeSyntaxFailure.hs b/tests/examples/UnicodeSyntaxFailure.hs deleted file mode 100644 --- a/tests/examples/UnicodeSyntaxFailure.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE UnicodeSyntax #-} - -foo x = addToEnv (∀) diff --git a/tests/examples/Utilities.hs b/tests/examples/Utilities.hs deleted file mode 100644 --- a/tests/examples/Utilities.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Utilities (toBinary, fl) where - -import Stream -import Data.Ratio - --- Convert from an Integer to its signed-digit representation -toBinary :: Integer -> Stream -toBinary 0 = [0] -toBinary x = toBinary t ++ [x `mod` 2] - where t = x `div` 2 - - - -fl :: Stream -> Stream -fl (x:xs) = (f x):xs - where f 0 = 1 - f 1 = 0 diff --git a/tests/examples/Utils2.hs b/tests/examples/Utils2.hs deleted file mode 100644 --- a/tests/examples/Utils2.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -module Utils2 where - - -import Control.Applicative (Applicative(..)) -import Control.Monad (when, liftM, ap) -import Control.Exception -import Data.Data -import Data.List -import Data.Maybe -import Data.Monoid - --- import Language.Haskell.GHC.ExactPrint.Utils -import Language.Haskell.GHC.ExactPrint.Types hiding (showGhc) - -import qualified Bag as GHC -import qualified BasicTypes as GHC -import qualified BooleanFormula as GHC -import qualified Class as GHC -import qualified CoAxiom as GHC -import qualified DynFlags as GHC -import qualified FastString as GHC -import qualified ForeignCall as GHC -import qualified GHC as GHC -import qualified GHC.Paths as GHC -import qualified Lexer as GHC -import qualified Name as GHC -import qualified NameSet as GHC -import qualified Outputable as GHC -import qualified RdrName as GHC -import qualified SrcLoc as GHC -import qualified StringBuffer as GHC -import qualified UniqSet as GHC -import qualified Unique as GHC -import qualified Var as GHC - -import qualified Data.Map as Map - --- --------------------------------------------------------------------- - -instance AnnotateP GHC.RdrName where - annotateP l n = do - case rdrName2String n of - "[]" -> do - addDeltaAnnotation GHC.AnnOpenS -- '[' nonBUG - addDeltaAnnotation GHC.AnnCloseS -- ']' BUG - "()" -> do - addDeltaAnnotation GHC.AnnOpenP -- '(' - addDeltaAnnotation GHC.AnnCloseP -- ')' - "(##)" -> do - addDeltaAnnotation GHC.AnnOpen -- '(#' - addDeltaAnnotation GHC.AnnClose -- '#)' - "[::]" -> do - addDeltaAnnotation GHC.AnnOpen -- '[:' - addDeltaAnnotation GHC.AnnClose -- ':]' - _ -> do - addDeltaAnnotation GHC.AnnType - addDeltaAnnotation GHC.AnnOpenP -- '(' - addDeltaAnnotationLs GHC.AnnBackquote 0 - addDeltaAnnotations GHC.AnnCommaTuple -- For '(,,,)' - cnt <- countAnnsAP GHC.AnnVal - cntT <- countAnnsAP GHC.AnnCommaTuple - cntR <- countAnnsAP GHC.AnnRarrow - case cnt of - 0 -> if cntT >0 || cntR >0 then return () else addDeltaAnnotationExt l GHC.AnnVal - 1 -> addDeltaAnnotation GHC.AnnVal - x -> error $ "annotateP.RdrName: too many AnnVal :" ++ showGhc (l,x) - addDeltaAnnotation GHC.AnnTildehsh - addDeltaAnnotation GHC.AnnTilde - addDeltaAnnotation GHC.AnnRarrow - addDeltaAnnotationLs GHC.AnnBackquote 1 - addDeltaAnnotation GHC.AnnCloseP -- ')' - - -- temporary, for test -class (Typeable ast) => AnnotateP ast where - annotateP :: GHC.SrcSpan -> ast -> IO () - -addDeltaAnnotation = undefined -addDeltaAnnotations = undefined -addDeltaAnnotationLs = undefined -addDeltaAnnotationExt = undefined -countAnnsAP = undefined -showGhc = undefined -rdrName2String = undefined - diff --git a/tests/examples/Vect.hs b/tests/examples/Vect.hs deleted file mode 100644 --- a/tests/examples/Vect.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE ParallelArrays #-} -{-# OPTIONS_GHC -fvectorise #-} -{-# LANGUAGE UnboxedTuples #-} - -module Vect where - --- import Data.Array.Parallel - - -{-# VECTORISe isFive = blah #-} -{-# NoVECTORISE isEq #-} - -{-# VECTORISE SCALAR type Int #-} -{-# VECTORISE type Char #-} -{-# VECTORISE type ( ) #-} -{-# VECTORISE type (# #) #-} - -{-# VECTORISE SCALAR type Integer = Int #-} -{-# VECTORISE type Bool = String #-} - -{-# Vectorise class Eq #-} - -blah = 5 - -data MyBool = MyTrue | MyFalse - -class Eq a => Cmp a where - cmp :: a -> a -> Bool - --- FIXME: --- instance Cmp Int where --- cmp = (==) --- isFive :: (Eq a, Num a) => a -> Bool -isFive :: Int -> Bool -isFive x = x == 5 - -isEq :: Eq a => a -> Bool -isEq x = x == x - - -fiveEq :: Int -> Bool -fiveEq x = isFive x && isEq x - -cmpArrs :: PArray Int -> PArray Int -> Bool -{-# NOINLINE cmpArrs #-} -cmpArrs v w = cmpArrs' (fromPArrayP v) (fromPArrayP w) - -cmpArrs' :: [:Int:] -> [:Int:] -> Bool -cmpArrs' xs ys = andP [:x == y | x <- xs | y <- ys:] - -isFives :: PArray Int -> Bool -{-# NOINLINE isFives #-} -isFives xs = isFives' (fromPArrayP xs) - -isFives' :: [:Int:] -> Bool -isFives' xs = andP (mapP isFive xs) - -isEqs :: PArray Int -> Bool -{-# NOINLINE isEqs #-} -isEqs xs = isEqs' (fromPArrayP xs) - -isEqs' :: [:Int:] -> Bool -isEqs' xs = undefined -- andP (mapP isEq xs) - --- fudge for compiler - -fromPArrayP = undefined -andP = undefined -mapP = undefined -data PArray a = PArray a diff --git a/tests/examples/ViewPatterns.hs b/tests/examples/ViewPatterns.hs deleted file mode 100644 --- a/tests/examples/ViewPatterns.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - --- From https://ghc.haskell.org/trac/ghc/wiki/ViewPatterns -import Prelude hiding (length) - -data JList a = Empty - | Single a - | Join (JList a) (JList a) - -data JListView a = Nil - | Cons a (JList a) - - -view :: JList a -> JListView a -view Empty = Nil -view (Single a) = Cons a Empty -view (Join (view -> Cons xh xt) y) = Cons xh $ Join xt y -view (Join (view -> Nil) y) = view y - -length :: JList a -> Integer -length (view -> Nil) = 0 -length (view -> Cons x xs) = 1 + length xs - diff --git a/tests/examples/Warning.hs b/tests/examples/Warning.hs deleted file mode 100644 --- a/tests/examples/Warning.hs +++ /dev/null @@ -1,16 +0,0 @@ - -module Warning -{-# WARNINg ["This is a module warning", - "multi-line"] #-} - where - -{-# Warning foo , bar - ["This is a multi-line", - "deprecation message", - "for foo"] #-} -foo :: Int -foo = 4 - -bar :: Char -bar = 'c' - diff --git a/tests/examples/WhereIn3.hs b/tests/examples/WhereIn3.hs deleted file mode 100644 --- a/tests/examples/WhereIn3.hs +++ /dev/null @@ -1,19 +0,0 @@ -module WhereIn3 where - ---A definition can be demoted to the local 'where' binding of a friend declaration, ---if it is only used by this friend declaration. - ---Demoting a definition narrows down the scope of the definition. ---In this example, demote the top level 'sq' to 'sumSquares' ---In this case (there are multi matches), the parameters are not folded after demoting. - -sumSquares x y = sq p x + sq p y - where p=2 {-There is a comment-} - -sq :: Int -> Int -> Int -sq pow 0 = 0 --prior comment -sq pow {- blah -} z = z^pow --there is a comment - --- A leading comment -anotherFun 0 y = sq y - where sq x = x^2 diff --git a/tests/examples/WhereIn3.hs.expected b/tests/examples/WhereIn3.hs.expected deleted file mode 100644 --- a/tests/examples/WhereIn3.hs.expected +++ /dev/null @@ -1,16 +0,0 @@ -module WhereIn3 where - ---A definition can be demoted to the local 'where' binding of a friend declaration, ---if it is only used by this friend declaration. - ---Demoting a definition narrows down the scope of the definition. ---In this example, demote the top level 'sq' to 'sumSquares' ---In this case (there are multi matches), the parameters are not folded after demoting. - -sumSquares x y = sq p x + sq p y - where p=2 {-There is a comment-} - -sq :: Int -> Int -> Int - -anotherFun 0 y = sq y - where sq x = x^2 diff --git a/tests/examples/WhereIn3a.hs b/tests/examples/WhereIn3a.hs deleted file mode 100644 --- a/tests/examples/WhereIn3a.hs +++ /dev/null @@ -1,19 +0,0 @@ -module WhereIn3a where - ---A definition can be demoted to the local 'where' binding of a friend declaration, ---if it is only used by this friend declaration. - ---Demoting a definition narrows down the scope of the definition. ---In this example, demote the top level 'sq' to 'sumSquares' ---In this case (there are multi matches), the parameters are not folded after demoting. - -sumSquares x y = sq p x + sq p y - where p=2 {-There is a comment-} - -sq :: Int -> Int -> Int -sq pow 0 = 0 -- prior comment -sq pow z = z^pow --there is a comment - --- A leading comment -anotherFun 0 y = sq y - where sq x = x^2 diff --git a/tests/examples/WhereIn3a.hs.expected b/tests/examples/WhereIn3a.hs.expected deleted file mode 100644 --- a/tests/examples/WhereIn3a.hs.expected +++ /dev/null @@ -1,25 +0,0 @@ -module WhereIn3a where - --- A leading comment -anotherFun 0 y = sq y - where sq x = x^2 -sq pow 0 = 0 -- prior comment -sq pow z = z^pow --there is a comment - ---A definition can be demoted to the local 'where' binding of a friend declaration, ---if it is only used by this friend declaration. - ---Demoting a definition narrows down the scope of the definition. ---In this example, demote the top level 'sq' to 'sumSquares' ---In this case (there are multi matches), the parameters are not folded after demoting. - -sumSquares x y = sq p x + sq p y - where p=2 {-There is a comment-} - -sq :: Int -> Int -> Int -sq pow 0 = 0 -- prior comment -sq pow z = z^pow --there is a comment - --- A leading comment -anotherFun 0 y = sq y - where sq x = x^2 diff --git a/tests/examples/WhereIn4.hs b/tests/examples/WhereIn4.hs deleted file mode 100644 --- a/tests/examples/WhereIn4.hs +++ /dev/null @@ -1,19 +0,0 @@ -module WhereIn4 where - ---A definition can be demoted to the local 'where' binding of a friend declaration, ---if it is only used by this friend declaration. - ---Demoting a definition narrows down the scope of the definition. ---In this example, demote the top level 'sq' to 'sumSquares' ---In this case (there is single matches), if possible, ---the parameters will be folded after demoting and type sigature will be removed. - -sumSquares x y = sq p x + sq p y - where p=2 {-There is a comment-} - -sq::Int->Int->Int -sq pow z = z^pow --there is a comment - -anotherFun 0 y = sq y - where sq x = x^2 - diff --git a/tests/examples/WhereIn4.hs.expected b/tests/examples/WhereIn4.hs.expected deleted file mode 100644 --- a/tests/examples/WhereIn4.hs.expected +++ /dev/null @@ -1,19 +0,0 @@ -module WhereIn4 where - ---A definition can be demoted to the local 'where' binding of a friend declaration, ---if it is only used by this friend declaration. - ---Demoting a definition narrows down the scope of the definition. ---In this example, demote the top level 'sq' to 'sumSquares' ---In this case (there is single matches), if possible, ---the parameters will be folded after demoting and type sigature will be removed. - -sumSquares x y = sq p x + sq p y - where p_2=2 {-There is a comment-} - -sq::Int->Int->Int -sq pow z = z^pow --there is a comment - -anotherFun 0 y = sq y - where sq x = x^2 - diff --git a/tests/examples/Zipper.hs b/tests/examples/Zipper.hs deleted file mode 100644 --- a/tests/examples/Zipper.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE Rank2Types #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Generics.Zipper --- Copyright : (c) Michael D. Adams, 2010 --- License : BSD-style (see the LICENSE file) --- --- ``Scrap Your Zippers: A Generic Zipper for Heterogeneous Types. --- Michael D. Adams. WGP '10: Proceedings of the 2010 ACM SIGPLAN --- workshop on Generic programming, 2010.'' --- --- See --- ------------------------------------------------------------------------------ - -{-# OPTIONS -Wall #-} -{-# LANGUAGE Rank2Types, GADTs #-} - -module Zipper where - -import Data.Generics -import Control.Monad ((<=<), MonadPlus, mzero, mplus, liftM) -import Data.Maybe (fromJust) - --- Core types - --- | A generic zipper with a root object of type @root@. -data Zipper root = - forall hole. (Data hole) => - Zipper hole (Context hole root) - ----- Internal types and functions -data Context hole root where - CtxtNull :: Context a a - CtxtCons :: - forall hole root rights parent. (Data parent) => - Left (hole -> rights) - -> Right rights parent - -> Context parent root - -> Context hole root - -combine :: Left (hole -> rights) - -> hole - -> Right rights parent - -> parent -combine lefts hole rights = - fromRight ((fromLeft lefts) hole) rights - -data Left expects - = LeftUnit expects - | forall b. (Data b) => LeftCons (Left (b -> expects)) b - -toLeft :: (Data a) => a -> Left a -toLeft a = gfoldl LeftCons LeftUnit a - -fromLeft :: Left r -> r -fromLeft (LeftUnit a) = a -fromLeft (LeftCons f b) = fromLeft f b - -data Right provides parent where - RightNull :: Right parent parent - RightCons :: - (Data b) => b -> Right a t -> Right (b -> a) t - -fromRight :: r -> Right r parent -> parent -fromRight f (RightNull) = f -fromRight f (RightCons b r) = fromRight (f b) r - --- | Apply a generic monadic transformation to the hole -transM :: (Monad m) => GenericM m -> Zipper a -> m (Zipper a) -transM f (Zipper hole ctxt) = do - hole' <- f hole - return (Zipper hole' ctxt) - --- Generic zipper traversals ----- Traversal helpers --- | A movement operation such as 'left', 'right', 'up', or 'down'. -type Move a = Zipper a -> Maybe (Zipper a) - --- | Apply a generic query using the specified movement operation. -moveQ :: Move a -- ^ Move operation - -> b -- ^ Default if can't move - -> (Zipper a -> b) -- ^ Query if can move - -> Zipper a -- ^ Zipper - -> b -moveQ move b f z = case move z of - Nothing -> b - Just z' -> f z' - --- | Repeatedly apply a monadic 'Maybe' generic transformation at the --- top-most, left-most position that the transformation returns --- 'Just'. Behaves like iteratively applying 'zsomewhere' but is --- more efficient because it re-evaluates the transformation --- at only the parents of the last successful application. -zreduce :: GenericM Maybe -> Zipper a -> Zipper a -zreduce f z = - case transM f z of - Nothing -> - downQ (g z) (zreduce f . leftmost) z where - g z' = rightQ (upQ z' g z') (zreduce f) z' - Just x -> zreduce f (reduceAncestors1 f x x) - -reduceAncestors1 :: - GenericM Maybe -> Zipper a -> Zipper a -> Zipper a -reduceAncestors1 f z def = upQ def g z where - g z' = reduceAncestors1 f z' def' where - def' = case transM f z' of - Nothing -> def - Just x -> reduceAncestors1 f x x - ------- Query --- | Apply a generic query to the left sibling if one exists. -leftQ :: b -- ^ Value to return of no left sibling exists. - -> (Zipper a -> b) -> Zipper a -> b -leftQ b f z = moveQ left b f z - --- | Apply a generic query to the right sibling if one exists. -rightQ :: b -- ^ Value to return if no right sibling exists. - -> (Zipper a -> b) -> Zipper a -> b -rightQ b f z = moveQ right b f z - --- | Apply a generic query to the parent if it exists. -downQ :: b -- ^ Value to return if no children exist. - -> (Zipper a -> b) -> Zipper a -> b -downQ b f z = moveQ down b f z - --- | Apply a generic query to the rightmost child if one exists. -upQ :: b -- ^ Value to return if parent does not exist. - -> (Zipper a -> b) -> Zipper a -> b -upQ b f z = moveQ up b f z - ----- Basic movement - --- | Move left. Returns 'Nothing' iff already at leftmost sibling. -left :: Zipper a -> Maybe (Zipper a) -left (Zipper _ CtxtNull) = Nothing -left (Zipper _ (CtxtCons (LeftUnit _) _ _)) = Nothing -left (Zipper h (CtxtCons (LeftCons l h') r c)) = - Just (Zipper h' (CtxtCons l (RightCons h r) c)) - --- | Move right. Returns 'Nothing' iff already at rightmost sibling. -right :: Zipper a -> Maybe (Zipper a) -right (Zipper _ CtxtNull) = Nothing -right (Zipper _ (CtxtCons _ RightNull _)) = Nothing -right (Zipper h (CtxtCons l (RightCons h' r) c)) = - Just (Zipper h' (CtxtCons (LeftCons l h) r c)) - --- | Move down. Moves to rightmost immediate child. Returns 'Nothing' iff at a leaf and thus no children exist. -down :: Zipper a -> Maybe (Zipper a) -down (Zipper hole ctxt) = - case toLeft hole of - LeftUnit _ -> Nothing - LeftCons l hole' -> - Just (Zipper hole' (CtxtCons l RightNull ctxt)) - --- | Move up. Returns 'Nothing' iff already at root and thus no parent exists. -up :: Zipper a -> Maybe (Zipper a) -up (Zipper _ CtxtNull) = Nothing -up (Zipper hole (CtxtCons l r ctxt)) = - Just (Zipper (combine l hole r) ctxt) - ------- Movement --- | Move to the leftmost sibling. -leftmost :: Zipper a -> Zipper a -leftmost z = leftQ z leftmost z - diff --git a/tests/examples/failing/Deprecation.hs b/tests/examples/failing/Deprecation.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/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/failing/Deprecation.hs.bad b/tests/examples/failing/Deprecation.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/Deprecation.hs.bad @@ -0,0 +1,16 @@ + +module Deprecation +{-# Deprecated ["This is a module \"deprecation\"", + "multi-line", + "with unicode: Fr\232re" ] #-} + ( 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/failing/InfixOperator.hs b/tests/examples/failing/InfixOperator.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/InfixOperator.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} + +#define BACKSLASH 92 +#define CLOSE_CURLY 125 +#define CLOSE_SQUARE 93 +#define COMMA 44 +#define DOUBLE_QUOTE 34 +#define OPEN_CURLY 123 +#define OPEN_SQUARE 91 +#define C_0 48 +#define C_9 57 +#define C_A 65 +#define C_F 70 +#define C_a 97 +#define C_f 102 +#define C_n 110 +#define C_t 116 + +json_ :: Parser Value -> Parser Value -> Parser Value +json_ obj ary = do + w <- skipSpace *> A.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE) + if w == OPEN_CURLY + then obj + else ary +{-# INLINE json_ #-} + diff --git a/tests/examples/failing/InfixOperator.hs.bad b/tests/examples/failing/InfixOperator.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/InfixOperator.hs.bad @@ -0,0 +1,25 @@ +{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-} + +#define BACKSLASH 92 +#define CLOSE_CURLY 125 +#define CLOSE_SQUARE 93 +#define COMMA 44 +#define DOUBLE_QUOTE 34 +#define OPEN_CURLY 123 +#define OPEN_SQUARE 91 +#define C_0 48 +#define C_9 57 +#define C_A 65 +#define C_F 70 +#define C_a 97 +#define C_f 102 +#define C_n 110 +#define C_t 116 + +json_ :: Parser Value -> Parser Value -> Parser Value +json_ obj ary = do + w <- skipSpace *> A.satisfy (\w -> w == 123OPEN_CURLY w ==||) == OPEN_SQUARE) + if w == 123OPEN_CURLY + then obj + else ary +{-# INLINE json_ #-} diff --git a/tests/examples/failing/MultiLineWarningPragma.hs b/tests/examples/failing/MultiLineWarningPragma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/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/failing/MultiLineWarningPragma.hs.bad b/tests/examples/failing/MultiLineWarningPragma.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/MultiLineWarningPragma.hs.bad @@ -0,0 +1,17 @@ + +{-# 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/failing/UnicodeRules.hs b/tests/examples/failing/UnicodeRules.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/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/failing/UnicodeRules.hs.bad b/tests/examples/failing/UnicodeRules.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/UnicodeRules.hs.bad @@ -0,0 +1,16 @@ +{-# LANGUAGE + BangPatterns + , FlexibleContexts + , FlexibleInstances + , ScopedTypeVariables + , UnboxedTuples + , UndecidableInstances + , UnicodeSyntax + #-} + +strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool +{-# RULES "head \8594 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/failing/UnicodeSyntax.hs b/tests/examples/failing/UnicodeSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/UnicodeSyntax.hs @@ -0,0 +1,236 @@ +{-# 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) + } + diff --git a/tests/examples/failing/UnicodeSyntax.hs.bad b/tests/examples/failing/UnicodeSyntax.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/UnicodeSyntax.hs.bad @@ -0,0 +1,236 @@ +{-# 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) + } + diff --git a/tests/examples/ghc710/AddAndOr3.hs b/tests/examples/ghc710/AddAndOr3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/AddAndOr3.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module AddAndOr3 where + +addAndOr3 :: _ -> _ -> _ +addAndOr3 (a, b) (c, d) = (a `plus` d, b || c) + where plus :: Int -> Int -> Int + x `plus` y = x + y diff --git a/tests/examples/ghc710/AltsSemis.hs b/tests/examples/ghc710/AltsSemis.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/AltsSemis.hs @@ -0,0 +1,11 @@ + + +foo x = + case x of + { ;;; -- leading + 0 -> 'a'; -- case 0 + 1 -> 'b' -- case 1 + ; 2 -> 'c' ; -- case 2 + ; 3 -> 'd' -- case 3 + ;;; -- case 4 + } diff --git a/tests/examples/ghc710/Ann01.hs b/tests/examples/ghc710/Ann01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Ann01.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Ann01 where + +{-# ANN module (1 :: Int) #-} +{-# ANN module (1 :: Integer) #-} +{-# ANN module (1 :: Double) #-} +{-# ANN module $([| 1 :: Int |]) #-} +{-# ANN module "Hello" #-} +{-# ANN module (Just (1 :: Int)) #-} +{-# ANN module [1 :: Int, 2, 3] #-} +{-# ANN module ([1..10] :: [Integer]) #-} +{-# ANN module ''Foo #-} +{-# ANN module (-1 :: Int) #-} + +{-# ANN type Foo (1 :: Int) #-} +{-# ANN type Foo (1 :: Integer) #-} +{-# ANN type Foo (1 :: Double) #-} +{-# ANN type Foo $([| 1 :: Int |]) #-} +{-# ANN type Foo "Hello" #-} +{-# ANN type Foo (Just (1 :: Int)) #-} +{-# ANN type Foo [1 :: Int, 2, 3] #-} +{-# ANN type Foo ([1..10] :: [Integer]) #-} +{-# ANN type Foo ''Foo #-} +{-# ANN type Foo (-1 :: Int) #-} +data Foo = Bar Int + +{-# ANN f (1 :: Int) #-} +{-# ANN f (1 :: Integer) #-} +{-# ANN f (1 :: Double) #-} +{-# ANN f $([| 1 :: Int |]) #-} +{-# ANN f "Hello" #-} +{-# ANN f (Just (1 :: Int)) #-} +{-# ANN f [1 :: Int, 2, 3] #-} +{-# ANN f ([1..10] :: [Integer]) #-} +{-# ANN f 'f #-} +{-# ANN f (-1 :: Int) #-} +f x = x diff --git a/tests/examples/ghc710/AnnPackageName.hs b/tests/examples/ghc710/AnnPackageName.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/AnnPackageName.hs @@ -0,0 +1,4 @@ + + +import "base" Prelude +import "base" Data.Data diff --git a/tests/examples/ghc710/Annotations.hs b/tests/examples/ghc710/Annotations.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Annotations.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Annotations where + +{-# ANN module (1 :: Int) #-} +{-# ANN module (1 :: Integer) #-} +{-# ANN module (1 :: Double) #-} +{-# ANN module $([| 1 :: Int |]) #-} +{-# ANN module "Hello" #-} +{-# ANN module (Just (1 :: Int)) #-} +{-# ANN module [1 :: Int, 2, 3] #-} +{-# ANN module ([1..10] :: [Integer]) #-} +{-# ANN module ''Foo #-} +{-# ANN module (-1 :: Int) #-} + +{-# ANN type Foo (1 :: Int) #-} +{-# ANN type Foo (1 :: Integer) #-} +{-# ANN type Foo (1 :: Double) #-} +{-# ANN type Foo $([| 1 :: Int |]) #-} +{-# ANN type Foo "Hello" #-} +{-# ANN type Foo (Just (1 :: Int)) #-} +{-# ANN type Foo [1 :: Int, 2, 3] #-} +{-# ANN type Foo ([1..10] :: [Integer]) #-} +{-# ANN type Foo ''Foo #-} +{-# ANN type Foo (-1 :: Int) #-} +data Foo = Bar Int + +{-# ANN f (1 :: Int) #-} +{-# ANN f (1 :: Integer) #-} +{-# ANN f (1 :: Double) #-} +{-# ANN f $([| 1 :: Int |]) #-} +{-# ANN f "Hello" #-} +{-# ANN f (Just (1 :: Int)) #-} +{-# ANN f [1 :: Int, 2, 3] #-} +{-# ANN f ([1..10] :: [Integer]) #-} +{-# ANN f 'f #-} +{-# ANN f (-1 :: Int) #-} +f x = x + +{-# ANN foo "HLint: ignore" #-};foo = map f (map g x) diff --git a/tests/examples/ghc710/Arrow.hs b/tests/examples/ghc710/Arrow.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Arrow.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE Arrows #-} +module Arrow where + +import Control.Arrow +import qualified Control.Category as Cat + +addA :: Arrow a => a b Int -> a b Int -> a b Int +addA f g = proc x -> do + y <- f -< x + z <- g -< x + returnA -< y + z + +newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) } + +instance Cat.Category Circuit where + id = Circuit $ \a -> (Cat.id, a) + (.) = dot + where + (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a -> + let (cir1', b) = cir1 a + (cir2', c) = cir2 b + in (cir2' `dot` cir1', c) + +instance Arrow Circuit where + arr f = Circuit $ \a -> (arr f, f a) + first (Circuit cir) = Circuit $ \(b, d) -> + let (cir', c) = cir b + in (first cir', (c, d)) + +-- | Accumulator that outputs a value determined by the supplied function. +accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b +accum acc f = Circuit $ \input -> + let (output, acc') = input `f` acc + in (accum acc' f, output) + +-- | Accumulator that outputs the accumulator value. +accum' :: b -> (a -> b -> b) -> Circuit a b +accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b')) + +total :: Num a => Circuit a a +total = accum' 0 (+) + +mean3 :: Fractional a => Circuit a a +mean3 = proc value -> do + (t, n) <- (| (&&&) (total -< value) (total -< 1) |) + returnA -< t / n diff --git a/tests/examples/ghc710/Arrows.hs b/tests/examples/ghc710/Arrows.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Arrows.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE Arrows #-} +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-21-arrows.html + +import Control.Monad (guard) +import Control.Monad.Identity (Identity, runIdentity) +import Control.Arrow (returnA, Kleisli(Kleisli), runKleisli) + +f :: Int -> (Int, Int) +f = \x -> + let y = 2 * x + z1 = y + 3 + z2 = y - 5 + in (z1, z2) + +-- ghci> f 10 +-- (23, 15) + +fM :: Int -> Identity (Int, Int) +fM = \x -> do + y <- return (2 * x) + z1 <- return (y + 3) + z2 <- return (y - 5) + return (z1, z2) + +-- ghci> runIdentity (fM 10) +-- (23,15) + + +fA :: Int -> (Int, Int) +fA = proc x -> do + y <- (2 *) -< x + z1 <- (+ 3) -< y + z2 <- (subtract 5) -< y + returnA -< (z1, z2) + +-- ghci> fA 10 +-- (23,15) + +range :: Int -> [Int] +range r = [-r..r] + +cM :: Int -> [(Int, Int)] +cM = \r -> do + x <- range 5 + y <- range 5 + guard (x*x + y*y <= r*r) + return (x, y) + +-- ghci> take 10 (cM 5) +-- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)] + + +type K = Kleisli + +k :: (a -> m b) -> Kleisli m a b +k = Kleisli + +runK :: Kleisli m a b -> (a -> m b) +runK = runKleisli + +cA :: Kleisli [] Int (Int, Int) +cA = proc r -> do + x <- k range -< 5 + y <- k range -< 5 + k guard -< (x*x + y*y <= r*r) + returnA -< (x, y) + +-- ghci> take 10 (runK cA 5) +-- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)] + +getLineM :: String -> IO String +getLineM prompt = do + print prompt + getLine + +printM :: String -> IO () +printM = print + +writeFileM :: (FilePath, String) -> IO () +writeFileM (filePath, string) = writeFile filePath string + +procedureM :: String -> IO () +procedureM = \prompt -> do + input <- getLineM prompt + if input == "Hello" + then printM "You said 'Hello'" + else writeFileM ("/tmp/output", "The user said '" ++ input ++ "'") diff --git a/tests/examples/ghc710/Associated.hs b/tests/examples/ghc710/Associated.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Associated.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +-- From https://www.haskell.org/haskellwiki/GHC/Type_families#An_associated_data_type_example + +import qualified Data.IntMap +import Prelude hiding (lookup) +import Data.Char (ord) + +class GMapKey k where + data GMap k :: * -> * + empty :: GMap k v + lookup :: k -> GMap k v -> Maybe v + insert :: k -> v -> GMap k v -> GMap k v + +-- An Int instance +instance GMapKey Int where + data GMap Int v = GMapInt (Data.IntMap.IntMap v) + empty = GMapInt Data.IntMap.empty + lookup k (GMapInt m) = Data.IntMap.lookup k m + insert k v (GMapInt m) = GMapInt (Data.IntMap.insert k v m) + +-- A Char instance +instance GMapKey Char where + data GMap Char v = GMapChar (GMap Int v) + empty = GMapChar empty + lookup k (GMapChar m) = lookup (ord k) m + insert k v (GMapChar m) = GMapChar (insert (ord k) v m) + +-- A Unit instance +instance GMapKey () where + data GMap () v = GMapUnit (Maybe v) + empty = GMapUnit Nothing + lookup () (GMapUnit v) = v + insert () v (GMapUnit _) = GMapUnit $ Just v + +-- Product and sum instances +instance (GMapKey a, GMapKey b) => GMapKey (a, b) where + data GMap (a, b) v = GMapPair (GMap a (GMap b v)) + empty = GMapPair empty + lookup (a, b) (GMapPair gm) = lookup a gm >>= lookup b + insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of + Nothing -> insert a (insert b v empty) gm + Just gm2 -> insert a (insert b v gm2 ) gm + +instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where + data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) + empty = GMapEither empty empty + lookup (Left a) (GMapEither gm1 _gm2) = lookup a gm1 + lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2 + insert (Left a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2 + insert (Right b) v (GMapEither gm1 gm2) = GMapEither gm1 (insert b v gm2) + +myGMap :: GMap (Int, Either Char ()) String +myGMap = insert (5, Left 'c') "(5, Left 'c')" $ + insert (4, Right ()) "(4, Right ())" $ + insert (5, Right ()) "This is the one!" $ + insert (5, Right ()) "This is the two!" $ + insert (6, Right ()) "(6, Right ())" $ + insert (5, Left 'a') "(5, Left 'a')" $ + empty + +main = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap + +-- (Type) Synonym Family + +type family Elem c + +type instance Elem [e] = e + +-- type instance Elem BitSet = Char + + +data family T a +data instance T Int = T1 Int | T2 Bool +newtype instance T Char = TC Bool + +data family G a b +data instance G [a] b where + G1 :: c -> G [Int] b + G2 :: G [a] Bool diff --git a/tests/examples/ghc710/AssociatedType.hs b/tests/examples/ghc710/AssociatedType.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/AssociatedType.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} +class Foldable t where + type FoldableConstraint t x :: * + type FoldableConstraint t x = () + diff --git a/tests/examples/ghc710/B.hs b/tests/examples/ghc710/B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/B.hs @@ -0,0 +1,4 @@ + +foo x = case (odd x) of + True -> "Odd" + False -> "Even" diff --git a/tests/examples/ghc710/BCase.hs b/tests/examples/ghc710/BCase.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/BCase.hs @@ -0,0 +1,8 @@ + + +main = + case 1 > 10 of + True -> do putStrLn "hello" + putStrLn "there" + False -> do putStrLn "blah" + putStrLn "blah" diff --git a/tests/examples/ghc710/BIf.hs b/tests/examples/ghc710/BIf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/BIf.hs @@ -0,0 +1,8 @@ + + +main = + if 1 > 10 + then do putStrLn "hello" + putStrLn "there" + else do putStrLn "blah" + putStrLn "blah" diff --git a/tests/examples/ghc710/Backquote.hs b/tests/examples/ghc710/Backquote.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Backquote.hs @@ -0,0 +1,11 @@ +import Data.List + +foo = do + let genOut (f,st) = putStrLn (f ++ "\t"++go [e`div`4,e`div`2,3*e`div`4] (scanl1 (+) $ sort st)) + Just 5 + +f = undefined +go = undefined +e = undefined + + diff --git a/tests/examples/ghc710/BangPatterns.hs b/tests/examples/ghc710/BangPatterns.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/BangPatterns.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE BangPatterns #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-05-bang-patterns.html + +import Data.Function (fix) +import Data.List (foldl') + +hello3 :: Bool -> String +hello3 !loud = "Hello." + +mean :: [Double] -> Double +mean xs = s / fromIntegral l + where + (s, l) = foldl' step (0, 0) xs + step (!s, !l) a = (s + a, l + 1) + diff --git a/tests/examples/ghc710/BootImport.hs b/tests/examples/ghc710/BootImport.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/BootImport.hs @@ -0,0 +1,3 @@ +module BootImport where + +data Foo = Foo Int diff --git a/tests/examples/ghc710/BootImport.hs-boot b/tests/examples/ghc710/BootImport.hs-boot new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/BootImport.hs-boot @@ -0,0 +1,3 @@ +module BootImport where + +data Foo diff --git a/tests/examples/ghc710/BracesSemiDataDecl.hs b/tests/examples/ghc710/BracesSemiDataDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/BracesSemiDataDecl.hs @@ -0,0 +1,7 @@ + + +data Nat (t :: NatKind) where +{ + ZeroNat :: Nat Zero; + SuccNat :: Nat t -> Nat (Succ t); +}; diff --git a/tests/examples/ghc710/CExpected.hs b/tests/examples/ghc710/CExpected.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/CExpected.hs @@ -0,0 +1,12 @@ +module CExpected where +-- Test for refactor of if to case +-- The comments on the then and else legs should be preserved + +foo x = case (odd x) of + True -> -- This is an odd result + bob x 1 + False -> -- This is an even result + bob x 2 + +bob x y = x + y + diff --git a/tests/examples/ghc710/Cg008.hs b/tests/examples/ghc710/Cg008.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Cg008.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MagicHash, BangPatterns #-} +{-# OPTIONS_GHC -O0 #-} + +-- Variant of cgrun066; compilation as a module is different. + +module Cg008 (hashStr) where + +import Foreign.C +import Data.Word +import Foreign.Ptr +import GHC.Exts + +import Control.Exception + +hashStr :: Ptr Word8 -> Int -> Int +hashStr (Ptr a#) (I# len#) = loop 0# 0# + where + loop h n | isTrue# (n GHC.Exts.==# len#) = I# h + | otherwise = loop h2 (n GHC.Exts.+# 1#) + where !c = ord# (indexCharOffAddr# a# n) + !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` 4091# diff --git a/tests/examples/ghc710/Commands.hs b/tests/examples/ghc710/Commands.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Commands.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE QuasiQuotes #-} + +commands :: [Command] +commands = [ + command "help" "display a list of all commands, and their current keybindings" $ do + macroGuesses <- Macro.guessCommands commandNames <$> getMacros + addTab (Other "Help") (makeHelpWidget commands macroGuesses) AutoClose + + , command "log" "show the error log" $ do + messages <- gets logMessages + let widget = ListWidget.moveLast (ListWidget.new $ reverse messages) + addTab (Other "Log") (AnyWidget . LogWidget $ widget) AutoClose + + , command "map" "display a list of all commands that are currently bound to keys" $ do + showMappings + + , command "map" "display the command that is currently bound to the key {name}" $ do + showMapping + + , command "map" [help| + Bind the command {expansion} to the key {name}. The same command may + be bound to different keys. + |] $ do + addMapping + + , command "unmap" "remove the binding currently bound to the key {name}" $ do + \(MacroName m) -> removeMacro m + + , command "mapclear" "" $ do + clearMacros + + , command "exit" "exit vimus" $ do + eval "quit" + + , command "quit" "exit vimus" $ do + liftIO exitSuccess :: Vimus () + + , command "close" "close the current window (not all windows can be closed)" $ do + void closeTab + + , command "source" "read the file {path} and interprets all lines found there as if they were entered as commands." $ do + \(Path p) -> liftIO (expandHome p) >>= either printError source_ + + , command "runtime" "" $ + \(Path p) -> liftIO (getDataFileName p) >>= source_ + + , command "color" "define the fore- and background color for a thing on the screen." $ do + \color fg bg -> liftIO (defineColor color fg bg) :: Vimus () + + , command "repeat" "set the playlist option *repeat*. When *repeat* is set, the playlist will start over when the last song has finished playing." $ do + MPD.repeat True :: Vimus () + + , command "norepeat" "Unset the playlist option *repeat*." $ do + MPD.repeat False :: Vimus () + + , command "consume" "set the playlist option *consume*. When *consume* is set, songs that have finished playing are automatically removed from the playlist." $ do + MPD.consume True :: Vimus () + + , command "noconsume" "Unset the playlist option *consume*." $ do + MPD.consume False :: Vimus () + + , command "random" "set the playlist option *random*. When *random* is set, songs in the playlist are played in random order." $ do + MPD.random True :: Vimus () + + , command "norandom" "Unset the playlist option *random*." $ do + MPD.random False :: Vimus () + + , command "single" "Set the playlist option *single*. When *single* is set, playback does not advance automatically to the next item in the playlist. Combine with *repeat* to repeatedly play the same song." $ do + MPD.single True :: Vimus () + + , command "nosingle" "Unset the playlist option *single*." $ do + MPD.single False :: Vimus () + + , command "autotitle" "Set the *autotitle* option. When *autotitle* is set, the console window title is automatically set to the currently playing song." $ do + setAutoTitle True + + , command "noautotitle" "Unset the *autotitle* option." $ do + setAutoTitle False + + , command "volume" "[+-] set volume to or adjust by [+-] num" $ do + volume :: Volume -> Vimus () + + , command "toggle-repeat" "Toggle the *repeat* option." $ do + MPD.status >>= MPD.repeat . not . MPD.stRepeat :: Vimus () + + , command "toggle-consume" "Toggle the *consume* option." $ do + MPD.status >>= MPD.consume . not . MPD.stConsume :: Vimus () + + , command "toggle-random" "Toggle the *random* option." $ do + MPD.status >>= MPD.random . not . MPD.stRandom :: Vimus () + + , command "toggle-single" "Toggle the *single* option." $ do + MPD.status >>= MPD.single . not . MPD.stSingle :: Vimus () + + , command "set-library-path" "While MPD knows where your songs are stored, vimus doesn't. If you want to use the *%* feature of the command :! you need to tell vimus where your songs are stored." $ do + \(Path p) -> setLibraryPath p + + , command "next" "stop playing the current song, and starts the next one" $ do + MPD.next :: Vimus () + + , command "previous" "stop playing the current song, and starts the previous one" $ do + MPD.previous :: Vimus () + + , command "toggle" "toggle between play and pause" $ do + MPDE.toggle :: Vimus () + + , command "stop" "stop playback" $ do + MPD.stop :: Vimus () + + , command "update" "tell MPD to update the music database. You must update your database when you add or delete files in your music directory, or when you edit the metadata of a song. MPD will only rescan a file already in the database if its modification time has changed." $ do + void (MPD.update Nothing) :: Vimus () + + , command "rescan" "" $ do + void (MPD.rescan Nothing) :: Vimus () + + , command "clear" "delete all songs from the playlist" $ do + MPD.clear :: Vimus () + + , command "search-next" "jump to the next occurrence of the search string in the current window" + searchNext + + , command "search-prev" "jump to the previous occurrence of the search string in the current window" + searchPrev + + + , command "window-library" "open the *Library* window" $ + selectTab Library + + , command "window-playlist" "open the *Playlist* window" $ + selectTab Playlist + + , command "window-search" "open the *SearchResult* window" $ + selectTab SearchResult + + , command "window-browser" "open the *Browser* window" $ + selectTab Browser + + , command "window-next" "open the window to the right of the current one" + nextTab + + , command "window-prev" "open the window to the left of the current one" + previousTab + + , command "!" "execute {cmd} on the system shell. See chapter \"Using an external tag editor\" for an example." + runShellCommand + + , command "seek" "jump to the given position in the current song" + seek + + , command "visual" "start visual selection" $ + sendEventCurrent EvVisual + + , command "novisual" "cancel visual selection" $ + sendEventCurrent EvNoVisual + + -- Remove current song from playlist + , command "remove" "remove the song under the cursor from the playlist" $ + sendEventCurrent EvRemove + + , command "paste" "add the last deleted song after the selected song in the playlist" $ + sendEventCurrent EvPaste + + , command "paste-prev" "" $ + sendEventCurrent EvPastePrevious + + , command "copy" "" $ + sendEventCurrent EvCopy + + , command "shuffle" "shuffle the current playlist" $ do + MPD.shuffle Nothing :: Vimus () + + , command "add" "append selected songs to the end of the playlist" $ do + sendEventCurrent EvAdd + + -- insert a song right after the current song + , command "insert" [help| + inserts a song to the playlist. The song is inserted after the currently + playing song. + |] $ do + st <- MPD.status + case MPD.stSongPos st of + Just n -> do + -- there is a current song, insert after + sendEventCurrent (EvInsert (n + 1)) + _ -> do + -- there is no current song, just add + sendEventCurrent EvAdd + + -- Playlist: play selected song + -- Library: add song to playlist and play it + -- Browse: either add song to playlist and play it, or :move-in + , command "default-action" [help| + depending on the item under the cursor, somthing different happens: + + - *Playlist* start playing the song under the cursor + + - *Library* append the song under the cursor to the playlist and start playing it + + - *Browser* on a song: append the song to the playlist and play it. On a directory: go down to that directory. + |] $ do + sendEventCurrent EvDefaultAction + + , command "add-album" "add all songs of the album of the selected song to the playlist" $ do + songs <- fromCurrent MPD.Album [MPD.Disc, MPD.Track] + maybe (printError "Song has no album metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs + + , command "add-artist" "add all songs of the artist of the selected song to the playlist" $ do + songs <- fromCurrent MPD.Artist [MPD.Date, MPD.Album, MPD.Disc, MPD.Track] + maybe (printError "Song has no artist metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs + + -- movement + , command "move-up" "move the cursor one line up" $ + sendEventCurrent EvMoveUp + + , command "move-down" "move the cursor one line down" $ + sendEventCurrent EvMoveDown + + , command "move-album-prev" "move the cursor up to the first song of an album" $ + sendEventCurrent EvMoveAlbumPrev + + , command "move-album-next" "move the cursor down to the first song of an album" $ + sendEventCurrent EvMoveAlbumNext + + , command "move-in" "go down one level the directory hierarchy in the *Browser* window" $ + sendEventCurrent EvMoveIn + + , command "move-out" "go up one level in the directory hierarchy in the *Browser* window" $ + sendEventCurrent EvMoveOut + + , command "move-first" "go to the first line in the current window" $ + sendEventCurrent EvMoveFirst + + , command "move-last" "go to the last line in the current window" $ + sendEventCurrent EvMoveLast + + , command "scroll-up" "scroll the contents of the current window up one line" $ + sendEventCurrent (EvScroll (-1)) + + , command "scroll-down" "scroll the contents of the current window down one line" $ + sendEventCurrent (EvScroll 1) + + , command "scroll-page-up" "scroll the contents of the current window up one page" $ + pageScroll >>= sendEventCurrent . EvScroll . negate + + , command "scroll-half-page-up" "scroll the contents of the current window up one half page" $ + pageScroll >>= sendEventCurrent . EvScroll . negate . (`div` 2) + + , command "scroll-page-down" "scroll the contents of the current window down one page" $ + pageScroll >>= sendEventCurrent . EvScroll + + , command "scroll-half-page-down" "scroll the contents of the current window down one half page" $ + pageScroll >>= sendEventCurrent . EvScroll . (`div` 2) + + , command "song-format" "set song rendering format" $ + sendEvent . EvChangeSongFormat + ] + diff --git a/tests/examples/ghc710/Control.hs b/tests/examples/ghc710/Control.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Control.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , ScopedTypeVariables + , BangPatterns + #-} + +module GHC.Event.Control + ( + -- * Managing the IO manager + Signal + , ControlMessage(..) + , Control + , newControl + , closeControl + -- ** Control message reception + , readControlMessage + -- *** File descriptors + , controlReadFd + , controlWriteFd + , wakeupReadFd + -- ** Control message sending + , sendWakeup + , sendDie + -- * Utilities + , setNonBlockingFD + ) where + +#include "EventConfig.h" + +import Foreign.ForeignPtr (ForeignPtr) +import GHC.Base +import GHC.Conc.Signal (Signal) +import GHC.Real (fromIntegral) +import GHC.Show (Show) +import GHC.Word (Word8) +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.C.Types (CInt(..), CSize(..)) +import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr) +import Foreign.Marshal (alloca, allocaBytes) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peek, peekElemOff, poke) +import System.Posix.Internals (c_close, c_pipe, c_read, c_write, + setCloseOnExec, setNonBlockingFD) +import System.Posix.Types (Fd) + +#if defined(HAVE_EVENTFD) +import Foreign.C.Error (throwErrnoIfMinus1) +import Foreign.C.Types (CULLong(..)) +#else +import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno) +#endif + +data ControlMessage = CMsgWakeup + | CMsgDie + | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Signal + deriving (Eq, Show) + +-- | The structure used to tell the IO manager thread what to do. +data Control = W { + controlReadFd :: {-# UNPACK #-} !Fd + , controlWriteFd :: {-# UNPACK #-} !Fd +#if defined(HAVE_EVENTFD) + , controlEventFd :: {-# UNPACK #-} !Fd +#else + , wakeupReadFd :: {-# UNPACK #-} !Fd + , wakeupWriteFd :: {-# UNPACK #-} !Fd +#endif + , didRegisterWakeupFd :: !Bool + } deriving (Show) + +#if defined(HAVE_EVENTFD) +wakeupReadFd :: Control -> Fd +wakeupReadFd = controlEventFd +{-# INLINE wakeupReadFd #-} +#endif + +-- | Create the structure (usually a pipe) used for waking up the IO +-- manager thread from another thread. +newControl :: Bool -> IO Control +newControl shouldRegister = allocaArray 2 $ \fds -> do + let createPipe = do + throwErrnoIfMinus1_ "pipe" $ c_pipe fds + rd <- peekElemOff fds 0 + wr <- peekElemOff fds 1 + -- The write end must be non-blocking, since we may need to + -- poke the event manager from a signal handler. + setNonBlockingFD wr True + setCloseOnExec rd + setCloseOnExec wr + return (rd, wr) + (ctrl_rd, ctrl_wr) <- createPipe +#if defined(HAVE_EVENTFD) + ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0 + setNonBlockingFD ev True + setCloseOnExec ev + when shouldRegister $ c_setIOManagerWakeupFd ev +#else + (wake_rd, wake_wr) <- createPipe + when shouldRegister $ c_setIOManagerWakeupFd wake_wr +#endif + return W { controlReadFd = fromIntegral ctrl_rd + , controlWriteFd = fromIntegral ctrl_wr +#if defined(HAVE_EVENTFD) + , controlEventFd = fromIntegral ev +#else + , wakeupReadFd = fromIntegral wake_rd + , wakeupWriteFd = fromIntegral wake_wr +#endif + , didRegisterWakeupFd = shouldRegister + } + +-- | Close the control structure used by the IO manager thread. +-- N.B. If this Control is the Control whose wakeup file was registered with +-- the RTS, then *BEFORE* the wakeup file is closed, we must call +-- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup +-- file after it has been closed. +closeControl :: Control -> IO () +closeControl w = do + _ <- c_close . fromIntegral . controlReadFd $ w + _ <- c_close . fromIntegral . controlWriteFd $ w + when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1) +#if defined(HAVE_EVENTFD) + _ <- c_close . fromIntegral . controlEventFd $ w +#else + _ <- c_close . fromIntegral . wakeupReadFd $ w + _ <- c_close . fromIntegral . wakeupWriteFd $ w +#endif + return () + +io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8 +io_MANAGER_WAKEUP = 0xff +io_MANAGER_DIE = 0xfe + +foreign import ccall "__hscore_sizeof_siginfo_t" + sizeof_siginfo_t :: CSize + +readControlMessage :: Control -> Fd -> IO ControlMessage +readControlMessage ctrl fd + | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do + throwErrnoIfMinus1_ "readWakeupMessage" $ + c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize) + return CMsgWakeup + | otherwise = + alloca $ \p -> do + throwErrnoIfMinus1_ "readControlMessage" $ + c_read (fromIntegral fd) p 1 + s <- peek p + case s of + -- Wakeup messages shouldn't be sent on the control + -- file descriptor but we handle them anyway. + _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup + _ | s == io_MANAGER_DIE -> return CMsgDie + _ -> do -- Signal + fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t) + withForeignPtr fp $ \p_siginfo -> do + r <- c_read (fromIntegral fd) (castPtr p_siginfo) + sizeof_siginfo_t + when (r /= fromIntegral sizeof_siginfo_t) $ + error "failed to read siginfo_t" + let !s' = fromIntegral s + return $ CMsgSignal fp s' + + where wakeupBufferSize = +#if defined(HAVE_EVENTFD) + 8 +#else + 4096 +#endif + +sendWakeup :: Control -> IO () +#if defined(HAVE_EVENTFD) +sendWakeup c = + throwErrnoIfMinus1_ "sendWakeup" $ + c_eventfd_write (fromIntegral (controlEventFd c)) 1 +#else +sendWakeup c = do + n <- sendMessage (wakeupWriteFd c) CMsgWakeup + case n of + _ | n /= -1 -> return () + | otherwise -> do + errno <- getErrno + when (errno /= eAGAIN && errno /= eWOULDBLOCK) $ + throwErrno "sendWakeup" +#endif + +sendDie :: Control -> IO () +sendDie c = throwErrnoIfMinus1_ "sendDie" $ + sendMessage (controlWriteFd c) CMsgDie + +sendMessage :: Fd -> ControlMessage -> IO Int +sendMessage fd msg = alloca $ \p -> do + case msg of + CMsgWakeup -> poke p io_MANAGER_WAKEUP + CMsgDie -> poke p io_MANAGER_DIE + CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS" + fromIntegral `fmap` c_write (fromIntegral fd) p 1 + +#if defined(HAVE_EVENTFD) +foreign import ccall unsafe "sys/eventfd.h eventfd" + c_eventfd :: CInt -> CInt -> IO CInt + +foreign import ccall unsafe "sys/eventfd.h eventfd_write" + c_eventfd_write :: CInt -> CULLong -> IO CInt +#endif + +foreign import ccall unsafe "setIOManagerWakeupFd" + c_setIOManagerWakeupFd :: CInt -> IO () diff --git a/tests/examples/ghc710/CorePragma.hs b/tests/examples/ghc710/CorePragma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/CorePragma.hs @@ -0,0 +1,6 @@ +{-# INLINE strictStream #-} +strictStream (Bitstream l v) + = {-# CORE "Strict Bitstream stream" #-} + S.concatMap stream (GV.stream v) + `S.sized` + Exact l diff --git a/tests/examples/ghc710/Cpp.hs b/tests/examples/ghc710/Cpp.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Cpp.hs @@ -0,0 +1,17 @@ +{-# Language CPP #-} + +#if __GLASGOW_HASKELL__ > 704 +foo :: Int +#else +foo :: Integer +#endif +foo = 3 + +bar :: ( +#if __GLASGOW_HASKELL__ > 704 + Int) +#else + Integer) +#endif +bar = 4 + diff --git a/tests/examples/ghc710/DataDecl.hs b/tests/examples/ghc710/DataDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DataDecl.hs @@ -0,0 +1,34 @@ +{-# Language DatatypeContexts #-} +{-# Language ExistentialQuantification #-} +{-# LAnguage GADTs #-} +{-# LAnguage KindSignatures #-} + +data Foo = A + | B + | C + +-- | data_or_newtype capi_ctype tycl_hdr constrs deriving +data {-# Ctype "Foo" "bar" #-} F1 = F1 +data {-# Ctype "baz" #-} Eq a => F2 a = F2 a + +data (Eq a,Ord a) => F3 a = F3 Int a + +data F4 a = forall x y. (Eq x,Eq y) => F4 a x y + | forall x y. (Eq x,Eq y) => F4b a x y + + +data G1 a :: * where + G1A, G1B :: Int -> G1 a + G1C :: Double -> G1 a + +data G2 a :: * where + G2A { g2a :: a, g2b :: Int } :: G2 a + G2C :: Double -> G2 a + + + +data (Eq a,Ord a) => G3 a = G3 + { g3A :: Int + , g3B :: Bool + , g3a :: a + } deriving (Eq,Ord) diff --git a/tests/examples/ghc710/DataFamilies.hs b/tests/examples/ghc710/DataFamilies.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DataFamilies.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- Based on https://www.haskell.org/haskellwiki/GHC/Type_families#Detailed_definition_of_data_families + +module DataFamilies + ( + GMap + , GMapKey(type GMapK) + ) where + +-- Type 1, Top level + +data family GMap k :: * -> * + +data family Array e + +data family ArrayK :: * -> * + + +-- Type 2, associated types + +class GMapKey k where + data GMapK k :: * -> * + +class C a b c where { data T1 c a :: * } -- OK +-- class C a b c where { data T a a :: * } -- Bad: repeated variable +-- class D a where { data T a x :: * } -- Bad: x is not a class variable +class D a where { data T2 a :: * -> * } -- OK + +-- Instances + +data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) + +data family T3 a +data instance T3 Int = A +data instance T3 Char = B +nonsense :: T3 a -> Int +-- nonsense A = 1 -- WRONG: These two equations together... +-- nonsense B = 2 -- ...will produce a type error. +nonsense = undefined + + +instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where + data GMapK (Either a b) v = GMapEitherK (GMap a v) (GMap b v) + +-- data GMap () v = GMapUnit (Maybe v) +-- deriving Show + + diff --git a/tests/examples/ghc710/Dead1.hs b/tests/examples/ghc710/Dead1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Dead1.hs @@ -0,0 +1,42 @@ +{-# OPTIONS -O -ddump-stranal #-} + +module Dead1(foo) where + +foo :: Int -> Int +foo n = baz (n+1) (bar1 n) + +{-# NOINLINE bar1 #-} +bar1 n = 1 + bar n + +bar :: Int -> Int +{-# NOINLINE bar #-} +{-# RULES +"bar/foo" forall n. bar (foo n) = n + #-} +bar n = n-1 + +baz :: Int -> Int -> Int +{-# INLINE [0] baz #-} +baz m n = m + + +{- Ronam writes (Feb08) + + Note that bar becomes dead as soon as baz gets inlined. But strangely, + the simplifier only deletes it after full laziness and CSE. That is, it + is not deleted in the phase in which baz gets inlined. In fact, it is + still there after w/w and the subsequent simplifier run. It gets deleted + immediately if I comment out the rule. + + I stumbled over this when I removed one simplifier run after SpecConstr + (at the moment, it runs twice at the end but I don't think that should + be necessary). With this change, the original version of a specialised + loop (the one with the rules) is not longer deleted even if it isn't + used any more. I'll reenable the second simplifier run for now but + should this really be necessary? + +No, it should not be necessary. A refactoring in OccurAnal makes +this work right. Look at the simplifier output just before strictness +analysis; there should be a binding for 'foo', but for nothing else. + +-} diff --git a/tests/examples/ghc710/Default.hs b/tests/examples/ghc710/Default.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Default.hs @@ -0,0 +1,8 @@ +default (Integer, Double) -- "default default" + +mag :: Float -> Float -> Float +mag x y = sqrt( x^2 + y^2 ) + +main = do + +print $ mag 1 1 diff --git a/tests/examples/ghc710/DefaultTypeInstance.hs b/tests/examples/ghc710/DefaultTypeInstance.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DefaultTypeInstance.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} + + +class Foldable t where + type FoldableConstraint t x :: Constraint + type FoldableConstraint t x = () diff --git a/tests/examples/ghc710/Deriving.hs b/tests/examples/ghc710/Deriving.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Deriving.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +import Data.Data + +data Foo = FooA | FooB + +deriving instance Show Foo + +deriving instance {-# Overlappable #-} Eq Foo +deriving instance {-# Overlapping #-} Ord Foo +deriving instance {-# Overlaps #-} Typeable Foo +deriving instance {-# Incoherent #-} Data Foo + diff --git a/tests/examples/ghc710/DerivingOC.hs b/tests/examples/ghc710/DerivingOC.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DerivingOC.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-15-deriving.html + +import Data.Data +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.State + +data MiniIoF a = Terminate + | PrintLine String a + | ReadLine (String -> a) + deriving (Functor) + + +-- data List a = Nil | Cons a (List a) +-- deriving (Eq, Show, Functor, Foldable, Traversable) + + + +data List a = Nil | Cons a (List a) + deriving ( Eq, Show + , Functor, Foldable, Traversable + , Typeable, Data) + +data Config = C String String +data AppState = S Int Bool + +newtype App a = App { unApp :: ReaderT Config (StateT AppState IO) a } + deriving (Monad, MonadReader Config, + MonadState AppState, MonadIO, + Applicative,Functor) diff --git a/tests/examples/ghc710/DoParens.hs b/tests/examples/ghc710/DoParens.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DoParens.hs @@ -0,0 +1,4 @@ + +foo = do + (-) <- Just 5 + return () diff --git a/tests/examples/ghc710/DoPatBind.hs b/tests/examples/ghc710/DoPatBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DoPatBind.hs @@ -0,0 +1,4 @@ +module Main where + +bar = do + foo :: String <- baz diff --git a/tests/examples/ghc710/DocDecls.hs b/tests/examples/ghc710/DocDecls.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DocDecls.hs @@ -0,0 +1,7 @@ +module DocDecls where + +-- | A document before +data Foo = A Int | B Char + deriving (Show) + + diff --git a/tests/examples/ghc710/DoubleForall.hs b/tests/examples/ghc710/DoubleForall.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DoubleForall.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ScopedTypeVariables #-} + + +extremumNewton :: (Eq a, Fractional a) => + (forall tag. forall tag1. + Tower tag1 (Tower tag a) + -> Tower tag1 (Tower tag a)) + -> a -> [a] +extremumNewton f x0 = zeroNewton (diffUU f) x0 diff --git a/tests/examples/ghc710/DroppedComma.hs b/tests/examples/ghc710/DroppedComma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DroppedComma.hs @@ -0,0 +1,5 @@ + + +foo = + let (xs, ys) = ([1,2..3], [4,5..6]) in + bar diff --git a/tests/examples/ghc710/DroppedDoSpace.hs b/tests/examples/ghc710/DroppedDoSpace.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DroppedDoSpace.hs @@ -0,0 +1,26 @@ +import FooBarBaz -- non-existent import, check that we can still parse + +save :: C -> IO () +save state = saveFileDialog "Save file " (maybe Nothing (Just . (++) "*.") (filesuffix state)) $ + do \fileName -> + case onSaveCB state of + Nothing -> + return () + Just callback -> + do + c <- callback + case c of + Nothing -> + return () + Just c' -> + let realfn = maybe + fileName + (extendFileName fileName) + (filesuffix state) + in do + L.writeFile realfn c' + postGUIAsync $ labelSetText (View.statusL $ gui state) $ realfn ++ " Saved." + where + extendFileName fileName suffix = if isSuffixOf suffix fileName + then fileName + else fileName ++ "." ++ suffix diff --git a/tests/examples/ghc710/DroppedDoSpace2.hs b/tests/examples/ghc710/DroppedDoSpace2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DroppedDoSpace2.hs @@ -0,0 +1,6 @@ + + +save state = do \fileName -> + 4 + + diff --git a/tests/examples/ghc710/EmptyMostly.hs b/tests/examples/ghc710/EmptyMostly.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/EmptyMostly.hs @@ -0,0 +1,13 @@ +module EmptyMostly where + { ;;; + ;;x=let{;;;;;y=2;;z=3;;;;}in y; + -- ;;;; + class Foo a where {;;;;;; + (--<>--) :: a -> a -> Int ; + infixl 5 --<>-- ; + (--<>--) _ _ = 2 ; -- empty decl at the end. +}; +-- ;;;;;;;;;;;; +-- foo = a where {;;;;;;;;;;;;;;;;;;;;;;;a=1;;;;;;;;} +-- ;; + } diff --git a/tests/examples/ghc710/EmptyMostly2.hs b/tests/examples/ghc710/EmptyMostly2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/EmptyMostly2.hs @@ -0,0 +1,8 @@ +module EmptyMostly2 where + { +;;;;;;;;;;;; +; +class Baz a where {;;;;;;;;; + ; baz :: a -> Int;;; +} + } diff --git a/tests/examples/ghc710/EmptyMostlyInst.hs b/tests/examples/ghc710/EmptyMostlyInst.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/EmptyMostlyInst.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleInstances #-} +module EmptyMostlyInst where + { +;;;;;;;;;;;; +; +instance Eq (Int,Integer) where {;;;;;;;;; +;;;;;;; a == b = False;;;;;;;;;;; +} + } diff --git a/tests/examples/ghc710/EmptyMostlyNoSemis.hs b/tests/examples/ghc710/EmptyMostlyNoSemis.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/EmptyMostlyNoSemis.hs @@ -0,0 +1,8 @@ +module EmptyMostlyNoSemis where + +x=let{y=2}in y +class Foo a where { + (--<>--) :: a -> a -> Int; + infixl 5 --<>--; + (--<>--) _ _ = 2 ; -- empty decl at the end. + } diff --git a/tests/examples/ghc710/Existential.hs b/tests/examples/ghc710/Existential.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Existential.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-19-existential-quantification.html + +data HashMap k v = HM -- ... -- actual implementation + +class Hashable v where + h :: v -> Int + +data HashMapM hm = HashMapM + { empty :: forall k v . hm k v + , lookup :: Hashable k => k -> hm k v -> Maybe v + , insert :: Hashable k => k -> v -> hm k v -> hm k v + , union :: Hashable k => hm k v -> hm k v -> hm k v + } + + +data HashMapE = forall hm . HashMapE (HashMapM hm) + +-- public +mkHashMapE :: Int -> HashMapE +mkHashMapE = HashMapE . mkHashMapM + +-- private +mkHashMapM :: Int -> HashMapM HashMap +mkHashMapM salt = HashMapM { {- implementation -} } + +instance Hashable String where + +type Name = String +data Gift = G String + +giraffe :: Gift +giraffe = G "giraffe" + +addGift :: HashMapM hm -> hm Name Gift -> hm Name Gift +addGift mod gifts = + let + HashMapM{..} = mod + in + insert "Ollie" giraffe gifts + +-- ------------------------------- + +santa'sSecretSalt = undefined +sendGiftToOllie = undefined +traverse_ = undefined + +sendGifts = + case mkHashMapE santa'sSecretSalt of + HashMapE (mod@HashMapM{..}) -> + let + gifts = addGift mod empty + in + traverse_ sendGiftToOllie $ lookup "Ollie" gifts diff --git a/tests/examples/ghc710/ExplicitNamespaces.hs b/tests/examples/ghc710/ExplicitNamespaces.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ExplicitNamespaces.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +module CLaSH.Prelude.BitIndex where + +import GHC.TypeLits (KnownNat, type (+), type (-)) diff --git a/tests/examples/ghc710/Expr.hs b/tests/examples/ghc710/Expr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Expr.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Expr where + +import Data.Generics +import Language.Haskell.TH as TH +import Language.Haskell.TH.Quote + +-- import Text.ParserCombinators.Parsec +-- import Text.ParserCombinators.Parsec.Char + +data Expr = IntExpr Integer + | AntiIntExpr String + | BinopExpr BinOp Expr Expr + | AntiExpr String + deriving(Typeable, Data,Show) + +data BinOp = AddOp + | SubOp + | MulOp + | DivOp + deriving(Typeable, Data,Show) + +eval :: Expr -> Integer +eval (IntExpr n) = n +eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y) + where + opToFun AddOp = (+) + opToFun SubOp = (-) + opToFun MulOp = (*) + opToFun DivOp = (div) + +small = lower <|> char '_' +large = upper +idchar = small <|> large <|> digit <|> char '\'' + +lexeme p = do{ x <- p; spaces; return x } +symbol name = lexeme (string name) +parens p = undefined -- between (symbol "(") (symbol ")") p + +_expr :: CharParser st Expr +_expr = term `chainl1` mulop + +term :: CharParser st Expr +term = factor `chainl1` addop + +factor :: CharParser st Expr +factor = parens _expr <|> integer <|> anti + +mulop = undefined +{- + do{ symbol "*"; return $ BinopExpr MulOp } + <|> do{ symbol "/"; return $ BinopExpr DivOp } +-} +addop = undefined +{- + do{ symbol "+"; return $ BinopExpr AddOp } + <|> do{ symbol "-"; return $ BinopExpr SubOp } +-} + +integer :: CharParser st Expr +integer = lexeme $ do{ ds <- many1 digit ; return $ IntExpr (read ds) } + +anti = undefined +{- + lexeme $ + do symbol "$" + c <- small + cs <- many idchar + return $ AntiIntExpr (c : cs) +-} + +parseExpr :: Monad m => TH.Loc -> String -> m Expr +parseExpr (Loc {loc_filename = file, loc_start = (line,col)}) s = + case runParser p () "" s of + Left err -> fail $ "baz" + Right e -> return e + where + p = do pos <- getPosition + setPosition $ setSourceName (setSourceLine (setSourceColumn pos col) line) file + spaces + e <- _expr + eof + return e + +expr = QuasiQuoter { quoteExp = parseExprExp, quotePat = parseExprPat } + +parseExprExp :: String -> Q Exp +parseExprExp s = do loc <- location + expr <- parseExpr loc s + dataToExpQ (const Nothing `extQ` antiExprExp) expr + +antiExprExp :: Expr -> Maybe (Q Exp) +antiExprExp (AntiIntExpr v) = Just $ appE (conE (mkName "IntExpr")) + (varE (mkName v)) +antiExprExp (AntiExpr v) = Just $ varE (mkName v) +antiExprExp _ = Nothing + +parseExprPat :: String -> Q Pat +parseExprPat s = do loc <- location + expr <- parseExpr loc s + dataToPatQ (const Nothing `extQ` antiExprPat) expr + +antiExprPat :: Expr -> Maybe (Q Pat) +antiExprPat (AntiIntExpr v) = Just $ conP (mkName "IntExpr") + [varP (mkName v)] +antiExprPat (AntiExpr v) = Just $ varP (mkName v) +antiExprPat _ = Nothing + +-- keep parser happy +runParser = undefined +getPosition = undefined +setPosition = undefined +setSourceName = undefined +setSourceLine = undefined +setSourceColumn = undefined +spaces = undefined +eof = undefined +many = undefined +digit = undefined +many1 = undefined +data CharParser a b = F a b +(<|>) = undefined +chainl1 = undefined +string = undefined +char = undefined +lower = undefined +upper = undefined +between = undefined +instance Monad (CharParser a) where +instance Applicative (CharParser a) where +instance Functor (CharParser a) where + diff --git a/tests/examples/ghc710/ExprPragmas.hs b/tests/examples/ghc710/ExprPragmas.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ExprPragmas.hs @@ -0,0 +1,7 @@ +module ExprPragmas where + +a = {-# SCC "name" #-} 0x5 + +b = {-# SCC foo #-} 006 + +c = {-# GENERATED "foobar" 1 : 2 - 3 : 4 #-} 0.00 diff --git a/tests/examples/ghc710/ExtraConstraints1.hs b/tests/examples/ghc710/ExtraConstraints1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ExtraConstraints1.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ExtraConstraints1 where + +arbitCs1 :: _ => a -> String +arbitCs1 x = show (succ x) ++ show (x == x) + +arbitCs2 :: (Show a, _) => a -> String +arbitCs2 x = arbitCs1 x + +arbitCs3 :: (Show a, Enum a, _) => a -> String +arbitCs3 x = arbitCs1 x + +arbitCs4 :: (Eq a, _) => a -> String +arbitCs4 x = arbitCs1 x + +arbitCs5 :: (Eq a, Enum a, Show a, _) => a -> String +arbitCs5 x = arbitCs1 x diff --git a/tests/examples/ghc710/FooExpected.hs b/tests/examples/ghc710/FooExpected.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/FooExpected.hs @@ -0,0 +1,8 @@ + + +main = + case 1 > 10 of + True -> do putStrLn "hello" + putStrLn "there" + False -> do putStrLn "blah" + putStrLn "blah" diff --git a/tests/examples/ghc710/ForAll.hs b/tests/examples/ghc710/ForAll.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ForAll.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes #-} +module ForAll where + +import Data.Data + +foo :: (forall a. Data a => a -> a) -> forall a. Data a => a -> a +foo a = a diff --git a/tests/examples/ghc710/ForeignDecl.hs b/tests/examples/ghc710/ForeignDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ForeignDecl.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE MagicHash, UnliftedFFITypes #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +-- Based on ghc/testsuite/tests/ffi/should_compile contents +module ForeignDecl where + +import Foreign +import GHC.Exts +import Data.Int +import Data.Word + +-- simple functions + +foreign import ccall unsafe "a" a :: IO Int + +foreign import ccall unsafe "b" b :: Int -> IO Int + +foreign import ccall unsafe "c" + c :: Int -> Char -> Float -> Double -> IO Float + +-- simple monadic code + +d = a >>= \ x -> + b x >>= \ y -> + c y 'f' 1.0 2.0 + +-- We can't import the same function using both stdcall and ccall +-- calling conventions in the same file when compiling via C (this is a +-- restriction in the C backend caused by the need to emit a prototype +-- for stdcall functions). +foreign import stdcall "p" m_stdcall :: StablePtr a -> IO (StablePtr b) +foreign import ccall unsafe "q" m_ccall :: ByteArray# -> IO Int + +-- We can't redefine the calling conventions of certain functions (those from +-- math.h). +foreign import stdcall "my_sin" my_sin :: Double -> IO Double +foreign import stdcall "my_cos" my_cos :: Double -> IO Double + +foreign import stdcall "m1" m8 :: IO Int8 +foreign import stdcall "m2" m16 :: IO Int16 +foreign import stdcall "m3" m32 :: IO Int32 +foreign import stdcall "m4" m64 :: IO Int64 + +foreign import stdcall "dynamic" d8 :: FunPtr (IO Int8) -> IO Int8 +foreign import stdcall "dynamic" d16 :: FunPtr (IO Int16) -> IO Int16 +foreign import stdcall "dynamic" d32 :: FunPtr (IO Int32) -> IO Int32 +foreign import stdcall "dynamic" d64 :: FunPtr (IO Int64) -> IO Int64 + +foreign import ccall unsafe "safe_qd.h safe_qd_add" c_qd_add :: Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO (); + +foreign import ccall unsafe "kitchen" + sink :: Ptr a + -> ByteArray# + -> MutableByteArray# RealWorld + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Int64 + -> Word8 + -> Word16 + -> Word32 + -> Word64 + -> Float + -> Double + -> IO () + + +type Sink2 b = Ptr b + -> ByteArray# + -> MutableByteArray# RealWorld + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Word8 + -> Word16 + -> Word32 + -> Float + -> Double + -> IO () + +foreign import ccall unsafe "dynamic" + sink2 :: Ptr (Sink2 b) -> Sink2 b + +-- exports +foreign export ccall "plusInt" (+) :: Int -> Int -> Int + +listToJSArray :: ToJSRef a => [a] -> IO (JSArray a) +listToJSArray = toJSArray deconstr + where deconstr (x : xs) = Just (x, xs) + deconstr [] = Nothing + +foreign import javascript unsafe "$r = new Float32Array($1);" + float32Array :: JSArray Float -> IO Float32Array + +foreign import javascript unsafe "$r = new Int32Array($1);" + int32Array :: JSArray Int32 -> IO Int32Array + +foreign import javascript unsafe "$r = new Uint16Array($1);" + uint16Array :: JSArray Word16 -> IO Uint16Array + +foreign import javascript unsafe "$r = new Uint8Array($1);" + uint8Array :: JSArray Word8 -> IO Uint8Array + +foreign import javascript unsafe "$r = $1.getContext(\"webgl\");" + getCtx :: JSRef a -> IO Ctx diff --git a/tests/examples/ghc710/FromUtils.hs b/tests/examples/ghc710/FromUtils.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/FromUtils.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +import Data.Data + + +-- --------------------------------------------------------------------- + +instance AnnotateP RdrName where + annotateP l n = do + case rdrName2String n of + "[]" -> do + addDeltaAnnotation AnnOpenS -- '[' + addDeltaAnnotation AnnCloseS -- ']' + +-- --------------------------------------------------------------------- + +class (Typeable ast) => AnnotateP ast where + annotateP :: SrcSpan -> ast -> IO () + + +type SrcSpan = Int +rdrName2String = undefined +type RdrName = String + +data A = AnnOpenS | AnnCloseS + +addDeltaAnnotation = undefined diff --git a/tests/examples/ghc710/FunDeps.hs b/tests/examples/ghc710/FunDeps.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/FunDeps.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +-- FunDeps example +class Foo a b c | a b -> c where + bar :: a -> b -> c + diff --git a/tests/examples/ghc710/FunctionalDeps.hs b/tests/examples/ghc710/FunctionalDeps.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/FunctionalDeps.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +-- from https://ocharles.org.uk/blog/posts/2014-12-14-functional-dependencies.html + +import Data.Foldable (forM_) +import Data.IORef + +class Store store m | store -> m where + new :: a -> m (store a) + get :: store a -> m a + put :: store a -> a -> m () + +instance Store IORef IO where + new = newIORef + get = readIORef + put ioref a = modifyIORef ioref (const a) + diff --git a/tests/examples/ghc710/GADTContext.hs b/tests/examples/ghc710/GADTContext.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/GADTContext.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} + +data StackItem a where + Snum :: forall a. Fractional a => a -> StackItem a + Sop :: OpDesc -> StackItem a +deriving instance Show a => Show (StackItem a) + +-- AZ added to test Trac #10399 +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]) diff --git a/tests/examples/ghc710/GADTRecords.hs b/tests/examples/ghc710/GADTRecords.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/GADTRecords.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE GADTs #-} +module GADTRecords (H1(..)) where + +-- | h1 +data H1 a b where + C1 :: H1 a b + C2 :: Ord a => [a] -> H1 a a + C3 :: { field :: Int -- ^ hello docs + } -> H1 Int Int + C4 :: { field2 :: a -- ^ hello2 docs + } -> H1 Int a + + FwdDataflowAnalysis :: (Eq f, Monad m) => { analysisTop :: f + , analysisMeet :: f -> f -> f + , analysisTransfer :: f -> Instruction -> m f + , analysisFwdEdgeTransfer :: Maybe (f -> Instruction -> m [(BasicBlock, f)]) + } -> DataflowAnalysis m f + +data GADT :: * -> * where + Ctor :: { gadtField :: A } -> GADT A diff --git a/tests/examples/ghc710/GADTRecords2.hs b/tests/examples/ghc710/GADTRecords2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/GADTRecords2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTs #-} +module GADTRecords2 (H1(..)) where + +-- | h1 +data H1 a b where + C3 :: (Num a) => { field :: a -- ^ hello docs + } -> H1 Int Int diff --git a/tests/examples/ghc710/GHCOrig.hs b/tests/examples/ghc710/GHCOrig.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/GHCOrig.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, DeriveGeneric #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Tuple +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/ghc-prim/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- The tuple data types +-- +----------------------------------------------------------------------------- + +module GHC.Tuple where + + +default () -- Double and Integer aren't available yet + +-- | The unit datatype @()@ has one non-undefined member, the nullary +-- constructor @()@. +data () = () + +data (,) a b = (,) a b +data (,,) a b c = (,,) a b c +data (,,,) a b c d = (,,,) a b c d +data (,,,,) a b c d e = (,,,,) a b c d e +data (,,,,,) a b c d e f = (,,,,,) a b c d e f +data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g +data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h +data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i +data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j +data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k +data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l +data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m +data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n +data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o +data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p +data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q + = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q +data (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r + = (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r +data (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s + = (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s +data (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t + = (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t +data (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u + = (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u +data (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v + = (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v +data (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w + = (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w +data (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x + = (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x +data (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y + = (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y +data (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z + = (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z +data (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ + +{- Manuel says: Including one more declaration gives a segmentation fault. +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___ +-} diff --git a/tests/examples/ghc710/GenericDeriving.hs b/tests/examples/ghc710/GenericDeriving.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/GenericDeriving.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +import GHC.Generics + +-- from https://ocharles.org.uk/blog/posts/2014-12-16-derive-generic.html + +data Valid e a = Error e | OK a + deriving (Generic) + +toEither :: Valid e a -> Either e a +toEither (Error e) = Left e +toEither (OK a) = Right a + +fromEither :: Either e a -> Valid e a +fromEither (Left e) = Error e +fromEither (Right a) = OK a + +-- --------------------------------------------------------------------- + +class GetError rep e | rep -> e where + getError' :: rep a -> Maybe e + +instance GetError f e => GetError (M1 i c f) e where + getError' (M1 m1) = getError' m1 + +instance GetError l e => GetError (l :+: r) e where + getError' (L1 l) = getError' l + getError' (R1 _) = Nothing + +instance GetError (K1 i e) e where + getError' (K1 e) = Just e + +getError :: (Generic (errorLike e a), GetError (Rep (errorLike e a)) e) => errorLike e a -> Maybe e +getError = getError' . from + diff --git a/tests/examples/ghc710/Guards.hs b/tests/examples/ghc710/Guards.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Guards.hs @@ -0,0 +1,6 @@ + + +f x | x > 0, x /= 10 = 1 / x + | x == 0 = undefined + where + y = 4 diff --git a/tests/examples/ghc710/Hang.hs b/tests/examples/ghc710/Hang.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Hang.hs @@ -0,0 +1,1 @@ +(~>) = forall diff --git a/tests/examples/ghc710/HangingRecord.hs b/tests/examples/ghc710/HangingRecord.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/HangingRecord.hs @@ -0,0 +1,5 @@ + +data Foo = Foo + { r1 :: Int + , r2 :: Int + } diff --git a/tests/examples/ghc710/HashQQ.hs b/tests/examples/ghc710/HashQQ.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/HashQQ.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Web.Maid.ApacheMimeTypes where + + +import qualified Data.Text as T +import Air.TH + + + +apache_mime_types :: T.Text +apache_mime_types = [here| + +# This file maps Internet media types to unique file extension(s). +# Although created for httpd, this file is used by many software systems +# and has been placed in the public domain for unlimited redisribution. +# +# The table below contains both registered and (common) unregistered types. +# A type that has no unique extension can be ignored -- they are listed +# here to guide configurations toward known types and to make it easier to +# identify "new" types. File extensions are also commonly used to indicate +# content languages and encodings, so choose them carefully. +# +# Internet media types should be registered as described in RFC 4288. +# The registry is at . +# +# MIME type (lowercased) Extensions +# ============================================ ========== +# application/1d-interleaved-parityfec +# application/3gpp-ims+xml +# application/activemessage +application/andrew-inset ez |] + + +testComplex = assertBool "" ([$istr| + ok +#{Foo 4 "Great!" : [Foo 3 "Scott!"]} + then +|] == ("\n" ++ + " ok\n" ++ + "[Foo 4 \"Great!\",Foo 3 \"Scott!\"]\n" ++ + " then\n")) + diff --git a/tests/examples/ghc710/HsDo.hs b/tests/examples/ghc710/HsDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/HsDo.hs @@ -0,0 +1,22 @@ +module HsDo where + +import qualified Data.Map as Map + +moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] + + +graphFromEdgedVertices = undefined +nodes = undefined +lookup_node = undefined +type NodeMap a = Map.Map (Int,Int) (Int,Int,Int) +data SummaryNode = SummaryNode +moduleName = undefined +ms_mod = undefined +ms_hsc_src = undefined + diff --git a/tests/examples/ghc710/IfThenElse1.hs b/tests/examples/ghc710/IfThenElse1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/IfThenElse1.hs @@ -0,0 +1,7 @@ +-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai +main = do + cs <- if True + then getLine + else return "computer input" + putStrLn cs + diff --git a/tests/examples/ghc710/IfThenElse2.hs b/tests/examples/ghc710/IfThenElse2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/IfThenElse2.hs @@ -0,0 +1,5 @@ +-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai +main = if True +then print 12 +else print 42 + diff --git a/tests/examples/ghc710/IfThenElse3.hs b/tests/examples/ghc710/IfThenElse3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/IfThenElse3.hs @@ -0,0 +1,6 @@ +-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai +main = do + print 3 + if True then do + print 5 + else print 7 diff --git a/tests/examples/ghc710/ImplicitParams.hs b/tests/examples/ghc710/ImplicitParams.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ImplicitParams.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ImplicitParams #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-11-implicit-params.html + +import Data.Char + + +type LogFunction = String -> IO () + +type Present = String + +queueNewChristmasPresents :: LogFunction -> [Present] -> IO () +queueNewChristmasPresents logMessage presents = do + mapM (logMessage . ("Queueing present for delivery: " ++)) presents + return () + +queueNewChristmasPresents2 :: (?logMessage :: LogFunction) => [Present] -> IO () +queueNewChristmasPresents2 presents = do + mapM (?logMessage . ("Queueing present for delivery: " ++)) presents + return () + + +ex1 :: IO () +ex1 = + let ?logMessage = \t -> putStrLn ("[XMAS LOG]: " ++ t) + in queueNewChristmasPresents2 ["Cuddly Lambda", "Gamma Christmas Pudding"] + + +ex2 :: IO () +ex2 = do + -- Specifies its own logger + ex1 + + -- We can locally define a new logging function + let ?logMessage = \t -> putStrLn (zipWith (\i c -> if even i + then c + else toUpper c) + [0..] + t) + queueNewChristmasPresents2 ["Category Theory Books"] + diff --git a/tests/examples/ghc710/ImplicitSemi.hs b/tests/examples/ghc710/ImplicitSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ImplicitSemi.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ImplicitParams #-} + +explicit :: ((?above :: q, ?below :: a -> q) => b) -> q -> (a -> q) -> b +explicit x ab be = x where ?above = ab; ?below = be diff --git a/tests/examples/ghc710/ImplicitTypeSyn.hs b/tests/examples/ghc710/ImplicitTypeSyn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ImplicitTypeSyn.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnicodeSyntax #-} + +type MPI = ?mpi_secret :: MPISecret diff --git a/tests/examples/ghc710/Imports.hs b/tests/examples/ghc710/Imports.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Imports.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/ghc710/ImportsSemi.hs b/tests/examples/ghc710/ImportsSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ImportsSemi.hs @@ -0,0 +1,6 @@ +module ImportsSemi where +{ +; ; ; ; ; ; +import Data.List +;;; +} diff --git a/tests/examples/ghc710/IndentedDo.hs b/tests/examples/ghc710/IndentedDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/IndentedDo.hs @@ -0,0 +1,12 @@ + + + +foo = + parseTestFile "gitlogo-double.ppm" "a multi-image file" $ do + \res -> case res of + Right ([ PPM { ppmHeader = h1 } + , PPM { ppmHeader = h2 }], rest) -> do h1 `shouldBe` PPMHeader P6 220 92 + h2 `shouldBe` PPMHeader P6 220 92 + rest `shouldBe` Nothing + Right r -> assertFailure $ "parsed unexpected: " ++ show r + Left e -> assertFailure $ "did not parse: " ++ e diff --git a/tests/examples/ghc710/Infix.hs b/tests/examples/ghc710/Infix.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Infix.hs @@ -0,0 +1,8 @@ + +infix 3 &&& + +(&&&) :: (Eq a) => [a] -> [a] -> [a] +(&&& ) [] [] = [] +xs &&& [] = xs +( &&&) [] ys = ys + diff --git a/tests/examples/ghc710/InfixPatternSynonyms.hs b/tests/examples/ghc710/InfixPatternSynonyms.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/InfixPatternSynonyms.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | The pattern synonym equivalent of 'destIff'. +pattern l :<=> r <- Comb (Comb (Const "=" (TyBool :-> TyBool :-> TyBool)) l) r + +-- | Destructor for boolean conjunctions. +destConj :: HOLTerm -> Maybe (HOLTerm, HOLTerm) +destConj = destBinary "/\\" + +-- | The pattern synonym equivalent of 'destConj'. +pattern l :/\ r <- Binary "/\\" l r + +-- | Destructor for boolean implications. +destImp :: HOLTerm -> Maybe (HOLTerm, HOLTerm) +destImp = destBinary "==>" + +-- | The pattern synonym equivalent of 'destImp'. +pattern l :==> r <- Binary "==>" l r diff --git a/tests/examples/ghc710/InlineSemi.hs b/tests/examples/ghc710/InlineSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/InlineSemi.hs @@ -0,0 +1,1 @@ +{-# INLINE (|.) #-}; (|.)::Storable a=>Ptr a -> Int -> IO a ; (|.) a i = peekElemOff a i diff --git a/tests/examples/ghc710/Internals.hs b/tests/examples/ghc710/Internals.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Internals.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, + CPP #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE RoleAnnotations #-} +#endif + +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.IO.Internal +-- Copyright : (c) The University of Glasgow 2001-2012 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (uses Data.Array.Base) +-- +-- Mutable boxed and unboxed arrays in the IO monad. +-- +----------------------------------------------------------------------------- + +module Data.Array.IO.Internals ( + IOArray(..), -- instance of: Eq, Typeable + IOUArray(..), -- instance of: Eq, Typeable + castIOUArray, -- :: IOUArray ix a -> IO (IOUArray ix b) + unsafeThawIOUArray, + ) where + +import Data.Int +import Data.Word +import Data.Typeable + +import Control.Monad.ST ( RealWorld, stToIO ) +import Foreign.Ptr ( Ptr, FunPtr ) +import Foreign.StablePtr ( StablePtr ) + +#if __GLASGOW_HASKELL__ < 711 +import Data.Ix +#endif +import Data.Array.Base + +import GHC.IOArray (IOArray(..)) + +----------------------------------------------------------------------------- +-- Flat unboxed mutable arrays (IO monad) + +-- | Mutable, unboxed, strict arrays in the 'IO' monad. The type +-- arguments are as follows: +-- +-- * @i@: the index type of the array (should be an instance of 'Ix') +-- +-- * @e@: the element type of the array. Only certain element types +-- are supported: see "Data.Array.MArray" for a list of instances. +-- +newtype IOUArray i e = IOUArray (STUArray RealWorld i e) + deriving Typeable +#if __GLASGOW_HASKELL__ >= 708 +-- Both parameters have class-based invariants. See also #9220. +type role IOUArray nominal nominal +#endif + +instance Eq (IOUArray i e) where + IOUArray s1 == IOUArray s2 = s1 == s2 + +instance MArray IOUArray Bool IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Char IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (Ptr a) IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (FunPtr a) IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Float IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Double IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (StablePtr a) IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int8 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int16 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int32 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int64 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word8 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word16 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word32 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word64 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +-- | Casts an 'IOUArray' with one element type into one with a +-- different element type. All the elements of the resulting array +-- are undefined (unless you know what you\'re doing...). +castIOUArray :: IOUArray ix a -> IO (IOUArray ix b) +castIOUArray (IOUArray marr) = stToIO $ do + marr' <- castSTUArray marr + return (IOUArray marr') + +{-# INLINE unsafeThawIOUArray #-} +#if __GLASGOW_HASKELL__ >= 711 +unsafeThawIOUArray :: UArray ix e -> IO (IOUArray ix e) +#else +unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) +#endif +unsafeThawIOUArray arr = stToIO $ do + marr <- unsafeThawSTUArray arr + return (IOUArray marr) + +{-# RULES +"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray + #-} + +#if __GLASGOW_HASKELL__ >= 711 +thawIOUArray :: UArray ix e -> IO (IOUArray ix e) +#else +thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) +#endif +thawIOUArray arr = stToIO $ do + marr <- thawSTUArray arr + return (IOUArray marr) + +{-# RULES +"thaw/IOUArray" thaw = thawIOUArray + #-} + +{-# INLINE unsafeFreezeIOUArray #-} +#if __GLASGOW_HASKELL__ >= 711 +unsafeFreezeIOUArray :: IOUArray ix e -> IO (UArray ix e) +#else +unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) +#endif +unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr) + +{-# RULES +"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray + #-} + +#if __GLASGOW_HASKELL__ >= 711 +freezeIOUArray :: IOUArray ix e -> IO (UArray ix e) +#else +freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) +#endif +freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr) + +{-# RULES +"freeze/IOUArray" freeze = freezeIOUArray + #-} diff --git a/tests/examples/ghc710/Jon.hs b/tests/examples/ghc710/Jon.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Jon.hs @@ -0,0 +1,4 @@ +{- ___ -}import Data.Char;main=putStr$do{c<-"/1 AA A A;9+ )11929 )1191A 2C9A ";e +{- | -} .(`divMod`8).(+(-32)).ord$c};e(0,0)="\n";e(m,n)=m?" "++n?"_/" +{- | -}n?x=do{[1..n];x} --- obfuscated +{-\_/ on Fairbairn, with apologies to Chris Brown. Above is / Haskell 98 -} diff --git a/tests/examples/ghc710/LambdaCase.hs b/tests/examples/ghc710/LambdaCase.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/LambdaCase.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LambdaCase #-} + +foo = f >>= \case + Just h -> loadTestDB (h ++ "/.testdb") + Nothing -> fmap S.Right initTestDB + +{-| Is the alarm set - i.e. will it go off at some point in the future even if `setAlarm` is not called? -} +isAlarmSetSTM :: AlarmClock -> STM Bool +isAlarmSetSTM AlarmClock{..} = readTVar acNewSetting + >>= \case { AlarmNotSet -> readTVar acIsSet; _ -> return True } diff --git a/tests/examples/ghc710/LayoutLet.hs b/tests/examples/ghc710/LayoutLet.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/LayoutLet.hs @@ -0,0 +1,7 @@ + +foo x = + let + a = 1 + b = 2 + in x + a + b + diff --git a/tests/examples/ghc710/LayoutWhere.hs b/tests/examples/ghc710/LayoutWhere.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/LayoutWhere.hs @@ -0,0 +1,6 @@ + +foo x = r + where + a = 3 + b = 4 + r = a + a + b diff --git a/tests/examples/ghc710/LetExpr.hs b/tests/examples/ghc710/LetExpr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/LetExpr.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# Language DeriveFoldable #-} +{-# LANGUAGE Safe #-} +{-# options_ghc -w #-} + +-- | A simple let expression, to ensure the layout is detected +-- With some haddock in the top +{- And a normal + multiline comment too -} + module {- brah -} LetExpr ( foo -- foo does .. + , bar -- bar does .. + , Baz () -- baz does .. + , Ba ( ..),Ca(Cc,Cd) , + bbb , aaa + , module Data.List + , pattern Bar + ) + where + +import Data.List +-- A comment in the middle +import {-# SOURCE #-} BootImport ( Foo(..) ) +import {-# SoURCE #-} safe qualified BootImport as BI +import qualified Data.Map as {- blah -} Foo.Map + +import Control.Monad ( ) +import Data.Word (Word8) +import Data.Tree hiding ( drawTree ) + +import qualified Data.Maybe as M hiding ( maybe , isJust ) + + +-- comment +foo = let x = 1 + y = 2 + in x + y + +bar = 3 +bbb x + | x == 1 = () + | otherwise = () + + +aaa [ ] _ = 0 +aaa x _unk = 1 + +aba () = 0 + +x `ccc` 1 = x + 1 +x `ccc` y = x + y + +x !@# y = x + y + +data Baz = Baz1 | Baz2 + +data Ba = Ba | Bb + +data Ca = Cc | Cd + +pattern Foo a <- RealFoo a +pattern Bar a <- RealBar a + +data Thing = RealFoo Thing | RealBar Int diff --git a/tests/examples/ghc710/LetExpr2.hs b/tests/examples/ghc710/LetExpr2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/LetExpr2.hs @@ -0,0 +1,4 @@ +l z = + let + ll = 34 + in ll + z diff --git a/tests/examples/ghc710/LetExprSemi.hs b/tests/examples/ghc710/LetExprSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/LetExprSemi.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# Language DeriveFoldable #-} +{-# LANGUAGE Safe #-} +{-# options_ghc -w #-} + +-- | A simple let expression, to ensure the layout is detected +-- With some haddock in the top +{- And a normal + multiline comment too -} + module {- brah -} LetExprSemi ( foo -- foo does .. + , bar -- bar does .. + , Baz () -- baz does .. + , Ba ( ..),Ca(Cc,Cd) , + bbb , aaa + , module Data.List + , pattern Bar + ) + where +{ +import Data.List +-- A comment in the middle +; import {-# SOURCE #-} BootImport ( Foo(..) ) ; +import {-# SOURCE #-} safe qualified BootImport as BI +;;; import qualified Data.Map as {- blah -} Foo.Map; + +import Control.Monad ( ) ; +import Data.Word (Word8); +import Data.Tree hiding ( drawTree ) ; + + ; import qualified Data.Maybe as M hiding ( maybe , isJust ) +; + +-- comment +foo = let x = 1 + y = 2 + in x + y +; +bar = 3; +bbb x + | x == 1 = () + | otherwise = () + +; +aaa [] _ = 0; +aaa x _unk = 1 +; +x `ccc` 1 = x + 1; +x `ccc` y = x + y +; +x !@# y = x + y +; +data Baz = Baz1 | Baz2 +; +data Ba = Ba | Bb +; +data Ca = Cc | Cd +; +pattern Foo a <- RealFoo a ; +pattern Bar a <- RealBar a +; +data Thing = RealFoo Thing | RealBar Int +} + + diff --git a/tests/examples/ghc710/LetStmt.hs b/tests/examples/ghc710/LetStmt.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/LetStmt.hs @@ -0,0 +1,9 @@ +-- A simple let statement, to ensure the layout is detected + +module Layout.LetStmt where + +foo = do +{- ffo -}let x = 1 + y = 2 -- baz + x+y + diff --git a/tests/examples/ghc710/LiftedConstructors.hs b/tests/examples/ghc710/LiftedConstructors.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/LiftedConstructors.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DataKinds, TypeOperators, GADTs #-} + +give :: b -> Pattern '[b] a +give b = Pattern (const (Just $ oneT b)) + + +pfail :: Pattern '[] a +pfail = is (const False) + +(/\) :: Pattern vs1 a -> Pattern vs2 a -> Pattern (vs1 :++: vs2) a +(/\) = mk2 (\a -> Just (a,a)) + +data Pattern :: [*] -> * where + Nil :: Pattern '[] + Cons :: Maybe h -> Pattern t -> Pattern (h ': t) + +type Pos = '("vpos", V3 GLfloat) +type Tag = '("tagByte", V1 Word8) + +-- | Alias for the 'In' type from the 'Direction' kind, allows users to write +-- the 'BroadcastChan In a' type without enabling DataKinds. +type In = 'In +-- | Alias for the 'Out' type from the 'Direction' kind, allows users to write +-- the 'BroadcastChan Out a' type without enabling DataKinds. +type Out = 'Out diff --git a/tests/examples/ghc710/LiftedInfixConstructor.hs b/tests/examples/ghc710/LiftedInfixConstructor.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/LiftedInfixConstructor.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds, TemplateHaskell #-} + +applicate :: Bool -> [Stmt] -> ExpQ +applicate rawPatterns stmt = do + return $ foldl (\g e -> VarE '(<**>) `AppE` e `AppE` g) + (VarE 'pure `AppE` f') + es + +tuple :: Int -> ExpQ +tuple n = do + ns <- replicateM n (newName "x") + lamE [foldr (\x y -> conP '(:) [varP x,y]) wildP ns] (tupE $ map varE ns) diff --git a/tests/examples/ghc710/LinePragma.hs b/tests/examples/ghc710/LinePragma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/LinePragma.hs @@ -0,0 +1,36 @@ +module UHC.Light.Compiler.Core.SysF.AsTy +( Ty +, ty2TySysfWithEnv, ty2TyC +, ty2TyCforFFI ) +where +import UHC.Light.Compiler.Base.Common +import UHC.Light.Compiler.Opts.Base +import UHC.Light.Compiler.Error +import qualified UHC.Light.Compiler.Core as C +import qualified UHC.Light.Compiler.Ty as T +import UHC.Light.Compiler.FinalEnv + +{-# LINE 50 "src/ehc/Core/SysF/AsTy.chs" #-} +-- | The type, represented by a term CExpr +type Ty = C.SysfTy -- base ty + +-- | Binding the bound +type TyBind = C.SysfTyBind +type TyBound = C.SysfTyBound + +-- | A sequence of parameters (for now just a single type) +type TySeq = C.SysfTySeq + + +{-# LINE 67 "src/ehc/Core/SysF/AsTy.chs" #-} +ty2TySysfWithEnv :: ToSysfEnv -> T.Ty -> Ty +ty2TySysfWithEnv _ t = t + +-- | Construct a type for use by AbstractCore +ty2TyC :: EHCOpts -> ToSysfEnv -> T.Ty -> C.CTy +ty2TyC o env t = C.mkCTy o t (ty2TySysfWithEnv env t) + +{-# LINE 93 "src/ehc/Core/SysF/AsTy.chs" #-} +-- | Construct a type for use by AbstractCore, specifically for use by FFI +ty2TyCforFFI :: EHCOpts -> T.Ty -> C.CTy +ty2TyCforFFI o t = C.mkCTy o t t diff --git a/tests/examples/ghc710/ListComprehensions.hs b/tests/examples/ghc710/ListComprehensions.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ListComprehensions.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE ParallelListComp, + TransformListComp, + RecordWildCards #-} +-- MonadComprehensions, + +-- 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 ] + +legendres :: [Poly Rational] +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 + ] + +fromGroups' :: (Ord k) => a -> [a] -> Maybe (W.Stack k) -> Groups k -> [a] + -> [(Bool,(a, W.Stack k))] +fromGroups' defl defls st gs sls = + [ (isNew,fromMaybe2 (dl, single w) (l, M.lookup w gs)) + | l <- map Just sls ++ repeat Nothing, let isNew = isNothing l + | dl <- defls ++ repeat defl + | w <- W.integrate' $ W.filter (`notElem` unfocs) =<< st ] diff --git a/tests/examples/ghc710/LocalDecls2Expected.hs b/tests/examples/ghc710/LocalDecls2Expected.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/LocalDecls2Expected.hs @@ -0,0 +1,6 @@ +module LocalDecls2Expected where + +foo a = bar a + where + nn :: Int + nn = 2 diff --git a/tests/examples/ghc710/MagicHash.hs b/tests/examples/ghc710/MagicHash.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/MagicHash.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE MagicHash #-} + +module Data.Text.Internal.Builder.Functions + ( + (<>) + , i2d + ) where + +import Data.Monoid (mappend) +import Data.Text.Lazy.Builder (Builder) +import GHC.Base + +-- | Unsafe conversion for decimal digits. +{-# INLINE i2d #-} +i2d :: Int -> Char +i2d (I# i#) = C# (chr# (ord# '0'# +# i#)) + +main = + print (F# (expFloat# 3.45#)) + +-- | The normal 'mappend' function with right associativity instead of +-- left. +(<>) :: Builder -> Builder -> Builder +(<>) = mappend +{-# INLINE (<>) #-} + +infixr 4 <> + + diff --git a/tests/examples/ghc710/MangledSemiLet.hs b/tests/examples/ghc710/MangledSemiLet.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/MangledSemiLet.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE + BangPatterns + #-} + + +mtGamma a b = + 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/ghc710/Minimal.hs b/tests/examples/ghc710/Minimal.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Minimal.hs @@ -0,0 +1,37 @@ +class AwsType a where + toText :: a -> b + + + {-# MINIMAL toText #-} + +class Minimal a where + toText :: a -> b + {-# MINIMAL decimal, hexadecimal, realFloat, scientific #-} + +class Minimal a where + toText :: a -> b + {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-} + +class Minimal a where + toText :: a -> b + {-# MINIMAL (toSample | toSamples) #-} + +class ManyOps a where + aOp :: a -> a -> Bool + bOp :: a -> a -> Bool + cOp :: a -> a -> Bool + dOp :: a -> a -> Bool + eOp :: a -> a -> Bool + fOp :: a -> a -> Bool + {-# MINIMAL ( aOp) + | ( bOp , cOp) + | ((dOp | eOp) , fOp) + #-} + +class Foo a where + bar :: a -> a -> Bool + foo :: a -> a -> Bool + baq :: a -> a -> Bool + baz :: a -> a -> Bool + quux :: a -> a -> Bool + {-# MINIMAL bar, (foo, baq | foo, quux) #-} diff --git a/tests/examples/ghc710/Mixed.hs b/tests/examples/ghc710/Mixed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Mixed.hs @@ -0,0 +1,48 @@ + +import Data.List () +import Data.List hiding () + +infixl 1 `f` +-- infixr 2 `\\\` +infix 3 :==> +infix 4 `MkFoo` + +data Foo = MkFoo Int | Float :==> Double + +x `f` y = x + +(\\\) :: (Eq a) => [a] -> [a] -> [a] +(\\\) xs ys = xs + +g x = x + if True then 1 else 2 +h x = x + 1::Int + +{-# SPECIALISe j :: Int -> Int #-} +j n = n + 1 + +test = let k x y = x+y in 1 `k` 2 `k` 3 + +data Rec = (:<-:) { a :: Int, b :: Float } + +ng1 x y = negate y + +instance (Num a, Num b) => Num (a,b) + where + negate (a,b) = (ng 'c' a, ng1 'c' b) where ng x y = negate y + + + +class Foo1 a where + +class Foz a + +x = 2 where +y = 3 + +instance Foo1 Int where + +ff = ff where g = g where +type T = Int + + + diff --git a/tests/examples/ghc710/MonadComprehensions.hs b/tests/examples/ghc710/MonadComprehensions.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/MonadComprehensions.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ParallelListComp, + TransformListComp, + RecordWildCards #-} +{-# LANGUAGE MonadComprehensions #-} + +-- 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) + + +-- Monad Comprehensions + +sqrts :: M.Map Int Int +sqrts = M.fromList $ [ (x, sx) + | x <- map (^2) [1..100] + | sx <- [1..100] + ] + +sumIntSqrts :: Int -> Int -> Maybe Int +sumIntSqrts a b = [ x + y + | x <- M.lookup a sqrts + , y <- M.lookup b sqrts + ] + +greet :: IO String +greet = [ name + | name <- getLine + , _ <- putStrLn $ unwords ["Hello, ", name, "!"] + ] + diff --git a/tests/examples/ghc710/Move1.hs b/tests/examples/ghc710/Move1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Move1.hs @@ -0,0 +1,53 @@ +module Move1 where + +data Located a = L Int a +type Name = String +hsBinds = undefined +divideDecls = undefined +definingDeclsNames = undefined +nub = undefined +definedPNs :: a -> [b] +definedPNs = undefined +logm = undefined +showGhc = undefined +pnsNeedRenaming = undefined +concatMap1 = undefined + +-- liftToTopLevel' :: ModuleName -- -> (ParseResult,[PosToken]) -> FilePath +-- -> Located Name +-- -> RefactGhc [a] +liftToTopLevel' :: Int -> Located Name -> IO [a] +liftToTopLevel' modName pn@(L _ n) = do + liftToMod + return [] + where + {-step1: divide the module's top level declaration list into three parts: + 'parent' is the top level declaration containing the lifted declaration, + 'before' and `after` are those declarations before and after 'parent'. + step2: get the declarations to be lifted from parent, bind it to liftedDecls + step3: remove the lifted declarations from parent and extra arguments may be introduce. + step4. test whether there are any names need to be renamed. + -} + liftToMod :: IO () + liftToMod = do + -- renamed <- getRefactRenamed + let renamed = undefined + let declsr = hsBinds renamed + let (before,parent,after) = divideDecls declsr pn + -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ++ + {- ++AZ++ : hsBinds does not return class or instance definitions + when (isClassDecl $ ghead "liftToMod" parent) + $ error "Sorry, the refactorer cannot lift a definition from a class declaration!" + when (isInstDecl $ ghead "liftToMod" parent) + $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!" + -} + let liftedDecls = definingDeclsNames [n] parent True True + declaredPns = nub $ concatMap1 definedPNs liftedDecls + + -- TODO: what about declarations between this + -- one and the top level that are used in this one? + + logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns)) + -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns + -- pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns + return () diff --git a/tests/examples/ghc710/MultiImplicitParams.hs b/tests/examples/ghc710/MultiImplicitParams.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/MultiImplicitParams.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ImplicitParams #-} + +foo = do + ev <- let ?mousePosition = relative<$>Reactive (Size 1 1) _size<|*>_mousePos + ?buttonChanges = _button + in sink + return baz diff --git a/tests/examples/ghc710/MultiLineCommentWithPragmas.hs b/tests/examples/ghc710/MultiLineCommentWithPragmas.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/MultiLineCommentWithPragmas.hs @@ -0,0 +1,18 @@ + +{- +-- this is ugly too: can't use Data.Complex because the qd bindings do +-- not implement some low-level functions properly, leading to obscure +-- crashes inside various Data.Complex functions... +data Complex c = {-# UNPACK #-} !c :+ {-# UNPACK #-} !c deriving (Read, Show, Eq) + +-- complex number arithmetic, with extra strictness and cost-centres +instance Num c => Num (Complex c) where + (!(a :+ b)) + (!(c :+ d)) = {-# SCC "C+" #-} ((a + c) :+ (b + d)) + (!(a :+ b)) - (!(c :+ d)) = {-# SCC "C-" #-} ((a - c) :+ (b - d)) + (!(a :+ b)) * (!(c :+ d)) = {-# SCC "C*" #-} ((a * c - b * d) :+ (a * d + b * c)) + negate !(a :+ b) = (-a) :+ (-b) + abs x = error $ "Complex.abs: " ++ show x + signum x = error $ "Complex.signum: " ++ show x + fromInteger !x = fromInteger x :+ 0 +-} + diff --git a/tests/examples/ghc710/MultiParamTypeClasses.hs b/tests/examples/ghc710/MultiParamTypeClasses.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/MultiParamTypeClasses.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-13-multi-param-type-classes.html + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT) +import Data.Foldable (forM_) +import Data.IORef + +class Store store m where + new :: a -> m (store a) + get :: store a -> m a + put :: store a -> a -> m () + +type Present = String +storePresents :: (Store store m, Monad m) => [Present] -> m (store [Present]) +storePresents xs = do + store <- new [] + forM_ xs $ \x -> do + old <- get store + put store (x : old) + return store + +instance Store IORef IO where + new = newIORef + get = readIORef + put ioref a = modifyIORef ioref (const a) + +-- ex ps = do +-- store <- storePresents ps +-- get (store :: IORef [Present]) diff --git a/tests/examples/ghc710/MultiWayIf.hs b/tests/examples/ghc710/MultiWayIf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/MultiWayIf.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultiWayIf #-} + + +instance Animatable Double where + interpolate ease from to t = + if | t <= 0 -> from + | t >= 1 -> to + | otherwise -> from + easeDouble ease t * (to - from) + animAdd = (+) + animSub = (-) + animZero = 0 diff --git a/tests/examples/ghc710/NegLit.hs b/tests/examples/ghc710/NegLit.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/NegLit.hs @@ -0,0 +1,1 @@ +a = -b/c diff --git a/tests/examples/ghc710/NestedDoLambda.hs b/tests/examples/ghc710/NestedDoLambda.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/NestedDoLambda.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE Arrows #-} + +operator = describe "Operators on ProcessA"$ + do + describe "feedback" $ + do + it "acts like local variable with hold." $ + do + let + pa = proc evx -> + do + (\evy -> hold 10 -< evy) + `feedback` \y -> + do + returnA -< ((+y) <$> evx, (y+1) <$ evx) + run pa [1, 2, 3] `shouldBe` [11, 13, 15] + + it "correctly handles stream end." $ + do + let + pa = proc x -> + (\asx -> returnA -< asx) + `feedback` + (\asy -> returnA -< (asy::Event Int, x)) + comp = mkProc (PgPush PgStop) >>> pa + stateProc comp [0, 0] `shouldBe` ([], [0]) + + it "correctly handles stream end.(2)" $ + do + pendingWith "now many utilities behave incorrectly at the end of stream." + diff --git a/tests/examples/ghc710/NestedLambda.hs b/tests/examples/ghc710/NestedLambda.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/NestedLambda.hs @@ -0,0 +1,8 @@ + + + +getPath :: [String] -> Filter +getPath names elms = + let follow = foldl (\f n -> \els-> subElems n $ f els) id' names :: Filter + id' = id :: Filter + in follow elms diff --git a/tests/examples/ghc710/NullaryTypeClasses.hs b/tests/examples/ghc710/NullaryTypeClasses.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/NullaryTypeClasses.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE NullaryTypeClasses #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-10-nullary-type-classes.html + +class Logger where + logMessage :: String -> IO () + +type Present = String +queueNewChristmasPresents :: Logger => [Present] -> IO () +queueNewChristmasPresents presents = do + mapM (logMessage . ("Queueing present for delivery: " ++)) presents + return () + +instance Logger where + logMessage t = putStrLn ("[XMAS LOG]: " ++ t) + diff --git a/tests/examples/ghc710/Obscure.hs b/tests/examples/ghc710/Obscure.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Obscure.hs @@ -0,0 +1,29 @@ +type A = Integer +data B = B { u :: !B, j :: B, r :: !A, i :: [A] } | Y +c=head +k=tail +b x y=x(y)y +n=map(snd)h +m=2:3:5:[7] +f=s(flip(a))t +s x y z=x(y(z)) +e=filter(v)[2..221] +z=s(s(s((s)b)(s(s)flip)))s +main=mapM_(print)(m++map(fst)h) +v=s(flip(all)m)(s((.)(/=0))mod) +t=(s(s(s(b))flip)((s)s))(s(B(Y)Y)c)k +g=z(:)(z(,)c(b(s((s)map(*))c)))(s(g)k) +h=c(q):c(k(q)):d(p(t((c)n))(k(n)))(k((k)q)) +q=g(scanl1(+)(11:cycle(zipWith(-)((k)e)e))) +a x Y = x +a Y x = x +a x y = case compare((r)x)(r(y)) of + GT -> a(y)x + _ -> B(a((j)x)y)(u(x))((r)x)(i(x)) +p x y = case compare((r)x)(c(c(y))) of + GT -> p(f((c)y)x)(k(y)) + _ -> r(x):p(f((i)x)(a(u(x))(j(x))))y +d x y = case compare((c)x)(fst(c(y))) of + GT -> c(y):(d)x((k)y) + LT -> d(k(x))y + EQ -> d((k)x)(k(y)) diff --git a/tests/examples/ghc710/OptSig.hs b/tests/examples/ghc710/OptSig.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/OptSig.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +errors= do + let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]" + return () + +-- This can be seen as the definition of accumFilter +accumFilter2 :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) +accumFilter2 f c_init = + switch (never &&& attach c_init) afAux + where + afAux (c, a) = + case f c a of + (c', Nothing) -> switch (never &&& (notYet>>>attach c')) afAux + (c', Just b) -> switch (now b &&& (notYet>>>attach c')) afAux + + attach :: b -> SF (Event a) (Event (b, a)) + attach c = arr (fmap (\a -> (c, a))) diff --git a/tests/examples/ghc710/OptSig2.hs b/tests/examples/ghc710/OptSig2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/OptSig2.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +errors= do + let ls :: Int = undefined + return () diff --git a/tests/examples/ghc710/OveridingPrimitives.hs b/tests/examples/ghc710/OveridingPrimitives.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/OveridingPrimitives.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +(~#) :: Comonad w => CascadeW w (t ': ts) -> w t -> Last (t ': ts) +(~#) = cascadeW +infixr 0 ~# diff --git a/tests/examples/ghc710/OverloadedStrings.hs b/tests/examples/ghc710/OverloadedStrings.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/OverloadedStrings.hs @@ -0,0 +1,15 @@ +{-# Language OverloadedStrings #-} +-- from https://ocharles.org.uk/blog/posts/2014-12-17-overloaded-strings.html + +import Data.String + +n :: Num a => a +n = 43 + +f :: Fractional a => a +f = 03.1420 + +-- foo :: Text +foo :: Data.String.IsString a => a +foo = "hello\n there" + diff --git a/tests/examples/ghc710/PArr.hs b/tests/examples/ghc710/PArr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/PArr.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ParallelListComp #-} + +module PArr where + +blah xs ys = [ (x, y) | x <- xs | y <- ys ] + +-- bar = [: 1, 2 .. 3 :] + + +-- entry point for desugaring a parallel array comprehension + +-- parr = [:e | qss:] = <<[:e | qss:]>> () [:():] + +{- +ary = let arr1 = toP [1..10] + arr2 = toP [1..10] + f = [: i1 + i2 | i1 <- arr1 | i2 <- arr2 :] + in f !: 1 +-} + + +foo = 'a' + diff --git a/tests/examples/ghc710/ParensAroundContext.hs b/tests/examples/ghc710/ParensAroundContext.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ParensAroundContext.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ParensAroundContext where + +f :: ((Eq a, _)) => a -> a -> Bool +f x y = x == y diff --git a/tests/examples/ghc710/PatBind.hs b/tests/examples/ghc710/PatBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/PatBind.hs @@ -0,0 +1,34 @@ +module Layout.PatBind where + +a,b :: Int +a = 1 +b = 2 + +c :: Maybe (a -> b) +c = Nothing + +f :: (Num a1, Num a) => a -> a1 -> ( a, a1 ) +f x y = ( x+1, y-1 ) + +-- Chris done comment attachment problem +foo = x + where -- do stuff + doStuff = do stuff +x = 1 +stuff = 4 + + -- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +blah = do { + ; print "a" + ; print "b" + } + + diff --git a/tests/examples/ghc710/PatSigBind.hs b/tests/examples/ghc710/PatSigBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/PatSigBind.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +runCoreRunIO + :: EHCOpts -- ^ options, e.g. for turning on tracing (if supported by runner) + -> Mod -- ^ the module to run + -> IO (Either Err RVal) +runCoreRunIO opts mod = do + catch + (runCoreRun opts [] mod $ cmodRun opts mod) + (\(e :: SomeException) -> hFlush stdout >> (return $ Left $ strMsg $ "runCoreRunIO: " ++ show e)) + + +foo = do + (a :: Int) <- baz + return grue diff --git a/tests/examples/ghc710/PatSynBind.hs b/tests/examples/ghc710/PatSynBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/PatSynBind.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-03-pattern-synonyms.html + +import Foreign.C + +{- + +data BlendMode = NoBlending -- | AlphaBlending | AdditiveBlending | ColourModulatedBlending + +toBlendMode :: BlendMode -> CInt +toBlendMode NoBlending = 0 -- #{const SDL_BLENDMODE_NONE} +-- toBlendMode AlphaBlending = #{const SDL_BLENDMODE_BLEND} + +fromBlendMode :: CInt -> Maybe BlendMode +fromBlendMode 0 = Just NoBlending + +-} + +{- + +pattern AlphaBlending = (1) :: CInt -- #{const SDL_BLENDMODE_BLEND} :: CInt + +setUpBlendMode :: CInt -> IO () +setUpBlendMode AlphaBlending = do + putStrLn "Enabling Alpha Blending" + activateAlphaBlendingForAllTextures + activateRenderAlphaBlending + +-} + +newtype BlendMode = MkBlendMode { unBlendMode :: CInt } + +pattern NoBlending = MkBlendMode 0 -- #{const SDL_BLENDMODE_NONE} +pattern AlphaBlending = MkBlendMode 1 -- #{const SDL_BLENDMODE_BLEND} + +setUpBlendMode :: BlendMode -> IO () +setUpBlendMode AlphaBlending = do + putStrLn "Enabling Alpha Blending" + activateAlphaBlendingForAllTextures + activateRenderAlphaBlending + +data Renderer + +setRenderAlphaBlending :: Renderer -> IO () +setRenderAlphaBlending r = + sdlSetRenderDrawBlendMode r (unBlendMode AlphaBlending) + +activateAlphaBlendingForAllTextures = return () +activateRenderAlphaBlending = return () + +sdlSetRenderDrawBlendMode _ _ = return () + +-- And from https://www.fpcomplete.com/user/icelandj/Pattern%20synonyms + +data Date = Date { month :: Int, day :: Int } deriving Show + +-- Months +pattern January day = Date { month = 1, day = day } +pattern February day = Date { month = 2, day = day } +pattern March day = Date { month = 3, day = day } +-- elided +pattern December day = Date { month = 12, day = day } + +-- Holidays +pattern Christmas = Date { month = 12, day = 25 } + +describe :: Date -> String +describe (January 1) = "First day of year" +describe (February n) = show n ++ "th of February" +describe Christmas = "Presents!" +describe _ = "meh" + +pattern Christmas2 = December 25 + +pattern BeforeChristmas <- December (compare 25 -> GT) +pattern Christmas3 <- December (compare 25 -> EQ) +pattern AfterChristmas <- December (compare 25 -> LT) + +react :: Date -> String +react BeforeChristmas = "Waiting :(" +react Christmas = "Presents!" +react AfterChristmas = "Have to wait a whole year :(" +react _ = "It's not even December..." + +isItNow :: Int -> (Ordering, Int) +isItNow day = (compare 25 day, day) + +pattern BeforeChristmas4 day <- December (isItNow -> (GT, day)) +pattern Christmas4 <- December (isItNow -> (EQ, _)) +pattern AfterChristmas4 day <- December (isItNow -> (LT, day)) + +days'tilChristmas :: Date -> Int +days'tilChristmas (BeforeChristmas4 n) = 25 - n +days'tilChristmas Christmas4 = 0 +days'tilChristmas (AfterChristmas4 n) = 365 + 25 - n diff --git a/tests/examples/ghc710/PatternGuards.hs b/tests/examples/ghc710/PatternGuards.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/PatternGuards.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternGuards #-} + +match n + | Just 5 <- Just n + , Just 6 <- Nothing + , Just 7 <- Just 9 + = Just 8 diff --git a/tests/examples/ghc710/ProcNotation.hs b/tests/examples/ghc710/ProcNotation.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ProcNotation.hs @@ -0,0 +1,12 @@ +{-#LANGUAGE Arrows, RankNTypes, ScopedTypeVariables, FlexibleContexts, + TypeSynonymInstances, NoMonomorphismRestriction, FlexibleInstances #-} + +valForm initVal vtor label = withInput $ + proc ((),nm,fi) -> do + s_curr <- keepState initVal -< fi + valid <- vtor -< s_curr + case valid of + Left err -> returnA -< (textField label (Just err) s_curr nm, + Nothing) + Right x -> returnA -< (textField label Nothing s_curr nm, + Just x) diff --git a/tests/examples/ghc710/Pseudonym.hs b/tests/examples/ghc710/Pseudonym.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Pseudonym.hs @@ -0,0 +1,41 @@ +default(Int);q s=s++ss s;ss ""=" \"\"";ss s=" "++show(take 50 s)++"++\n"++ + ss(dd 50 s);t3=" ";z n=t3++" xo"!!n:t3;zl n = z(l n);j=head$[m| + (m,0)<-zip[0..]p]++[-1];l s = if j==s then 2 else p!!s;m= + "default(Int);q s=s++ss s;ss \"\"=\" \\\"\\\"\";ss s=\" \"++s"++ + "how(take 50 s)++\"++\\n\"++\n ss(dd 50 s);t3=\" \";z n"++ + "=t3++\" xo\"!!n:t3;zl n = z(l n);j=head$[m|\n (m,0)<-"++ + "zip[0..]p]++[-1];l s = if j==s then 2 else p!!s;m=\n" +vv="\n "++z0++";z0=z"++z0++"0 ;a=\n "++zl 4++"-0;b="++zl 7++"-0;c="++zl 1++ + "\n "++z0++"-0;ms"++z0++"=[[4,\n 7,1],[6,0,5],[2,8,3],[4,6,2],[7\n ,0,8],[1, 5,3],[4,0,3],[1,0,2]]\n ;main=putStr(unlines[q m,q y,vv\n "++z0++"]);x=" + ++z0++"1; d=\n "++zl 6++"-0;e="++zl 0++"-0;f="++zl 5++"\n "++z0++"-0" + ++";o="++z0++"2;p=[\n e,c,g,i,a,f,d,b,h];r=[\"\",\"You \"\n ++\"win\",\"I win\"]!!head([w|w<-[1\n ,2],x<-ms,all(\\x->w==l x)x]++[0\n "++z0++"]);n="++z0++"1" + ++"9;g=\n "++zl 2++"-0;h="++zl 8++"-0;i="++zl 3++"\n "++z0++"-0;dd"++z0++ + "=drop\n\n"++r +;y= "vv=\"\\n \"++z0++\";z0=z\"++z0++\"0 ;a=\\n \"++zl 4++\"-0;b"++ + "=\"++zl 7++\"-0;c=\"++zl 1++\n \"\\n \"++z0++\"-0;ms\"++z0+"++ + "+\"=[[4,\\n 7,1],[6,0,5],[2,8,3],[4,6,2],[7\\n ,0,8],"++ + "[1, 5,3],[4,0,3],[1,0,2]]\\n ;main=putStr(unlines[q"++ + " m,q y,vv\\n \"++z0++\"]);x=\"\n ++z0++\"1; d=\\n \"++zl 6"++ + "++\"-0;e=\"++zl 0++\"-0;f=\"++zl 5++\"\\n \"++z0++\"-0\"\n +"++ + "+\";o=\"++z0++\"2;p=[\\n e,c,g,i,a,f,d,b,h];r=[\\\"\\\",\\\""++ + "You \\\"\\n ++\\\"win\\\",\\\"I win\\\"]!!head([w|w<-[1\\n ,2]"++ + ",x<-ms,all(\\\\x->w==l x)x]++[0\\n \"++z0++\"]);n=\"++z0"++ + "++\"1\"\n ++\"9;g=\\n \"++zl 2++\"-0;h=\"++zl 8++\"-0;i=\"++"++ + "zl 3++\"\\n \"++z0++\"-0;dd\"++z0++\n \"=drop\\n\\n\"++r\n;y=" + + ;z0=z 0 ;a= + -0;b= -0;c= + -0;ms =[[4, + 7,1],[6,0,5],[2,8,3],[4,6,2],[7 + ,0,8],[1, 5,3],[4,0,3],[1,0,2]] + ;main=putStr(unlines[q m,q y,vv + ]);x= 1; d= + -0;e= -0;f= + -0;o= 2;p=[ + e,c,g,i,a,f,d,b,h];r=["","You " + ++"win","I win"]!!head([w|w<-[1 + ,2],x<-ms,all(\x->w==l x)x]++[0 + ]);n= 19;g= + -0;h= -0;i= + -0;dd =drop + diff --git a/tests/examples/ghc710/PuncFunctions.hs b/tests/examples/ghc710/PuncFunctions.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/PuncFunctions.hs @@ -0,0 +1,25 @@ +-- | Compares two functions taking one container +(=*=) :: (Eq' a b) => (f -> a) -> (g -> b) + -> SameAs f g r -> r -> Property +(f =*= g) sa i = f (toF sa i) =^= g (toG sa i) + +-- | Compares two functions taking one scalar and one container +(=?*=) :: (Eq' a b) => (t -> f -> a) -> (t -> g -> b) + -> SameAs f g r -> r -> t -> Property +(f =?*= g) sa i t = (f t =*= g t) sa i + +-- | Compares functions taking two scalars and one container +(=??*=) :: (Eq' a b) => (t -> s -> f -> a) -> (t -> s -> g -> b) + -> SameAs f g r -> r -> t -> s -> Property +(f =??*= g) sa i t s = (f t s =*= g t s) sa i + +-- | Compares two functions taking two containers +(=**=) :: (Eq' a b) => (f -> f -> a) -> (g -> g -> b) + -> SameAs f g r -> r -> r -> Property +(f =**= g) sa i = (f (toF sa i) =*= g (toG sa i)) sa + +-- | Compares two functions taking one container with preprocessing +(=*==) :: (Eq' f g) => (z -> f) -> (z -> g) -> (p -> z) + -> SameAs f g r -> p -> Property +(f =*== g) p _ i = f i' =^= g i' + where i' = p i diff --git a/tests/examples/ghc710/QuasiQuote.hs b/tests/examples/ghc710/QuasiQuote.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/QuasiQuote.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE QuasiQuotes #-} +module QuasiQuote where + +import T7918A + +ex1 = [qq|e1|] +ex2 = [qq|e2|] +ex3 = [qq|e3|] +ex4 = [qq|e4|] + +tx1 = undefined :: [qq|t1|] +tx2 = undefined :: [qq|t2|] +tx3 = undefined :: [qq|t3|] +tx4 = undefined :: [qq|t4|] + +px1 [qq|p1|] = undefined +px2 [qq|p2|] = undefined +px3 [qq|p3|] = undefined +px4 [qq|p4|] = undefined + +{-# LANGUAGE QuasiQuotes #-} + +testComplex = assertBool "" ([$istr| + ok +#{Foo 4 "Great!" : [Foo 3 "Scott!"]} + then +|] == ("\n" ++ + " ok\n" ++ + "[Foo 4 \"Great!\",Foo 3 \"Scott!\"]\n" ++ + " then\n")) + diff --git a/tests/examples/ghc710/RSA.hs b/tests/examples/ghc710/RSA.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/RSA.hs @@ -0,0 +1,19 @@ +import Data.Char +e=181021504832735228091659724090293195791121747536890433 + +u(f,m)x=i(m(x), [],let(a,b)=f(x) in(a:u(f,m)b)) +(v,h)=(foldr(\x(y )->00+128*y+x)0,u( sp(25),((==)""))) +p::(Integer,Integer )->Integer -> Integer --NotInt +p(n,m)x =i(n==0 ,1,i(z n ,q(n,m)x, r(n,m)x)) +i(n,e,d )=if(n) then(e) else (d) --23+3d4f +(g,main ,s,un)= (\x->x, y(j),\x->x*x,unlines)--) +j(o)=i(take(2)o== "e=","e="++t (drop(4-2)o),i(d>e,k,l)o) +l=un.map (show.p (e,n).v.map( fromIntegral{-g-}.ord)).h +k=co.map(map(chr .fromIntegral ).w.p(d,n). read).lines +(t,y)=(\ (o:q)-> i(o=='-' ,'1','-' ): q,interact) +q(n,m)x= mod(s( p( div(n)2, m{-jl-})x) )m--hd&&gdb +(r,z,co) =(\(n, m)x->mod(x*p(n-1, m)x)m,even ,concat)--6 +(w,sp)=( u(\x->( mod(x)128,div(x )128),(==0 )),splitAt) + +d=563347325936+1197371806136556985877790097-563347325936 +n=351189532146914946493104395525009571831256157560461451 diff --git a/tests/examples/ghc710/RankNTypes.hs b/tests/examples/ghc710/RankNTypes.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/RankNTypes.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-18-rank-n-types.html + +import System.Random +import Control.Monad.State +import Data.Char + + +id' :: forall a. a -> a +id' x = x + +f = print (id' (3 :: Integer), + id' "blah") + +-- rank 2 polymorphism +type IdFunc = forall a. a -> a + +id'' :: IdFunc +id'' x = x + +someInt :: IdFunc -> Integer +someInt id' = id' 3 + +-- rank 3 polymorphism +type SomeInt = IdFunc -> Integer + +someOtherInt :: SomeInt -> Integer +someOtherInt someInt' = + someInt' id + someInt' id + +-- random numbers + +data Player = + Player { + playerName :: String, + playerPos :: (Double, Double) + } + deriving (Eq, Ord, Show) + + +{- +randomPlayer + :: (MonadIO m, MonadState g m, RandomGen g) + => m Player +-} + +type GenAction m = forall a. (Random a) => m a + +type GenActionR m = forall a. (Random a) => (a, a) -> m a + +-- genRandom :: (RandomGen g) => GenAction (State g) +-- genRandom = state random + +genRandomR :: (RandomGen g) => GenActionR (State g) +genRandomR range = state (randomR range) + +genRandom :: (Random a, RandomGen g) => State g a +genRandom = state random + + +randomPlayer :: (MonadIO m) => GenActionR m -> m Player +randomPlayer genR = do + liftIO (putStrLn "Generating random player...") + + len <- genR (8, 12) + name <- replicateM len (genR ('a', 'z')) + x <- genR (-100, 100) + y <- genR (-100, 100) + + liftIO (putStrLn "Done.") + return (Player name (x, y)) + +main :: IO () +main = randomPlayer randomRIO >>= print + +-- scott encoding + +data List a + = Cons a (List a) + | Nil + +uncons :: (a -> List a -> r) -> r -> List a -> r +uncons co ni (Cons x xs) = co x xs +uncons co ni Nil = ni + +listNull :: List a -> Bool +listNull = uncons (\_ _ -> False) True + +listMap :: (a -> b) -> List a -> List b +listMap f = + uncons (\x xs -> Cons (f x) (listMap f xs)) + Nil + +newtype ListS a = + ListS { + unconsS :: forall r. (a -> ListS a -> r) -> r -> r + } + +nilS :: ListS a +nilS = ListS (\co ni -> ni) + +consS :: a -> ListS a -> ListS a +consS x xs = ListS (\co ni -> co x xs) + +unconsS' :: (a -> ListS a -> r) -> r -> ListS a -> r +unconsS' co ni (ListS f) = f co ni + +instance Functor ListS where + fmap f = + unconsS' (\x xs -> consS (f x) (fmap f xs)) + nilS + +-- Church Encoding +newtype ListC a = + ListC { + foldC :: forall r. (a -> r -> r) -> r -> r + } + +foldC' :: (a -> r -> r) -> r -> ListC a -> r +foldC' co ni (ListC f) = f co ni + +instance Functor ListC where + fmap f = foldC' (\x xs -> consC (f x) xs) nilC + +consC = undefined +nilC = undefined + +-- GADTs and continuation passing style +data Some :: * -> * where + SomeInt :: Int -> Some Int + SomeChar :: Char -> Some Char + Anything :: a -> Some a + + +unSome :: Some a -> a +unSome (SomeInt x) = x + 3 +unSome (SomeChar c) = toLower c +unSome (Anything x) = x + + +newtype SomeC a = + SomeC { + runSomeC :: + forall r. + ((a ~ Int) => Int -> r) -> + ((a ~ Char) => Char -> r) -> + (a -> r) -> + r + } + +-- dependent types + +idk :: forall (a :: *). a -> a +idk x = x + diff --git a/tests/examples/ghc710/RdrNames.hs b/tests/examples/ghc710/RdrNames.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/RdrNames.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples #-} +module RdrNames where + +import Data.Monoid + +-- --------------------------------------------------------------------- + +-- | 'type' qcname {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2))) +-- [mj AnnType $1,mj AnnVal $2] } + +-- Tested in DataFamilies.hs + +-- --------------------------------------------------------------------- + +-- | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) +-- [mo $1,mj AnnVal $2,mc $3] } +ff = (RdrNames.:::) 0 1 + + +-- --------------------------------------------------------------------- + +-- | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) +-- [mo $1,mj AnnVal $2,mc $3] } +data FF = ( ::: ) Int Int + +-- --------------------------------------------------------------------- + +-- | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } +data GG = GG Int Int +gg = 0 ` GG ` 1 + +-- --------------------------------------------------------------------- + +-- | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } +vv = "a" ` mappend ` "b" + +-- --------------------------------------------------------------------- + +-- | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } +vvq = "a" ` Data.Monoid.mappend ` "b" + +-- --------------------------------------------------------------------- + +-- | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) +-- [mo $1,mc $2] } +-- Tested in Vect.hs + +-- --------------------------------------------------------------------- + +-- | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) +-- [mo $1,mc $2] } +-- Tested in Vect.hs + +-- --------------------------------------------------------------------- + +-- | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple +-- (snd $2 + 1))) +-- (mo $1:mc $3:(mcommas (fst $2))) } +ng :: (, , ,) Int Int Int Int +ng = undefined + +-- --------------------------------------------------------------------- + +-- | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple +-- (snd $2 + 1))) +-- (mo $1:mc $3:(mcommas (fst $2))) } +-- Tested in Unboxed.hs + +-- --------------------------------------------------------------------- + +-- | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) +-- [mo $1,mj AnnRarrow $2,mc $3] } + +ft :: (->) a b +ft = undefined + +fp :: ( -> ) a b +fp = undefined + +type family F a :: * -> * -> * +type instance F Int = (->) +type instance F Char = ( , ) + +-- --------------------------------------------------------------------- + +-- | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mo $1,mc $2] } +lt :: [] a +lt = undefined + +-- --------------------------------------------------------------------- + +-- | '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] } + +-- GHC source indicates this constuctor is only available in PrelPArr +-- ltp :: [::] a +-- ltp = undefined + +-- --------------------------------------------------------------------- + +-- | '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon) +-- [mo $1,mj AnnTildehsh $2,mc $3] } + +-- primitive type? +-- Refl Int :: ~# * Int Int +-- Refl Maybe :: ~# (* -> *) Maybe Maybe + +-- | A data constructor used to box up all unlifted equalities +-- +-- The type constructor is special in that GHC pretends that it +-- has kind (? -> ? -> Fact) rather than (* -> * -> *) +data (~) a b = Eq# ((~#) a b) + +data Coercible a b = MkCoercible ((~#) a b) + + +-- --------------------------------------------------------------------- + +-- | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) +-- [mo $1,mj AnnVal $2,mc $3] } +-- TBD + +-- --------------------------------------------------------------------- + +-- | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) +-- [mo $1,mj AnnTilde $2,mc $3] } + +-- --------------------------------------------------------------------- + +-- tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } + +-- --------------------------------------------------------------------- + + + diff --git a/tests/examples/ghc710/RebindableSyntax.hs b/tests/examples/ghc710/RebindableSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/RebindableSyntax.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE RebindableSyntax, NoMonomorphismRestriction #-} + +-- From https://ocharles.org.uk/blog/guest-posts/2014-12-06-rebindable-syntax.html + +import Prelude hiding ((>>), (>>=), return) +import Data.Monoid +import Control.Monad ((<=<)) +import Data.Map as M + +addNumbers = do + 80 + 60 + 10 + where (>>) = (+) + return = return + +(>>) = mappend +return = mempty + +-- We can perform the same computation as above using the Sum wrapper: + +someSum :: Sum Int +someSum = do + Sum 80 + Sum 60 + Sum 10 + return + +someProduct :: Product Int +someProduct = do + Product 10 + Product 30 + +-- Why not try something non-numeric? + +tummyMuscle :: String +tummyMuscle = do + "a" + "b" + + +ff = let + (>>) = flip (.) + return = id + + arithmetic = do + (+1) + (*100) + (/300) + return + + -- Here, the input is numeric and all functions operate on a number. + -- What if we want to take a list and output a string? No problem: + + check = do + sum + sqrt + floor + show + in 4 diff --git a/tests/examples/ghc710/RecordSemi.hs b/tests/examples/ghc710/RecordSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/RecordSemi.hs @@ -0,0 +1,15 @@ +-- | Generate a generate statement for the builtin function "fst" +genFst :: BuiltinBuilder +genFst = genNoInsts genFst' +genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm] +genFst' res f args@[(arg,argType)] = do { + ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType + ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg] + ; let { + ; labels = getFieldLabels arg_htype 0 + ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0) + ; assign = mkUncondAssign res argexprA + } ; + -- Return the generate functions + ; return [assign] + } diff --git a/tests/examples/ghc710/RecordUpdate.hs b/tests/examples/ghc710/RecordUpdate.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/RecordUpdate.hs @@ -0,0 +1,6 @@ + +data Foo = F { f1 :: Int, f2 :: String } + +foo :: Int -> Foo -> Foo +foo v f = f { f1 = v } + diff --git a/tests/examples/ghc710/RecordWildcard.hs b/tests/examples/ghc710/RecordWildcard.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/RecordWildcard.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RecordWildCards #-} + + +parseArgs = + Args + { equalProb = E `elem` opts + , .. + } diff --git a/tests/examples/ghc710/RecursiveDo.hs b/tests/examples/ghc710/RecursiveDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/RecursiveDo.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE RecursiveDo #-} +-- From https://ocharles.org.uk/blog/posts/2014-12-09-recursive-do.html + +import Control.Monad.Fix + +data RoseTree a = RoseTree a [RoseTree a] + deriving (Show) + +exampleTree :: RoseTree Int +exampleTree = RoseTree 5 [RoseTree 4 [], RoseTree 6 []] + +pureMax :: Ord a => RoseTree a -> RoseTree (a, a) +pureMax tree = + let (t, largest) = go largest tree + in t + where + go :: Ord a => a -> RoseTree a -> (RoseTree (a, a), a) + go biggest (RoseTree x []) = (RoseTree (x, biggest) [], x) + go biggest (RoseTree x xs) = + let sub = map (go biggest) xs + (xs', largests) = unzip sub + in (RoseTree (x, biggest) xs', max x (maximum largests)) + +t = pureMax exampleTree + +-- --------------------------------------------------------------------- + +impureMin :: (MonadFix m, Ord b) => (a -> m b) -> RoseTree a -> m (RoseTree (a, b)) +impureMin f tree = do + rec (t, largest) <- go largest tree + return t + where + go smallest (RoseTree x []) = do + b <- f x + return (RoseTree (x, smallest) [], b) + + go smallest (RoseTree x xs) = do + sub <- mapM (go smallest) xs + b <- f x + let (xs', bs) = unzip sub + return (RoseTree (x, smallest) xs', min b (minimum bs)) + +budget :: String -> IO Int +budget "Ada" = return 10 -- A struggling startup programmer +budget "Curry" = return 50 -- A big-earner in finance +budget "Dijkstra" = return 20 -- Teaching is the real reward +budget "Howard" = return 5 -- An frugile undergraduate! + +inviteTree = RoseTree "Ada" [ RoseTree "Dijkstra" [] + , RoseTree "Curry" [ RoseTree "Howard" []] + ] + +ti = impureMin budget inviteTree + +simplemdo = mdo + return 5 + diff --git a/tests/examples/ghc710/RedundantDo.hs b/tests/examples/ghc710/RedundantDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/RedundantDo.hs @@ -0,0 +1,4 @@ +foo = + case x of + True -> foo + False -> foo diff --git a/tests/examples/ghc710/Remorse.hs b/tests/examples/ghc710/Remorse.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Remorse.hs @@ -0,0 +1,88 @@ +import Prelude as P;import Data.Char as C;import Data.List;import System.Environment as S; +main = do + (.--.)<-(--.|.--.+);(.-)<-(--.|.-+) + case (.-) of ["+",(.-)]->(-|---|--+) (.-);["-",(.-)]->(..-.|.-.|--+) (.-);_->(.|.-.)("Usage: "++(.--.)++" (+/-) F.hs") + where + (-|---|--+) (.-)=do (..-.)<-(.-.|..-.+) (.-);(.--.|...+)(((-.-.|--+) (.--).(--.).(-..-))(..-.)) + (..-.|.-.|--+) (.-)=do (..-.)<-(.-.|..-.+) (.-);(.--.|...+)(((-.-.|--+) (.--|=).(--.|=).(-..-))(..-.)) + +-- | (--| ): (-.-.|---|-.|...-|.|.-.|-) (-.-.|....|.-|.-.) -> (--|---|.-.|...|.) +_--| 'a'=".-";_--| 'b'="-...";_--| 'c'="-.-.";_--| 'd'= "-..";_--| 'e'="."; +_--| 'f'="..-.";_--| 'g'="--.";_--| 'h'="....";_--| 'i'="..";_--| 'j'=".---"; +_--| 'k'="-.-";_--| 'l'=".-..";_--| 'm'="--";_--| 'n'="-.";_--| 'o'="---"; +_--| 'p'=".--.";_--| 'q'="--.-";_--| 'r'=".-.";_--| 's'="...";_--| 't'="-"; +_--| 'u'="..-";_--| 'v'="...-";_--| 'w'=".--";_--| 'x'="-..-";_--| 'y'="-.--"; +_--| 'z'="--..";_--| '0'="-----";_--| '1'=".----";_--| '2'="..---"; +_--| '3'="...--";_--| '4'="....-";_--| '5'=".....";_--| '6'="-...."; +_--| '7'="--...";_--| '8'="---..";_--| '9'="----.";_--| '_'="!";_--| '\''="="; +_--| (-.-.) + |'A'<=(-.-.)&&(-.-.)<='Z'=(()--| (-|.-..+) (-.-.))++"+" + |(-..|.|..-.)=[(-.-.)] + +-- | (--|=): (..|-.|...-) of (--| ) +(--|=) (...)=(..-.)[(-.-.)|(-.-.)<-['a'..'z']++['0'..'9']++['A'..'Z']++['_','\''],()--| (-.-.)==(...)] + where (..-.)[]=(....|-..) (...);(..-.) (-.-.|...)=(....|-..) (-.-.|...) + +-- | (.--): (-.-.|---|-.|...-|.|.-.|-) (.--|---|.-.|-..) +(.--) (...) + |(...).|.-..["e","i","m","o","t"]=(.--)((...)++" ") -- (...|---|--|.) (..-|-.|-|..|-..|-.--) (.|-..-|-.-.|.|.--.|-|..|---|-.|...): + -- .=(-.-.|---|--|.--.|---|...|..|-|..|---|-.), ..=(-.|..-|--|.|.-.|..|-.-.) (.-.|.-|-.|--.|.), --/---=(.|-.|-..)-of-(.-..|..|-.|.) (-.-.|---|--|--|.|-.|-), -=(...|..-|-...|-|.-.|.-|-.-.|-|..|---|-.) + |(...).|.-..(-.-|.|-.--|...)=(...) + |(..|-..) (...)=(('(':).(++")").(-.-.|-.-.).(..|.--.) "|".(--|.--.)((--| )()))(...) + |(..|-.|..-.|-..-) (...)=((-|.-..).(..|-).(.--).(-|.-..).(..|-))(...) + |(-..|.|..-.)=(...) + where + (..|-..)((-..-):_)=(..|.-..+) (-..-)||(-..-)=='_' + (..|-.|..-.|-..-)((-..-):_)=(-..-)=='`' + +-- | (.--|=): do (..|-.|...-) of (.--) +(.--|=) (...) + |(...)=="|"="|" + |(..|-..) (...)=((--|.--.) (--|=).(-.-.|....|.-.|...).(-|.-..).(..|-))(...) + |(---|-.|.) (...)='`':((--|=).(..|-))(...):"`" + |(..|-.|..-.|-..-) (...)='`':((--|.--.) (--|=).(-.-.|....|.-.|...))(...)++"`" + |(-..|.|..-.)=(...) + where + (..|-..)('(':(....):(-| ))=(.--.|.-.|.) (....)&&(.-..|.-) (-| )==')'&&(.-|.-..)(??)((..|-) (-| )) + (..|-..) _=False + (.--.|.-.|.) (-.-.)=(-.-.).|.-..".-" + (..|-.|..-.|-..-) (...)=(.--.|.-.|.) ((....|-..) (...))&&(.-|.-..)(??)((-|.-..) (...))&&(.-|-.)(=='|')(...) + (---|-.|.) (...)=(.-|.-..) (.--.|.-.|.) ((..|-) (...))&&(.-..|.-) (...)=='|' + (-.-.|....|.-.|...) (...)=case (-..|.--+)(=='|')(...) of []->[];(...)->let ((.--),(...|...))=(-...|.-.)(=='|')(...) in (.--):(-.-.|....|.-.|...) (...|...) + +-- | (.--.|.-.|.|-..) (---|-.) (-.-.|....|.-|.-.|...) +(??)(-.-.)=(-.-.).|.-..".-+/=!|" + +-- | (.-..|.|-..-) (...|.-.|-.-.) -> (-|---|-.-) (...|-|.-.|.|.-|--) +(-..-)[]=[] +(-..-)((-.-.):(...))|(..|...+) (-.-.)=((-.-.):(...|...)):(-..-) (.-.|--) where ((...|...),(.-.|--))=(...|.--.) (..|...+) (...) +(-..-) (...)=(-|---|-.-):(-..-) (.-.|--) where ((-|---|-.-),(.-.|--))=(....|-..)((.--.|.-..|.|-..-) (...)) + +-- | (--.): (--.|.-..|..-|.) (...|.|--.-) (-|---|-.-|...) -> (...|..|-.|--.|.-..|.) (-|---|-.-) +(--.)((--.-):".":(-.):(.-.|--))|(..|..-+)((....|-..) (--.-))=(--.)(((--.-)++"."++(-.)):(.-.|--)) +(--.)("`":(.-.|--))=case (--.) (.-.|--) of ((--.-|-.):"`":(.-.|--))->("`"++(--.-|-.)++"`"):(--.) (.-.|--);_->("`":(.-.|--)) +(--.)((...):(...|...))=(...):(--.) (...|...) +(--.)[]=[] + +-- | (--.|=): (.-..|..|-.-|.) (--.) in (.-.|.|...-) +(--.|=)("(":(-.):")":(.-.|--))|(.-|.-..)(??)(-.)=("("++(-.)++")"):(--.|=) (.-.|--) +(--.|=)("(":(-.):" ":")":(.-.|--))|(.-|.-..)(??)(-.)=("("++(-.)++")"):(--.|=) (.-.|--) +(--.|=)("|":(.-.|--))="|":(--.|=) (.-.|--) +(--.|=)((-.):(...|...):(.-.|--))|(.-|.-..)(.|.-..".-")((..|-) (-.))&&(.-..|.-) (-.)=='|'&&(.-|.-..) (..|...+) (...|...)=(-.):(--.|=) (.-.|--) +(--.|=)((-.):(.-.|--))=(-.):(--.|=) (.-.|--) +(--.|=)[]=[] + +-- | (....|.-|...|-.-|.|.-..|.-..) (-.-|.|-.--|.--|---|.-.|-..|...) +(-.-|.|-.--|...)= + ["case","class","data","default","deriving","do","else" + ,"if","import","in","infix","infixl","infixr","instance","let","module" + ,"newtype","of","then","type","where","_","main","foreign","ccall","as"] + +-- | (.-|-...|-...|.-.|.|...-) (.-..|..|-...) (..-.|-.|...) +(-.-.|-.-.)=P.concat;(.|.-..) (-..-)=P.elem (-..-);(--|.--.)=P.map;(-.-.|--+)=P.concatMap; +(...|.--.)=P.span;(-...|.-.)=P.break;(..|.--.)=intersperse;(-..|.--+)=P.dropWhile; +(....|-..)=P.head;(-|.-..)=P.tail;(..|-)=P.init;(.-..|.-)=P.last; +(-|.-..+)=C.toLower;(..|.-..+)=C.isLower;(..|...+)=C.isSpace;(..|..-+)=C.isUpper; +(.-.|..-.+)=P.readFile;(.--.|...+)=P.putStr;(.|.-.)=P.error; +(--.|.-+)=S.getArgs;(--.|.--.+)=S.getProgName; +(.-|.-..)=P.all;(.-|-.)=P.any;(-..|.|..-.)=P.otherwise;(.--.|.-..|.|-..-)=P.lex; diff --git a/tests/examples/ghc710/Roles.hs b/tests/examples/ghc710/Roles.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Roles.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE RoleAnnotations, PolyKinds #-} + +module Roles where + +data T1 a = K1 a +data T2 a = K2 a +data T3 (a :: k) = K3 +data T4 (a :: * -> *) b = K4 (a b) + +data T5 a = K5 a +data T6 a = K6 +data T7 a b = K7 b + +type role T1 nominal +type role T2 representational +type role T3 phantom +type role T4 nominal _ +type role T5 _ diff --git a/tests/examples/ghc710/Rules.hs b/tests/examples/ghc710/Rules.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Rules.hs @@ -0,0 +1,39 @@ +module Rules where + +import Data.Char + +{-# RULES "map-loop" [ ~ ] forall f . map' f = map' (id . f) #-} + +{-# NOINLINE map' #-} +map' f [] = [] +map' f (x:xs) = f x : map' f xs + +main = print (map' toUpper "Hello, World") + +-- Should warn +foo1 x = x +{-# RULES "foo1" [ 1] forall x. foo1 x = x #-} + +-- Should warn +foo2 x = x +{-# INLINE foo2 #-} +{-# RULES "foo2" [~ 1 ] forall x. foo2 x = x #-} + +-- Should not warn +foo3 x = x +{-# NOINLINE foo3 #-} +{-# RULES "foo3" forall x. foo3 x = x #-} + +{-# NOINLINE f #-} +f :: Int -> String +f x = "NOT FIRED" + +{-# NOINLINE neg #-} +neg :: Int -> Int +neg = negate + +{-# RULES + "f" forall (c::Char->Int) (x::Char). f (c x) = "RULE FIRED" + #-} + + diff --git a/tests/examples/ghc710/RulesSemi.hs b/tests/examples/ghc710/RulesSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/RulesSemi.hs @@ -0,0 +1,9 @@ + +{-# RULES + "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; + "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x; + "cFloatConv/Float->CFloat" forall (x::Float). cFloatConv x = CFloat x; + "cFloatConv/CFloat->Float" forall (x::Float). cFloatConv CFloat x = x; + "cFloatConv/Double->CDouble" forall (x::Double). cFloatConv x = CDouble x; + "cFloatConv/CDouble->Double" forall (x::Double). cFloatConv CDouble x = x + #-}; diff --git a/tests/examples/ghc710/ScopedTypeVariables.hs b/tests/examples/ghc710/ScopedTypeVariables.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ScopedTypeVariables.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-20-scoped-type-variables.html + +import qualified Data.Map as Map + +insertMany :: forall k v . Ord k => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v +insertMany f vs m = foldr f1 m vs + where + f1 :: (k, v) -> Map.Map k v -> Map.Map k v + f1 (k,v) m = Map.insertWith f k v m diff --git a/tests/examples/ghc710/SemiInstance.hs b/tests/examples/ghc710/SemiInstance.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SemiInstance.hs @@ -0,0 +1,11 @@ + +instance ArrowTransformer (AbortT v) where { + lift = AbortT . (>>> arr Right); + tmap f = AbortT . f . unwrapAbortT; +}; + +instance MakeValueTuple Float where type ValueTuple Float = Value Float ; valueTupleOf = valueOf + +instance Foo where { + type ListElement Zero (a,r) = a; +} diff --git a/tests/examples/ghc710/SemiWorkout.hs b/tests/examples/ghc710/SemiWorkout.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SemiWorkout.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE KindSignatures + , GADTs + , ScopedTypeVariables + , PatternSignatures + , MultiParamTypeClasses + , FunctionalDependencies + , FlexibleInstances + , UndecidableInstances + , TypeFamilies + , FlexibleContexts + #-} + +instance forall init prog prog' fromO fromI progOut progIn + sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem + keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem current current' invertedSessionsMe invertedSessionsThem . + ( ProgramToMVarsOutgoingT prog prog ~ progOut + , ProgramToMVarsOutgoingT prog' prog' ~ progIn + , SWellFormedConfig init (D0 E) prog + , SWellFormedConfig init (D0 E) prog' + , TyListIndex progOut init (MVar (ProgramCell (Cell fromO))) + , TyListIndex progIn init (MVar (ProgramCell (Cell fromI))) + , TyListIndex prog init current' + , Expand prog current' current + , MapLookup (TyMap sessionsToIdxMe idxsToPairStructsMe) init + (MVar (Map (RawPid, RawPid) (MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))))) + , TyListMember invertedSessionsThem init True + , MapSize (TyMap keyToIdxMe idxToValueMe) idxOfThem + , MapInsert (TyMap keyToIdxMe idxToValueMe) idxOfThem + (SessionState prog prog' (current, fromO, fromI)) (TyMap keyToIdxMe' idxToValueMe') + ) => + CreateSession False init prog prog' + sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem + keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem invertedSessionsMe invertedSessionsThem where + createSession init FF (Pid remotePid _) = + InterleavedChain $ + \ipid@(IPid (Pid localPid localSTMap) _) mp -> + do { let pidFuncMapMVar :: MVar (Map (RawPid, RawPid) + (MVar (PairStruct init prog prog' + ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))))) + = mapLookup localSTMap init + ; pidFuncMap <- takeMVar pidFuncMapMVar + ; emptyMVar :: MVar (TyMap keyToIdxMe' idxToValueMe') <- newEmptyMVar + ; psMVar :: MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))) + <- case Map.lookup (localPid, remotePid) pidFuncMap of + Nothing + -> do { empty <- newEmptyMVar + ; putMVar pidFuncMapMVar (Map.insert (localPid, remotePid) empty pidFuncMap) + ; return empty + } + (Just mv) + -> do { putMVar pidFuncMapMVar pidFuncMap + ; return mv + } + ; let idxOfThem :: idxOfThem = mapSize mp + ps :: PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)) + = PS localPid (f idxOfThem mp emptyMVar) + ; putMVar psMVar ps + ; mp' <- takeMVar emptyMVar + ; return (idxOfThem, mp', ipid) + } diff --git a/tests/examples/ghc710/Shebang.hs b/tests/examples/ghc710/Shebang.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Shebang.hs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell +{-# LANGUAGE OverloadedStrings #-} +import Aws.SSSP.App + +main = web diff --git a/tests/examples/ghc710/ShiftingLambda.hs b/tests/examples/ghc710/ShiftingLambda.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ShiftingLambda.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards #-} +spec :: Spec +spec = do + describe "split4'8" $ do + it "0xabc" $ do + split4'8 0xabc `shouldBe` (0x0a, 0xbc) + it "0xfff" $ do + split4'8 0xfff `shouldBe` (0x0f, 0xff) + + describe "(x, y) = split4'8 z" $ do + prop "x <= 0x0f" $ + \z -> let (x, _) = split4'8 z in x <= 0x0f + prop "x << 8 | y == z" $ do + \z -> let (x, y) = split4'8 z in + fromIntegral x `shiftL` 8 .|. fromIntegral y == z + +match s@Status{ pos, flips, captureAt, captureLen } + | isOne ?pat = ite (pos .>= strLen) __FAIL__ one + | otherwise = ite (pos + (toEnum $ minLen ?pat) .> strLen) __FAIL__ $ case ?pat of + POr ps -> choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps + +foo = 1 diff --git a/tests/examples/ghc710/Sigs.hs b/tests/examples/ghc710/Sigs.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Sigs.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Sigs where + +-- TypeSig +f :: Num a => a -> a +f = undefined + +pattern Single :: () => (Show a) => a -> [a] +pattern Single x = [x] + +g :: (Show a) => [a] -> a +g (Single x) = x + +-- Fixities + +infixr 6 +++ +infixr 7 ***,/// + +(+++) :: Int -> Int -> Int +a +++ b = a + 2*b + +(***) :: Int -> Int -> Int +a *** b = a - 4*b + +(///) :: Int -> Int -> Int +a /// b = 2*a - 3*b + +-- Inline signatures + +{-# Inline g #-} +{-# INLINE [~34] f #-} + +-- Specialise signature + +-- Multiple sigs +x,y,z :: Int +x = 0 +y = 0 +z = 0 diff --git a/tests/examples/ghc710/Simple.hs b/tests/examples/ghc710/Simple.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Simple.hs @@ -0,0 +1,4 @@ + +-- blah +x = 1 + diff --git a/tests/examples/ghc710/SimpleComplexTuple.hs b/tests/examples/ghc710/SimpleComplexTuple.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SimpleComplexTuple.hs @@ -0,0 +1,3 @@ + + +foo ((-),(.))= (5,6) diff --git a/tests/examples/ghc710/SimpleDo.hs b/tests/examples/ghc710/SimpleDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SimpleDo.hs @@ -0,0 +1,4 @@ + +foo = do + let x = 1 -- a comment + return x diff --git a/tests/examples/ghc710/SlidingDataClassDecl.hs b/tests/examples/ghc710/SlidingDataClassDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SlidingDataClassDecl.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + + +instance HasTrie R2Basis where + data R2Basis :->: x = R2Trie x x + trie f = R2Trie (f XB) (f YB) + untrie (R2Trie x _y) XB = x + untrie (R2Trie _x y) YB = y + enumerate (R2Trie x y) = [(XB,x),(YB,y)] diff --git a/tests/examples/ghc710/SlidingDoClause.hs b/tests/examples/ghc710/SlidingDoClause.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SlidingDoClause.hs @@ -0,0 +1,13 @@ + + +-- :bounds narrowing 35 +bndCom tenv args = + do { (bound,size) <- getBounds fail args + ; let get (s,m,ref) = do { n <- readRef ref; return(s++" = "++show n++ m)} + ; if bound == "" + then do { xs <- mapM get boundRef; warnM [Dl xs "\n"]} + else case find (\ (nm,info,ref) -> nm==bound) boundRef of + Just (_,_,ref) -> writeRef ref size + Nothing -> fail ("Unknown bound '"++bound++"'") + ; return tenv + } diff --git a/tests/examples/ghc710/SlidingLambda.hs b/tests/examples/ghc710/SlidingLambda.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SlidingLambda.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE ImplicitParams #-} + +foo = choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps diff --git a/tests/examples/ghc710/SlidingListComp.hs b/tests/examples/ghc710/SlidingListComp.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SlidingListComp.hs @@ -0,0 +1,8 @@ + + +foo = + [concatMap (\(n, f) -> [findPath copts v >>= f (listArg "ghc" as) | v <- listArg n as]) [ + ("project", Update.scanProject), + ("file", Update.scanFile), + ("path", Update.scanDirectory)], + map (Update.scanCabal (listArg "ghc" as)) cabals] diff --git a/tests/examples/ghc710/SlidingRecordSetter.hs b/tests/examples/ghc710/SlidingRecordSetter.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SlidingRecordSetter.hs @@ -0,0 +1,4 @@ + +selfQualify mod rsets = let defs = Set.fromList (map rs_name rsets) + in map (descend (f defs)) + (map (\RS{..} -> RS{rs_name = qualify mod rs_name, ..}) rsets) diff --git a/tests/examples/ghc710/SlidingTypeSyn.hs b/tests/examples/ghc710/SlidingTypeSyn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SlidingTypeSyn.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + + +type ( f :-> g) (r :: * -> *) ix = f r ix -> g r ix + +type ( f :--> g) b ix = f b ix -> g b ix + +type ((f :---> g)) b ix = f b ix -> g b ix diff --git a/tests/examples/ghc710/SpacesSplice.hs b/tests/examples/ghc710/SpacesSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SpacesSplice.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TemplateHaskell #-} + +makeLenses '' PostscriptFont diff --git a/tests/examples/ghc710/Splice.hs b/tests/examples/ghc710/Splice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Splice.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, + MultiParamTypeClasses, TypeSynonymInstances #-} + +module Splice where + +import Language.Haskell.TH.Syntax +import Language.Haskell.TH + +foo $( return $ VarP $ mkName "x" ) = x +bar $( [p| x |] ) = x + +baz = [| \ $( return $ VarP $ mkName "x" ) -> $(dyn "x") |] + + +class Eq a => MyClass a +data Foo = Foo deriving Eq + +instance MyClass Foo + +data Bar = Bar + deriving Eq + +type Baz = Bar +instance MyClass Baz + +data Quux a = Quux a deriving Eq +data Quux2 a = Quux2 a deriving Eq +instance Eq a => MyClass (Quux a) +instance Ord a => MyClass (Quux2 a) + +class MyClass2 a b +instance MyClass2 Int Bool + +$(return []) + +main = do + putStrLn $(do { info <- reify ''MyClass; lift (pprint info) }) + print $(isInstance ''Eq [ConT ''Foo] >>= lift) + print $(isInstance ''MyClass [ConT ''Foo] >>= lift) + print $ not $(isInstance ''Show [ConT ''Foo] >>= lift) + print $(isInstance ''MyClass [ConT ''Bar] >>= lift) -- this one + print $(isInstance ''MyClass [ConT ''Baz] >>= lift) + print $(isInstance ''MyClass [AppT (ConT ''Quux) (ConT ''Int)] >>= lift) --this one + print $(isInstance ''MyClass [AppT (ConT ''Quux2) (ConT ''Int)] >>= lift) -- this one + print $(isInstance ''MyClass2 [ConT ''Int, ConT ''Bool] >>= lift) + print $(isInstance ''MyClass2 [ConT ''Bool, ConT ''Bool] >>= lift) + diff --git a/tests/examples/ghc710/SpliceSemi.hs b/tests/examples/ghc710/SpliceSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/SpliceSemi.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} + + +$(makePredicates ''TheType) ; $(makePredicatesNot ''TheType) diff --git a/tests/examples/ghc710/StaticPointers.hs b/tests/examples/ghc710/StaticPointers.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/StaticPointers.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Main where + +import GHC.StaticPtr +import GHC.Word +import GHC.Generics +import Data.Data +import Data.Binary +import Data.ByteString + +fact :: Int -> Int +fact 0 = 1 +fact n = n * fact (n - 1) + +main = do + let sptr :: StaticPtr (Int -> Int) + sptr = static fact + print $ staticPtrInfo sptr + print $ deRefStaticPtr sptr 10 + +-- --------------------------------------------------------------------- + +type StaticKey1 = Fingerprint + +-- Defined in GHC.Fingerprint. +data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + deriving (Generic, Typeable) + +staticKey :: StaticPtr a -> StaticKey1 +staticKey = undefined + + diff --git a/tests/examples/ghc710/Stmts.hs b/tests/examples/ghc710/Stmts.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Stmts.hs @@ -0,0 +1,22 @@ +module Stmts where + +-- Make sure we get all the semicolons in statements + +foo :: IO () +foo = do + do { ;;;; a } + a + +bar :: IO () +bar = do + { ; + a ;; + b + } + +baz :: IO () +baz = do { ;; s ; s ; ; s ;; } + +a = undefined +b = undefined +s = undefined diff --git a/tests/examples/ghc710/StrangeTypeClass.hs b/tests/examples/ghc710/StrangeTypeClass.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/StrangeTypeClass.hs @@ -0,0 +1,18 @@ + + + +instance + ( + ) => Elms Z ix where + data Elm Z ix = ElmZ !ix + type Arg Z = Z + getArg !(ElmZ _) = Z + getIdx !(ElmZ ix) = ix + {-# INLINE getArg #-} + {-# INLINE getIdx #-} + +foo :: (Eq a) => a-> Bool +foo = undefined + +bar :: ( ) => a-> Bool +bar = undefined diff --git a/tests/examples/ghc710/Stream.hs b/tests/examples/ghc710/Stream.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Stream.hs @@ -0,0 +1,156 @@ +module Stream (Stream, carry, addStream, rationalToStream, + streamToFloat, addFiniteStream, negate', average) where + +import Data.Ratio + + +type Digit = Integer +type Stream = [Integer] + + + +-- Convert from a Rational fraction to its stream representation +rationalToStream :: Rational -> Stream +rationalToStream x + |t<1 = 0:rationalToStream t + |otherwise = 1:rationalToStream (t-1) + where t = 2*x + + + + +-- Convert from a stream to the Float value +streamToFloat :: Stream -> Float +streamToFloat x = f x (1) + +f :: Stream -> Integer -> Float +f [] n = 0 +f (y:ys) n = (fromIntegral)y/(fromIntegral(2^n)) + f ys (n+1) + + + + + +-- Add two stream +addStream :: Stream -> Stream -> Stream +addStream (x1:x2:x3:xs) (y1:y2:y3:ys) = (u+c):(addStream (x2:x3:xs) (y2:y3:ys)) + where u = interim x1 x2 y1 y2 + c = carry x2 x3 y2 y3 + + + +-- Compute carry, the C(i) value, given x(i) and y(i) +carry :: Digit -> Digit -> Digit -> Digit -> Digit +carry x1 x2 y1 y2 + |t>1 = 1 + |t<(-1) = -1 + |t==1 && (minus1 x2 y2) = 0 + |t==1 && not (minus1 x2 y2) = 1 + |t==(-1) && (minus1 x2 y2) = -1 + |t==(-1) && not (minus1 x2 y2) = 0 + |t==0 = 0 + where t = x1+y1 + + + +-- Computer the interim sum, the U(i) value, given x(i), y(i) and c(i) +interim :: Digit -> Digit -> Digit -> Digit -> Digit +interim x1 x2 y1 y2 + |t>1 = 0 + |t<(-1) = 0 + |t==1 && (minus1 x2 y2) = 1 + |t==1 && not (minus1 x2 y2) = -1 + |t==(-1) && (minus1 x2 y2) = 1 + |t==(-1) && not (minus1 x2 y2) = -1 + |t==0 = 0 + where t = x1+y1 + + + +-- Check if at least one of 2 digits is -1 +minus1 :: Digit -> Digit -> Bool +minus1 x y = (x==(-1))|| (y==(-1)) + + + + + + +-- Algin two stream so that they have the same length +align :: Stream -> Stream -> (Stream, Stream) +align xs ys + |x>y = (xs, (copy 0 (x-y)) ++ys) + |otherwise = ((copy 0 (y-x)) ++ xs, ys) + where x = toInteger(length xs) + y = toInteger(length ys) + + + +-- Generate a list of x +copy :: Integer -> Integer -> [Integer] +copy x n = [x| i<- [1..n]] + + + + + + + +-- Add two finite stream (to add the integral part) +addFiniteStream :: Stream -> Stream -> Stream +addFiniteStream xs ys = add' u v + where (u,v) = align xs ys + + + +-- Utility function for addFinitieStream +add' :: Stream -> Stream -> Stream +add' u v = normalise (f u v) + where f [] [] = [] + f (x:xs) (y:ys) = (x+y):f xs ys + + +-- Normalise the sum +normalise :: Stream -> Stream +normalise = foldr f [0] + where f x (y:ys) = (u:v:ys) + where u = (x+y) `div` 2 + v = (x+y) `mod` 2 + + +-- Negate a stream +negate' :: Stream -> Stream +negate' = map (*(-1)) + + + +-- Compute average of two stream +-- Using [-2,-1,0,1,2] to add, and then divide by 2 +average :: Stream -> Stream -> Stream +average xs ys = div2 (add xs ys) + + +-- Addition of two streams, using [-2,-1,0,1,2] +add :: Stream -> Stream -> Stream +add (x:xs) (y:ys) = (x+y):(add xs ys) + + +-- Then divided by 2, [-2,-1,0,1,2] -> [-1,0,1] +div2 :: Stream -> Stream +div2 (2:xs) = 1:div2 xs +div2 ((-2):xs) = (-1):div2 xs +div2 (0:xs) = 0:div2 xs +div2 (1:(-2):xs) = div2 (0:0:xs) +div2 (1:(-1):xs) = div2 (0:1:xs) +div2 (1:0:xs) = div2 (0:2:xs) +div2 (1:1:xs) = div2 (2:(-1):xs) +div2 (1:2:xs) = div2 (2:0:xs) +div2 ((-1):(-2):xs) = div2 ((-2):0:xs) +div2 ((-1):(-1):xs) = div2 ((-2):1:xs) +div2 ((-1):0:xs) = div2 (0:(-2):xs) +div2 ((-1):1:xs) = div2 (0:(-1):xs) +div2 ((-1):2:xs) = div2 (0:0:xs) + + + +test = take 100 (average (rationalToStream (1%2)) (rationalToStream (1%3))) diff --git a/tests/examples/ghc710/StrictLet.hs b/tests/examples/ghc710/StrictLet.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/StrictLet.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE MagicHash #-} + +{- +If the (unboxed, hence strict) "let thunk =" would survive to the CallArity +stage, it might yield wrong results (eta-expanding thunk and hence "cond" would +be called multiple times). + +It does not actually happen (CallArity sees a "case"), so this test just +safe-guards against future changes here. +-} + +import Debug.Trace +import GHC.Exts +import System.Environment + +cond :: Int# -> Bool +cond x = trace ("cond called with " ++ show (I# x)) True +{-# NOINLINE cond #-} + + +bar (I# x) = + let go n = let x = thunk n + in case n of + 100# -> I# x + _ -> go (n +# 1#) + in go x + where thunk = if cond x then \x -> (x +# 1#) else \x -> (x -# 1#) + + +main = do + args <- getArgs + bar (length args) `seq` return () diff --git a/tests/examples/ghc710/StringGap.hs b/tests/examples/ghc710/StringGap.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/StringGap.hs @@ -0,0 +1,8 @@ +module StringGap where + +-- based on https://www.reddit.com/r/haskelltil/comments/3duhdf/haskell_ignores_all_whitespace_enclosed_in/ + +foo = "lorem ipsum \ + \dolor sit amet" + +bar = "lorem ipsum \ \dolor sit amet" diff --git a/tests/examples/ghc710/T10196.hs b/tests/examples/ghc710/T10196.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/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/ghc710/T10942.hs b/tests/examples/ghc710/T10942.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/T10942.hs @@ -0,0 +1,6 @@ +-- Let's trick you +{-# LANGUAGE ExplicitForAll #-} +module Test (foo) where + +foo :: forall a. a -> a +foo x = x diff --git a/tests/examples/ghc710/T2388.hs b/tests/examples/ghc710/T2388.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/T2388.hs @@ -0,0 +1,14 @@ +module T2388 where + +import Data.Bits +import Data.Word +import Data.Int + +test1 :: Word32 -> Char +test1 w | w .&. 0x80000000 /= 0 = 'a' +test1 _ = 'b' + +-- this should use a testq instruction on x86_64 +test2 :: Int64 -> Char +test2 w | w .&. (-3) /= 0 = 'a' +test2 _ = 'b' diff --git a/tests/examples/ghc710/T3132.hs b/tests/examples/ghc710/T3132.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/T3132.hs @@ -0,0 +1,6 @@ +module T3132 where + +import Data.Array.Unboxed + +step :: UArray Int Double -> [Double] +step y = [y!1 + y!0] diff --git a/tests/examples/ghc710/T5951.hs b/tests/examples/ghc710/T5951.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/T5951.hs @@ -0,0 +1,11 @@ +module T5951 where + +class A a +class B b +class C c + +instance + A => + B => + C where + foo = undefined diff --git a/tests/examples/ghc710/T7918A.hs b/tests/examples/ghc710/T7918A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/T7918A.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +module T7918A where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +qq = QuasiQuoter { + quoteExp = \str -> case str of + "e1" -> [| True |] + "e2" -> [| id True |] + "e3" -> [| True || False |] + "e4" -> [| False |] + , quoteType = \str -> case str of + "t1" -> [t| Bool |] + "t2" -> [t| Maybe Bool |] + "t3" -> [t| Either Bool Int |] + "t4" -> [t| Int |] + , quotePat = let x = VarP (mkName "x") + y = VarP (mkName "y") + in \str -> case str of + "p1" -> return $ x + "p2" -> return $ ConP 'Just [x] + "p3" -> return $ TupP [x, y] + "p4" -> return $ y + , quoteDec = undefined + } diff --git a/tests/examples/ghc710/TH.hs b/tests/examples/ghc710/TH.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TH.hs @@ -0,0 +1,71 @@ +{-# Language TemplateHaskell #-} + +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-22-template-haskell.html + +import Language.Haskell.TH + +e1 :: IO Exp +e1 = runQ [| 1 + 2 |] + +e2 :: Integer +e2 = $( return (InfixE (Just (LitE (IntegerL 1))) + (VarE (mkName "+")) + (Just (LitE (IntegerL 2))) + ) + ) + +fibs :: [Integer] +fibs = 0 : 1 : zipWith (+) fibs (tail fibs) + +fibQ :: Int -> Q Exp +fibQ n = [| fibs !! n |] + +-- e3 gives stage restriction, need to import this module to get it +-- e3 = $(fibQ 22) + +e4 = $(runQ [| fibs !! $( [| 8 |]) |]) + +e5 :: IO Exp +e5 = runQ [| 1 + 2 |] + +e6 :: IO [Dec] +e6 = runQ [d|x = 5|] + +e7 :: IO Type +e7 = runQ [t|Int|] + +e8 :: IO Pat +e8 = runQ [p|(x,y)|] + +myExp :: Q Exp; myExp = runQ [| 1 + 2 |] + +e9 = runQ(myExp) >>= putStrLn.pprint + +-- --------------------------------------------------------------------- + +isPrime :: (Integral a) => a -> Bool +isPrime k | k <=1 = False | otherwise = not $ elem 0 (map (mod k)[2..k-1]) + +nextPrime :: (Integral a) => a -> a +nextPrime n | isPrime n = n | otherwise = nextPrime (n+1) + +-- returns a list of all primes between n and m, using the nextPrime function +doPrime :: (Integral a) => a -> a -> [a] +doPrime n m + | curr > m = [] + | otherwise = curr:doPrime (curr+1) m + where curr = nextPrime n + +-- and our Q expression +primeQ :: Int -> Int -> Q Exp +primeQ n m = [| doPrime n m |] + +-- stage restriction on e10 +-- e10 = $(primeQ 0 67) + +-- --------------------------------------------------------------------- + +e11 = $(stringE . show =<< reify ''Bool) + +-- stage restriction e12 +-- e12 = $(stringE . show =<< reify 'primeQ) diff --git a/tests/examples/ghc710/THMonadInstance.hs b/tests/examples/ghc710/THMonadInstance.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/THMonadInstance.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE + TemplateHaskell, + MultiParamTypeClasses, + FunctionalDependencies, + UndecidableInstances + #-} + + +genCodingInstance :: (Data c, Data h) => TypeQ -> Name -> [(c, h)] -> Q [Dec] +genCodingInstance ht ctn chs = do + let n = const Nothing + [d| + instance Monad m => EncodeM m $(ht) $(conT ctn) where + encodeM h = return $ $( + caseE [| h |] [ match (dataToPatQ n h) (normalB (dataToExpQ n c)) [] | (c,h) <- chs ] + ) + + instance Monad m => DecodeM m $(ht) $(conT ctn) where + decodeM c = return $ $( + caseE [| c |] [ match (dataToPatQ n c) (normalB (dataToExpQ n h)) [] | (c,h) <- chs ] + ) + |] diff --git a/tests/examples/ghc710/TemplateHaskell.hs b/tests/examples/ghc710/TemplateHaskell.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TemplateHaskell.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + +foo = $footemplate + +makeSplices ''Foo + +old = $(old) + +bar = $$bartemplate + +bar = [e| quasi |] + +bar = [| quasi |] + +baz = [quoter| quasi |] + +[t| Map.Map T.Text $tc |] + +{-# ANN module $([| 1 :: Int |]) #-} + +foo = [t| HT.HashTable $(varT s) Int + (Result $(varT str) $tt) |] + +objc_emit + +objc_import [""] + + +$(do + return $ foreignDecl cName ("build" ++ a) ([[t| Ptr Builder |]] ++ ats ++ [[t| CString |]]) [t| Ptr $(rt) |] + ) + +foo = do + let elemSize = [|sizeOf (undefined :: $(elemType))|] + alignment _ = alignment (undefined :: $(elemType)) + return 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/ghc710/TransformListComp.hs b/tests/examples/ghc710/TransformListComp.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TransformListComp.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TransformListComp #-} + +oldest :: [Int] -> [String] +oldest tbl = [ "str" + | n <- tbl + , then id + ] diff --git a/tests/examples/ghc710/Trit.hs b/tests/examples/ghc710/Trit.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Trit.hs @@ -0,0 +1,112 @@ +module Trit (Trit, rationalToTrit, getIntegral, getFraction, getFraction', + neg, addTrits, subTrits, shiftLeft, shiftRight, multiply + ) where + +import Stream +import Utilities +import Data.Ratio + +type Mantissa = Stream +type Fraction = Stream +type Trit = (Mantissa, Fraction) + + +-- Convert from a Rational number to its Trit representation (Integral, Fraction) +rationalToTrit :: Rational -> Trit +rationalToTrit x + |x<1 = ([0], rationalToStream x) + |otherwise = (u', rationalToStream v) + where u = n `div` d + u' = toBinary u + v = x - (toRational u) + n = numerator x + d = denominator x + + +-- Get the integral part of Trit +getIntegral :: Trit -> Mantissa +getIntegral = fst + + + +-- Get the fraction part of Trit, with n digit of the stream +getFraction :: Int -> Trit -> Stream +getFraction n = take n. snd + + +-- Get the fraction part of Trit +getFraction' :: Trit -> Stream +getFraction' = snd + + + +-- Negate a Trit +neg :: Trit -> Trit +neg (a, b) = (negate' a, negate' b) + + + +-- Add two Trits +addTrits :: Trit -> Trit -> Trit +addTrits (m1, (x1:x2:xs)) (m2, (y1:y2:ys)) = (u,addStream (x1:x2:xs) (y1:y2:ys)) + where u' = addFiniteStream m1 m2 + c = [carry x1 x2 y1 y2] + u = addFiniteStream u' c + + + +-- Substraction of 2 Trits +subTrits :: Trit -> Trit -> Trit +subTrits x y = addTrits x (neg y) + + + +-- Shift left = *2 opertaion with Trit +shiftLeft :: Trit -> Trit +shiftLeft (x, (y:ys)) = (x++ [y], ys) + + +-- Shift right = /2 operation with Trit +shiftRight :: Trit -> Integer -> Trit +shiftRight (x, xs) 1 = (init x, (u:xs)) + where u = last x +shiftRight (x, xs) n = shiftRight (init x, (u:xs)) (n-1) + where u = last x + + + +-- Multiply a Trit stream by 1,0 or -1, simply return the stream +mulOneDigit :: Integer -> Stream -> Stream +mulOneDigit x xs + |x==1 = xs + |x==0 = zero' + |otherwise = negate' xs + where zero' = (0:zero') + + + + + + +-- Multiplication of two streams +multiply :: Stream -> Stream -> Stream +multiply (a0:a1:x) (b0:b1:y) = average p q + where p = average (a1*b0: (average (mulOneDigit b1 x) + (mulOneDigit a1 y))) + (average (mulOneDigit b0 x) + (mulOneDigit a0 y)) + q = (a0*b0:a0*b1:a1*b1:(multiply x y)) + + + + +start0 = take 30 (multiply (rationalToStream (1%2)) zo) + +zo :: Stream +zo = 1:(-1):zero + where zero = 0:zero + +start1 = take 30 (average (rationalToStream (1%2)) (negate' (rationalToStream (1%4)))) + + + diff --git a/tests/examples/ghc710/Tuple.hs b/tests/examples/ghc710/Tuple.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Tuple.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TupleSections #-} + +baz = (1, "hello", 6.5,,) 'a' (Just ()) + diff --git a/tests/examples/ghc710/TupleSections.hs b/tests/examples/ghc710/TupleSections.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TupleSections.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TupleSections #-} + +foo = do + liftIO $ atomicModifyIORef ciTokens ((,()) . f) + liftIO $ atomicModifyIORef ciTokens (((),) . f) + liftIO $ atomicModifyIORef ciTokens ((,) . f) + +-- | Make bilateral dictionary from PoliMorf. +mkPoli :: [P.Entry] -> Poli +mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) + +foo = baz + where + _1 = ((,Nothing,Nothing,Nothing,Nothing,Nothing) . Just <$>) + _2 = ((Nothing,,Nothing,Nothing,Nothing,Nothing) . Just <$>) + _3 = ((Nothing,Nothing,,Nothing,Nothing,Nothing) . Just <$>) + _4 = ((Nothing,Nothing,Nothing,,Nothing,Nothing) . Just <$>) + _5 = ((Nothing,Nothing,Nothing,Nothing,,Nothing) . Just <$>) + _6 = ((Nothing,Nothing,Nothing,Nothing,Nothing,) . Just <$>) + +foo = (,,(),,,()) diff --git a/tests/examples/ghc710/TypeBrackets.hs b/tests/examples/ghc710/TypeBrackets.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TypeBrackets.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +foo (f :: (Maybe t -> Int)) = + undefined + +type (((f `ObjectsFUnder` a))) = ConstF f a :/\: f +type (f `ObjectsFOver` a) = f :/\: ConstF f a + +type (c `ObjectsUnder` a) = Id c `ObjectsFUnder` a +type (c `ObjectsOver` a) = Id c `ObjectsFOver` a + diff --git a/tests/examples/ghc710/TypeBrackets2.hs b/tests/examples/ghc710/TypeBrackets2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TypeBrackets2.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} + + +-- | The style and color attributes can either be the terminal defaults. Or be equivalent to the +-- previously applied style. Or be a specific value. +data MaybeDefault v where + Default :: MaybeDefault v + KeepCurrent :: MaybeDefault v + SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v + SetTo2 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v + +bar :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a]) +baz :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v + +instance Dsp (S n) where + data (ASig (S n)) = S_A CVar + data (KSig (S n)) = S_K CVar + data (INum (S n)) = S_I CVar + getSr = fst <$> ask + getKsmps = snd <$> ask diff --git a/tests/examples/ghc710/TypeBrackets4.hs b/tests/examples/ghc710/TypeBrackets4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TypeBrackets4.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} + + +type family ((a :: Bool) || (b :: Bool)) :: Bool +type instance 'True || a = 'True +type instance a || 'True = 'True +type instance 'False || a = a +type instance a || 'False = a diff --git a/tests/examples/ghc710/TypeFamilies.hs b/tests/examples/ghc710/TypeFamilies.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TypeFamilies.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-12-type-families.html + +import Control.Concurrent.STM +import Control.Concurrent.MVar +import Data.Foldable (forM_) +import Data.IORef + +class IOStore store where + newIO :: a -> IO (store a) + getIO :: store a -> IO a + putIO :: store a -> a -> IO () + +instance IOStore MVar where + newIO = newMVar + getIO = readMVar + putIO mvar a = modifyMVar_ mvar (return . const a) + +instance IOStore IORef where + newIO = newIORef + getIO = readIORef + putIO ioref a = modifyIORef ioref (const a) + +type Present = String +storePresentsIO :: IOStore store => [Present] -> IO (store [Present]) +storePresentsIO xs = do + store <- newIO [] + forM_ xs $ \x -> do + old <- getIO store + putIO store (x : old) + return store + +-- Type family version + +class Store store where + type StoreMonad store :: * -> * + new :: a -> (StoreMonad store) (store a) + get :: store a -> (StoreMonad store) a + put :: store a -> a -> (StoreMonad store) () + +instance Store IORef where + type StoreMonad IORef = IO + new = newIORef + get = readIORef + put ioref a = modifyIORef ioref (const a) + +instance Store TVar where + type StoreMonad TVar = STM + new = newTVar + get = readTVar + put ioref a = modifyTVar ioref (const a) + +storePresents :: (Store store, Monad (StoreMonad store)) + => [Present] -> (StoreMonad store) (store [Present]) +storePresents xs = do + store <- new [] + forM_ xs $ \x -> do + old <- get store + put store (x : old) + return store + +type family (++) (a :: [k]) (b :: [k]) :: [k] where + '[] ++ b = b + (a ': as) ++ b = a ': (as ++ b) + +type family (f :: * -> *) |> (s :: * -> *) :: * -> * + +type instance f |> Union s = Union (f :> s) + +type family Compare (a :: k) (b :: k') :: Ordering where + Compare '() '() = EQ + +type family (r1 :++: r2); infixr 5 :++: +type instance r :++: Nil = r +type instance r1 :++: r2 :> a = (r1 :++: r2) :> a diff --git a/tests/examples/ghc710/TypeFamilies2.hs b/tests/examples/ghc710/TypeFamilies2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TypeFamilies2.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +type family (++) (a :: [k]) (b :: [k]) :: [k] where + '[] ++ b = b + (a ': as) ++ b = a ': (as ++ b) + +type family F a :: * -> * -> * +type instance F Int = (->) +type instance F Char = ( , ) diff --git a/tests/examples/ghc710/TypeInstance.hs b/tests/examples/ghc710/TypeInstance.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TypeInstance.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} + +class TrieKey k where + type instance TrieRep k = TrieRepDefault k diff --git a/tests/examples/ghc710/TypeOperators.hs b/tests/examples/ghc710/TypeOperators.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TypeOperators.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-08-type-operators.html + +import Data.String + +data I a = I { unI :: a } +data Var a x = Var { unK :: a } + +infixr 8 + +data ((f + g)) a = InL (f a) | InR (g a) +-- data (f + g) a = InL (f a) | InR (g a) + +class sub :<: sup where + inj :: sub a -> sup a + +instance (sym :<: sym) where + inj = id + +instance (sym1 :<: (sym1 + sym2)) where inj = InL + +instance (sym1 :<: sym3) => (sym1 :<: (sym2 + sym3)) where + inj = InR . inj + +instance (I :<: g, IsString s) => IsString ((f + g) s) where + fromString = inj . I . fromString + +var :: (Var a :<: f) => a -> f e +var = inj . Var + +elim :: (I :<: f) => (a -> b) -> (Var a + f) b -> f b +elim eval f = + case f of + InL (Var xs) -> inj (I (eval xs)) + InR g -> g + +-------------------------------------------------------------------------------- + +data UserVar = UserName + +data ChristmasVar = ChristmasPresent + +email :: [(Var UserVar + Var ChristmasVar + I) String] +email = [ "Dear " + , var UserName + , ", thank you for your recent email to Santa & Santa Inc." + , "You have asked for a: " + , var ChristmasPresent + ] + +main :: IO () +main = + do name <- getLine + present <- getLine + putStrLn (concatMap (unI . + (elim (\ChristmasPresent -> present) . + elim (\UserName -> name))) + email) + +{- + +*Main> main +Ollie +Lambda Necklace +Dear Ollie, thank you for your recent email to Santa & Santa Inc.You have asked for a: Lambda Necklace + +-} diff --git a/tests/examples/ghc710/TypeSignature.hs b/tests/examples/ghc710/TypeSignature.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TypeSignature.hs @@ -0,0 +1,12 @@ +module TypeSignature where + +{- Lifting baz to the top level should bring in xx and a as parameters, + and update the signature to include these +-} +foo a = (baz xx a) + where + xx :: Int -> Int -> Int + xx p1 p2 = p1 + p2 + +baz :: (Int -> Int -> Int) -> Int ->Int +baz xx a = xx 1 a diff --git a/tests/examples/ghc710/TypeSignatureParens.hs b/tests/examples/ghc710/TypeSignatureParens.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TypeSignatureParens.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +pTokenCost :: forall loc state a .((Show a, Eq a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => [a] -> Int -> P (Str a state loc) [a]) +pTokenCost as cost = 5 + +pTokenCostStr :: forall a .((Show a) => [a] -> Int -> String) +pTokenCostStr as cost = "5" diff --git a/tests/examples/ghc710/TypeSynOperator.hs b/tests/examples/ghc710/TypeSynOperator.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TypeSynOperator.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TypeOperators #-} + +type a :-> t = a diff --git a/tests/examples/ghc710/TypeSynParens.hs b/tests/examples/ghc710/TypeSynParens.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/TypeSynParens.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies #-} + +class Compilable a where + type CompileResult a :: * + +instance Compilable a => Compilable [a] where + type CompileResult [a] = [CompileResult a] + +instance Compilable a => Compilable (Maybe a) where + type CompileResult (Maybe a) = Maybe (CompileResult a) + +instance Compilable InterpreterStmt where + type CompileResult InterpreterStmt = [Hask.Stmt] + +instance Compilable ModuleSpan where + type CompileResult ModuleSpan = Hask.Module + +instance Compilable StatementSpan where + type (CompileResult StatementSpan) = [Stmt] diff --git a/tests/examples/ghc710/Unboxed.hs b/tests/examples/ghc710/Unboxed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Unboxed.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE UnboxedTuples #-} +module Layout.Unboxed where + +f1 :: (Num a1, Num a) => a -> a1 -> (# , #) a a1 +f1 x y = (# , #) (x+1) (y-1) + +f2 x y z = (# ,, #) x y z diff --git a/tests/examples/ghc710/Undefined10.hs b/tests/examples/ghc710/Undefined10.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Undefined10.hs @@ -0,0 +1,643 @@ +{- + Copyright 2013-2015 Mario Blazevic + + License: BSD3 (see BSD3-LICENSE.txt file) +-} + +-- | This module defines the 'FactorialMonoid' class and some of its instances. +-- + +{-# LANGUAGE Haskell2010, Trustworthy #-} + +module Data.Monoid.Factorial ( + -- * Classes + FactorialMonoid(..), StableFactorialMonoid, + -- * Monad function equivalents + mapM, mapM_ + ) +where + +import Prelude hiding (break, drop, dropWhile, foldl, foldMap, foldr, last, length, map, mapM, mapM_, max, min, + null, reverse, span, splitAt, take, takeWhile) + +import Control.Arrow (first) +import qualified Control.Monad as Monad +import Data.Monoid (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo)) +import qualified Data.Foldable as Foldable +import qualified Data.List as List +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Sequence as Sequence +import qualified Data.Set as Set +import qualified Data.Vector as Vector +import Data.Int (Int64) +import Data.Numbers.Primes (primeFactors) + +import Data.Monoid.Null (MonoidNull(null), PositiveMonoid) + +-- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of +-- a 'Product' are literally its prime factors: +-- +-- prop> factors (Product 12) == [Product 2, Product 2, Product 3] +-- +-- Factors of a list are /not/ its elements but all its single-item sublists: +-- +-- prop> factors "abc" == ["a", "b", "c"] +-- +-- The methods of this class satisfy the following laws: +-- +-- > mconcat . factors == id +-- > null == List.null . factors +-- > List.all (\prime-> factors prime == [prime]) . factors +-- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix) +-- > reverse == mconcat . List.reverse . factors +-- > primePrefix == maybe mempty fst . splitPrimePrefix +-- > primeSuffix == maybe mempty snd . splitPrimeSuffix +-- > inits == List.map mconcat . List.tails . factors +-- > tails == List.map mconcat . List.tails . factors +-- > foldl f a == List.foldl f a . factors +-- > foldl' f a == List.foldl' f a . factors +-- > foldr f a == List.foldr f a . factors +-- > span p m == (mconcat l, mconcat r) where (l, r) = List.span p (factors m) +-- > List.all (List.all (not . pred) . factors) . split pred +-- > mconcat . intersperse prime . split (== prime) == id +-- > splitAt i m == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors m) +-- > spanMaybe () (const $ bool Nothing (Maybe ()) . p) m == (takeWhile p m, dropWhile p m, ()) +-- > spanMaybe s0 (\s m-> Just $ f s m) m0 == (m0, mempty, foldl f s0 m0) +-- > let (prefix, suffix, s') = spanMaybe s f m +-- > foldMaybe = foldl g (Just s) +-- > g s m = s >>= flip f m +-- > in all ((Nothing ==) . foldMaybe) (inits prefix) +-- > && prefix == last (filter (isJust . foldMaybe) $ inits m) +-- > && Just s' == foldMaybe prefix +-- > && m == prefix <> suffix +-- +-- A minimal instance definition must implement 'factors' or 'splitPrimePrefix'. Other methods are provided and should +-- be implemented only for performance reasons. +class MonoidNull m => FactorialMonoid m where + -- | Returns a list of all prime factors; inverse of mconcat. + factors :: m -> [m] + -- | The prime prefix, 'mempty' if none. + primePrefix :: m -> m + -- | The prime suffix, 'mempty' if none. + primeSuffix :: m -> m + -- | Splits the argument into its prime prefix and the remaining suffix. Returns 'Nothing' for 'mempty'. + splitPrimePrefix :: m -> Maybe (m, m) + -- | Splits the argument into its prime suffix and the remaining prefix. Returns 'Nothing' for 'mempty'. + splitPrimeSuffix :: m -> Maybe (m, m) + -- | Returns the list of all prefixes of the argument, 'mempty' first. + inits :: m -> [m] + -- | Returns the list of all suffixes of the argument, 'mempty' last. + tails :: m -> [m] + -- | Like 'List.foldl' from "Data.List" on the list of 'primes'. + foldl :: (a -> m -> a) -> a -> m -> a + -- | Like 'List.foldl'' from "Data.List" on the list of 'primes'. + foldl' :: (a -> m -> a) -> a -> m -> a + -- | Like 'List.foldr' from "Data.List" on the list of 'primes'. + foldr :: (m -> a -> a) -> a -> m -> a + -- | The 'length' of the list of 'primes'. + length :: m -> Int + -- | Generalizes 'foldMap' from "Data.Foldable", except the function arguments are prime factors rather than the + -- structure elements. + foldMap :: Monoid n => (m -> n) -> m -> n + -- | Like 'List.span' from "Data.List" on the list of 'primes'. + span :: (m -> Bool) -> m -> (m, m) + -- | Equivalent to 'List.break' from "Data.List". + break :: (m -> Bool) -> m -> (m, m) + -- | Splits the monoid into components delimited by prime separators satisfying the given predicate. The primes + -- satisfying the predicate are not a part of the result. + split :: (m -> Bool) -> m -> [m] + -- | Equivalent to 'List.takeWhile' from "Data.List". + takeWhile :: (m -> Bool) -> m -> m + -- | Equivalent to 'List.dropWhile' from "Data.List". + dropWhile :: (m -> Bool) -> m -> m + -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'. + spanMaybe :: s -> (s -> m -> Maybe s) -> m -> (m, m, s) + -- | Strict version of 'spanMaybe'. + spanMaybe' :: s -> (s -> m -> Maybe s) -> m -> (m, m, s) + -- | Like 'List.splitAt' from "Data.List" on the list of 'primes'. + splitAt :: Int -> m -> (m, m) + -- | Equivalent to 'List.drop' from "Data.List". + drop :: Int -> m -> m + -- | Equivalent to 'List.take' from "Data.List". + take :: Int -> m -> m + -- | Equivalent to 'List.reverse' from "Data.List". + reverse :: m -> m + + factors = List.unfoldr splitPrimePrefix + primePrefix = maybe mempty fst . splitPrimePrefix + primeSuffix = maybe mempty snd . splitPrimeSuffix + splitPrimePrefix x = case factors x + of [] -> Nothing + prefix : rest -> Just (prefix, mconcat rest) + splitPrimeSuffix x = case factors x + of [] -> Nothing + fs -> Just (mconcat (List.init fs), List.last fs) + inits = foldr (\m l-> mempty : List.map (mappend m) l) [mempty] + tails m = m : maybe [] (tails . snd) (splitPrimePrefix m) + foldl f f0 = List.foldl f f0 . factors + foldl' f f0 = List.foldl' f f0 . factors + foldr f f0 = List.foldr f f0 . factors + length = List.length . factors + foldMap f = foldr (mappend . f) mempty + span p m0 = spanAfter id m0 + where spanAfter f m = case splitPrimePrefix m + of Just (prime, rest) | p prime -> spanAfter (f . mappend prime) rest + _ -> (f mempty, m) + break = span . (not .) + spanMaybe s0 f m0 = spanAfter id s0 m0 + where spanAfter g s m = case splitPrimePrefix m + of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest + | otherwise -> (g mempty, m, s) + Nothing -> (m0, m, s) + spanMaybe' s0 f m0 = spanAfter id s0 m0 + where spanAfter g s m = seq s $ + case splitPrimePrefix m + of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest + | otherwise -> (g mempty, m, s) + Nothing -> (m0, m, s) + split p m = prefix : splitRest + where (prefix, rest) = break p m + splitRest = case splitPrimePrefix rest + of Nothing -> [] + Just (_, tl) -> split p tl + takeWhile p = fst . span p + dropWhile p = snd . span p + splitAt n0 m0 | n0 <= 0 = (mempty, m0) + | otherwise = split' n0 id m0 + where split' 0 f m = (f mempty, m) + split' n f m = case splitPrimePrefix m + of Nothing -> (f mempty, m) + Just (prime, rest) -> split' (pred n) (f . mappend prime) rest + drop n p = snd (splitAt n p) + take n p = fst (splitAt n p) + reverse = mconcat . List.reverse . factors + {-# MINIMAL factors | splitPrimePrefix #-} + +-- | A subclass of 'FactorialMonoid' whose instances satisfy this additional law: +-- +-- > factors (a <> b) == factors a <> factors b +class (FactorialMonoid m, PositiveMonoid m) => StableFactorialMonoid m + +instance FactorialMonoid () where + factors () = [] + primePrefix () = () + primeSuffix () = () + splitPrimePrefix () = Nothing + splitPrimeSuffix () = Nothing + length () = 0 + reverse = id + +instance FactorialMonoid a => FactorialMonoid (Dual a) where + factors (Dual a) = fmap Dual (reverse $ factors a) + length (Dual a) = length a + primePrefix (Dual a) = Dual (primeSuffix a) + primeSuffix (Dual a) = Dual (primePrefix a) + splitPrimePrefix (Dual a) = case splitPrimeSuffix a + of Nothing -> Nothing + Just (p, s) -> Just (Dual s, Dual p) + splitPrimeSuffix (Dual a) = case splitPrimePrefix a + of Nothing -> Nothing + Just (p, s) -> Just (Dual s, Dual p) + inits (Dual a) = fmap Dual (reverse $ tails a) + tails (Dual a) = fmap Dual (reverse $ inits a) + reverse (Dual a) = Dual (reverse a) + +instance (Integral a, Eq a) => FactorialMonoid (Sum a) where + primePrefix (Sum a) = Sum (signum a ) + primeSuffix = primePrefix + splitPrimePrefix (Sum 0) = Nothing + splitPrimePrefix (Sum a) = Just (Sum (signum a), Sum (a - signum a)) + splitPrimeSuffix (Sum 0) = Nothing + splitPrimeSuffix (Sum a) = Just (Sum (a - signum a), Sum (signum a)) + length (Sum a) = abs (fromIntegral a) + reverse = id + +instance Integral a => FactorialMonoid (Product a) where + factors (Product a) = List.map Product (primeFactors a) + reverse = id + +instance FactorialMonoid a => FactorialMonoid (Maybe a) where + factors Nothing = [] + factors (Just a) | null a = [Just a] + | otherwise = List.map Just (factors a) + length Nothing = 0 + length (Just a) | null a = 1 + | otherwise = length a + reverse = fmap reverse + +instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (a, b) where + factors (a, b) = List.map (\a1-> (a1, mempty)) (factors a) ++ List.map ((,) mempty) (factors b) + primePrefix (a, b) | null a = (a, primePrefix b) + | otherwise = (primePrefix a, mempty) + primeSuffix (a, b) | null b = (primeSuffix a, b) + | otherwise = (mempty, primeSuffix b) + splitPrimePrefix (a, b) = case (splitPrimePrefix a, splitPrimePrefix b) + of (Just (ap, as), _) -> Just ((ap, mempty), (as, b)) + (Nothing, Just (bp, bs)) -> Just ((a, bp), (a, bs)) + (Nothing, Nothing) -> Nothing + splitPrimeSuffix (a, b) = case (splitPrimeSuffix a, splitPrimeSuffix b) + of (_, Just (bp, bs)) -> Just ((a, bp), (mempty, bs)) + (Just (ap, as), Nothing) -> Just ((ap, b), (as, b)) + (Nothing, Nothing) -> Nothing + inits (a, b) = List.map (flip (,) mempty) (inits a) ++ List.map ((,) a) (List.tail $ inits b) + tails (a, b) = List.map (flip (,) b) (tails a) ++ List.map ((,) mempty) (List.tail $ tails b) + foldl f a0 (x, y) = foldl f2 (foldl f1 a0 x) y + where f1 a = f a . fromFst + f2 a = f a . fromSnd + foldl' f a0 (x, y) = a' `seq` foldl' f2 a' y + where f1 a = f a . fromFst + f2 a = f a . fromSnd + a' = foldl' f1 a0 x + foldr f a (x, y) = foldr (f . fromFst) (foldr (f . fromSnd) a y) x + foldMap f (x, y) = foldMap (f . fromFst) x `mappend` foldMap (f . fromSnd) y + length (a, b) = length a + length b + span p (x, y) = ((xp, yp), (xs, ys)) + where (xp, xs) = span (p . fromFst) x + (yp, ys) | null xs = span (p . fromSnd) y + | otherwise = (mempty, y) + spanMaybe s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2) + | otherwise = ((xp, mempty), (xs, y), s1) + where (xp, xs, s1) = spanMaybe s0 (\s-> f s . fromFst) x + (yp, ys, s2) = spanMaybe s1 (\s-> f s . fromSnd) y + spanMaybe' s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2) + | otherwise = ((xp, mempty), (xs, y), s1) + where (xp, xs, s1) = spanMaybe' s0 (\s-> f s . fromFst) x + (yp, ys, s2) = spanMaybe' s1 (\s-> f s . fromSnd) y + split p (x0, y0) = fst $ List.foldr combine (ys, False) xs + where xs = List.map fromFst $ split (p . fromFst) x0 + ys = List.map fromSnd $ split (p . fromSnd) y0 + combine x (~(y:rest), False) = (mappend x y : rest, True) + combine x (rest, True) = (x:rest, True) + splitAt n (x, y) = ((xp, yp), (xs, ys)) + where (xp, xs) = splitAt n x + (yp, ys) | null xs = splitAt (n - length x) y + | otherwise = (mempty, y) + reverse (a, b) = (reverse a, reverse b) + +{-# INLINE fromFst #-} +fromFst :: Monoid b => a -> (a, b) +fromFst a = (a, mempty) + +{-# INLINE fromSnd #-} +fromSnd :: Monoid a => b -> (a, b) +fromSnd b = (mempty, b) + +instance FactorialMonoid [x] where + factors xs = List.map (:[]) xs + primePrefix [] = [] + primePrefix (x:_) = [x] + primeSuffix [] = [] + primeSuffix xs = [List.last xs] + splitPrimePrefix [] = Nothing + splitPrimePrefix (x:xs) = Just ([x], xs) + splitPrimeSuffix [] = Nothing + splitPrimeSuffix xs = Just (splitLast id xs) + where splitLast f last@[_] = (f [], last) + splitLast f ~(x:rest) = splitLast (f . (x:)) rest + inits = List.inits + tails = List.tails + foldl _ a [] = a + foldl f a (x:xs) = foldl f (f a [x]) xs + foldl' _ a [] = a + foldl' f a (x:xs) = let a' = f a [x] in a' `seq` foldl' f a' xs + foldr _ f0 [] = f0 + foldr f f0 (x:xs) = f [x] (foldr f f0 xs) + length = List.length + foldMap f = mconcat . List.map (f . (:[])) + break f = List.break (f . (:[])) + span f = List.span (f . (:[])) + dropWhile f = List.dropWhile (f . (:[])) + takeWhile f = List.takeWhile (f . (:[])) + spanMaybe s0 f l = (prefix' [], suffix' [], s') + where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l + g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = (prefix . (x:), id, s2, True) + | otherwise = (prefix, suffix . (x:), s1, False) + spanMaybe' s0 f l = (prefix' [], suffix' [], s') + where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l + g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = seq s2 $ (prefix . (x:), id, s2, True) + | otherwise = (prefix, suffix . (x:), s1, False) + splitAt = List.splitAt + drop = List.drop + take = List.take + reverse = List.reverse + +instance FactorialMonoid ByteString.ByteString where + factors x = factorize (ByteString.length x) x + where factorize 0 _ = [] + factorize n xs = xs1 : factorize (pred n) xs' + where (xs1, xs') = ByteString.splitAt 1 xs + primePrefix = ByteString.take 1 + primeSuffix x = ByteString.drop (ByteString.length x - 1) x + splitPrimePrefix x = if ByteString.null x then Nothing else Just (ByteString.splitAt 1 x) + splitPrimeSuffix x = if ByteString.null x then Nothing else Just (ByteString.splitAt (ByteString.length x - 1) x) + inits = ByteString.inits + tails = ByteString.tails + foldl f = ByteString.foldl f' + where f' a byte = f a (ByteString.singleton byte) + foldl' f = ByteString.foldl' f' + where f' a byte = f a (ByteString.singleton byte) + foldr f = ByteString.foldr (f . ByteString.singleton) + break f = ByteString.break (f . ByteString.singleton) + span f = ByteString.span (f . ByteString.singleton) + spanMaybe s0 f b = case ByteString.foldr g id b (0, s0) + of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s') + where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ cont (i', s') + | otherwise = (i, s) + spanMaybe' s0 f b = case ByteString.foldr g id b (0, s0) + of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s') + where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') + | otherwise = (i, s) + dropWhile f = ByteString.dropWhile (f . ByteString.singleton) + takeWhile f = ByteString.takeWhile (f . ByteString.singleton) + length = ByteString.length + split f = ByteString.splitWith f' + where f' = f . ByteString.singleton + splitAt = ByteString.splitAt + drop = ByteString.drop + take = ByteString.take + reverse = ByteString.reverse + +instance FactorialMonoid LazyByteString.ByteString where + factors x = factorize (LazyByteString.length x) x + where factorize 0 _ = [] + factorize n xs = xs1 : factorize (pred n) xs' + where (xs1, xs') = LazyByteString.splitAt 1 xs + primePrefix = LazyByteString.take 1 + primeSuffix x = LazyByteString.drop (LazyByteString.length x - 1) x + splitPrimePrefix x = if LazyByteString.null x then Nothing + else Just (LazyByteString.splitAt 1 x) + splitPrimeSuffix x = if LazyByteString.null x then Nothing + else Just (LazyByteString.splitAt (LazyByteString.length x - 1) x) + inits = LazyByteString.inits + tails = LazyByteString.tails + foldl f = LazyByteString.foldl f' + where f' a byte = f a (LazyByteString.singleton byte) + foldl' f = LazyByteString.foldl' f' + where f' a byte = f a (LazyByteString.singleton byte) + foldr f = LazyByteString.foldr f' + where f' byte a = f (LazyByteString.singleton byte) a + length = fromIntegral . LazyByteString.length + break f = LazyByteString.break (f . LazyByteString.singleton) + span f = LazyByteString.span (f . LazyByteString.singleton) + spanMaybe s0 f b = case LazyByteString.foldr g id b (0, s0) + of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s') + where g w cont (i, s) | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ cont (i', s') + | otherwise = (i, s) + spanMaybe' s0 f b = case LazyByteString.foldr g id b (0, s0) + of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s') + where g w cont (i, s) + | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s') + | otherwise = (i, s) + dropWhile f = LazyByteString.dropWhile (f . LazyByteString.singleton) + takeWhile f = LazyByteString.takeWhile (f . LazyByteString.singleton) + split f = LazyByteString.splitWith f' + where f' = f . LazyByteString.singleton + splitAt = LazyByteString.splitAt . fromIntegral + drop n = LazyByteString.drop (fromIntegral n) + take n = LazyByteString.take (fromIntegral n) + reverse = LazyByteString.reverse + +instance FactorialMonoid Text.Text where + factors = Text.chunksOf 1 + primePrefix = Text.take 1 + primeSuffix x = if Text.null x then Text.empty else Text.singleton (Text.last x) + splitPrimePrefix = fmap (first Text.singleton) . Text.uncons + splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.init x, Text.singleton (Text.last x)) + inits = Text.inits + tails = Text.tails + foldl f = Text.foldl f' + where f' a char = f a (Text.singleton char) + foldl' f = Text.foldl' f' + where f' a char = f a (Text.singleton char) + foldr f = Text.foldr f' + where f' char a = f (Text.singleton char) a + length = Text.length + span f = Text.span (f . Text.singleton) + break f = Text.break (f . Text.singleton) + dropWhile f = Text.dropWhile (f . Text.singleton) + takeWhile f = Text.takeWhile (f . Text.singleton) + spanMaybe s0 f t = case Text.foldr g id t (0, s0) + of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') + where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ cont (i', s') + | otherwise = (i, s) + spanMaybe' s0 f t = case Text.foldr g id t (0, s0) + of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s') + where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') + | otherwise = (i, s) + split f = Text.split f' + where f' = f . Text.singleton + splitAt = Text.splitAt + drop = Text.drop + take = Text.take + reverse = Text.reverse + +instance FactorialMonoid LazyText.Text where + factors = LazyText.chunksOf 1 + primePrefix = LazyText.take 1 + primeSuffix x = if LazyText.null x then LazyText.empty else LazyText.singleton (LazyText.last x) + splitPrimePrefix = fmap (first LazyText.singleton) . LazyText.uncons + splitPrimeSuffix x = if LazyText.null x + then Nothing + else Just (LazyText.init x, LazyText.singleton (LazyText.last x)) + inits = LazyText.inits + tails = LazyText.tails + foldl f = LazyText.foldl f' + where f' a char = f a (LazyText.singleton char) + foldl' f = LazyText.foldl' f' + where f' a char = f a (LazyText.singleton char) + foldr f = LazyText.foldr f' + where f' char a = f (LazyText.singleton char) a + length = fromIntegral . LazyText.length + span f = LazyText.span (f . LazyText.singleton) + break f = LazyText.break (f . LazyText.singleton) + dropWhile f = LazyText.dropWhile (f . LazyText.singleton) + takeWhile f = LazyText.takeWhile (f . LazyText.singleton) + spanMaybe s0 f t = case LazyText.foldr g id t (0, s0) + of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') + where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ cont (i', s') + | otherwise = (i, s) + spanMaybe' s0 f t = case LazyText.foldr g id t (0, s0) + of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s') + where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s') + | otherwise = (i, s) + split f = LazyText.split f' + where f' = f . LazyText.singleton + splitAt = LazyText.splitAt . fromIntegral + drop n = LazyText.drop (fromIntegral n) + take n = LazyText.take (fromIntegral n) + reverse = LazyText.reverse + +instance Ord k => FactorialMonoid (Map.Map k v) where + factors = List.map (uncurry Map.singleton) . Map.toAscList + primePrefix map | Map.null map = map + | otherwise = uncurry Map.singleton $ Map.findMin map + primeSuffix map | Map.null map = map + | otherwise = uncurry Map.singleton $ Map.findMax map + splitPrimePrefix = fmap singularize . Map.minViewWithKey + where singularize ((k, v), rest) = (Map.singleton k v, rest) + splitPrimeSuffix = fmap singularize . Map.maxViewWithKey + where singularize ((k, v), rest) = (rest, Map.singleton k v) + foldl f = Map.foldlWithKey f' + where f' a k v = f a (Map.singleton k v) + foldl' f = Map.foldlWithKey' f' + where f' a k v = f a (Map.singleton k v) + foldr f = Map.foldrWithKey f' + where f' k v a = f (Map.singleton k v) a + length = Map.size + reverse = id + +instance FactorialMonoid (IntMap.IntMap a) where + factors = List.map (uncurry IntMap.singleton) . IntMap.toAscList + primePrefix map | IntMap.null map = map + | otherwise = uncurry IntMap.singleton $ IntMap.findMin map + primeSuffix map | IntMap.null map = map + | otherwise = uncurry IntMap.singleton $ IntMap.findMax map + splitPrimePrefix = fmap singularize . IntMap.minViewWithKey + where singularize ((k, v), rest) = (IntMap.singleton k v, rest) + splitPrimeSuffix = fmap singularize . IntMap.maxViewWithKey + where singularize ((k, v), rest) = (rest, IntMap.singleton k v) + foldl f = IntMap.foldlWithKey f' + where f' a k v = f a (IntMap.singleton k v) + foldl' f = IntMap.foldlWithKey' f' + where f' a k v = f a (IntMap.singleton k v) + foldr f = IntMap.foldrWithKey f' + where f' k v a = f (IntMap.singleton k v) a + length = IntMap.size + reverse = id + +instance FactorialMonoid IntSet.IntSet where + factors = List.map IntSet.singleton . IntSet.toAscList + primePrefix set | IntSet.null set = set + | otherwise = IntSet.singleton $ IntSet.findMin set + primeSuffix set | IntSet.null set = set + | otherwise = IntSet.singleton $ IntSet.findMax set + splitPrimePrefix = fmap singularize . IntSet.minView + where singularize (min, rest) = (IntSet.singleton min, rest) + splitPrimeSuffix = fmap singularize . IntSet.maxView + where singularize (max, rest) = (rest, IntSet.singleton max) + foldl f = IntSet.foldl f' + where f' a b = f a (IntSet.singleton b) + foldl' f = IntSet.foldl' f' + where f' a b = f a (IntSet.singleton b) + foldr f = IntSet.foldr f' + where f' a b = f (IntSet.singleton a) b + length = IntSet.size + reverse = id + +instance FactorialMonoid (Sequence.Seq a) where + factors = List.map Sequence.singleton . Foldable.toList + primePrefix = Sequence.take 1 + primeSuffix q = Sequence.drop (Sequence.length q - 1) q + splitPrimePrefix q = case Sequence.viewl q + of Sequence.EmptyL -> Nothing + hd Sequence.:< rest -> Just (Sequence.singleton hd, rest) + splitPrimeSuffix q = case Sequence.viewr q + of Sequence.EmptyR -> Nothing + rest Sequence.:> last -> Just (rest, Sequence.singleton last) + inits = Foldable.toList . Sequence.inits + tails = Foldable.toList . Sequence.tails + foldl f = Foldable.foldl f' + where f' a b = f a (Sequence.singleton b) + foldl' f = Foldable.foldl' f' + where f' a b = f a (Sequence.singleton b) + foldr f = Foldable.foldr f' + where f' a b = f (Sequence.singleton a) b + span f = Sequence.spanl (f . Sequence.singleton) + break f = Sequence.breakl (f . Sequence.singleton) + dropWhile f = Sequence.dropWhileL (f . Sequence.singleton) + takeWhile f = Sequence.takeWhileL (f . Sequence.singleton) + spanMaybe s0 f b = case Foldable.foldr g id b (0, s0) + of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') + where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ cont (i', s') + | otherwise = (i, s) + spanMaybe' s0 f b = case Foldable.foldr g id b (0, s0) + of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s') + where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s') + | otherwise = (i, s) + splitAt = Sequence.splitAt + drop = Sequence.drop + take = Sequence.take + length = Sequence.length + reverse = Sequence.reverse + +instance Ord a => FactorialMonoid (Set.Set a) where + factors = List.map Set.singleton . Set.toAscList + primePrefix set | Set.null set = set + | otherwise = Set.singleton $ Set.findMin set + primeSuffix set | Set.null set = set + | otherwise = Set.singleton $ Set.findMax set + splitPrimePrefix = fmap singularize . Set.minView + where singularize (min, rest) = (Set.singleton min, rest) + splitPrimeSuffix = fmap singularize . Set.maxView + where singularize (max, rest) = (rest, Set.singleton max) + foldl f = Foldable.foldl f' + where f' a b = f a (Set.singleton b) + foldl' f = Foldable.foldl' f' + where f' a b = f a (Set.singleton b) + foldr f = Foldable.foldr f' + where f' a b = f (Set.singleton a) b + length = Set.size + reverse = id + +instance FactorialMonoid (Vector.Vector a) where + factors x = factorize (Vector.length x) x + where factorize 0 _ = [] + factorize n xs = xs1 : factorize (pred n) xs' + where (xs1, xs') = Vector.splitAt 1 xs + primePrefix = Vector.take 1 + primeSuffix x = Vector.drop (Vector.length x - 1) x + splitPrimePrefix x = if Vector.null x then Nothing else Just (Vector.splitAt 1 x) + splitPrimeSuffix x = if Vector.null x then Nothing else Just (Vector.splitAt (Vector.length x - 1) x) + inits x0 = initsWith x0 [] + where initsWith x rest | Vector.null x = x:rest + | otherwise = initsWith (Vector.unsafeInit x) (x:rest) + tails x = x : if Vector.null x then [] else tails (Vector.unsafeTail x) + foldl f = Vector.foldl f' + where f' a byte = f a (Vector.singleton byte) + foldl' f = Vector.foldl' f' + where f' a byte = f a (Vector.singleton byte) + foldr f = Vector.foldr f' + where f' byte a = f (Vector.singleton byte) a + break f = Vector.break (f . Vector.singleton) + span f = Vector.span (f . Vector.singleton) + dropWhile f = Vector.dropWhile (f . Vector.singleton) + takeWhile f = Vector.takeWhile (f . Vector.singleton) + spanMaybe s0 f v = case Vector.ifoldr g Left v s0 + of Left s' -> (v, Vector.empty, s') + Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') + where g i x cont s | Just s' <- f s (Vector.singleton x) = cont s' + | otherwise = Right (i, s) + spanMaybe' s0 f v = case Vector.ifoldr' g Left v s0 + of Left s' -> (v, Vector.empty, s') + Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s') + where g i x cont s | Just s' <- f s (Vector.singleton x) = seq s' (cont s') + | otherwise = Right (i, s) + splitAt = Vector.splitAt + drop = Vector.drop + take = Vector.take + length = Vector.length + reverse = Vector.reverse + +instance StableFactorialMonoid () +instance StableFactorialMonoid a => StableFactorialMonoid (Dual a) +instance StableFactorialMonoid [x] +instance StableFactorialMonoid ByteString.ByteString +instance StableFactorialMonoid LazyByteString.ByteString +instance StableFactorialMonoid Text.Text +instance StableFactorialMonoid LazyText.Text +instance StableFactorialMonoid (Sequence.Seq a) +instance StableFactorialMonoid (Vector.Vector a) + +-- | A 'Monad.mapM' equivalent. +mapM :: (FactorialMonoid a, Monoid b, Monad m) => (a -> m b) -> a -> m b +mapM f = ($ return mempty) . appEndo . foldMap (Endo . Monad.liftM2 mappend . f) + +-- | A 'Monad.mapM_' equivalent. +mapM_ :: (FactorialMonoid a, Monad m) => (a -> m b) -> a -> m () +mapM_ f = foldr ((>>) . f) (return ()) diff --git a/tests/examples/ghc710/Undefined11.hs b/tests/examples/ghc710/Undefined11.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Undefined11.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Algebra.Additive ( + -- * Class + C, + zero, + (+), (-), + negate, subtract, + + -- * Complex functions + sum, sum1, + sumNestedAssociative, + sumNestedCommutative, + + -- * Instance definition helpers + elementAdd, elementSub, elementNeg, + (<*>.+), (<*>.-), (<*>.-$), + + -- * Instances for atomic types + propAssociative, + propCommutative, + propIdentity, + propInverse, + ) where + +import qualified Algebra.Laws as Laws + +import Data.Int (Int, Int8, Int16, Int32, Int64, ) +import Data.Word (Word, Word8, Word16, Word32, Word64, ) + +import qualified NumericPrelude.Elementwise as Elem +import Control.Applicative (Applicative(pure, (<*>)), ) +import Data.Tuple.HT (fst3, snd3, thd3, ) +import qualified Data.List.Match as Match + +import qualified Data.Complex as Complex98 +import qualified Data.Ratio as Ratio98 +import qualified Prelude as P +import Prelude (Integer, Float, Double, fromInteger, ) +import NumericPrelude.Base + + +infixl 6 +, - + +{- | +Additive a encapsulates the notion of a commutative group, specified +by the following laws: + +@ + a + b === b + a + (a + b) + c === a + (b + c) + zero + a === a + a + negate a === 0 +@ + +Typical examples include integers, dollars, and vectors. + +Minimal definition: '+', 'zero', and ('negate' or '(-)') +-} + +class C a where + {-# MINIMAL zero, (+), ((-) | negate) #-} + -- | zero element of the vector space + zero :: a + -- | add and subtract elements + (+), (-) :: a -> a -> a + -- | inverse with respect to '+' + negate :: a -> a + + {-# INLINE negate #-} + negate a = zero - a + {-# INLINE (-) #-} + a - b = a + negate b + +{- | +'subtract' is @(-)@ with swapped operand order. +This is the operand order which will be needed in most cases +of partial application. +-} +subtract :: C a => a -> a -> a +subtract = flip (-) + + + + +{- | +Sum up all elements of a list. +An empty list yields zero. + +This function is inappropriate for number types like Peano. +Maybe we should make 'sum' a method of Additive. +This would also make 'lengthLeft' and 'lengthRight' superfluous. +-} +sum :: (C a) => [a] -> a +sum = foldl (+) zero + +{- | +Sum up all elements of a non-empty list. +This avoids including a zero which is useful for types +where no universal zero is available. +-} +sum1 :: (C a) => [a] -> a +sum1 = foldl1 (+) + + +{- | +Sum the operands in an order, +such that the dependencies are minimized. +Does this have a measurably effect on speed? + +Requires associativity. +-} +sumNestedAssociative :: (C a) => [a] -> a +sumNestedAssociative [] = zero +sumNestedAssociative [x] = x +sumNestedAssociative xs = sumNestedAssociative (sum2 xs) + +{- +Make sure that the last entries in the list +are equally often part of an addition. +Maybe this can reduce rounding errors. +The list that sum2 computes is a breadth-first-flattened binary tree. + +Requires associativity and commutativity. +-} +sumNestedCommutative :: (C a) => [a] -> a +sumNestedCommutative [] = zero +sumNestedCommutative xs@(_:rs) = + let ys = xs ++ Match.take rs (sum2 ys) + in last ys + +_sumNestedCommutative :: (C a) => [a] -> a +_sumNestedCommutative [] = zero +_sumNestedCommutative xs@(_:rs) = + let ys = xs ++ take (length rs) (sum2 ys) + in last ys + +{- +[a,b,c, a+b,c+(a+b)] +[a,b,c,d, a+b,c+d,(a+b)+(c+d)] +[a,b,c,d,e, a+b,c+d,e+(a+b),(c+d)+e+(a+b)] +[a,b,c,d,e,f, a+b,c+d,e+f,(a+b)+(c+d),(e+f)+((a+b)+(c+d))] +-} + +sum2 :: (C a) => [a] -> [a] +sum2 (x:y:rest) = (x+y) : sum2 rest +sum2 xs = xs + + + +{- | +Instead of baking the add operation into the element function, +we could use higher rank types +and pass a generic @uncurry (+)@ to the run function. +We do not do so in order to stay Haskell 98 +at least for parts of NumericPrelude. +-} +{-# INLINE elementAdd #-} +elementAdd :: + (C x) => + (v -> x) -> Elem.T (v,v) x +elementAdd f = + Elem.element (\(x,y) -> f x + f y) + +{-# INLINE elementSub #-} +elementSub :: + (C x) => + (v -> x) -> Elem.T (v,v) x +elementSub f = + Elem.element (\(x,y) -> f x - f y) + +{-# INLINE elementNeg #-} +elementNeg :: + (C x) => + (v -> x) -> Elem.T v x +elementNeg f = + Elem.element (negate . f) + + +-- like <*> +infixl 4 <*>.+, <*>.-, <*>.-$ + +{- | +> addPair :: (Additive.C a, Additive.C b) => (a,b) -> (a,b) -> (a,b) +> addPair = Elem.run2 $ Elem.with (,) <*>.+ fst <*>.+ snd +-} +{-# INLINE (<*>.+) #-} +(<*>.+) :: + (C x) => + Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a +(<*>.+) f acc = + f <*> elementAdd acc + +{-# INLINE (<*>.-) #-} +(<*>.-) :: + (C x) => + Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a +(<*>.-) f acc = + f <*> elementSub acc + +{-# INLINE (<*>.-$) #-} +(<*>.-$) :: + (C x) => + Elem.T v (x -> a) -> (v -> x) -> Elem.T v a +(<*>.-$) f acc = + f <*> elementNeg acc + + +-- * Instances for atomic types + +instance C Integer where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Float where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Double where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + + +instance C Int where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Int8 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Int16 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Int32 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Int64 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + + +instance C Word where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Word8 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Word16 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Word32 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Word64 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + + + + +-- * Instances for composed types + +instance (C v0, C v1) => C (v0, v1) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = (,) zero zero + (+) = Elem.run2 $ pure (,) <*>.+ fst <*>.+ snd + (-) = Elem.run2 $ pure (,) <*>.- fst <*>.- snd + negate = Elem.run $ pure (,) <*>.-$ fst <*>.-$ snd + +instance (C v0, C v1, C v2) => C (v0, v1, v2) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = (,,) zero zero zero + (+) = Elem.run2 $ pure (,,) <*>.+ fst3 <*>.+ snd3 <*>.+ thd3 + (-) = Elem.run2 $ pure (,,) <*>.- fst3 <*>.- snd3 <*>.- thd3 + negate = Elem.run $ pure (,,) <*>.-$ fst3 <*>.-$ snd3 <*>.-$ thd3 + + +instance (C v) => C [v] where + zero = [] + negate = map negate + (+) (x:xs) (y:ys) = (+) x y : (+) xs ys + (+) xs [] = xs + (+) [] ys = ys + (-) (x:xs) (y:ys) = (-) x y : (-) xs ys + (-) xs [] = xs + (-) [] ys = negate ys + + +instance (C v) => C (b -> v) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero _ = zero + (+) f g x = (+) (f x) (g x) + (-) f g x = (-) (f x) (g x) + negate f x = negate (f x) + +-- * Properties + +propAssociative :: (Eq a, C a) => a -> a -> a -> Bool +propCommutative :: (Eq a, C a) => a -> a -> Bool +propIdentity :: (Eq a, C a) => a -> Bool +propInverse :: (Eq a, C a) => a -> Bool + +propCommutative = Laws.commutative (+) +propAssociative = Laws.associative (+) +propIdentity = Laws.identity (+) zero +propInverse = Laws.inverse (+) negate zero + + + +-- legacy + +instance (P.Integral a) => C (Ratio98.Ratio a) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + (+) = (P.+) + (-) = (P.-) + negate = P.negate + +instance (P.RealFloat a) => C (Complex98.Complex a) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + (+) = (P.+) + (-) = (P.-) + negate = P.negate diff --git a/tests/examples/ghc710/Undefined13.hs b/tests/examples/ghc710/Undefined13.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Undefined13.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.TigHTTP.Papillon ( + ContentType(..), Type(..), Subtype(..), Parameter(..), Charset(..), + parseContentType, showContentType, +) where + +import Data.Char +import Text.Papillon + +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack) +import qualified Data.ByteString as BS + +import Network.TigHTTP.Token + +data ContentType = ContentType Type Subtype [Parameter] + deriving (Show, Eq) + +parseContentType :: BS.ByteString -> ContentType +parseContentType ct = case runError . contentType $ parse ct of + Left _ -> error "parseContentType" + Right (r, _) -> r + +showContentType :: ContentType -> BS.ByteString +showContentType (ContentType t st ps) = showType t + `BS.append` "/" + `BS.append` showSubtype st + `BS.append` showParameters ps + +data Type + = Text + | TypeRaw BS.ByteString + deriving (Show, Eq) + +mkType :: BS.ByteString -> Type +mkType "text" = Text +mkType t = TypeRaw t + +showType :: Type -> BS.ByteString +showType Text = "text" +showType (TypeRaw t) = t + +data Subtype + = Plain + | Html + | Css + | SubtypeRaw BS.ByteString + deriving (Show, Eq) + +mkSubtype :: BS.ByteString -> Subtype +mkSubtype "html" = Html +mkSubtype "plain" = Plain +mkSubtype "css" = Css +mkSubtype s = SubtypeRaw s + +showSubtype :: Subtype -> BS.ByteString +showSubtype Plain = "plain" +showSubtype Html = "html" +showSubtype Css = "css" +showSubtype (SubtypeRaw s) = s + +data Parameter + = Charset Charset + | ParameterRaw BS.ByteString BS.ByteString + deriving (Show, Eq) + +mkParameter :: BS.ByteString -> BS.ByteString -> Parameter +mkParameter "charset" "UTF-8" = Charset Utf8 +mkParameter "charset" v = Charset $ CharsetRaw v +mkParameter a v = ParameterRaw a v + +showParameters :: [Parameter] -> BS.ByteString +showParameters [] = "" +showParameters (Charset v : ps) = "; " `BS.append` "charset" + `BS.append` "=" `BS.append` showCharset v `BS.append` showParameters ps +showParameters (ParameterRaw a v : ps) = "; " `BS.append` a + `BS.append` "=" `BS.append` v `BS.append` showParameters ps + +data Charset + = Utf8 + | CharsetRaw BS.ByteString + deriving (Show, Eq) + +showCharset :: Charset -> BS.ByteString +showCharset Utf8 = "UTF-8" +showCharset (CharsetRaw cs) = cs + +bsconcat :: [ByteString] -> ByteString +bsconcat = BS.concat + +[papillon| + +source: ByteString + +contentType :: ContentType + = c:token '/' sc:token ps:(';' ' '* p:parameter { p })* + { ContentType (mkType c) (mkSubtype sc) ps } + +token :: ByteString + = t:+ { pack t } + +quotedString :: ByteString + = '"' t:(qt:qdtext { qt } / qp:quotedPair { pack [qp] })* '"' + { bsconcat t } + +quotedPair :: Char + = '\\' c: { c } + +crlf :: () = '\r' '\n' + +lws :: () = _:crlf _:(' ' / '\t')+ + +-- text :: ByteString +-- = ts:(cs:+ { cs } / _:lws { " " })+ { pack $ concat ts } + +qdtext :: ByteString + = ts:(cs:+ { cs } / _:lws { " " })+ { pack $ concat ts } + +parameter :: Parameter + = a:attribute '=' v:value { mkParameter a v } + +attribute :: ByteString = t:token { t } + +value :: ByteString + = t:token { t } + / qs:quotedString { qs } + +|] diff --git a/tests/examples/ghc710/Undefined2.hs b/tests/examples/ghc710/Undefined2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Undefined2.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE Safe #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Zip +-- Copyright : (c) Nils Schweinsberg 2011, +-- (c) George Giorgidze 2011 +-- (c) University Tuebingen 2011 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Monadic zipping (used for monad comprehensions) +-- +----------------------------------------------------------------------------- + +module Control.Monad.Zip where + +import Prelude +import Control.Monad (liftM) + +-- | `MonadZip` type class. Minimal definition: `mzip` or `mzipWith` +-- +-- Instances should satisfy the laws: +-- +-- * Naturality : +-- +-- > liftM (f *** g) (mzip ma mb) = mzip (liftM f ma) (liftM g mb) +-- +-- * Information Preservation: +-- +-- > liftM (const ()) ma = liftM (const ()) mb +-- > ==> +-- > munzip (mzip ma mb) = (ma, mb) +-- +class Monad m => MonadZip m where + + mzip :: m a -> m b -> m (a,b) + mzip = mzipWith (,) + + mzipWith :: (a -> b -> c) -> m a -> m b -> m c + mzipWith f ma mb = liftM (uncurry f) (mzip ma mb) + + munzip :: m (a,b) -> (m a, m b) + munzip mab = (liftM fst mab, liftM snd mab) + -- munzip is a member of the class because sometimes + -- you can implement it more efficiently than the + -- above default code. See Trac #4370 comment by giorgidze + {-# MINIMAL mzip | mzipWith #-} + +instance MonadZip [] where + mzip = zip + mzipWith = zipWith + munzip = unzip + diff --git a/tests/examples/ghc710/Undefined3.hs b/tests/examples/ghc710/Undefined3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Undefined3.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Foldable +-- Copyright : Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Class of data structures that can be folded to a summary value. +-- +-- Many of these functions generalize "Prelude", "Control.Monad" and +-- "Data.List" functions of the same names from lists to any 'Foldable' +-- functor. To avoid ambiguity, either import those modules hiding +-- these names or qualify uses of these function names with an alias +-- for this module. +-- +----------------------------------------------------------------------------- + +module Data.Foldable ( + -- * Folds + Foldable(..), + -- ** Special biased folds + foldrM, + foldlM, + -- ** Folding actions + -- *** Applicative actions + traverse_, + for_, + sequenceA_, + asum, + -- *** Monadic actions + mapM_, + forM_, + sequence_, + msum, + -- ** Specialized folds + toList, + concat, + concatMap, + and, + or, + any, + all, + sum, + product, + maximum, + maximumBy, + minimum, + minimumBy, + -- ** Searches + elem, + notElem, + find + ) where + +import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_, + elem, notElem, concat, concatMap, and, or, any, all, + sum, product, maximum, minimum) +import qualified Prelude (foldl, foldr, foldl1, foldr1) +import qualified Data.List as List (foldl') +import Control.Applicative +import Control.Monad (MonadPlus(..)) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Monoid +import Data.Proxy + +import GHC.Exts (build) +import GHC.Arr + +-- | Data structures that can be folded. +-- +-- Minimal complete definition: 'foldMap' or 'foldr'. +-- +-- For example, given a data type +-- +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- +-- a suitable instance would be +-- +-- > instance Foldable Tree where +-- > foldMap f Empty = mempty +-- > foldMap f (Leaf x) = f x +-- > foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r +-- +-- This is suitable even for abstract types, as the monoid is assumed +-- to satisfy the monoid laws. Alternatively, one could define @foldr@: +-- +-- > instance Foldable Tree where +-- > foldr f z Empty = z +-- > foldr f z (Leaf x) = f x z +-- > foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l +-- +class Foldable t where + -- | Combine the elements of a structure using a monoid. + fold :: Monoid m => t m -> m + fold = foldMap id + + -- | Map each element of the structure to a monoid, + -- and combine the results. + foldMap :: Monoid m => (a -> m) -> t a -> m + foldMap f = foldr (mappend . f) mempty + + -- | Right-associative fold of a structure. + -- + -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@ + foldr :: (a -> b -> b) -> b -> t a -> b + foldr f z t = appEndo (foldMap (Endo . f) t) z + + -- | Right-associative fold of a structure, + -- but with strict application of the operator. + foldr' :: (a -> b -> b) -> b -> t a -> b + foldr' f z0 xs = foldl f' id xs z0 + where f' k x z = k $! f x z + + -- | Left-associative fold of a structure. + -- + -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@ + foldl :: (b -> a -> b) -> b -> t a -> b + foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z + + -- | Left-associative fold of a structure. + -- but with strict application of the operator. + -- + -- @'foldl' f z = 'List.foldl'' f z . 'toList'@ + foldl' :: (b -> a -> b) -> b -> t a -> b + foldl' f z0 xs = foldr f' id xs z0 + where f' x k z = k $! f z x + + -- | A variant of 'foldr' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@ + foldr1 :: (a -> a -> a) -> t a -> a + foldr1 f xs = fromMaybe (error "foldr1: empty structure") + (foldr mf Nothing xs) + where + mf x Nothing = Just x + mf x (Just y) = Just (f x y) + + -- | A variant of 'foldl' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@ + foldl1 :: (a -> a -> a) -> t a -> a + foldl1 f xs = fromMaybe (error "foldl1: empty structure") + (foldl mf Nothing xs) + where + mf Nothing y = Just y + mf (Just x) y = Just (f x y) + {-# MINIMAL foldMap | foldr #-} + +-- instances for Prelude types + +instance Foldable Maybe where + foldr _ z Nothing = z + foldr f z (Just x) = f x z + + foldl _ z Nothing = z + foldl f z (Just x) = f z x + +instance Foldable [] where + foldr = Prelude.foldr + foldl = Prelude.foldl + foldl' = List.foldl' + foldr1 = Prelude.foldr1 + foldl1 = Prelude.foldl1 + +instance Foldable (Either a) where + foldMap _ (Left _) = mempty + foldMap f (Right y) = f y + + foldr _ z (Left _) = z + foldr f z (Right y) = f y z + +instance Foldable ((,) a) where + foldMap f (_, y) = f y + + foldr f z (_, y) = f y z + +instance Ix i => Foldable (Array i) where + foldr f z = Prelude.foldr f z . elems + foldl f z = Prelude.foldl f z . elems + foldr1 f = Prelude.foldr1 f . elems + foldl1 f = Prelude.foldl1 f . elems + +instance Foldable Proxy where + foldMap _ _ = mempty + {-# INLINE foldMap #-} + fold _ = mempty + {-# INLINE fold #-} + foldr _ z _ = z + {-# INLINE foldr #-} + foldl _ z _ = z + {-# INLINE foldl #-} + foldl1 _ _ = error "foldl1: Proxy" + {-# INLINE foldl1 #-} + foldr1 _ _ = error "foldr1: Proxy" + {-# INLINE foldr1 #-} + +instance Foldable (Const m) where + foldMap _ _ = mempty + +-- | Monadic fold over the elements of a structure, +-- associating to the right, i.e. from right to left. +foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b +foldrM f z0 xs = foldl f' return xs z0 + where f' k x z = f x z >>= k + +-- | Monadic fold over the elements of a structure, +-- associating to the left, i.e. from left to right. +foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b +foldlM f z0 xs = foldr f' return xs z0 + where f' x k z = f z x >>= k + +-- | Map each element of a structure to an action, evaluate +-- these actions from left to right, and ignore the results. +traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () +traverse_ f = foldr ((*>) . f) (pure ()) + +-- | 'for_' is 'traverse_' with its arguments flipped. +for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f () +{-# INLINE for_ #-} +for_ = flip traverse_ + +-- | Map each element of a structure to a monadic action, evaluate +-- these actions from left to right, and ignore the results. +mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () +mapM_ f = foldr ((>>) . f) (return ()) + +-- | 'forM_' is 'mapM_' with its arguments flipped. +forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = flip mapM_ + +-- | Evaluate each action in the structure from left to right, +-- and ignore the results. +sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f () +sequenceA_ = foldr (*>) (pure ()) + +-- | Evaluate each monadic action in the structure from left to right, +-- and ignore the results. +sequence_ :: (Foldable t, Monad m) => t (m a) -> m () +sequence_ = foldr (>>) (return ()) + +-- | The sum of a collection of actions, generalizing 'concat'. +asum :: (Foldable t, Alternative f) => t (f a) -> f a +{-# INLINE asum #-} +asum = foldr (<|>) empty + +-- | The sum of a collection of actions, generalizing 'concat'. +msum :: (Foldable t, MonadPlus m) => t (m a) -> m a +{-# INLINE msum #-} +msum = foldr mplus mzero + +-- These use foldr rather than foldMap to avoid repeated concatenation. + +-- | List of elements of a structure. +toList :: Foldable t => t a -> [a] +{-# INLINE toList #-} +toList t = build (\ c n -> foldr c n t) + +-- | The concatenation of all the elements of a container of lists. +concat :: Foldable t => t [a] -> [a] +concat = fold + +-- | Map a function over all the elements of a container and concatenate +-- the resulting lists. +concatMap :: Foldable t => (a -> [b]) -> t a -> [b] +concatMap = foldMap + +-- | 'and' returns the conjunction of a container of Bools. For the +-- result to be 'True', the container must be finite; 'False', however, +-- results from a 'False' value finitely far from the left end. +and :: Foldable t => t Bool -> Bool +and = getAll . foldMap All + +-- | 'or' returns the disjunction of a container of Bools. For the +-- result to be 'False', the container must be finite; 'True', however, +-- results from a 'True' value finitely far from the left end. +or :: Foldable t => t Bool -> Bool +or = getAny . foldMap Any + +-- | Determines whether any element of the structure satisfies the predicate. +any :: Foldable t => (a -> Bool) -> t a -> Bool +any p = getAny . foldMap (Any . p) + +-- | Determines whether all elements of the structure satisfy the predicate. +all :: Foldable t => (a -> Bool) -> t a -> Bool +all p = getAll . foldMap (All . p) + +-- | The 'sum' function computes the sum of the numbers of a structure. +sum :: (Foldable t, Num a) => t a -> a +sum = getSum . foldMap Sum + +-- | The 'product' function computes the product of the numbers of a structure. +product :: (Foldable t, Num a) => t a -> a +product = getProduct . foldMap Product + +-- | The largest element of a non-empty structure. +maximum :: (Foldable t, Ord a) => t a -> a +maximum = foldr1 max + +-- | The largest element of a non-empty structure with respect to the +-- given comparison function. +maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a +maximumBy cmp = foldr1 max' + where max' x y = case cmp x y of + GT -> x + _ -> y + +-- | The least element of a non-empty structure. +minimum :: (Foldable t, Ord a) => t a -> a +minimum = foldr1 min + +-- | The least element of a non-empty structure with respect to the +-- given comparison function. +minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a +minimumBy cmp = foldr1 min' + where min' x y = case cmp x y of + GT -> y + _ -> x + +-- | Does the element occur in the structure? +elem :: (Foldable t, Eq a) => a -> t a -> Bool +elem = any . (==) + +-- | 'notElem' is the negation of 'elem'. +notElem :: (Foldable t, Eq a) => a -> t a -> Bool +notElem x = not . elem x + +-- | The 'find' function takes a predicate and a structure and returns +-- the leftmost element of the structure matching the predicate, or +-- 'Nothing' if there is no such element. +find :: Foldable t => (a -> Bool) -> t a -> Maybe a +find p = listToMaybe . concatMap (\ x -> if p x then [x] else []) + diff --git a/tests/examples/ghc710/Undefined4.hs b/tests/examples/ghc710/Undefined4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Undefined4.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Traversable +-- Copyright : Conor McBride and Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Class of data structures that can be traversed from left to right, +-- performing an action on each element. +-- +-- See also +-- +-- * \"Applicative Programming with Effects\", +-- by Conor McBride and Ross Paterson, +-- /Journal of Functional Programming/ 18:1 (2008) 1-13, online at +-- . +-- +-- * \"The Essence of the Iterator Pattern\", +-- by Jeremy Gibbons and Bruno Oliveira, +-- in /Mathematically-Structured Functional Programming/, 2006, online at +-- . +-- +-- * \"An Investigation of the Laws of Traversals\", +-- by Mauro Jaskelioff and Ondrej Rypacek, +-- in /Mathematically-Structured Functional Programming/, 2012, online at +-- . +-- +-- Note that the functions 'mapM' and 'sequence' generalize "Prelude" +-- functions of the same names from lists to any 'Traversable' functor. +-- To avoid ambiguity, either import the "Prelude" hiding these names +-- or qualify uses of these function names with an alias for this module. +-- +----------------------------------------------------------------------------- + +module Data.Traversable ( + -- * The 'Traversable' class + Traversable(..), + -- * Utility functions + for, + forM, + mapAccumL, + mapAccumR, + -- * General definitions for superclass methods + fmapDefault, + foldMapDefault, + ) where + +import Prelude hiding (mapM, sequence, foldr) +import qualified Prelude (mapM, foldr) +import Control.Applicative +import Data.Foldable (Foldable()) +import Data.Monoid (Monoid) +import Data.Proxy + +import GHC.Arr + +-- | Functors representing data structures that can be traversed from +-- left to right. +-- +-- Minimal complete definition: 'traverse' or 'sequenceA'. +-- +-- A definition of 'traverse' must satisfy the following laws: +-- +-- [/naturality/] +-- @t . 'traverse' f = 'traverse' (t . f)@ +-- for every applicative transformation @t@ +-- +-- [/identity/] +-- @'traverse' Identity = Identity@ +-- +-- [/composition/] +-- @'traverse' (Compose . 'fmap' g . f) = Compose . 'fmap' ('traverse' g) . 'traverse' f@ +-- +-- A definition of 'sequenceA' must satisfy the following laws: +-- +-- [/naturality/] +-- @t . 'sequenceA' = 'sequenceA' . 'fmap' t@ +-- for every applicative transformation @t@ +-- +-- [/identity/] +-- @'sequenceA' . 'fmap' Identity = Identity@ +-- +-- [/composition/] +-- @'sequenceA' . 'fmap' Compose = Compose . 'fmap' 'sequenceA' . 'sequenceA'@ +-- +-- where an /applicative transformation/ is a function +-- +-- @t :: (Applicative f, Applicative g) => f a -> g a@ +-- +-- preserving the 'Applicative' operations, i.e. +-- +-- * @t ('pure' x) = 'pure' x@ +-- +-- * @t (x '<*>' y) = t x '<*>' t y@ +-- +-- and the identity functor @Identity@ and composition of functors @Compose@ +-- are defined as +-- +-- > newtype Identity a = Identity a +-- > +-- > instance Functor Identity where +-- > fmap f (Identity x) = Identity (f x) +-- > +-- > instance Applicative Indentity where +-- > pure x = Identity x +-- > Identity f <*> Identity x = Identity (f x) +-- > +-- > newtype Compose f g a = Compose (f (g a)) +-- > +-- > instance (Functor f, Functor g) => Functor (Compose f g) where +-- > fmap f (Compose x) = Compose (fmap (fmap f) x) +-- > +-- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where +-- > pure x = Compose (pure (pure x)) +-- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) +-- +-- (The naturality law is implied by parametricity.) +-- +-- Instances are similar to 'Functor', e.g. given a data type +-- +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- +-- a suitable instance would be +-- +-- > instance Traversable Tree where +-- > traverse f Empty = pure Empty +-- > traverse f (Leaf x) = Leaf <$> f x +-- > traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r +-- +-- This is suitable even for abstract types, as the laws for '<*>' +-- imply a form of associativity. +-- +-- The superclass instances should satisfy the following: +-- +-- * In the 'Functor' instance, 'fmap' should be equivalent to traversal +-- with the identity applicative functor ('fmapDefault'). +-- +-- * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be +-- equivalent to traversal with a constant applicative functor +-- ('foldMapDefault'). +-- +class (Functor t, Foldable t) => Traversable t where + -- | Map each element of a structure to an action, evaluate + -- these actions from left to right, and collect the results. + traverse :: Applicative f => (a -> f b) -> t a -> f (t b) + traverse f = sequenceA . fmap f + + -- | Evaluate each action in the structure from left to right, + -- and collect the results. + sequenceA :: Applicative f => t (f a) -> f (t a) + sequenceA = traverse id + + -- | Map each element of a structure to a monadic action, evaluate + -- these actions from left to right, and collect the results. + mapM :: Monad m => (a -> m b) -> t a -> m (t b) + mapM f = unwrapMonad . traverse (WrapMonad . f) + + -- | Evaluate each monadic action in the structure from left to right, + -- and collect the results. + sequence :: Monad m => t (m a) -> m (t a) + sequence = mapM id + {-# MINIMAL traverse | sequenceA #-} + +-- instances for Prelude types + +instance Traversable Maybe where + traverse _ Nothing = pure Nothing + traverse f (Just x) = Just <$> f x + +instance Traversable [] where + {-# INLINE traverse #-} -- so that traverse can fuse + traverse f = Prelude.foldr cons_f (pure []) + where cons_f x ys = (:) <$> f x <*> ys + + mapM = Prelude.mapM + +instance Traversable (Either a) where + traverse _ (Left x) = pure (Left x) + traverse f (Right y) = Right <$> f y + +instance Traversable ((,) a) where + traverse f (x, y) = (,) x <$> f y + +instance Ix i => Traversable (Array i) where + traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr) + +instance Traversable Proxy where + traverse _ _ = pure Proxy + {-# INLINE traverse #-} + sequenceA _ = pure Proxy + {-# INLINE sequenceA #-} + mapM _ _ = return Proxy + {-# INLINE mapM #-} + sequence _ = return Proxy + {-# INLINE sequence #-} + +instance Traversable (Const m) where + traverse _ (Const m) = pure $ Const m + +-- general functions + +-- | 'for' is 'traverse' with its arguments flipped. +for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b) +{-# INLINE for #-} +for = flip traverse + +-- | 'forM' is 'mapM' with its arguments flipped. +forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) +{-# INLINE forM #-} +forM = flip mapM + +-- left-to-right state transformer +newtype StateL s a = StateL { runStateL :: s -> (s, a) } + +instance Functor (StateL s) where + fmap f (StateL k) = StateL $ \ s -> let (s', v) = k s in (s', f v) + +instance Applicative (StateL s) where + pure x = StateL (\ s -> (s, x)) + StateL kf <*> StateL kv = StateL $ \ s -> + let (s', f) = kf s + (s'', v) = kv s' + in (s'', f v) + +-- |The 'mapAccumL' function behaves like a combination of 'fmap' +-- and 'foldl'; it applies a function to each element of a structure, +-- passing an accumulating parameter from left to right, and returning +-- a final value of this accumulator together with the new structure. +mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) +mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s + +-- right-to-left state transformer +newtype StateR s a = StateR { runStateR :: s -> (s, a) } + +instance Functor (StateR s) where + fmap f (StateR k) = StateR $ \ s -> let (s', v) = k s in (s', f v) + +instance Applicative (StateR s) where + pure x = StateR (\ s -> (s, x)) + StateR kf <*> StateR kv = StateR $ \ s -> + let (s', v) = kv s + (s'', f) = kf s' + in (s'', f v) + +-- |The 'mapAccumR' function behaves like a combination of 'fmap' +-- and 'foldr'; it applies a function to each element of a structure, +-- passing an accumulating parameter from right to left, and returning +-- a final value of this accumulator together with the new structure. +mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) +mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s + +-- | This function may be used as a value for `fmap` in a `Functor` +-- instance, provided that 'traverse' is defined. (Using +-- `fmapDefault` with a `Traversable` instance defined only by +-- 'sequenceA' will result in infinite recursion.) +fmapDefault :: Traversable t => (a -> b) -> t a -> t b +{-# INLINE fmapDefault #-} +fmapDefault f = getId . traverse (Id . f) + +-- | This function may be used as a value for `Data.Foldable.foldMap` +-- in a `Foldable` instance. +foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m +foldMapDefault f = getConst . traverse (Const . f) + +-- local instances + +newtype Id a = Id { getId :: a } + +instance Functor Id where + fmap f (Id x) = Id (f x) + +instance Applicative Id where + pure = Id + Id f <*> Id x = Id (f x) + diff --git a/tests/examples/ghc710/Undefined5.hs b/tests/examples/ghc710/Undefined5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Undefined5.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +module Algebra.Ring.Polynomial.Parser ( monomial, expression, variable, variableWithPower + , number, integer, natural, parsePolyn) where +import Algebra.Ring.Polynomial.Monomorphic +import Control.Applicative hiding (many) +import qualified Data.Map as M +import Data.Ratio +import qualified Numeric.Algebra as NA +import Text.Peggy + +[peggy| +expression :: Polynomial Rational + = expr !. + +letter :: Char + = [a-zA-Z] + +variable :: Variable + = letter ('_' integer)? { Variable $1 (fromInteger <$> $2) } + +variableWithPower :: (Variable, Integer) + = variable "^" natural { ($1, $2) } + / variable { ($1, 1) } + +expr :: Polynomial Rational + = expr "+" term { $1 + $2 } + / expr "-" term { $1 - $2 } + / term + +term :: Polynomial Rational + = number space* monoms { injectCoeff $1 * $3 } + / number { injectCoeff $1 } + / monoms + +monoms :: Polynomial Rational + = monoms space * fact { $1 * $3 } + / fact + +fact :: Polynomial Rational + = fact "^" natural { $1 ^ $2 } + / "(" expr ")" + / monomial { toPolyn [($1, 1)] } + +monomial :: Monomial + = variableWithPower+ { M.fromListWith (+) $1 } + +number :: Rational + = integer "/" integer { $1 % $2 } + / integer '.' [0-9]+ { realToFrac (read (show $1 ++ '.' : $2) :: Double) } + / integer { fromInteger $1 } + +integer :: Integer + = "-" natural { negate $1 } + / natural + +natural :: Integer + = [1-9] [0-9]* { read ($1 : $2) } + +|] + +toPolyn :: [(Monomial, Ratio Integer)] -> Polynomial (Ratio Integer) +toPolyn = normalize . Polynomial . M.fromList + +parsePolyn :: String -> Either ParseError (Polynomial Rational) +parsePolyn = parseString expression "polynomial" diff --git a/tests/examples/ghc710/Undefined6.hs b/tests/examples/ghc710/Undefined6.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Undefined6.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE BangPatterns, FlexibleContexts, MultiParamTypeClasses + , TypeFamilies #-} + +module Vision.Image.Class ( + -- * Classes + Pixel (..), MaskedImage (..), Image (..), ImageChannel, FromFunction (..) + , FunctorImage (..) + -- * Functions + , (!), (!?), nChannels, pixel + -- * Conversion + , Convertible (..), convert + ) where + +import Data.Convertible (Convertible (..), convert) +import Data.Int +import Data.Vector.Storable (Vector, generate, unfoldr) +import Data.Word +import Foreign.Storable (Storable) +import Prelude hiding (map, read) + +import Vision.Primitive ( + Z (..), (:.) (..), Point, Size + , fromLinearIndex, toLinearIndex, shapeLength + ) + +-- Classes --------------------------------------------------------------------- + +-- | Determines the number of channels and the type of each pixel of the image +-- and how images are represented. +class Pixel p where + type PixelChannel p + + -- | Returns the number of channels of the pixel. + -- + -- Must not consume 'p' (could be 'undefined'). + pixNChannels :: p -> Int + + pixIndex :: p -> Int -> PixelChannel p + +instance Pixel Int16 where + type PixelChannel Int16 = Int16 + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Int32 where + type PixelChannel Int32 = Int32 + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Int where + type PixelChannel Int = Int + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Word8 where + type PixelChannel Word8 = Word8 + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Word16 where + type PixelChannel Word16 = Word16 + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Word32 where + type PixelChannel Word32 = Word32 + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Word where + type PixelChannel Word = Word + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Float where + type PixelChannel Float = Float + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Double where + type PixelChannel Double = Double + pixNChannels _ = 1 + pixIndex p _ = p + +instance Pixel Bool where + type PixelChannel Bool = Bool + pixNChannels _ = 1 + pixIndex p _ = p + +-- | Provides an abstraction for images which are not defined for each of their +-- pixels. The interface is similar to 'Image' except that indexing functions +-- don't always return. +-- +-- Image origin (@'ix2' 0 0@) is located in the upper left corner. +class Storable (ImagePixel i) => MaskedImage i where + type ImagePixel i + + shape :: i -> Size + + -- | Returns the pixel\'s value at 'Z :. y, :. x'. + maskedIndex :: i -> Point -> Maybe (ImagePixel i) + maskedIndex img = (img `maskedLinearIndex`) . toLinearIndex (shape img) + {-# INLINE maskedIndex #-} + + -- | Returns the pixel\'s value as if the image was a single dimension + -- vector (row-major representation). + maskedLinearIndex :: i -> Int -> Maybe (ImagePixel i) + maskedLinearIndex img = (img `maskedIndex`) . fromLinearIndex (shape img) + {-# INLINE maskedLinearIndex #-} + + -- | Returns the non-masked values of the image. + values :: i -> Vector (ImagePixel i) + values !img = + unfoldr step 0 + where + !n = shapeLength (shape img) + + step !i | i >= n = Nothing + | Just p <- img `maskedLinearIndex` i = Just (p, i + 1) + | otherwise = step (i + 1) + {-# INLINE values #-} + + {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-} + +type ImageChannel i = PixelChannel (ImagePixel i) + +-- | Provides an abstraction over the internal representation of an image. +-- +-- Image origin is located in the lower left corner. +class MaskedImage i => Image i where + -- | Returns the pixel value at 'Z :. y :. x'. + index :: i -> Point -> ImagePixel i + index img = (img `linearIndex`) . toLinearIndex (shape img) + {-# INLINE index #-} + + -- | Returns the pixel value as if the image was a single dimension vector + -- (row-major representation). + linearIndex :: i -> Int -> ImagePixel i + linearIndex img = (img `index`) . fromLinearIndex (shape img) + {-# INLINE linearIndex #-} + + -- | Returns every pixel values as if the image was a single dimension + -- vector (row-major representation). + vector :: i -> Vector (ImagePixel i) + vector img = generate (shapeLength $ shape img) (img `linearIndex`) + {-# INLINE vector #-} + + {-# MINIMAL index | linearIndex #-} + +-- | Provides ways to construct an image from a function. +class FromFunction i where + type FromFunctionPixel i + + -- | Generates an image by calling the given function for each pixel of the + -- constructed image. + fromFunction :: Size -> (Point -> FromFunctionPixel i) -> i + + -- | Generates an image by calling the last function for each pixel of the + -- constructed image. + -- + -- The first function is called for each line, generating a line invariant + -- value. + -- + -- This function is faster for some image representations as some recurring + -- computation can be cached. + fromFunctionLine :: Size -> (Int -> a) + -> (a -> Point -> FromFunctionPixel i) -> i + fromFunctionLine size line f = + fromFunction size (\pt@(Z :. y :. _) -> f (line y) pt) + {-# INLINE fromFunctionLine #-} + + -- | Generates an image by calling the last function for each pixel of the + -- constructed image. + -- + -- The first function is called for each column, generating a column + -- invariant value. + -- + -- This function *can* be faster for some image representations as some + -- recurring computations can be cached. However, it may requires a vector + -- allocation for these values. If the column invariant is cheap to + -- compute, prefer 'fromFunction'. + fromFunctionCol :: Storable b => Size -> (Int -> b) + -> (b -> Point -> FromFunctionPixel i) -> i + fromFunctionCol size col f = + fromFunction size (\pt@(Z :. _ :. x) -> f (col x) pt) + {-# INLINE fromFunctionCol #-} + + -- | Generates an image by calling the last function for each pixel of the + -- constructed image. + -- + -- The two first functions are called for each line and for each column, + -- respectively, generating common line and column invariant values. + -- + -- This function is faster for some image representations as some recurring + -- computation can be cached. However, it may requires a vector + -- allocation for column values. If the column invariant is cheap to + -- compute, prefer 'fromFunctionLine'. + fromFunctionCached :: Storable b => Size + -> (Int -> a) -- ^ Line function + -> (Int -> b) -- ^ Column function + -> (a -> b -> Point + -> FromFunctionPixel i) -- ^ Pixel function + -> i + fromFunctionCached size line col f = + fromFunction size (\pt@(Z :. y :. x) -> f (line y) (col x) pt) + {-# INLINE fromFunctionCached #-} + + {-# MINIMAL fromFunction #-} + +-- | Defines a class for images on which a function can be applied. The class is +-- different from 'Functor' as there could be some constraints and +-- transformations the pixel and image types. +class (MaskedImage src, MaskedImage res) => FunctorImage src res where + map :: (ImagePixel src -> ImagePixel res) -> src -> res + +-- Functions ------------------------------------------------------------------- + +-- | Alias of 'maskedIndex'. +(!?) :: MaskedImage i => i -> Point -> Maybe (ImagePixel i) +(!?) = maskedIndex +{-# INLINE (!?) #-} + +-- | Alias of 'index'. +(!) :: Image i => i -> Point -> ImagePixel i +(!) = index +{-# INLINE (!) #-} + +-- | Returns the number of channels of an image. +nChannels :: (Pixel (ImagePixel i), MaskedImage i) => i -> Int +nChannels img = pixNChannels (pixel img) +{-# INLINE nChannels #-} + +-- | Returns an 'undefined' instance of a pixel of the image. This is sometime +-- useful to satisfy the type checker as in a call to 'pixNChannels' : +-- +-- > nChannels img = pixNChannels (pixel img) +pixel :: MaskedImage i => i -> ImagePixel i +pixel _ = undefined diff --git a/tests/examples/ghc710/Undefined7.hs b/tests/examples/ghc710/Undefined7.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Undefined7.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, StandaloneDeriving, DeriveDataTypeable #-} + +module Test where + +import Control.Applicative +import Control.Monad +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.Map as M +import Data.Generics + +import Data.Binary.ISO8583 +import Data.Binary.ISO8583.TH + +[binary| + Message + 2 pan embedded 2 + 4 amount int 12 + 11 stan int 6 + 43 termAddress TermAddress 222 +|] + +deriving instance Eq Message +deriving instance Show Message + +data TermAddress = TermAddress { + tOwner :: B.ByteString, + tCity :: B.ByteString, + tOther :: L.ByteString } + deriving (Eq, Show, Typeable) + +instance Binary TermAddress where + -- NB: this implementation is smth odd and usable only for this testcase. + get = + TermAddress + <$> B.filter (/= 0x20) `fmap` getByteString 30 + <*> B.filter (/= 0x20) `fmap` getByteString 30 + <*> L.filter (/= 0x20) `fmap` getRemainingLazyByteString + + put (TermAddress owner city other) = do + putByteStringPad 30 owner + putByteStringPad 30 city + putLazyByteStringPad 162 other + +instance Binary Message where + get = do + m <- getBitmap getMessage + return $ constructMessage m + + put msg = do + putBitmap' (putMessage msg) + +testMsg :: Message +testMsg = Message { + pan = Just $ toBS "12345678", + amount = Just $ 100500, + stan = Just $ 123456, + termAddress = Just $ TermAddress { + tOwner = toBS "TestBank", + tCity = toBS "Magnitogorsk", + tOther = L.empty } +} + +test :: IO () +test = do + let bstr = encode testMsg + msg = decode bstr + if msg /= testMsg + then fail $ "Encode/decode mismatch:\n" ++ + show testMsg ++ "\n /= \n" ++ + show msg + else putStrLn "passed." + diff --git a/tests/examples/ghc710/Undefined8.hs b/tests/examples/ghc710/Undefined8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Undefined8.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, PackageImports #-} + +module Text.Markdown.Pap.Parser ( + parseMrd +) where + +import Control.Arrow +import "monads-tf" Control.Monad.State +import "monads-tf" Control.Monad.Error +import Data.Maybe +import Data.Char +import Text.Papillon + +import Text.Markdown.Pap.Text + +parseMrd :: String -> Maybe [Text] +parseMrd src = case flip runState (0, [- 1]) $ runErrorT $ markdown $ parse src of + (Right (r, _), _) -> Just r + _ -> Nothing + +clear :: State (Int, [Int]) Bool +clear = put (0, [- 1]) >> return True + +reset :: State (Int, [Int]) Bool +reset = modify (first $ const 0) >> return True + +count :: State (Int, [Int]) () +count = modify $ first (+ 1) + +deeper :: State (Int, [Int]) Bool +deeper = do + (n, n0 : ns) <- get + if n > n0 then put (n, n : n0 : ns) >> return True else return False + +same :: State (Int, [Int]) Bool +same = do + (n, n0 : _) <- get + return $ n == n0 + +shallow :: State (Int, [Int]) Bool +shallow = do + (n, n0 : ns) <- get + if n < n0 then put (n, ns) >> return True else return False + +[papillon| + +monad: State (Int, [Int]) + +markdown :: [Text] + = md:(m:markdown1 _:dmmy[clear] { return m })* { return md } + +markdown1 :: Text + = h:header { return h } + / l:link '\n'* { return l } + / i:image '\n'* { return i } + / l:list '\n'* { return $ List l } + / c:code { return $ Code c } + / p:paras { return $ Paras p } + +header :: Text + = n:sharps _:* l:line '\n'+ { return $ Header n l } + / l:line '\n' _:equals '\n'+ { return $ Header 1 l } + / l:line '\n' _:hyphens '\n'+ { return $ Header 2 l } + +sharps :: Int + = '#' n:sharps { return $ n + 1 } + / '#' { return 1 } + +equals :: () + = '=' _:equals + / '=' + +hyphens :: () + = '-' _:hyphens + / '-' + +line :: String + = l:<(`notElem` "#\n")>+ { return l } + +line' :: String + = l:<(`notElem` "\n")>+ { return l } + +code :: String + = l:fourSpacesLine c:code { return $ l ++ c } + / l:fourSpacesLine { return l } + +fourSpacesLine :: String + = _:fourSpaces l:line' ns:('\n' { return '\n' })+ { return $ l ++ ns } + +fourSpaces :: () + = ' ' ' ' ' ' ' ' + +list :: List = _:cnt _:dmmy[deeper] l:list1 ls:list1'* _:shllw { return $ l : ls } + +cnt :: () = _:dmmy[reset] _:(' ' { count })* + +list1' :: List1 + = _:cnt _:dmmy[same] l:list1 { return l } + +list1 :: List1 + = _:listHead ' ' l:line '\n' ls:list? + { return $ BulItem l $ fromMaybe [] ls } + / _:nListHead ' ' l:line '\n' ls:list? + { return $ OrdItem l $ fromMaybe [] ls } + +listHead :: () + = '*' / '-' / '+' + +nListHead :: () + = _:+ '.' + +paras :: [String] + = ps:para+ { return ps } + +para :: String + = ls:(!_:('!') !_:listHead !_:nListHead !_:header !_:fourSpaces l:line '\n' { return l })+ _:('\n' / !_ / !_:para) + { return $ unwords ls } + +shllw :: () + = _:dmmy[shallow] + / !_ + / !_:list + +dmmy :: () = + +link :: Text + = '[' t:<(/= ']')>+ ']' ' '* '(' a:<(/= ')')>+ ')' { return $ Link t a "" } + +image :: Text + = '!' '[' alt:<(/= ']')>+ ']' ' '* '(' addrs:<(`notElem` ")\" ")>+ ' '* + '"' t:<(/= '"')>+ '"' ')' + { return $ Image alt addrs t } + +|] diff --git a/tests/examples/ghc710/Undefined9.hs b/tests/examples/ghc710/Undefined9.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Undefined9.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies #-} + +module Image.PNG (isPNG, pngSize) where + +import Data.Maybe +import File.Binary.PNG +import File.Binary +import File.Binary.Instances +import File.Binary.Instances.BigEndian + +isPNG :: String -> Bool +isPNG img = isJust (fromBinary () img :: Maybe (PNGHeader, String)) + +pngSize :: String -> Maybe (Double, Double) +pngSize src = case getChunks src of + Right cs -> Just + (fromIntegral $ width $ ihdr cs, fromIntegral $ height $ ihdr cs) + _ -> Nothing + +[binary| + +PNGHeader deriving Show + +1: 0x89 +3: "PNG" +2: "\r\n" +1: "\SUB" +1: "\n" + +|] diff --git a/tests/examples/ghc710/Unicode.hs b/tests/examples/ghc710/Unicode.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Unicode.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE UnicodeSyntax #-} + +module Unicode where + +import Control.Monad.Trans.State.Strict + +-- | 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 α + } + +-- | We'll run an ABT computation by starting the variable counter at @0@. +-- +runM ∷ M α → α +runM (M m) = evalState m 0 + + +-- | To indicate that a term is in normal form. +-- +stepsExhausted + ∷ Applicative m + ⇒ StepT m α +stepsExhausted = StepT . MaybeT $ pure Nothing + +stepsExhausted2 + ∷ Applicative m + => m α +stepsExhausted2 = undefined diff --git a/tests/examples/ghc710/UnicodeSyntaxFailure.hs b/tests/examples/ghc710/UnicodeSyntaxFailure.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/UnicodeSyntaxFailure.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE UnicodeSyntax #-} + +foo x = addToEnv (∀) diff --git a/tests/examples/ghc710/Utilities.hs b/tests/examples/ghc710/Utilities.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Utilities.hs @@ -0,0 +1,17 @@ +module Utilities (toBinary, fl) where + +import Stream +import Data.Ratio + +-- Convert from an Integer to its signed-digit representation +toBinary :: Integer -> Stream +toBinary 0 = [0] +toBinary x = toBinary t ++ [x `mod` 2] + where t = x `div` 2 + + + +fl :: Stream -> Stream +fl (x:xs) = (f x):xs + where f 0 = 1 + f 1 = 0 diff --git a/tests/examples/ghc710/Utils2.hs b/tests/examples/ghc710/Utils2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Utils2.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +module Utils2 where + + +import Control.Applicative (Applicative(..)) +import Control.Monad (when, liftM, ap) +import Control.Exception +import Data.Data +import Data.List +import Data.Maybe +import Data.Monoid + +-- import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Types hiding (showGhc) + +import qualified Bag as GHC +import qualified BasicTypes as GHC +import qualified BooleanFormula as GHC +import qualified Class as GHC +import qualified CoAxiom as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified ForeignCall as GHC +import qualified GHC as GHC +import qualified GHC.Paths as GHC +import qualified Lexer as GHC +import qualified Name as GHC +import qualified NameSet as GHC +import qualified Outputable as GHC +import qualified RdrName as GHC +import qualified SrcLoc as GHC +import qualified StringBuffer as GHC +import qualified UniqSet as GHC +import qualified Unique as GHC +import qualified Var as GHC + +import qualified Data.Map as Map + +-- --------------------------------------------------------------------- + +instance AnnotateP GHC.RdrName where + annotateP l n = do + case rdrName2String n of + "[]" -> do + addDeltaAnnotation GHC.AnnOpenS -- '[' nonBUG + addDeltaAnnotation GHC.AnnCloseS -- ']' BUG + "()" -> do + addDeltaAnnotation GHC.AnnOpenP -- '(' + addDeltaAnnotation GHC.AnnCloseP -- ')' + "(##)" -> do + addDeltaAnnotation GHC.AnnOpen -- '(#' + addDeltaAnnotation GHC.AnnClose -- '#)' + "[::]" -> do + addDeltaAnnotation GHC.AnnOpen -- '[:' + addDeltaAnnotation GHC.AnnClose -- ':]' + _ -> do + addDeltaAnnotation GHC.AnnType + addDeltaAnnotation GHC.AnnOpenP -- '(' + addDeltaAnnotationLs GHC.AnnBackquote 0 + addDeltaAnnotations GHC.AnnCommaTuple -- For '(,,,)' + cnt <- countAnnsAP GHC.AnnVal + cntT <- countAnnsAP GHC.AnnCommaTuple + cntR <- countAnnsAP GHC.AnnRarrow + case cnt of + 0 -> if cntT >0 || cntR >0 then return () else addDeltaAnnotationExt l GHC.AnnVal + 1 -> addDeltaAnnotation GHC.AnnVal + x -> error $ "annotateP.RdrName: too many AnnVal :" ++ showGhc (l,x) + addDeltaAnnotation GHC.AnnTildehsh + addDeltaAnnotation GHC.AnnTilde + addDeltaAnnotation GHC.AnnRarrow + addDeltaAnnotationLs GHC.AnnBackquote 1 + addDeltaAnnotation GHC.AnnCloseP -- ')' + + -- temporary, for test +class (Typeable ast) => AnnotateP ast where + annotateP :: GHC.SrcSpan -> ast -> IO () + +addDeltaAnnotation = undefined +addDeltaAnnotations = undefined +addDeltaAnnotationLs = undefined +addDeltaAnnotationExt = undefined +countAnnsAP = undefined +showGhc = undefined +rdrName2String = undefined + diff --git a/tests/examples/ghc710/Vect.hs b/tests/examples/ghc710/Vect.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Vect.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE ParallelArrays #-} +{-# OPTIONS_GHC -fvectorise #-} +{-# LANGUAGE UnboxedTuples #-} + +module Vect where + +-- import Data.Array.Parallel + + +{-# VECTORISe isFive = blah #-} +{-# NoVECTORISE isEq #-} + +{-# VECTORISE SCALAR type Int #-} +{-# VECTORISE type Char #-} +{-# VECTORISE type ( ) #-} +{-# VECTORISE type (# #) #-} + +{-# VECTORISE SCALAR type Integer = Int #-} +{-# VECTORISE type Bool = String #-} + +{-# Vectorise class Eq #-} + +blah = 5 + +data MyBool = MyTrue | MyFalse + +class Eq a => Cmp a where + cmp :: a -> a -> Bool + +-- FIXME: +-- instance Cmp Int where +-- cmp = (==) +-- isFive :: (Eq a, Num a) => a -> Bool +isFive :: Int -> Bool +isFive x = x == 5 + +isEq :: Eq a => a -> Bool +isEq x = x == x + + +fiveEq :: Int -> Bool +fiveEq x = isFive x && isEq x + +cmpArrs :: PArray Int -> PArray Int -> Bool +{-# NOINLINE cmpArrs #-} +cmpArrs v w = cmpArrs' (fromPArrayP v) (fromPArrayP w) + +cmpArrs' :: [:Int:] -> [:Int:] -> Bool +cmpArrs' xs ys = andP [:x == y | x <- xs | y <- ys:] + +isFives :: PArray Int -> Bool +{-# NOINLINE isFives #-} +isFives xs = isFives' (fromPArrayP xs) + +isFives' :: [:Int:] -> Bool +isFives' xs = andP (mapP isFive xs) + +isEqs :: PArray Int -> Bool +{-# NOINLINE isEqs #-} +isEqs xs = isEqs' (fromPArrayP xs) + +isEqs' :: [:Int:] -> Bool +isEqs' xs = undefined -- andP (mapP isEq xs) + +-- fudge for compiler + +fromPArrayP = undefined +andP = undefined +mapP = undefined +data PArray a = PArray a diff --git a/tests/examples/ghc710/ViewPatterns.hs b/tests/examples/ghc710/ViewPatterns.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/ViewPatterns.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ViewPatterns #-} + +-- From https://ghc.haskell.org/trac/ghc/wiki/ViewPatterns +import Prelude hiding (length) + +data JList a = Empty + | Single a + | Join (JList a) (JList a) + +data JListView a = Nil + | Cons a (JList a) + + +view :: JList a -> JListView a +view Empty = Nil +view (Single a) = Cons a Empty +view (Join (view -> Cons xh xt) y) = Cons xh $ Join xt y +view (Join (view -> Nil) y) = view y + +length :: JList a -> Integer +length (view -> Nil) = 0 +length (view -> Cons x xs) = 1 + length xs + diff --git a/tests/examples/ghc710/Warning.hs b/tests/examples/ghc710/Warning.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Warning.hs @@ -0,0 +1,16 @@ + +module Warning +{-# WARNINg ["This is a module warning", + "multi-line"] #-} + where + +{-# Warning foo , bar + ["This is a multi-line", + "deprecation message", + "for foo"] #-} +foo :: Int +foo = 4 + +bar :: Char +bar = 'c' + diff --git a/tests/examples/ghc710/Zipper.hs b/tests/examples/ghc710/Zipper.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/Zipper.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Zipper +-- Copyright : (c) Michael D. Adams, 2010 +-- License : BSD-style (see the LICENSE file) +-- +-- ``Scrap Your Zippers: A Generic Zipper for Heterogeneous Types. +-- Michael D. Adams. WGP '10: Proceedings of the 2010 ACM SIGPLAN +-- workshop on Generic programming, 2010.'' +-- +-- See +-- +----------------------------------------------------------------------------- + +{-# OPTIONS -Wall #-} +{-# LANGUAGE Rank2Types, GADTs #-} + +module Zipper where + +import Data.Generics +import Control.Monad ((<=<), MonadPlus, mzero, mplus, liftM) +import Data.Maybe (fromJust) + +-- Core types + +-- | A generic zipper with a root object of type @root@. +data Zipper root = + forall hole. (Data hole) => + Zipper hole (Context hole root) + +---- Internal types and functions +data Context hole root where + CtxtNull :: Context a a + CtxtCons :: + forall hole root rights parent. (Data parent) => + Left (hole -> rights) + -> Right rights parent + -> Context parent root + -> Context hole root + +combine :: Left (hole -> rights) + -> hole + -> Right rights parent + -> parent +combine lefts hole rights = + fromRight ((fromLeft lefts) hole) rights + +data Left expects + = LeftUnit expects + | forall b. (Data b) => LeftCons (Left (b -> expects)) b + +toLeft :: (Data a) => a -> Left a +toLeft a = gfoldl LeftCons LeftUnit a + +fromLeft :: Left r -> r +fromLeft (LeftUnit a) = a +fromLeft (LeftCons f b) = fromLeft f b + +data Right provides parent where + RightNull :: Right parent parent + RightCons :: + (Data b) => b -> Right a t -> Right (b -> a) t + +fromRight :: r -> Right r parent -> parent +fromRight f (RightNull) = f +fromRight f (RightCons b r) = fromRight (f b) r + +-- | Apply a generic monadic transformation to the hole +transM :: (Monad m) => GenericM m -> Zipper a -> m (Zipper a) +transM f (Zipper hole ctxt) = do + hole' <- f hole + return (Zipper hole' ctxt) + +-- Generic zipper traversals +---- Traversal helpers +-- | A movement operation such as 'left', 'right', 'up', or 'down'. +type Move a = Zipper a -> Maybe (Zipper a) + +-- | Apply a generic query using the specified movement operation. +moveQ :: Move a -- ^ Move operation + -> b -- ^ Default if can't move + -> (Zipper a -> b) -- ^ Query if can move + -> Zipper a -- ^ Zipper + -> b +moveQ move b f z = case move z of + Nothing -> b + Just z' -> f z' + +-- | Repeatedly apply a monadic 'Maybe' generic transformation at the +-- top-most, left-most position that the transformation returns +-- 'Just'. Behaves like iteratively applying 'zsomewhere' but is +-- more efficient because it re-evaluates the transformation +-- at only the parents of the last successful application. +zreduce :: GenericM Maybe -> Zipper a -> Zipper a +zreduce f z = + case transM f z of + Nothing -> + downQ (g z) (zreduce f . leftmost) z where + g z' = rightQ (upQ z' g z') (zreduce f) z' + Just x -> zreduce f (reduceAncestors1 f x x) + +reduceAncestors1 :: + GenericM Maybe -> Zipper a -> Zipper a -> Zipper a +reduceAncestors1 f z def = upQ def g z where + g z' = reduceAncestors1 f z' def' where + def' = case transM f z' of + Nothing -> def + Just x -> reduceAncestors1 f x x + +------ Query +-- | Apply a generic query to the left sibling if one exists. +leftQ :: b -- ^ Value to return of no left sibling exists. + -> (Zipper a -> b) -> Zipper a -> b +leftQ b f z = moveQ left b f z + +-- | Apply a generic query to the right sibling if one exists. +rightQ :: b -- ^ Value to return if no right sibling exists. + -> (Zipper a -> b) -> Zipper a -> b +rightQ b f z = moveQ right b f z + +-- | Apply a generic query to the parent if it exists. +downQ :: b -- ^ Value to return if no children exist. + -> (Zipper a -> b) -> Zipper a -> b +downQ b f z = moveQ down b f z + +-- | Apply a generic query to the rightmost child if one exists. +upQ :: b -- ^ Value to return if parent does not exist. + -> (Zipper a -> b) -> Zipper a -> b +upQ b f z = moveQ up b f z + +---- Basic movement + +-- | Move left. Returns 'Nothing' iff already at leftmost sibling. +left :: Zipper a -> Maybe (Zipper a) +left (Zipper _ CtxtNull) = Nothing +left (Zipper _ (CtxtCons (LeftUnit _) _ _)) = Nothing +left (Zipper h (CtxtCons (LeftCons l h') r c)) = + Just (Zipper h' (CtxtCons l (RightCons h r) c)) + +-- | Move right. Returns 'Nothing' iff already at rightmost sibling. +right :: Zipper a -> Maybe (Zipper a) +right (Zipper _ CtxtNull) = Nothing +right (Zipper _ (CtxtCons _ RightNull _)) = Nothing +right (Zipper h (CtxtCons l (RightCons h' r) c)) = + Just (Zipper h' (CtxtCons (LeftCons l h) r c)) + +-- | Move down. Moves to rightmost immediate child. Returns 'Nothing' iff at a leaf and thus no children exist. +down :: Zipper a -> Maybe (Zipper a) +down (Zipper hole ctxt) = + case toLeft hole of + LeftUnit _ -> Nothing + LeftCons l hole' -> + Just (Zipper hole' (CtxtCons l RightNull ctxt)) + +-- | Move up. Returns 'Nothing' iff already at root and thus no parent exists. +up :: Zipper a -> Maybe (Zipper a) +up (Zipper _ CtxtNull) = Nothing +up (Zipper hole (CtxtCons l r ctxt)) = + Just (Zipper (combine l hole r) ctxt) + +------ Movement +-- | Move to the leftmost sibling. +leftmost :: Zipper a -> Zipper a +leftmost z = leftQ z leftmost z + diff --git a/tests/examples/ghc8/A.hs b/tests/examples/ghc8/A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/A.hs @@ -0,0 +1,3 @@ +module A where + +data A = A diff --git a/tests/examples/ghc8/Associated.hs b/tests/examples/ghc8/Associated.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/AssociatedInternal.hs b/tests/examples/ghc8/AssociatedInternal.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/B.hs b/tests/examples/ghc8/B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/B.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module B where + +import A + +b :: Maybe a +b = Nothing diff --git a/tests/examples/ghc8/C.hs b/tests/examples/ghc8/C.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/C.hs @@ -0,0 +1,3 @@ +module C (oops) where + +import {-# SOURCE #-} B diff --git a/tests/examples/ghc8/CheckUtils.hs b/tests/examples/ghc8/CheckUtils.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ClosedFam1a.hs b/tests/examples/ghc8/ClosedFam1a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ClosedFam1a.hs @@ -0,0 +1,3 @@ +module ClosedFam1a where + +import {-# SOURCE #-} ClosedFam1 diff --git a/tests/examples/ghc8/ClosedFam2a.hs b/tests/examples/ghc8/ClosedFam2a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ClosedFam2a.hs @@ -0,0 +1,2 @@ +module ClosedFam2a where +import {-# SOURCE #-} ClosedFam2 diff --git a/tests/examples/ghc8/ClosedFam3a.hs b/tests/examples/ghc8/ClosedFam3a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ClosedFam3a.hs @@ -0,0 +1,3 @@ +module ClosedFam3a where + +import {-# SOURCE #-} ClosedFam3 diff --git a/tests/examples/ghc8/CmmSwitchTest.hs b/tests/examples/ghc8/CmmSwitchTest.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/CmmSwitchTestGen.hs b/tests/examples/ghc8/CmmSwitchTestGen.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/D.hs b/tests/examples/ghc8/D.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/DataFamilyInstanceLHS.hs b/tests/examples/ghc8/DataFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Defer03.hs b/tests/examples/ghc8/Defer03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Defer03.hs @@ -0,0 +1,7 @@ +module Main where + +a :: Int +a = 'p' + +main :: IO () +main = print "No errors!" diff --git a/tests/examples/ghc8/DeprM.hs b/tests/examples/ghc8/DeprM.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/DeprU.hs b/tests/examples/ghc8/DeprU.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/DsStrictData.hs b/tests/examples/ghc8/DsStrictData.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ExpandSynsFail1.hs b/tests/examples/ghc8/ExpandSynsFail1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ExpandSynsFail1.hs @@ -0,0 +1,4 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ExpandSynsFail3.hs b/tests/examples/ghc8/ExpandSynsFail3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ExpandSynsFail4.hs b/tests/examples/ghc8/ExpandSynsFail4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ExportSyntax.hs b/tests/examples/ghc8/ExportSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ExportSyntaxImport.hs b/tests/examples/ghc8/ExportSyntaxImport.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ExportSyntaxImport.hs @@ -0,0 +1,7 @@ +module ExportSyntaxImport where + +import ExportSyntax + +foo = NoA + +baz = A diff --git a/tests/examples/ghc8/ExtraConstraintsWildcardInExpressionSignature.hs b/tests/examples/ghc8/ExtraConstraintsWildcardInExpressionSignature.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ExtraConstraintsWildcardInExpressionSignature.hs @@ -0,0 +1,3 @@ +module ExtraConstraintsWildcardInExpressionSignature where + +foo x y = ((==) :: _ => _) x y diff --git a/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSignature.hs b/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSignature.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSignature.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module ExtraConstraintsWildcardInPatternSignature where + +foo (x :: _ => _) y = x == y diff --git a/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSplice.hs b/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ExtraConstraintsWildcardInPatternSplice.hs @@ -0,0 +1,5 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ExtraConstraintsWildcardInTypeSplice.hs @@ -0,0 +1,7 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ExtraConstraintsWildcardInTypeSpliceUsed.hs b/tests/examples/ghc8/ExtraConstraintsWildcardInTypeSpliceUsed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ExtraConstraintsWildcardTwice.hs b/tests/examples/ghc8/ExtraConstraintsWildcardTwice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ExtraConstraintsWildcardTwice.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ExtraConstraintsWildcardTwice where + +foo :: ((_), _) => a -> a +foo = undefined diff --git a/tests/examples/ghc8/FDsFromGivens2.hs b/tests/examples/ghc8/FDsFromGivens2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/FooBar.hs b/tests/examples/ghc8/FooBar.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/FooBar.hs @@ -0,0 +1,4 @@ +module FooBar where + +import Foo +import Bar diff --git a/tests/examples/ghc8/IPLocation.hs b/tests/examples/ghc8/IPLocation.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Improvement.hs b/tests/examples/ghc8/Improvement.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ListComprehensions.hs b/tests/examples/ghc8/ListComprehensions.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Main.hs b/tests/examples/ghc8/Main.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Main.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE QuasiQuotes, ViewPatterns #-} + +module Main where + +import A + +main = do + case 1 of + [foo|x|] -> print x + case 1 of + [bar| print fixed_var diff --git a/tests/examples/ghc8/NamedWildcardInDataFamilyInstanceLHS.hs b/tests/examples/ghc8/NamedWildcardInDataFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/NamedWildcardInTypeFamilyInstanceLHS.hs b/tests/examples/ghc8/NamedWildcardInTypeFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/NamedWildcardInTypeFamilyInstanceLHS.hs @@ -0,0 +1,5 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/OutOfHeap.hs b/tests/examples/ghc8/OutOfHeap.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/P.hs b/tests/examples/ghc8/P.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/PartialClassMethodSignature2.hs b/tests/examples/ghc8/PartialClassMethodSignature2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Q.hs b/tests/examples/ghc8/Q.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/QQ.hs b/tests/examples/ghc8/QQ.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/RandomPGC.hs b/tests/examples/ghc8/RandomPGC.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/RepArrow.hs b/tests/examples/ghc8/RepArrow.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Roles12a.hs b/tests/examples/ghc8/Roles12a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Roles12a.hs @@ -0,0 +1,2 @@ +module Roles12a where +import {-# SOURCE #-} Roles12 diff --git a/tests/examples/ghc8/RuleDefiningPlugin.hs b/tests/examples/ghc8/RuleDefiningPlugin.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap1.hs b/tests/examples/ghc8/SH_Overlap1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap10.hs b/tests/examples/ghc8/SH_Overlap10.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap10_A.hs b/tests/examples/ghc8/SH_Overlap10_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap10_B.hs b/tests/examples/ghc8/SH_Overlap10_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap11.hs b/tests/examples/ghc8/SH_Overlap11.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap11_A.hs b/tests/examples/ghc8/SH_Overlap11_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap11_B.hs b/tests/examples/ghc8/SH_Overlap11_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap1_A.hs b/tests/examples/ghc8/SH_Overlap1_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap1_B.hs b/tests/examples/ghc8/SH_Overlap1_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap2.hs b/tests/examples/ghc8/SH_Overlap2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap2_A.hs b/tests/examples/ghc8/SH_Overlap2_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap2_B.hs b/tests/examples/ghc8/SH_Overlap2_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap3.hs b/tests/examples/ghc8/SH_Overlap3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap3_A.hs b/tests/examples/ghc8/SH_Overlap3_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap3_B.hs b/tests/examples/ghc8/SH_Overlap3_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap4.hs b/tests/examples/ghc8/SH_Overlap4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap4_A.hs b/tests/examples/ghc8/SH_Overlap4_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap4_B.hs b/tests/examples/ghc8/SH_Overlap4_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap5.hs b/tests/examples/ghc8/SH_Overlap5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap5_A.hs b/tests/examples/ghc8/SH_Overlap5_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap5_B.hs b/tests/examples/ghc8/SH_Overlap5_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap6.hs b/tests/examples/ghc8/SH_Overlap6.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap6_A.hs b/tests/examples/ghc8/SH_Overlap6_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap6_B.hs b/tests/examples/ghc8/SH_Overlap6_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap7.hs b/tests/examples/ghc8/SH_Overlap7.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap7_A.hs b/tests/examples/ghc8/SH_Overlap7_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap7_B.hs b/tests/examples/ghc8/SH_Overlap7_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap8.hs b/tests/examples/ghc8/SH_Overlap8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap8_A.hs b/tests/examples/ghc8/SH_Overlap8_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap9.hs b/tests/examples/ghc8/SH_Overlap9.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap9_A.hs b/tests/examples/ghc8/SH_Overlap9_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SH_Overlap9_B.hs b/tests/examples/ghc8/SH_Overlap9_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SayAnnNames.hs b/tests/examples/ghc8/SayAnnNames.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Setup.hs b/tests/examples/ghc8/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/tests/examples/ghc8/ShouldFail.hs b/tests/examples/ghc8/ShouldFail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/ShouldFail.hs @@ -0,0 +1,1 @@ +import Set diff --git a/tests/examples/ghc8/Splices.hs b/tests/examples/ghc8/Splices.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/SplicesUsed.hs b/tests/examples/ghc8/SplicesUsed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/StackOverflow.hs b/tests/examples/ghc8/StackOverflow.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/StackOverflow.hs @@ -0,0 +1,4 @@ +main :: IO () +main = main' () + where + main' _ = main >> main' () diff --git a/tests/examples/ghc8/T10009.hs b/tests/examples/ghc8/T10009.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10030.hs b/tests/examples/ghc8/T10030.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10041.hs b/tests/examples/ghc8/T10041.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10047.hs b/tests/examples/ghc8/T10047.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10052-input.hs b/tests/examples/ghc8/T10052-input.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10052-input.hs @@ -0,0 +1,1 @@ +main = let (x :: String) = "hello" in putStrLn x diff --git a/tests/examples/ghc8/T10052.hs b/tests/examples/ghc8/T10052.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10083.hs b/tests/examples/ghc8/T10083.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10083a.hs b/tests/examples/ghc8/T10083a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10100.hs b/tests/examples/ghc8/T10100.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10104.hs b/tests/examples/ghc8/T10104.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10109.hs b/tests/examples/ghc8/T10109.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10110A.hs b/tests/examples/ghc8/T10110A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10110A.hs @@ -0,0 +1,4 @@ +module T10110A (a) where +{-# NOINLINE a #-} +a :: Int +a = 3 diff --git a/tests/examples/ghc8/T10110B.hs b/tests/examples/ghc8/T10110B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10110B.hs @@ -0,0 +1,3 @@ +module T10110B (b) where +b :: Int +b = 5 diff --git a/tests/examples/ghc8/T10110C.hs b/tests/examples/ghc8/T10110C.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10112.hs b/tests/examples/ghc8/T10112.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10134.hs b/tests/examples/ghc8/T10134.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10134a.hs b/tests/examples/ghc8/T10134a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10139.hs b/tests/examples/ghc8/T10139.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10141.hs b/tests/examples/ghc8/T10141.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10148.hs b/tests/examples/ghc8/T10148.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10156.hs b/tests/examples/ghc8/T10156.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10180.hs b/tests/examples/ghc8/T10180.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10181.hs b/tests/examples/ghc8/T10181.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10181.hs @@ -0,0 +1,3 @@ +module T10181 where + +t a = t a diff --git a/tests/examples/ghc8/T10182.hs b/tests/examples/ghc8/T10182.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10182.hs @@ -0,0 +1,4 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10182a.hs @@ -0,0 +1,2 @@ +module T10182a where +import {-# SOURCE #-} T10182 diff --git a/tests/examples/ghc8/T10184.hs b/tests/examples/ghc8/T10184.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10185.hs b/tests/examples/ghc8/T10185.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10188.hs b/tests/examples/ghc8/T10188.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10194.hs b/tests/examples/ghc8/T10194.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10195.hs b/tests/examples/ghc8/T10195.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10196.hs b/tests/examples/ghc8/T10196.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10196Fail1.hs b/tests/examples/ghc8/T10196Fail1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10196Fail1.hs @@ -0,0 +1,4 @@ +module T10196Fail1 where + +-- Constructors are not allowed to start with a modifier letter. +data Foo = ᵦfoo diff --git a/tests/examples/ghc8/T10196Fail2.hs b/tests/examples/ghc8/T10196Fail2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10196Fail2.hs @@ -0,0 +1,4 @@ +module T10196Fail2 where + +-- Variables are not allowed to start with a modifier letter. +ᵦ = 1 diff --git a/tests/examples/ghc8/T10196Fail3.hs b/tests/examples/ghc8/T10196Fail3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10196Fail3.hs @@ -0,0 +1,6 @@ +module T10196Fail3 where + +-- Modifier letters are not allowed in the middle of an identifier. +-- And this should not be lexed as 2 separate identifiers either. +xᵦx :: Int +xᵦx = 1 diff --git a/tests/examples/ghc8/T10218.hs b/tests/examples/ghc8/T10218.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10220B.hs b/tests/examples/ghc8/T10220B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10220B.hs @@ -0,0 +1,1 @@ +module T10220B where diff --git a/tests/examples/ghc8/T10226.hs b/tests/examples/ghc8/T10226.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10233.hs b/tests/examples/ghc8/T10233.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10233.hs @@ -0,0 +1,2 @@ +module T10233 where +import T10233a( Constraint, Int ) diff --git a/tests/examples/ghc8/T10233a.hs b/tests/examples/ghc8/T10233a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10233a.hs @@ -0,0 +1,3 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10246.hs b/tests/examples/ghc8/T10246.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10251.hs b/tests/examples/ghc8/T10251.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10263.hs b/tests/examples/ghc8/T10263.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10263.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +module T10263 where + +data Maybe a = AF +type role Maybe representational diff --git a/tests/examples/ghc8/T10279.hs b/tests/examples/ghc8/T10279.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10279.hs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10284.hs b/tests/examples/ghc8/T10284.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10285.hs b/tests/examples/ghc8/T10285.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10285a.hs b/tests/examples/ghc8/T10285a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10294.hs b/tests/examples/ghc8/T10294.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10294.hs @@ -0,0 +1,7 @@ +module T10294 where + +import SayAnnNames + +{-# ANN foo SomeAnn #-} +foo :: () +foo = () diff --git a/tests/examples/ghc8/T10294a.hs b/tests/examples/ghc8/T10294a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10294a.hs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10321.hs b/tests/examples/ghc8/T10321.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10322A.hs b/tests/examples/ghc8/T10322A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10322A.hs @@ -0,0 +1,4 @@ +module T10322A (a) where +{-# NOINLINE a #-} +a :: Int +a = 3 diff --git a/tests/examples/ghc8/T10322B.hs b/tests/examples/ghc8/T10322B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10322B.hs @@ -0,0 +1,4 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10335.hs b/tests/examples/ghc8/T10335.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10340.hs b/tests/examples/ghc8/T10340.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10348.hs b/tests/examples/ghc8/T10348.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10351.hs b/tests/examples/ghc8/T10351.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10351.hs @@ -0,0 +1,6 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10384.hs b/tests/examples/ghc8/T10384.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10390.hs b/tests/examples/ghc8/T10390.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10398.hs b/tests/examples/ghc8/T10398.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10403.hs b/tests/examples/ghc8/T10403.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10414.hs b/tests/examples/ghc8/T10414.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10420.hs b/tests/examples/ghc8/T10420.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10420a.hs b/tests/examples/ghc8/T10420a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10420a.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -fplugin RuleDefiningPlugin #-} +module T10420a where diff --git a/tests/examples/ghc8/T10423.hs b/tests/examples/ghc8/T10423.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10428.hs b/tests/examples/ghc8/T10428.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10438.hs b/tests/examples/ghc8/T10438.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10447.hs b/tests/examples/ghc8/T10447.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10451.hs b/tests/examples/ghc8/T10451.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10460.hs b/tests/examples/ghc8/T10460.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10461.hs b/tests/examples/ghc8/T10461.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10463.hs b/tests/examples/ghc8/T10463.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10463.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables, PartialTypeSignatures #-} + +module T10463 where + +f (x :: _) = x ++ "" diff --git a/tests/examples/ghc8/T10481.hs b/tests/examples/ghc8/T10481.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10482.hs b/tests/examples/ghc8/T10482.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10482a.hs b/tests/examples/ghc8/T10482a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10489.hs b/tests/examples/ghc8/T10489.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10493.hs b/tests/examples/ghc8/T10493.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10494.hs b/tests/examples/ghc8/T10494.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10495.hs b/tests/examples/ghc8/T10495.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10495.hs @@ -0,0 +1,5 @@ +module T10495 where + +import Data.Coerce + +foo = coerce diff --git a/tests/examples/ghc8/T10503.hs b/tests/examples/ghc8/T10503.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10507.hs b/tests/examples/ghc8/T10507.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10508_api.hs b/tests/examples/ghc8/T10508_api.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10516.hs b/tests/examples/ghc8/T10516.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10519.hs b/tests/examples/ghc8/T10519.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10521.hs b/tests/examples/ghc8/T10521.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10521b.hs b/tests/examples/ghc8/T10521b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10524.hs b/tests/examples/ghc8/T10524.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10524.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +module T10524 where + +import Data.Data + +newtype WrappedFunctor f a = WrapFunctor (f a) deriving (Data, Typeable) + diff --git a/tests/examples/ghc8/T10534.hs b/tests/examples/ghc8/T10534.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10534a.hs b/tests/examples/ghc8/T10534a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10549.hs b/tests/examples/ghc8/T10549.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10561.hs b/tests/examples/ghc8/T10561.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10562.hs b/tests/examples/ghc8/T10562.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10564.hs b/tests/examples/ghc8/T10564.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10570.hs b/tests/examples/ghc8/T10570.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10582.hs b/tests/examples/ghc8/T10582.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10582.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE Arrows #-} + +module T10582 where + +(|:) :: Int -> Int -> Int +(|:) = (+) diff --git a/tests/examples/ghc8/T10590.hs b/tests/examples/ghc8/T10590.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10596.hs b/tests/examples/ghc8/T10596.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10602.hs b/tests/examples/ghc8/T10602.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10602b.hs b/tests/examples/ghc8/T10602b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10615.hs b/tests/examples/ghc8/T10615.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10615.hs @@ -0,0 +1,10 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10618.hs @@ -0,0 +1,3 @@ +module T10618 where + +foo = Just $ Nothing <> Nothing diff --git a/tests/examples/ghc8/T10620.hs b/tests/examples/ghc8/T10620.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10627.hs b/tests/examples/ghc8/T10627.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10632.hs b/tests/examples/ghc8/T10632.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10634.hs b/tests/examples/ghc8/T10634.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10637.hs b/tests/examples/ghc8/T10637.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10637.hs @@ -0,0 +1,4 @@ +module T10637 where + +import {-# SOURCE #-} A () +data B = B diff --git a/tests/examples/ghc8/T10638.hs b/tests/examples/ghc8/T10638.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10638.hs @@ -0,0 +1,31 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10668.hs b/tests/examples/ghc8/T10668.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10668.hs @@ -0,0 +1,3 @@ +module T10668 where + +import Data.Type.Equality(Refl) diff --git a/tests/examples/ghc8/T10670.hs b/tests/examples/ghc8/T10670.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10670a.hs b/tests/examples/ghc8/T10670a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10689.hs b/tests/examples/ghc8/T10689.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10689a.hs b/tests/examples/ghc8/T10689a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10694.hs b/tests/examples/ghc8/T10694.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10698.hs b/tests/examples/ghc8/T10698.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10704.hs b/tests/examples/ghc8/T10704.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10704a.hs b/tests/examples/ghc8/T10704a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10713.hs b/tests/examples/ghc8/T10713.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10742.hs b/tests/examples/ghc8/T10742.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10744.hs b/tests/examples/ghc8/T10744.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10753.hs b/tests/examples/ghc8/T10753.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10781.hs b/tests/examples/ghc8/T10781.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10806.hs b/tests/examples/ghc8/T10806.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10815.hs b/tests/examples/ghc8/T10815.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10826.hs b/tests/examples/ghc8/T10826.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10830.hs b/tests/examples/ghc8/T10830.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10830.hs @@ -0,0 +1,3 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T10895.hs b/tests/examples/ghc8/T10895.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T10895.hs @@ -0,0 +1,1 @@ +module NotMain where diff --git a/tests/examples/ghc8/T1133Aa.hs b/tests/examples/ghc8/T1133Aa.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T1133Aa.hs @@ -0,0 +1,3 @@ +module T1133Aa where + +import {-# SOURCE #-} T1133A diff --git a/tests/examples/ghc8/T1133a.hs b/tests/examples/ghc8/T1133a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T1133a.hs @@ -0,0 +1,3 @@ +module T1133a where + +import {-# SOURCE #-} T1133 diff --git a/tests/examples/ghc8/T17a.hs b/tests/examples/ghc8/T17a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T17b.hs b/tests/examples/ghc8/T17b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T17c.hs b/tests/examples/ghc8/T17c.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T17d.hs b/tests/examples/ghc8/T17d.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T17e.hs b/tests/examples/ghc8/T17e.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T2632.hs b/tests/examples/ghc8/T2632.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T2632.hs @@ -0,0 +1,14 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T2991.hs b/tests/examples/ghc8/T2991.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T3468a.hs b/tests/examples/ghc8/T3468a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T3468a.hs @@ -0,0 +1,3 @@ +module T3468a where + +import {-# SOURCE #-} T3468 diff --git a/tests/examples/ghc8/T3572.hs b/tests/examples/ghc8/T3572.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T3572.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE EmptyDataDecls #-} + +-- 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/T4056.hs b/tests/examples/ghc8/T4056.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T4056.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-} + +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/T4169.hs b/tests/examples/ghc8/T4169.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T4169.hs @@ -0,0 +1,13 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T4170.hs @@ -0,0 +1,12 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T5333.hs b/tests/examples/ghc8/T5333.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T5721.hs b/tests/examples/ghc8/T5721.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T5821.hs b/tests/examples/ghc8/T5821.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T5884Other.hs b/tests/examples/ghc8/T5884Other.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T5884Other.hs @@ -0,0 +1,3 @@ +module T5884Other where + +data Pair a = Pair a a diff --git a/tests/examples/ghc8/T5908.hs b/tests/examples/ghc8/T5908.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T6018.hs b/tests/examples/ghc8/T6018.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T6018.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T6018Bfail.hs b/tests/examples/ghc8/T6018Bfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T6018Cfail.hs b/tests/examples/ghc8/T6018Cfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T6018Dfail.hs b/tests/examples/ghc8/T6018Dfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T6018a.hs b/tests/examples/ghc8/T6018a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T6018fail.hs b/tests/examples/ghc8/T6018fail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T6018failclosed.hs b/tests/examples/ghc8/T6018failclosed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T6018failclosed2.hs b/tests/examples/ghc8/T6018failclosed2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T6018rnfail.hs b/tests/examples/ghc8/T6018rnfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T6018th.hs b/tests/examples/ghc8/T6018th.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T6018th.hs @@ -0,0 +1,119 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T6062.hs @@ -0,0 +1,2 @@ +module T6062 where +x = [| False True |] diff --git a/tests/examples/ghc8/T7411.hs b/tests/examples/ghc8/T7411.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T7411.hs @@ -0,0 +1,3 @@ +import Control.Exception +import Control.DeepSeq +main = evaluate (('a' : undefined) `deepseq` return () :: IO ()) diff --git a/tests/examples/ghc8/T7672.hs b/tests/examples/ghc8/T7672.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T7672.hs @@ -0,0 +1,3 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T7672a.hs @@ -0,0 +1,2 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T7765.hs @@ -0,0 +1,1 @@ +module Main where diff --git a/tests/examples/ghc8/T7788.hs b/tests/examples/ghc8/T7788.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T8030.hs b/tests/examples/ghc8/T8030.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T8034.hs b/tests/examples/ghc8/T8034.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T8101b.hs b/tests/examples/ghc8/T8101b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T8131b.hs b/tests/examples/ghc8/T8131b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T8274.hs b/tests/examples/ghc8/T8274.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T8455.hs b/tests/examples/ghc8/T8455.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T8455.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DataKinds #-} + +module T8455 where + +ty = [t| 5 |] diff --git a/tests/examples/ghc8/T8550.hs b/tests/examples/ghc8/T8550.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T8555.hs b/tests/examples/ghc8/T8555.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T8633.hs b/tests/examples/ghc8/T8633.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T8743a.hs b/tests/examples/ghc8/T8743a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T8743a.hs @@ -0,0 +1,3 @@ +module T8743a where + +import {-# SOURCE #-} T8743 () diff --git a/tests/examples/ghc8/T8759a.hs b/tests/examples/ghc8/T8759a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T8759a.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + +module T8759a where + +foo = [d| pattern Q = False |] diff --git a/tests/examples/ghc8/T8799.hs b/tests/examples/ghc8/T8799.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9177a.hs b/tests/examples/ghc8/T9177a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9177a.hs @@ -0,0 +1,6 @@ +module T9177a where + +foo3 = bar +foo4 = Fun + + diff --git a/tests/examples/ghc8/T9204a.hs b/tests/examples/ghc8/T9204a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9204a.hs @@ -0,0 +1,2 @@ +module T9204a where +import {-# SOURCE #-} T9204 diff --git a/tests/examples/ghc8/T9204b.hs b/tests/examples/ghc8/T9204b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9204b.hs @@ -0,0 +1,5 @@ +module T9204b where + +import T9204b2 + +data P a = P diff --git a/tests/examples/ghc8/T9204b2.hs b/tests/examples/ghc8/T9204b2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9204b2.hs @@ -0,0 +1,3 @@ +module T9204b2 where + +import {-# SOURCE #-} T9204b diff --git a/tests/examples/ghc8/T9225.hs b/tests/examples/ghc8/T9225.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9225.hs @@ -0,0 +1,4 @@ +module T9225 where +-- Should be a parse error: +-- version numbers not allowed in package qualified imports +import "some-package-0.1.2.3" Some.Module diff --git a/tests/examples/ghc8/T9233.hs b/tests/examples/ghc8/T9233.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9233a.hs b/tests/examples/ghc8/T9233a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9260.hs b/tests/examples/ghc8/T9260.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9430.hs b/tests/examples/ghc8/T9430.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9554.hs b/tests/examples/ghc8/T9554.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9600-1.hs b/tests/examples/ghc8/T9600-1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9600.hs b/tests/examples/ghc8/T9600.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9600.hs @@ -0,0 +1,3 @@ +import Control.Applicative + +newtype Foo a = Foo (a -> a) deriving Applicative diff --git a/tests/examples/ghc8/T9723a.hs b/tests/examples/ghc8/T9723a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9723a.hs @@ -0,0 +1,9 @@ + +{-# OPTIONS -fwarn-tabs #-} + +-- Check we get a warning for a single tab + +module ShouldCompile where + +tab1 = 'a' + diff --git a/tests/examples/ghc8/T9723b.hs b/tests/examples/ghc8/T9723b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9723b.hs @@ -0,0 +1,22 @@ + +{-# OPTIONS -fwarn-tabs #-} + +-- Check we get a warning for multiple tabs, with the correct number of tabs +-- mentioned + +module ShouldCompile where + +-- tab in middle of line +tab1 = 'a' +-- tab at end of line +tab2 = 'b' +-- two tabs in middle of line +tab3 = 'c' + +tab4 = if True +-- tab at start of line + then 'd' +-- tab at start of line + else 'e' + + -- tab before a comment starts diff --git a/tests/examples/ghc8/T9824.hs b/tests/examples/ghc8/T9824.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9824.hs @@ -0,0 +1,5 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9839_02.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/ghc8/T9839_03.hs b/tests/examples/ghc8/T9839_03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9839_03.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/ghc8/T9839_04.hs b/tests/examples/ghc8/T9839_04.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9839_04.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/ghc8/T9839_05.hs b/tests/examples/ghc8/T9839_05.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9839_05.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/ghc8/T9839_06.hs b/tests/examples/ghc8/T9839_06.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9839_06.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/ghc8/T9840.hs b/tests/examples/ghc8/T9840.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9840a.hs b/tests/examples/ghc8/T9840a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9858a.hs b/tests/examples/ghc8/T9858a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9858b.hs b/tests/examples/ghc8/T9858b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9858c.hs b/tests/examples/ghc8/T9858c.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9858d.hs b/tests/examples/ghc8/T9858d.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9858e.hs b/tests/examples/ghc8/T9858e.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9867.hs b/tests/examples/ghc8/T9867.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9867.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-} + +module T9867 where + +pattern Nil = [] :: [a] diff --git a/tests/examples/ghc8/T9878b.hs b/tests/examples/ghc8/T9878b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/T9878b.hs @@ -0,0 +1,6 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9938B.hs b/tests/examples/ghc8/T9938B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9939.hs b/tests/examples/ghc8/T9939.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9964.hs b/tests/examples/ghc8/T9964.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9973.hs b/tests/examples/ghc8/T9973.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9975a.hs b/tests/examples/ghc8/T9975a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/T9975b.hs b/tests/examples/ghc8/T9975b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/TH_abstractFamily.hs b/tests/examples/ghc8/TH_abstractFamily.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/TH_abstractFamily.hs @@ -0,0 +1,11 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/TH_bracket1.hs @@ -0,0 +1,7 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/TH_bracket2.hs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/TH_bracket3.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +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_localname.hs b/tests/examples/ghc8/TH_localname.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/TH_localname.hs @@ -0,0 +1,3 @@ +module TH_localname where + +x = \y -> [| y |] diff --git a/tests/examples/ghc8/TH_namePackage.hs b/tests/examples/ghc8/TH_namePackage.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/TH_ppr1.hs b/tests/examples/ghc8/TH_ppr1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/TH_ppr1.hs @@ -0,0 +1,37 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/TH_reifyType2.hs b/tests/examples/ghc8/TH_reifyType2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/TH_repE1.hs b/tests/examples/ghc8/TH_repE1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/TH_repE1.hs @@ -0,0 +1,30 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/TH_repE3.hs @@ -0,0 +1,19 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/TH_scope.hs @@ -0,0 +1,8 @@ +-- 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_tf2.hs b/tests/examples/ghc8/TH_tf2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/TcCustomSolverSuper.hs b/tests/examples/ghc8/TcCustomSolverSuper.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test.hs b/tests/examples/ghc8/Test.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10255.hs b/tests/examples/ghc8/Test10255.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10268.hs b/tests/examples/ghc8/Test10268.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10269.hs b/tests/examples/ghc8/Test10269.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Test10269.hs @@ -0,0 +1,4 @@ +module Test10269 where + + +(f =*= g) sa i = undefined diff --git a/tests/examples/ghc8/Test10278.hs b/tests/examples/ghc8/Test10278.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10280.hs b/tests/examples/ghc8/Test10280.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/Test10280.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TupleSections #-} +module Test10280 where + +foo2 = atomicModifyIORef ciTokens ((,()) . f) diff --git a/tests/examples/ghc8/Test10307.hs b/tests/examples/ghc8/Test10307.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10309.hs b/tests/examples/ghc8/Test10309.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10312.hs b/tests/examples/ghc8/Test10312.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10313.hs b/tests/examples/ghc8/Test10313.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10354.hs b/tests/examples/ghc8/Test10354.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10357.hs b/tests/examples/ghc8/Test10357.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10358.hs b/tests/examples/ghc8/Test10358.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10396.hs b/tests/examples/ghc8/Test10396.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Test10399.hs b/tests/examples/ghc8/Test10399.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/TestBoolFormula.hs b/tests/examples/ghc8/TestBoolFormula.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/Trac10045.hs b/tests/examples/ghc8/Trac10045.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/TransAssociated.hs b/tests/examples/ghc8/TransAssociated.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/TypeFamilyInstanceLHS.hs b/tests/examples/ghc8/TypeFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/TypedSplice.hs b/tests/examples/ghc8/TypedSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ado001.hs b/tests/examples/ghc8/ado001.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ado002.hs b/tests/examples/ghc8/ado002.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ado003.hs b/tests/examples/ghc8/ado003.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ado004.hs b/tests/examples/ghc8/ado004.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ado005.hs b/tests/examples/ghc8/ado005.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ado006.hs b/tests/examples/ghc8/ado006.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/ado007.hs b/tests/examples/ghc8/ado007.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/boolFormula.hs b/tests/examples/ghc8/boolFormula.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/export-class.hs b/tests/examples/ghc8/export-class.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/export-super-class-fail.hs b/tests/examples/ghc8/export-super-class-fail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/export-super-class.hs b/tests/examples/ghc8/export-super-class.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/export-syntax.hs b/tests/examples/ghc8/export-syntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/export-syntax.hs @@ -0,0 +1,3 @@ +module Foo(A(.., B)) where + +data A = A | B diff --git a/tests/examples/ghc8/export-type.hs b/tests/examples/ghc8/export-type.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/export-type.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Export (A(..,MyB), B(MyA)) where + +data A = A + +data B = B + +pattern MyB = B + +pattern MyA = A diff --git a/tests/examples/ghc8/haddockA034.hs b/tests/examples/ghc8/haddockA034.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/import-syntax.hs b/tests/examples/ghc8/import-syntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/import-syntax.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} +module Foo where + +import ImportSyntax (A(.., B)) diff --git a/tests/examples/ghc8/listcomps.hs b/tests/examples/ghc8/listcomps.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/multi-export.hs b/tests/examples/ghc8/multi-export.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/performGC.hs b/tests/examples/ghc8/performGC.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/plugins07.hs b/tests/examples/ghc8/plugins07.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/plugins07.hs @@ -0,0 +1,6 @@ +module Main where + +{-# NOINLINE x #-} +x = "foo" + +main = putStrLn (show x) diff --git a/tests/examples/ghc8/poly-export-fail2.hs b/tests/examples/ghc8/poly-export-fail2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/poly-export.hs b/tests/examples/ghc8/poly-export.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/poly-export.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +module Foo (Foo(P,Q)) 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/poly-export3.hs b/tests/examples/ghc8/poly-export3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/stringSource.hs b/tests/examples/ghc8/stringSource.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10255.hs b/tests/examples/ghc8/t10255.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10268.hs b/tests/examples/ghc8/t10268.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10269.hs b/tests/examples/ghc8/t10269.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10278.hs b/tests/examples/ghc8/t10278.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10280.hs b/tests/examples/ghc8/t10280.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10307.hs b/tests/examples/ghc8/t10307.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10309.hs b/tests/examples/ghc8/t10309.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10312.hs b/tests/examples/ghc8/t10312.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10354.hs b/tests/examples/ghc8/t10354.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10357.hs b/tests/examples/ghc8/t10357.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10358.hs b/tests/examples/ghc8/t10358.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10396.hs b/tests/examples/ghc8/t10396.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/t10399.hs b/tests/examples/ghc8/t10399.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/tc265.hs b/tests/examples/ghc8/tc265.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/tcfail223.hs b/tests/examples/ghc8/tcfail223.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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/ghc8/update-existential.hs b/tests/examples/ghc8/update-existential.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc8/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.) +} diff --git a/tests/examples/transform/AddDecl.hs b/tests/examples/transform/AddDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddDecl.hs @@ -0,0 +1,9 @@ +module AddDecl where + +-- Adding a declaration to an existing file + +-- | Do foo +foo a b = a + b + +-- | Do bar +bar x y = foo (x+y) x diff --git a/tests/examples/transform/AddDecl.hs.expected b/tests/examples/transform/AddDecl.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddDecl.hs.expected @@ -0,0 +1,11 @@ +module AddDecl where + +nn = n2 + +-- Adding a declaration to an existing file + +-- | Do foo +foo a b = a + b + +-- | Do bar +bar x y = foo (x+y) x diff --git a/tests/examples/transform/AddHiding1.hs b/tests/examples/transform/AddHiding1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddHiding1.hs @@ -0,0 +1,7 @@ +module AddHiding1 where + +import Data.Maybe + +import Data.Maybe hiding (n1,n2) + +f = 1 diff --git a/tests/examples/transform/AddHiding1.hs.expected b/tests/examples/transform/AddHiding1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddHiding1.hs.expected @@ -0,0 +1,7 @@ +module AddHiding1 where + +import Data.Maybe hiding (n1,n2) + +import Data.Maybe hiding (n1,n2) + +f = 1 diff --git a/tests/examples/transform/AddHiding2.hs b/tests/examples/transform/AddHiding2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddHiding2.hs @@ -0,0 +1,5 @@ +module AddHiding2 where + +import Data.Maybe hiding (f1,f2) + +f = 1 diff --git a/tests/examples/transform/AddHiding2.hs.expected b/tests/examples/transform/AddHiding2.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddHiding2.hs.expected @@ -0,0 +1,5 @@ +module AddHiding2 where + +import Data.Maybe hiding (f1,f2,n1,n2) + +f = 1 diff --git a/tests/examples/transform/AddLocalDecl1.hs b/tests/examples/transform/AddLocalDecl1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl1.hs @@ -0,0 +1,9 @@ +module AddLocalDecl1 where + +-- |This is a function +foo = x -- comment1 + +-- |Another fun +x = a -- comment2 + where + a = 3 diff --git a/tests/examples/transform/AddLocalDecl1.hs.expected b/tests/examples/transform/AddLocalDecl1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl1.hs.expected @@ -0,0 +1,11 @@ +module AddLocalDecl1 where + +-- |This is a function +foo = x -- comment1 + where + nn = 2 + +-- |Another fun +x = a -- comment2 + where + a = 3 diff --git a/tests/examples/transform/AddLocalDecl2.hs b/tests/examples/transform/AddLocalDecl2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl2.hs @@ -0,0 +1,10 @@ +module AddLocalDecl2 where + +-- |This is a function +foo = x -- comment 0 + where p = 2 -- comment 1 + +-- |Another fun +bar = a -- comment 2 + where nn = 2 + p = 2 -- comment 3 diff --git a/tests/examples/transform/AddLocalDecl2.hs.expected b/tests/examples/transform/AddLocalDecl2.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl2.hs.expected @@ -0,0 +1,11 @@ +module AddLocalDecl2 where + +-- |This is a function +foo = x -- comment 0 + where nn = 2 + p = 2 -- comment 1 + +-- |Another fun +bar = a -- comment 2 + where nn = 2 + p = 2 -- comment 3 diff --git a/tests/examples/transform/AddLocalDecl3.hs b/tests/examples/transform/AddLocalDecl3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl3.hs @@ -0,0 +1,10 @@ +module AddLocalDecl2 where + +-- |This is a function +foo = x -- comment 0 + where p = 2 -- comment 1 + +-- |Another fun +bar = a -- comment 2 + where p = 2 -- comment 3 + nn = 2 diff --git a/tests/examples/transform/AddLocalDecl3.hs.expected b/tests/examples/transform/AddLocalDecl3.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl3.hs.expected @@ -0,0 +1,11 @@ +module AddLocalDecl2 where + +-- |This is a function +foo = x -- comment 0 + where p = 2 -- comment 1 + nn = 2 + +-- |Another fun +bar = a -- comment 2 + where p = 2 -- comment 3 + nn = 2 diff --git a/tests/examples/transform/AddLocalDecl4.hs b/tests/examples/transform/AddLocalDecl4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl4.hs @@ -0,0 +1,3 @@ +module AddLocalDecl4 where + +toplevel x = c * x diff --git a/tests/examples/transform/AddLocalDecl4.hs.expected b/tests/examples/transform/AddLocalDecl4.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl4.hs.expected @@ -0,0 +1,6 @@ +module AddLocalDecl4 where + +toplevel x = c * x + where + nn :: Int + nn = 2 diff --git a/tests/examples/transform/AddLocalDecl5.hs b/tests/examples/transform/AddLocalDecl5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl5.hs @@ -0,0 +1,8 @@ +module AddLocalDecl5 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +-- c,d :: Integer +c = 7 +d = 9 diff --git a/tests/examples/transform/AddLocalDecl5.hs.expected b/tests/examples/transform/AddLocalDecl5.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl5.hs.expected @@ -0,0 +1,9 @@ +module AddLocalDecl5 where + +toplevel :: Integer -> Integer +toplevel x = c * x + where + -- c,d :: Integer + c = 7 + +d = 9 diff --git a/tests/examples/transform/AddLocalDecl6.hs b/tests/examples/transform/AddLocalDecl6.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl6.hs @@ -0,0 +1,9 @@ +module AddLocalDecl6 where + +foo [] = 1 -- comment 0 +foo xs = 2 -- comment 1 + +bar [] = 1 -- comment 2 + where + x = 3 +bar xs = 2 -- comment 3 diff --git a/tests/examples/transform/AddLocalDecl6.hs.expected b/tests/examples/transform/AddLocalDecl6.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddLocalDecl6.hs.expected @@ -0,0 +1,11 @@ +module AddLocalDecl6 where + +foo [] = 1 -- comment 0 + where + x = 3 +foo xs = 2 -- comment 1 + +bar [] = 1 -- comment 2 + where + x = 3 +bar xs = 2 -- comment 3 diff --git a/tests/examples/transform/C.hs b/tests/examples/transform/C.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/C.hs @@ -0,0 +1,12 @@ +module C where +-- Test for refactor of if to case +-- The comments on the then and else legs should be preserved + +foo x = if (odd x) + then -- This is an odd result + bob x 1 + else -- This is an even result + bob x 2 + +bob x y = x + y + diff --git a/tests/examples/transform/C.hs.expected b/tests/examples/transform/C.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/C.hs.expected @@ -0,0 +1,12 @@ +module C where +-- Test for refactor of if to case +-- The comments on the then and else legs should be preserved + +foo x = case (odd x) of + True -> -- This is an odd result + bob x 1 + False -> -- This is an even result + bob x 2 + +bob x y = x + y + diff --git a/tests/examples/transform/CloneDecl1.hs b/tests/examples/transform/CloneDecl1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/CloneDecl1.hs @@ -0,0 +1,10 @@ +module CloneDecl1 where + +z = 3 + +foo a b = + let + x = a + b + z + y = a * b - z + in + x + y diff --git a/tests/examples/transform/CloneDecl1.hs.expected b/tests/examples/transform/CloneDecl1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/CloneDecl1.hs.expected @@ -0,0 +1,17 @@ +module CloneDecl1 where + +z = 3 + +foo a b = + let + x = a + b + z + y = a * b - z + in + x + y + +foo a b = + let + x = a + b + z + y = a * b - z + in + x + y diff --git a/tests/examples/transform/LayoutIn1.hs b/tests/examples/transform/LayoutIn1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutIn1.hs @@ -0,0 +1,9 @@ +module LayoutIn1 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'sq' to 'square'. + +sumSquares x y= sq x + sq y where sq x= x^pow + --There is a comment. + pow=2 diff --git a/tests/examples/transform/LayoutIn1.hs.expected b/tests/examples/transform/LayoutIn1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutIn1.hs.expected @@ -0,0 +1,9 @@ +module LayoutIn1 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'sq' to 'square'. + +sumSquares x y= square x + square y where sq x= x^pow + --There is a comment. + pow=2 diff --git a/tests/examples/transform/LayoutIn3.hs b/tests/examples/transform/LayoutIn3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutIn3.hs @@ -0,0 +1,13 @@ +module LayoutIn3 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let x = 12 in (let y = 3 + z = 2 in x * y * z * w) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/transform/LayoutIn3.hs.expected b/tests/examples/transform/LayoutIn3.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutIn3.hs.expected @@ -0,0 +1,13 @@ +module LayoutIn3 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let anotherX = 12 in (let y = 3 + z = 2 in anotherX * y * z * w) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/transform/LayoutIn3a.hs b/tests/examples/transform/LayoutIn3a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutIn3a.hs @@ -0,0 +1,13 @@ +module LayoutIn3a where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let x = 12 in ( + x ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/transform/LayoutIn3a.hs.expected b/tests/examples/transform/LayoutIn3a.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutIn3a.hs.expected @@ -0,0 +1,13 @@ +module LayoutIn3a where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let anotherX = 12 in ( + anotherX ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/transform/LayoutIn3b.hs b/tests/examples/transform/LayoutIn3b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutIn3b.hs @@ -0,0 +1,12 @@ +module LayoutIn3b where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let x = 12 in ( x ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/transform/LayoutIn3b.hs.expected b/tests/examples/transform/LayoutIn3b.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutIn3b.hs.expected @@ -0,0 +1,12 @@ +module LayoutIn3b where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let anotherX = 12 in ( anotherX ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/transform/LayoutIn4.hs b/tests/examples/transform/LayoutIn4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutIn4.hs @@ -0,0 +1,13 @@ +module LayoutIn4 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'ioFun' to 'io' + +main = ioFun "hello" where ioFun s= do let k = reverse s + --There is a comment + s <- getLine + let q = (k ++ s) + putStr q + putStr "foo" + diff --git a/tests/examples/transform/LayoutIn4.hs.expected b/tests/examples/transform/LayoutIn4.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutIn4.hs.expected @@ -0,0 +1,13 @@ +module LayoutIn4 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'ioFun' to 'io' + +main = io "hello" where io s= do let k = reverse s +--There is a comment + s <- getLine + let q = (k ++ s) + putStr q + putStr "foo" + diff --git a/tests/examples/transform/LayoutLet2.hs b/tests/examples/transform/LayoutLet2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutLet2.hs @@ -0,0 +1,9 @@ +module LayoutLet2 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 in xxx + a + b + diff --git a/tests/examples/transform/LayoutLet2.hs.expected b/tests/examples/transform/LayoutLet2.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutLet2.hs.expected @@ -0,0 +1,9 @@ +module LayoutLet2 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxxlonger = let a = 1 + b = 2 in xxxlonger + a + b + diff --git a/tests/examples/transform/LayoutLet3.hs b/tests/examples/transform/LayoutLet3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutLet3.hs @@ -0,0 +1,10 @@ +module LayoutLet3 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 + in xxx + a + b + diff --git a/tests/examples/transform/LayoutLet3.hs.expected b/tests/examples/transform/LayoutLet3.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutLet3.hs.expected @@ -0,0 +1,10 @@ +module LayoutLet3 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxxlonger = let a = 1 + b = 2 + in xxxlonger + a + b + diff --git a/tests/examples/transform/LayoutLet4.hs b/tests/examples/transform/LayoutLet4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutLet4.hs @@ -0,0 +1,11 @@ +module LayoutLet4 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 + in xxx + a + b + +bar = 3 diff --git a/tests/examples/transform/LayoutLet4.hs.expected b/tests/examples/transform/LayoutLet4.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutLet4.hs.expected @@ -0,0 +1,11 @@ +module LayoutLet4 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxxlonger = let a = 1 + b = 2 + in xxxlonger + a + b + +bar = 3 diff --git a/tests/examples/transform/LayoutLet5.hs b/tests/examples/transform/LayoutLet5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutLet5.hs @@ -0,0 +1,11 @@ +module LayoutLet5 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 + in xxx + a + b + +bar = 3 diff --git a/tests/examples/transform/LayoutLet5.hs.expected b/tests/examples/transform/LayoutLet5.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LayoutLet5.hs.expected @@ -0,0 +1,11 @@ +module LayoutLet5 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo x = let a = 1 + b = 2 + in x + a + b + +bar = 3 diff --git a/tests/examples/transform/LetIn1.hs b/tests/examples/transform/LetIn1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LetIn1.hs @@ -0,0 +1,19 @@ +module LetIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the local 'pow' to 'sq' +--This example also aims to test the demoting a local declaration in 'let'. + +sumSquares x y = let sq 0=0 + sq z=z^pow + pow=2 + in sq x + sq y + + +anotherFun 0 y = sq y + where sq x = x^2 + + diff --git a/tests/examples/transform/LetIn1.hs.expected b/tests/examples/transform/LetIn1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LetIn1.hs.expected @@ -0,0 +1,18 @@ +module LetIn1 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the local 'pow' to 'sq' +--This example also aims to test the demoting a local declaration in 'let'. + +sumSquares x y = let sq 0=0 + sq z=z^pow + in sq x + sq y + + +anotherFun 0 y = sq y + where sq x = x^2 + + diff --git a/tests/examples/transform/LocToName.hs b/tests/examples/transform/LocToName.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LocToName.hs @@ -0,0 +1,24 @@ +module LocToName where + +{- + + + + + + + + +-} + + + + + + + +sumSquares (x:xs) = x ^2 + sumSquares xs + -- where sq x = x ^pow + -- pow = 2 + +sumSquares [] = 0 diff --git a/tests/examples/transform/LocToName.hs.expected b/tests/examples/transform/LocToName.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LocToName.hs.expected @@ -0,0 +1,24 @@ +module LocToName where + +{- + + + + + + + + +-} + + + + + + + +LocToName.newPoint (x:xs) = x ^2 + LocToName.newPoint xs + -- where sq x = x ^pow + -- pow = 2 + +LocToName.newPoint [] = 0 diff --git a/tests/examples/transform/LocalDecls.hs b/tests/examples/transform/LocalDecls.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LocalDecls.hs @@ -0,0 +1,8 @@ +module LocalDecls where + +foo a = bar a + where + bar :: Int -> Int + bar x = x + 2 + + baz = 4 diff --git a/tests/examples/transform/LocalDecls.hs.expected b/tests/examples/transform/LocalDecls.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LocalDecls.hs.expected @@ -0,0 +1,11 @@ +module LocalDecls where + +foo a = bar a + where + nn :: Int + nn = 2 + + bar :: Int -> Int + bar x = x + 2 + + baz = 4 diff --git a/tests/examples/transform/LocalDecls2.hs b/tests/examples/transform/LocalDecls2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LocalDecls2.hs @@ -0,0 +1,3 @@ +module LocalDecls2 where + +foo a = bar a diff --git a/tests/examples/transform/LocalDecls2.hs.expected b/tests/examples/transform/LocalDecls2.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LocalDecls2.hs.expected @@ -0,0 +1,6 @@ +module LocalDecls2 where + +foo a = bar a + where + nn :: Int + nn = 2 diff --git a/tests/examples/transform/NormaliseLayout.hs b/tests/examples/transform/NormaliseLayout.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/NormaliseLayout.hs @@ -0,0 +1,5 @@ +module Main where + +foo x = baz + where foo = 2 + two = 4 where bax = 4 diff --git a/tests/examples/transform/NormaliseLayout.hs.expected b/tests/examples/transform/NormaliseLayout.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/NormaliseLayout.hs.expected @@ -0,0 +1,1 @@ +module Main where diff --git a/tests/examples/transform/Rename1.hs b/tests/examples/transform/Rename1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/Rename1.hs @@ -0,0 +1,6 @@ + + +foo x y = + do c <- getChar + return c + diff --git a/tests/examples/transform/Rename1.hs.expected b/tests/examples/transform/Rename1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/Rename1.hs.expected @@ -0,0 +1,6 @@ + + +bar2 x y = + do c <- getChar + return c + diff --git a/tests/examples/transform/Rename2.hs b/tests/examples/transform/Rename2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/Rename2.hs @@ -0,0 +1,4 @@ + +foo' x = case (odd x) of + True -> "Odd" + False -> "Even" diff --git a/tests/examples/transform/Rename2.hs.expected b/tests/examples/transform/Rename2.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/Rename2.hs.expected @@ -0,0 +1,4 @@ + +joe x = case (odd x) of + True -> "Odd" + False -> "Even" diff --git a/tests/examples/transform/RenameCase1.hs b/tests/examples/transform/RenameCase1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RenameCase1.hs @@ -0,0 +1,6 @@ +module RenameCase1 where + +foo x = case (baz x) of + 1 -> "a" + _ -> "b" + diff --git a/tests/examples/transform/RenameCase1.hs.expected b/tests/examples/transform/RenameCase1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RenameCase1.hs.expected @@ -0,0 +1,6 @@ +module RenameCase1 where + +foo x = case (bazLonger x) of + 1 -> "a" + _ -> "b" + diff --git a/tests/examples/transform/RenameCase2.hs b/tests/examples/transform/RenameCase2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RenameCase2.hs @@ -0,0 +1,6 @@ +module RenameCase2 where + +foo x = case (baz x) of + 1 -> "a" + _ -> "b" + diff --git a/tests/examples/transform/RenameCase2.hs.expected b/tests/examples/transform/RenameCase2.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RenameCase2.hs.expected @@ -0,0 +1,6 @@ +module RenameCase2 where + +fooLonger x = case (baz x) of + 1 -> "a" + _ -> "b" + diff --git a/tests/examples/transform/RmDecl1.hs b/tests/examples/transform/RmDecl1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl1.hs @@ -0,0 +1,12 @@ +module RmDecl1 where + +sumSquares x = x * p + where p=2 {-There is a comment-} + +sq :: Int -> Int -> Int +sq pow 0 = 0 +sq pow z = z^pow --there is a comment + +{- foo bar -} +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/tests/examples/transform/RmDecl1.hs.expected b/tests/examples/transform/RmDecl1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl1.hs.expected @@ -0,0 +1,8 @@ +module RmDecl1 where + +sumSquares x = x * p + where p=2 {-There is a comment-} + +{- foo bar -} +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/tests/examples/transform/RmDecl2.hs b/tests/examples/transform/RmDecl2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl2.hs @@ -0,0 +1,10 @@ +module RmDecl2 where + +sumSquares x y = let sq 0=0 + sq z=z^pow + pow=2 + in sq x + sq y + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/tests/examples/transform/RmDecl2.hs.expected b/tests/examples/transform/RmDecl2.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl2.hs.expected @@ -0,0 +1,9 @@ +module RmDecl2 where + +sumSquares x y = let sq 0=0 + sq z=z^pow + in sq x + sq y + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/tests/examples/transform/RmDecl3.hs b/tests/examples/transform/RmDecl3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl3.hs @@ -0,0 +1,9 @@ +module RmDecl3 where + +-- Remove last declaration from a where clause, where should disappear too +ff y = y + zz + where + zz = 1 + +foo = 3 +-- EOF diff --git a/tests/examples/transform/RmDecl3.hs.expected b/tests/examples/transform/RmDecl3.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl3.hs.expected @@ -0,0 +1,9 @@ +module RmDecl3 where + +-- Remove last declaration from a where clause, where should disappear too +ff y = y + zz + +zz = 1 + +foo = 3 +-- EOF diff --git a/tests/examples/transform/RmDecl4.hs b/tests/examples/transform/RmDecl4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl4.hs @@ -0,0 +1,9 @@ +module RmDecl4 where + +-- Remove first declaration from a where clause, last should still be indented +ff y = y + zz + xx + where + zz = 1 + xx = 2 + +-- EOF diff --git a/tests/examples/transform/RmDecl4.hs.expected b/tests/examples/transform/RmDecl4.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl4.hs.expected @@ -0,0 +1,10 @@ +module RmDecl4 where + +-- Remove first declaration from a where clause, last should still be indented +ff y = y + zz + xx + where + xx = 2 + +zz = 1 + +-- EOF diff --git a/tests/examples/transform/RmDecl5.hs b/tests/examples/transform/RmDecl5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl5.hs @@ -0,0 +1,6 @@ +module RmDecl5 where + +sumSquares x y = let sq 0=0 + sq z=z^pow + pow=2 + in sq x + sq y diff --git a/tests/examples/transform/RmDecl5.hs.expected b/tests/examples/transform/RmDecl5.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl5.hs.expected @@ -0,0 +1,4 @@ +module RmDecl5 where + +sumSquares x y = let pow=2 + in sq x + sq y diff --git a/tests/examples/transform/RmDecl6.hs b/tests/examples/transform/RmDecl6.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl6.hs @@ -0,0 +1,11 @@ +module RmDecl6 where + +foo a = baz + where + baz :: Int + baz = x + a + + x = 1 + + y :: Int -> Int -> Int + y a b = undefined diff --git a/tests/examples/transform/RmDecl6.hs.expected b/tests/examples/transform/RmDecl6.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl6.hs.expected @@ -0,0 +1,8 @@ +module RmDecl6 where + +foo a = baz + where + x = 1 + + y :: Int -> Int -> Int + y a b = undefined diff --git a/tests/examples/transform/RmDecl7.hs b/tests/examples/transform/RmDecl7.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl7.hs @@ -0,0 +1,8 @@ +module RmDecl7 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +-- c,d :: Integer +c = 7 +d = 9 diff --git a/tests/examples/transform/RmDecl7.hs.expected b/tests/examples/transform/RmDecl7.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmDecl7.hs.expected @@ -0,0 +1,6 @@ +module RmDecl7 where + +toplevel :: Integer -> Integer +toplevel x = c * x + +d = 9 diff --git a/tests/examples/transform/RmTypeSig1.hs b/tests/examples/transform/RmTypeSig1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmTypeSig1.hs @@ -0,0 +1,7 @@ +module RmTypeSig1 where + +sq,anotherFun :: Int -> Int +sq 0 = 0 +sq z = z^2 + +anotherFun x = x^2 diff --git a/tests/examples/transform/RmTypeSig1.hs.expected b/tests/examples/transform/RmTypeSig1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmTypeSig1.hs.expected @@ -0,0 +1,7 @@ +module RmTypeSig1 where + +anotherFun :: Int -> Int +sq 0 = 0 +sq z = z^2 + +anotherFun x = x^2 diff --git a/tests/examples/transform/RmTypeSig2.hs b/tests/examples/transform/RmTypeSig2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmTypeSig2.hs @@ -0,0 +1,7 @@ +module RmTypeSig2 where + +-- Pattern bind +tup@(h,t) = (1,ff) + where + ff :: Int + ff = 15 diff --git a/tests/examples/transform/RmTypeSig2.hs.expected b/tests/examples/transform/RmTypeSig2.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RmTypeSig2.hs.expected @@ -0,0 +1,6 @@ +module RmTypeSig2 where + +-- Pattern bind +tup@(h,t) = (1,ff) + where + ff = 15 diff --git a/tests/examples/transform/WhereIn3.hs b/tests/examples/transform/WhereIn3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/WhereIn3.hs @@ -0,0 +1,19 @@ +module WhereIn3 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there are multi matches), the parameters are not folded after demoting. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq :: Int -> Int -> Int +sq pow 0 = 0 --prior comment +sq pow {- blah -} z = z^pow --there is a comment + +-- A leading comment +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/tests/examples/transform/WhereIn3.hs.expected b/tests/examples/transform/WhereIn3.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/WhereIn3.hs.expected @@ -0,0 +1,16 @@ +module WhereIn3 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there are multi matches), the parameters are not folded after demoting. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq :: Int -> Int -> Int + +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/tests/examples/transform/WhereIn3a.hs b/tests/examples/transform/WhereIn3a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/WhereIn3a.hs @@ -0,0 +1,19 @@ +module WhereIn3a where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there are multi matches), the parameters are not folded after demoting. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq :: Int -> Int -> Int +sq pow 0 = 0 -- prior comment +sq pow z = z^pow --there is a comment + +-- A leading comment +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/tests/examples/transform/WhereIn3a.hs.expected b/tests/examples/transform/WhereIn3a.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/WhereIn3a.hs.expected @@ -0,0 +1,25 @@ +module WhereIn3a where + +-- A leading comment +anotherFun 0 y = sq y + where sq x = x^2 +sq pow 0 = 0 -- prior comment +sq pow z = z^pow --there is a comment + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there are multi matches), the parameters are not folded after demoting. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq :: Int -> Int -> Int +sq pow 0 = 0 -- prior comment +sq pow z = z^pow --there is a comment + +-- A leading comment +anotherFun 0 y = sq y + where sq x = x^2 diff --git a/tests/examples/transform/WhereIn4.hs b/tests/examples/transform/WhereIn4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/WhereIn4.hs @@ -0,0 +1,19 @@ +module WhereIn4 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there is single matches), if possible, +--the parameters will be folded after demoting and type sigature will be removed. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq::Int->Int->Int +sq pow z = z^pow --there is a comment + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/tests/examples/transform/WhereIn4.hs.expected b/tests/examples/transform/WhereIn4.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/WhereIn4.hs.expected @@ -0,0 +1,19 @@ +module WhereIn4 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there is single matches), if possible, +--the parameters will be folded after demoting and type sigature will be removed. + +sumSquares x y = sq p x + sq p y + where p_2=2 {-There is a comment-} + +sq::Int->Int->Int +sq pow z = z^pow --there is a comment + +anotherFun 0 y = sq y + where sq x = x^2 +