diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,17 @@ +2025-10-14 v1.14.0.0 + * Support GHC 9.14.1 +2025-01-21 v1.12.0.0 + * Harmonise layout processing so we do not have a special case for + the top level This is a breaking change, in that the hand-crafted + different line deltas will have to have 1 subtracted from the + column. +2024-12-06 v1.11.0.0 + * Support GHC 9.12.1 (rc1) +2024-05-21 v1.10.0.0 + * Make the Language.Haskell.GHC.ExactPrint.Transform API pure + * Remove EPOoptions fields that had no effect +2024-05-16 v1.9.0.0 + * Support GHC 9.10.1 2022-12-19 v1.8.0.0 * Support GHC 9.8.1 2022-12-19 v1.7.1.0 diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,45 +1,32 @@ +cabal-version: 2.4 name: ghc-exactprint -version: 1.8.0.0 +version: 1.14.0.0 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 9.2.1, this library provides a means to round trip any code that can be compiled by GHC, currently excluding lhs files. . - Note: requires GHC 9.8.*. For earlier GHC + Note: requires GHC 9.14.*. For earlier GHC versions see lower version numbers. . -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Alan Zimmerman, Matthew Pickering maintainer: alan.zimm@gmail.com category: Development build-type: Simple -tested-with: GHC == 9.8.1 -extra-source-files: ChangeLog - tests/examples/failing/*.hs - tests/examples/ghc710-only/*.hs - tests/examples/ghc710/*.hs - tests/examples/ghc80/*.hs - tests/examples/ghc810/*.hs - tests/examples/ghc82/*.hs - tests/examples/ghc84/*.hs - tests/examples/ghc86/*.hs - tests/examples/ghc88/*.hs - tests/examples/ghc90/*.hs - tests/examples/ghc92/*.hs - tests/examples/ghc94/*.hs - tests/examples/ghc96/*.hs - tests/examples/ghc98/*.hs - tests/examples/pre-ghc810/*.hs - tests/examples/pre-ghc86/*.hs - tests/examples/pre-ghc90/*.hs - tests/examples/vect/*.hs - tests/examples/transform/*.hs +tested-with: GHC == 9.14.1 +extra-doc-files: ChangeLog +extra-source-files: tests/examples/failing/*.hs tests/examples/failing/*.hs.bad + tests/examples/ghc910/*.hs + tests/examples/ghc912/*.hs + tests/examples/ghc914/*.hs + tests/examples/pre-ghc910/*.hs + tests/examples/pre-ghc910/*.hs-boot + tests/examples/transform/*.hs tests/examples/transform/*.hs.expected - tests/examples/ghc710/*.hs-boot -cabal-version: >=1.10 source-repository head type: git @@ -55,44 +42,33 @@ Default: False } +common warnings + GHC-options: -Wall -Wredundant-constraints -Wunused-packages library + import: warnings exposed-modules: Language.Haskell.GHC.ExactPrint - , Language.Haskell.GHC.ExactPrint.Dump , Language.Haskell.GHC.ExactPrint.ExactPrint - , Language.Haskell.GHC.ExactPrint.Lookup - , Language.Haskell.GHC.ExactPrint.Orphans , Language.Haskell.GHC.ExactPrint.Parsers , Language.Haskell.GHC.ExactPrint.Preprocess , Language.Haskell.GHC.ExactPrint.Transform , Language.Haskell.GHC.ExactPrint.Types , Language.Haskell.GHC.ExactPrint.Utils - hs-source-dirs: src - -- other-modules: - -- other-extensions: - GHC-Options: -Wall -Wredundant-constraints - -- GHC-Options: -Weverything - build-depends: base >=4.19 && <4.20 - , bytestring >= 0.10.6 - , containers >= 0.5 - , ordered-containers - , data-default - , directory >= 1.2 - , filepath >= 1.4 - , ghc >= 9.8.1 - , mtl >= 2.2.1 - , syb >= 0.5 - , free >= 4.12 - , ghc-boot - + build-depends: base >=4.22 && <4.23 + , containers >= 0.5 && < 0.9 + , ghc >= 9.14 && < 9.15 + , ghc-boot >= 9.14 && < 9.15 + , mtl >= 2.2.1 && < 2.5 + , syb >= 0.5 && < 0.8 default-language: Haskell2010 - if impl (ghc < 9.8) - buildable: False + if impl (ghc < 9.12) + buildable: False Test-Suite test + import: warnings type: exitcode-stdio-1.0 if flag (dev) hs-source-dirs: tests @@ -105,95 +81,87 @@ , Test.CommonUtils , Test.NoAnnotations , Test.Transform - GHC-Options: -threaded -Wall -Wredundant-constraints + GHC-Options: -threaded Default-language: Haskell2010 - Build-depends: HUnit >= 1.2 - , base < 4.20 - , bytestring + Build-depends: base < 4.23 + , HUnit >= 1.2 , containers >= 0.5 - , ordered-containers - , data-default , Diff , directory >= 1.2 - , extra , filepath >= 1.4 - , ghc >= 9.8.1 + , ghc >= 9.14 , ghc-paths >= 0.1 - , mtl >= 2.2.1 , syb >= 0.5 , silently >= 1.2 , ghc-boot - , Cabal-syntax if flag (dev) - build-depends: free + build-depends: + mtl >= 2.2.1 else build-depends: ghc-exactprint - if impl (ghc < 9.8) + if impl (ghc < 9.14) buildable: False executable roundtrip + import: warnings main-is: Roundtrip.hs hs-source-dirs: tests other-modules: Test.Common Test.CommonUtils - -- Test.Consistency default-language: Haskell2010 - if impl (ghc >= 9.8) && flag (roundtrip) + if impl (ghc >= 9.14) && flag (roundtrip) build-depends: - HUnit - , base - , containers - , directory - , extra - , filemanip - , filepath - , ghc + HUnit < 1.7 + , base < 4.23 + , containers < 0.9 + , directory < 1.4 + , extra < 1.9 + , filepath < 1.6 + , ghc >= 9.14 && < 9.15 , ghc-exactprint - , ghc-paths - , syb - , temporary - , time + , ghc-paths < 0.2 + , time < 1.16 , ghc-boot buildable: True else buildable: False - GHC-Options: -threaded -Wall -Wredundant-constraints + GHC-Options: -threaded executable static + import: warnings main-is: Static.hs hs-source-dirs: tests + other-modules: Test.CommonUtils default-language: Haskell2010 if flag (roundtrip) - build-depends: base - , directory - , extra - , filemanip - , filepath - , ghc - , Diff - , ghc-boot + build-depends: base < 4.23 + , directory < 1.4 + , extra < 1.9 + , filepath < 1.6 + , ghc >= 9.14 && < 9.15 + , Diff < 1.1 buildable: True else buildable: False - GHC-Options: -threaded -Wall -Wredundant-constraints + GHC-Options: -threaded -executable prepare-hackage - main-is: PrepareHackage.hs - hs-source-dirs: tests - default-language: Haskell2010 - if flag (roundtrip) - build-depends: base - , containers - , directory - , extra - , filemanip - , filepath - , ghc >= 9.8.1 - , HUnit - , text >= 1.2.2 - , turtle >= 1.3.0 - , ghc-boot - buildable: True - else - buildable: False - GHC-Options: -threaded -Wall -Wredundant-constraints +-- executable prepare-hackage +-- import: warnings +-- main-is: PrepareHackage.hs +-- other-modules: Test.CommonUtils +-- hs-source-dirs: tests +-- default-language: Haskell2010 +-- if flag (roundtrip) +-- build-depends: base < 4.22 +-- , containers +-- , directory +-- , extra +-- , filepath +-- , ghc >= 9.12 +-- , HUnit +-- , text >= 1.2.2 +-- , turtle >= 1.3.0 +-- buildable: True +-- else +-- buildable: False +-- GHC-Options: -threaded diff --git a/src/Language/Haskell/GHC/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint.hs @@ -16,17 +16,8 @@ -- * Relativising , makeDeltaAst - - - -- * Dumping ASTs - , showAst - -- ** Temporary copy from GHC, shows AnchorOps embedded in SrcSpan - , showAstData - , BlankSrcSpan(..) - , BlankEpAnnotations(..) ) where -import Language.Haskell.GHC.ExactPrint.Dump import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Transform import Language.Haskell.GHC.ExactPrint.Types diff --git a/src/Language/Haskell/GHC/ExactPrint/Dump.hs b/src/Language/Haskell/GHC/ExactPrint/Dump.hs deleted file mode 100644 --- a/src/Language/Haskell/GHC/ExactPrint/Dump.hs +++ /dev/null @@ -1,305 +0,0 @@ - -{- -Temporary copy of the GHC.Hs.Dump module, modified to show DeltaPos -hacked into a SrcSpan. --} - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.GHC.ExactPrint.Dump ( - -- * Dumping ASTs - showAstData, - BlankSrcSpan(..), - BlankEpAnnotations(..), - ) where - -import Prelude () -import GHC.Prelude - -import GHC.Hs hiding ( ann, anns, deltaPos, realSrcSpan ) - -import GHC.Core.DataCon - -import GHC.Data.Bag -import GHC.Data.FastString -import GHC.Types.Name.Set -import GHC.Types.Name hiding ( occName ) -import GHC.Types.SrcLoc -import GHC.Types.Var -import GHC.Types.SourceText -import GHC.Utils.Outputable - -import Data.Data hiding (Fixity) -import qualified Data.ByteString as B - -import Data.Generics (extQ, ext1Q, ext2Q) - -data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan - deriving (Eq,Show) - -data BlankEpAnnotations = BlankEpAnnotations | NoBlankEpAnnotations - deriving (Eq,Show) - --- | Show a GHC syntax tree. This parameterised because it is also used for --- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked --- out, to avoid comparing locations, only structure -showAstData :: Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc -showAstData bs ba a0 = blankLine $$ showAstData' a0 - where - showAstData' :: Data a => a -> SDoc - showAstData' = - generic - `ext1Q` list - `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan - `extQ` annotation - `extQ` annotationModule - `extQ` annotationAddEpAnn - `extQ` annotationGrhsAnn - `extQ` annotationEpAnnHsCase - `extQ` annotationAnnList - `extQ` annotationEpAnnImportDecl - `extQ` annotationAnnParen - `extQ` annotationTrailingAnn - `extQ` annotationEpaLocation - `extQ` annotationNoEpAnns - `extQ` addEpAnn - `extQ` lit `extQ` litr `extQ` litt - `extQ` sourceText - `extQ` deltaPos - `extQ` epaAnchor - `extQ` bytestring - `extQ` name `extQ` occName `extQ` moduleName `extQ` var - `extQ` dataCon - `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet - `extQ` fixity - `ext2Q` located - `extQ` srcSpanAnnA - `extQ` srcSpanAnnL - `extQ` srcSpanAnnP - `extQ` srcSpanAnnC - `extQ` srcSpanAnnN - - where generic :: Data a => a -> SDoc - generic t = parens $ text (showConstr (toConstr t)) - $$ vcat (gmapQ showAstData' t) - - string :: String -> SDoc - string = text . normalize_newlines . show - - fastString :: FastString -> SDoc - fastString s = braces $ - text "FastString:" - <+> text (normalize_newlines . show $ s) - - bytestring :: B.ByteString -> SDoc - bytestring = text . normalize_newlines . show - - list [] = brackets empty - list [x] = brackets (showAstData' x) - list (x1 : x2 : xs) = (text "[" <> showAstData' x1) - $$ go x2 xs - where - go y [] = text "," <> showAstData' y <> text "]" - go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys - - -- Eliminate word-size dependence - lit :: HsLit GhcPs -> SDoc - lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s - lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s - lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s - lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s - lit l = generic l - - litr :: HsLit GhcRn -> SDoc - litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s - litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s - litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s - litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s - litr l = generic l - - litt :: HsLit GhcTc -> SDoc - litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s - litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s - litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s - litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s - litt l = generic l - - numericLit :: String -> Integer -> SourceText -> SDoc - numericLit tag x s = braces $ hsep [ text tag - , generic x - , generic s ] - - sourceText :: SourceText -> SDoc - sourceText NoSourceText = parens $ text "NoSourceText" - sourceText (SourceText src) = case bs of - NoBlankSrcSpan -> parens $ text "SourceText" <+> ftext src - BlankSrcSpanFile -> parens $ text "SourceText" <+> ftext src - _ -> parens $ text "SourceText" <+> text "blanked" - - epaAnchor :: EpaLocation -> SDoc - epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r - epaAnchor (EpaDelta d cs) = case ba of - NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs - BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked" - - deltaPos :: DeltaPos -> SDoc - deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c - deltaPos (DifferentLine l c) = parens $ text "DifferentLine" <+> ppr l <+> ppr c - - name :: Name -> SDoc - name nm = braces $ text "Name:" <+> ppr nm - - occName n = braces $ - text "OccName:" - <+> ftext (occNameFS n) - - moduleName :: ModuleName -> SDoc - moduleName m = braces $ text "ModuleName:" <+> ppr m - - srcSpan :: SrcSpan -> SDoc - srcSpan ss = case bs of - BlankSrcSpan -> text "{ ss }" - NoBlankSrcSpan -> braces $ char ' ' <> - (hang (ppr ss) 1 - -- TODO: show annotations here - (text "")) - BlankSrcSpanFile -> braces $ char ' ' <> - (hang (pprUserSpan False ss) 1 - -- TODO: show annotations here - (text "")) - - realSrcSpan :: RealSrcSpan -> SDoc - realSrcSpan ss = case bs of - BlankSrcSpan -> text "{ ss }" - NoBlankSrcSpan -> braces $ char ' ' <> - (hang (ppr ss) 1 - -- TODO: show annotations here - (text "")) - BlankSrcSpanFile -> braces $ char ' ' <> - (hang (pprUserRealSpan False ss) 1 - -- TODO: show annotations here - (text "")) - - - addEpAnn :: AddEpAnn -> SDoc - addEpAnn (AddEpAnn a s) = case ba of - BlankEpAnnotations -> parens - $ text "blanked:" <+> text "AddEpAnn" - NoBlankEpAnnotations -> - parens $ text "AddEpAnn" <+> ppr a <+> epaAnchor s - - var :: Var -> SDoc - var v = braces $ text "Var:" <+> ppr v - - dataCon :: DataCon -> SDoc - dataCon c = braces $ text "DataCon:" <+> ppr c - - bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc - bagRdrName bg = braces $ - text "Bag(LocatedA (HsBind GhcPs)):" - $$ (list . bagToList $ bg) - - bagName :: Bag (LocatedA (HsBind GhcRn)) -> SDoc - bagName bg = braces $ - text "Bag(LocatedA (HsBind Name)):" - $$ (list . bagToList $ bg) - - bagVar :: Bag (LocatedA (HsBind GhcTc)) -> SDoc - bagVar bg = braces $ - text "Bag(LocatedA (HsBind Var)):" - $$ (list . bagToList $ bg) - - nameSet ns = braces $ - text "NameSet:" - $$ (list . nameSetElemsStable $ ns) - - fixity :: Fixity -> SDoc - fixity fx = braces $ - text "Fixity:" - <+> ppr fx - - located :: (Data a, Data b) => GenLocated a b -> SDoc - located (L ss a) - = parens (text "L" - $$ vcat [showAstData' ss, showAstData' a]) - - - -- ------------------------- - - annotation :: EpAnn [AddEpAnn] -> SDoc - annotation = annotation' (text "EpAnn [AddEpAnn]") - - annotationModule :: EpAnn AnnsModule -> SDoc - annotationModule = annotation' (text "EpAnn AnnsModule") - - annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc - annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn") - - annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc - annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") - - annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc - annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase") - - annotationAnnList :: EpAnn AnnList -> SDoc - annotationAnnList = annotation' (text "EpAnn AnnList") - - annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc - annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl") - - annotationAnnParen :: EpAnn AnnParen -> SDoc - annotationAnnParen = annotation' (text "EpAnn AnnParen") - - annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc - annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn") - - annotationEpaLocation :: EpAnn EpaLocation -> SDoc - annotationEpaLocation = annotation' (text "EpAnn EpaLocation") - - annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc - annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns") - - annotation' :: forall a .(Data a) - => SDoc -> EpAnn a -> SDoc - annotation' tag anns = case ba of - BlankEpAnnotations -> parens (text "blanked:" <+> tag) - NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns)) - $$ vcat (gmapQ showAstData' anns) - - -- ------------------------- - - srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc - srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") - - srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc - srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") - - srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc - srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") - - srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc - srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") - - srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc - srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") - - locatedAnn'' :: forall a. (Data a) - => SDoc -> SrcSpanAnn' a -> SDoc - locatedAnn'' tag ss = parens $ - case cast ss of - Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) -> - case ba of - BlankEpAnnotations - -> parens (text "blanked:" <+> tag) - NoBlankEpAnnotations - -> text "SrcSpanAnn" <+> showAstData' ann - <+> srcSpan s - Nothing -> text "locatedAnn:unmatched" <+> tag - <+> (parens $ text (showConstr (toConstr ss))) - - -normalize_newlines :: String -> String -normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs -normalize_newlines (x:xs) = x:normalize_newlines xs -normalize_newlines [] = [] diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs @@ -1,5060 +1,5026 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE UndecidableInstances #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Language.Haskell.GHC.ExactPrint.ExactPrint - ( - ExactPrint(..) - , exactPrint - , exactPrintWithOptions - , makeDeltaAst - - -- * Configuration - , EPOptions(epRigidity, epAstPrint, epTokenPrint, epWhitespacePrint, epUpdateAnchors) - , stringOptions - , epOptions - , deltaOptions - - -- Temporary to avoid import loop problems - , showAst - ) where - -import GHC -import GHC.Core.Coercion.Axiom (Role(..)) -import GHC.Data.Bag -import qualified GHC.Data.BooleanFormula as BF -import GHC.Data.FastString -import GHC.TypeLits -import GHC.Types.Basic hiding (EP) -import GHC.Types.Fixity -import GHC.Types.ForeignCall -import GHC.Types.Name.Reader -import GHC.Types.PkgQual -import GHC.Types.SourceText -import GHC.Types.Var -import GHC.Utils.Outputable hiding ( (<>) ) -import GHC.Unit.Module.Warnings -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Base (NonEmpty(..)) - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -import Control.Monad (forM, when, unless) -import Control.Monad.Identity (Identity(..)) -import qualified Control.Monad.Reader as Reader -import Control.Monad.RWS (MonadReader, RWST, evalRWST, tell, modify, get, gets, ask) -import Control.Monad.Trans (lift) -import Data.Data ( Data ) -import Data.Dynamic -import Data.Foldable -import Data.Functor.Const -import qualified Data.Set as Set -import Data.Typeable -import Data.List ( partition, sort, sortBy) -import Data.Maybe ( isJust, mapMaybe ) -import Data.Void - -import Language.Haskell.GHC.ExactPrint.Dump -import Language.Haskell.GHC.ExactPrint.Lookup -import Language.Haskell.GHC.ExactPrint.Utils -import Language.Haskell.GHC.ExactPrint.Types - --- import Debug.Trace - --- --------------------------------------------------------------------- - --- Note: moved from Language.Haskell.GHC.ExactPrint.Utils as a hack to --- avoid import loop problems while we have to use the local version --- of Dump -showAst :: (Data a) => a -> String -showAst ast - = showSDocUnsafe - $ showAstData NoBlankSrcSpan NoBlankEpAnnotations ast - --- --------------------------------------------------------------------- - -exactPrint :: ExactPrint ast => ast -> String -exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast)) - --- | The additional option to specify the rigidity and printing --- configuration. -exactPrintWithOptions :: (ExactPrint ast, Monoid b, Monad m) - => EPOptions m b - -> ast - -> m (ast, b) -exactPrintWithOptions r ast = - runEP r (markAnnotated ast) - --- | Transform concrete annotations into relative annotations which --- are more useful when transforming an AST. This corresponds to the --- earlier 'relativiseApiAnns'. -makeDeltaAst :: ExactPrint ast => ast -> ast -makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast)) - ------------------------------------------------------- - -type EP w m a = RWST (EPOptions m w) (EPWriter w) EPState m a - -runEP :: (Monad m) - => EPOptions m w - -> EP w m a -> m (a, w) -runEP epReader action = do - (ast, w) <- evalRWST action epReader defaultEPState - return (ast, output w) - --- --------------------------------------------------------------------- - -defaultEPState :: EPState -defaultEPState = EPState - { epPos = (1,1) - , dLHS = 1 - , pMarkLayout = False - , pLHS = 1 - , dMarkLayout = False - , dPriorEndPosition = (1,1) - , uAnchorSpan = badRealSrcSpan - , uExtraDP = Nothing - , epComments = [] - , epCommentsApplied = [] - , epEof = Nothing - } - - --- --------------------------------------------------------------------- --- The EP monad and basic combinators - --- | The R part of RWS. The environment. Updated via 'local' as we --- enter a new AST element, having a different anchor point. -data EPOptions m a = EPOptions - { - epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a - , epTokenPrint :: String -> m a - , epWhitespacePrint :: String -> m a - , epRigidity :: Rigidity - , epUpdateAnchors :: Bool - } - --- | Helper to create a 'EPOptions' -epOptions :: - (forall ast . Data ast => GHC.Located ast -> a -> m a) - -> (String -> m a) - -> (String -> m a) - -> Rigidity - -> Bool - -> EPOptions m a -epOptions astPrint tokenPrint wsPrint rigidity delta = EPOptions - { - epAstPrint = astPrint - , epWhitespacePrint = wsPrint - , epTokenPrint = tokenPrint - , epRigidity = rigidity - , epUpdateAnchors = delta - } - --- | Options which can be used to print as a normal String. -stringOptions :: EPOptions Identity String -stringOptions = epOptions (\_ b -> return b) return return NormalLayout False - --- | Options which can be used to simply update the AST to be in delta --- form, without generating output -deltaOptions :: EPOptions Identity () -deltaOptions = epOptions (\_ _ -> return ()) (\_ -> return ()) (\_ -> return ()) NormalLayout True - -data EPWriter a = EPWriter - { output :: !a } - -instance Monoid w => Semigroup (EPWriter w) where - (EPWriter a) <> (EPWriter b) = EPWriter (a <> b) - -instance Monoid w => Monoid (EPWriter w) where - mempty = EPWriter mempty - -data EPState = EPState - { uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST - -- reference frame, from - -- Annotation - , uExtraDP :: !(Maybe Anchor) -- ^ Used to anchor a - -- list - - -- Print phase - , epPos :: !Pos -- ^ Current output position - , pMarkLayout :: !Bool - , pLHS :: !LayoutStartCol - - -- Delta phase - , dPriorEndPosition :: !Pos -- ^ End of Position reached - -- when processing the - -- preceding element - , dMarkLayout :: !Bool - , dLHS :: !LayoutStartCol - - -- Shared - , epComments :: ![Comment] - , epCommentsApplied :: ![[Comment]] - , epEof :: !(Maybe (RealSrcSpan, RealSrcSpan)) - } - --- --------------------------------------------------------------------- - --- AZ:TODO: this can just be a function :: (EpAnn a) -> Entry -class HasEntry ast where - fromAnn :: ast -> Entry - --- --------------------------------------------------------------------- - --- | Key entry point. Switches to an independent AST element with its --- own annotation, calculating new offsets, etc -markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a -markAnnotated a = enterAnn (getAnnotationEntry a) a - --- | For HsModule, because we do not have a proper SrcSpan, we must --- indicate to flush trailing comments when done. -data FlushComments = FlushComments - | NoFlushComments - deriving (Eq, Show) - --- | For GenLocated SrcSpan, we construct an entry location but cannot update it. -data CanUpdateAnchor = CanUpdateAnchor - | CanUpdateAnchorOnly - | NoCanUpdateAnchor - deriving (Eq, Show) - -data Entry = Entry Anchor EpAnnComments FlushComments CanUpdateAnchor - | NoEntryVal - --- | For flagging whether to capture comments in an EpaDelta or not -data CaptureComments = CaptureComments - | NoCaptureComments - -mkEntry :: Anchor -> EpAnnComments -> Entry -mkEntry anc cs = Entry anc cs NoFlushComments CanUpdateAnchor - -instance HasEntry (SrcSpanAnn' (EpAnn an)) where - fromAnn (SrcSpanAnn EpAnnNotUsed ss) = mkEntry (spanAsAnchor ss) emptyComments - fromAnn (SrcSpanAnn an _) = fromAnn an - -instance HasEntry (EpAnn a) where - fromAnn (EpAnn anchor _ cs) = mkEntry anchor cs - fromAnn EpAnnNotUsed = NoEntryVal - --- --------------------------------------------------------------------- - -fromAnn' :: (HasEntry a) => a -> Entry -fromAnn' an = case fromAnn an of - NoEntryVal -> NoEntryVal - Entry a c _ u -> Entry a c FlushComments u - --- --------------------------------------------------------------------- - -astId :: (Typeable a) => a -> String -astId a = show (typeOf a) - -cua :: (Monad m, Monoid w) => CanUpdateAnchor -> EP w m [a] -> EP w m [a] -cua CanUpdateAnchor f = f -cua CanUpdateAnchorOnly _ = return [] -cua NoCanUpdateAnchor _ = return [] - --- | "Enter" an annotation, by using the associated 'anchor' field as --- the new reference point for calculating all DeltaPos positions. --- --- This is combination of the ghc=exactprint Delta.withAST and --- Print.exactPC functions and effectively does the delta processing --- immediately followed by the print processing. JIT ghc-exactprint. -enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a -enterAnn NoEntryVal a = do - p <- getPosP - debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a) - r <- exact a - debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a) - return r -enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do - p <- getPosP - debugM $ "enterAnn:starting:(p,a) =" ++ show (p, astId a) - -- debugM $ "enterAnn:(cs) =" ++ showGhc (cs) - let curAnchor = anchor anchor' -- As a base for the current AST element - debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor) - case canUpdateAnchor of - CanUpdateAnchor -> pushAppliedComments - _ -> return () - addCommentsA (priorComments cs) - debugM $ "enterAnn:Added comments" - printComments curAnchor - priorCs <- cua canUpdateAnchor takeAppliedComments -- no pop - -- ------------------------- - case anchor_op anchor' of - MovedAnchor dp -> do - debugM $ "enterAnn: MovedAnchor:" ++ show dp - -- Set the original anchor as prior end, so the rest of this AST - -- fragment has a reference - setPriorEndNoLayoutD (ss2pos curAnchor) - _ -> do - return () - -- ------------------------- - if ((fst $ fst $ rs2range curAnchor) >= 0) - then - setAnchorU curAnchor - else - debugM $ "enterAnn: not calling setAnchorU for : " ++ show (rs2range curAnchor) - -- ------------------------------------------------------------------- - -- Make sure the running dPriorEndPosition gets updated according to - -- the change in the current anchor. - - -- Compute the distance from dPriorEndPosition to the start of the new span. - - -- While processing in the context of the prior anchor, we choose to - -- enter a new Anchor, which has a defined position relative to the - -- prior anchor, even if we do not actively output anything at that - -- point. - -- Is this edp? - - -- ------------------------------------------------------------------- - -- The first part corresponds to the delta phase, so should only use - -- delta phase variables ----------------------------------- - -- Calculate offset required to get to the start of the SrcSPan - off <- getLayoutOffsetD - let spanStart = ss2pos curAnchor - priorEndAfterComments <- getPriorEndD - let edp' = adjustDeltaForOffset - -- Use the propagated offset if one is set - -- Note that we need to use the new offset if it has - -- changed. - off (ss2delta priorEndAfterComments curAnchor) - debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor) - let edp'' = case anchor_op anchor' of - MovedAnchor dp -> dp - _ -> edp' - -- --------------------------------------------- - -- let edp = edp'' - med <- getExtraDP - setExtraDP Nothing - let edp = case med of - Nothing -> edp'' - Just (Anchor _ (MovedAnchor dp)) -> dp - -- Replace original with desired one. Allows all - -- list entry values to be DP (1,0) - Just (Anchor r _) -> dp - where - dp = adjustDeltaForOffset - off (ss2delta priorEndAfterComments r) - when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ show (med,edp) - -- --------------------------------------------- - -- Preparation complete, perform the action - when (priorEndAfterComments < spanStart) (do - debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart - modify (\s -> s { dPriorEndPosition = spanStart } )) - - debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor) - debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp) - p0 <- getPosP - d <- getPriorEndD - debugM $ "enterAnn: (posp, posd)=" ++ show (p0,d) - - -- end of delta phase processing - -- ------------------------------------------------------------------- - -- start of print phase processing - - let mflush = when (flush == FlushComments) $ do - debugM $ "flushing comments in enterAnn:" ++ showAst cs - flushComments (getFollowingComments cs) - - advance edp - a' <- exact a - mflush - - -- end of sub-Anchor processing, start of tail end processing - postCs <- cua canUpdateAnchor takeAppliedCommentsPop - when (flush == NoFlushComments) $ do - when ((getFollowingComments cs) /= []) $ do - debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs) - mapM_ printOneComment (concatMap tokComment $ getFollowingComments cs) - debugM $ "ending trailing comments" - - eof <- getEofPos - case eof of - Nothing -> return () - Just (pos, prior) -> do - let dp = if pos == prior - then (DifferentLine 1 0) - else origDelta pos prior - debugM $ "EOF:(pos,prior,dp) =" ++ showGhc (ss2pos pos, ss2pos prior, dp) - printStringAtLsDelta dp "" - setEofPos Nothing -- Only do this once - - let newAchor = anchor' { anchor_op = MovedAnchor edp } - let r = case canUpdateAnchor of - CanUpdateAnchor -> setAnnotationAnchor a' newAchor (mkEpaComments (priorCs++ postCs) []) - CanUpdateAnchorOnly -> setAnnotationAnchor a' newAchor emptyComments - NoCanUpdateAnchor -> a' - -- debugM $ "calling setAnnotationAnchor:(curAnchor, newAchor,priorCs,postCs)=" ++ showAst (show (rs2range curAnchor), newAchor, priorCs, postCs) - -- debugM $ "calling setAnnotationAnchor:(newAchor,postCs)=" ++ showAst (newAchor, postCs) - debugM $ "enterAnn:done:(p,a) =" ++ show (p0, astId a') - return r - --- --------------------------------------------------------------------- - -addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () -addCommentsA csNew = addComments (concatMap tokComment csNew) - -{- -TODO: When we addComments, some may have an anchor that is no longer -valid, as it has been moved and has an anchor_op. - -Does an Anchor even make sense for a comment, perhaps it should be an -EpaLocation? - -How do we sort them? do we assign a location based on when we add them -to the list, based on the current output pos? Except the offset is a -delta compared to a reference location. Need to nail the concept of -the reference location. - -By definition it is the current anchor, so work against that. And that -also means that the first entry comment that has moved should not have -a line offset. --} -addComments :: (Monad m, Monoid w) => [Comment] -> EP w m () -addComments csNew = do - -- debugM $ "addComments:" ++ show csNew - cs <- getUnallocatedComments - - putUnallocatedComments (sort (cs ++ csNew)) - --- --------------------------------------------------------------------- - --- | Just before we print out the EOF comments, flush the remaining --- ones in the state. -flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () -flushComments trailing = do - addCommentsA trailing - cs <- getUnallocatedComments - debugM $ "flushing comments starting" - mapM_ printOneComment (sortComments cs) - debugM $ "flushing comments done" - --- --------------------------------------------------------------------- - --- |In order to interleave annotations into the stream, we turn them into --- comments. They are removed from the annotation to avoid duplication. -annotationsToComments :: (Monad m, Monoid w) - => EpAnn a -> Lens a [AddEpAnn] -> [AnnKeywordId] -> EP w m (EpAnn a) -annotationsToComments EpAnnNotUsed _ _kws = return EpAnnNotUsed -annotationsToComments (EpAnn anc a cs) l kws = do - let (newComments, newAnns) = go ([],[]) (view l a) - addComments newComments - return (EpAnn anc (set l (reverse newAnns) a) cs) - where - keywords = Set.fromList kws - - go :: ([Comment], [AddEpAnn]) -> [AddEpAnn] -> ([Comment], [AddEpAnn]) - go acc [] = acc - go (cs',ans) ((AddEpAnn k ss) : ls) - | Set.member k keywords = go ((mkKWComment k ss):cs', ans) ls - | otherwise = go (cs', (AddEpAnn k ss):ans) ls - --- --------------------------------------------------------------------- - --- Temporary function to simply reproduce the "normal" pretty printer output -withPpr :: (Monad m, Monoid w, Outputable a) => a -> EP w m a -withPpr a = do - ss <- getAnchorU - debugM $ "withPpr: ss=" ++ show ss - printStringAtRs' ss (showPprUnsafe a) - return a - --- --------------------------------------------------------------------- - --- | An AST fragment with an annotation must be able to return the --- requirements for nesting another one, captured in an 'Entry', and --- to be able to use the rest of the exactprint machinery to print the --- element. In the analogy to Outputable, 'exact' plays the role of --- 'ppr'. -class (Typeable a) => ExactPrint a where - getAnnotationEntry :: a -> Entry - setAnnotationAnchor :: a -> Anchor -> EpAnnComments -> a - exact :: (Monad m, Monoid w) => a -> EP w m a - --- --------------------------------------------------------------------- --- Start of utility functions --- --------------------------------------------------------------------- - -printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m () -printSourceText (NoSourceText) txt = printStringAdvance txt >> return () -printSourceText (SourceText txt) _ = printStringAdvance (unpackFS txt) >> return () - --- --------------------------------------------------------------------- - -printStringAtSs :: (Monad m, Monoid w) => SrcSpan -> String -> EP w m () -printStringAtSs ss str = printStringAtRs (realSrcSpan ss) str >> return () - -printStringAtRs :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m EpaLocation -printStringAtRs pa str = printStringAtRsC CaptureComments pa str - -printStringAtRsC :: (Monad m, Monoid w) - => CaptureComments -> RealSrcSpan -> String -> EP w m EpaLocation -printStringAtRsC capture pa str = do - debugM $ "printStringAtRsC: pa=" ++ showAst pa - printComments pa - pe <- getPriorEndD - debugM $ "printStringAtRsC:pe=" ++ show pe - let p = ss2delta pe pa - p' <- adjustDeltaForOffsetM p - debugM $ "printStringAtRsC:(p,p')=" ++ show (p,p') - printStringAtLsDelta p' str - setPriorEndASTD pa - cs' <- case capture of - CaptureComments -> takeAppliedComments - NoCaptureComments -> return [] - debugM $ "printStringAtRsC:cs'=" ++ show cs' - debugM $ "printStringAtRsC:p'=" ++ showAst p' - debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' []) - debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta p' (map comment2LEpaComment cs')) - return (EpaDelta p' (map comment2LEpaComment cs')) - -printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m () -printStringAtRs' pa str = printStringAtRsC NoCaptureComments pa str >> return () - --- --------------------------------------------------------------------- - -printStringAtMLoc' :: (Monad m, Monoid w) - => Maybe EpaLocation -> String -> EP w m (Maybe EpaLocation) -printStringAtMLoc' (Just aa) s = Just <$> printStringAtAA aa s -printStringAtMLoc' Nothing s = do - printStringAtLsDelta (SameLine 1) s - return (Just (EpaDelta (SameLine 1) [])) - -printStringAtMLocL :: (Monad m, Monoid w) - => EpAnn a -> Lens a (Maybe EpaLocation) -> String -> EP w m (EpAnn a) -printStringAtMLocL EpAnnNotUsed _ _ = return EpAnnNotUsed -printStringAtMLocL (EpAnn anc an cs) l s = do - r <- go (view l an) s - return (EpAnn anc (set l r an) cs) - where - go (Just aa) str = Just <$> printStringAtAA aa str - go Nothing str = do - printStringAtLsDelta (SameLine 1) str - return (Just (EpaDelta (SameLine 1) [])) - -printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLocation -printStringAtAA el str = printStringAtAAC CaptureComments el str - -printStringAtAAL :: (Monad m, Monoid w) - => EpAnn a -> Lens a EpaLocation -> String -> EP w m (EpAnn a) -printStringAtAAL EpAnnNotUsed _ _ = return EpAnnNotUsed -printStringAtAAL (EpAnn anc an cs) l str = do - r <- printStringAtAAC CaptureComments (view l an) str - return (EpAnn anc (set l r an) cs) - -printStringAtAAC :: (Monad m, Monoid w) - => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation -printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s -printStringAtAAC capture (EpaDelta d cs) s = do - mapM_ printOneComment $ concatMap tokComment cs - pe1 <- getPriorEndD - p1 <- getPosP - printStringAtLsDelta d s - p2 <- getPosP - pe2 <- getPriorEndD - debugM $ "printStringAtAA:(pe1,pe2,p1,p2)=" ++ show (pe1,pe2,p1,p2) - setPriorEndASTPD (pe1,pe2) - cs' <- case capture of - CaptureComments -> takeAppliedComments - NoCaptureComments -> return [] - debugM $ "printStringAtAA:(pe1,pe2,p1,p2,cs')=" ++ show (pe1,pe2,p1,p2,cs') - return (EpaDelta d (map comment2LEpaComment cs')) - --- --------------------------------------------------------------------- - -markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m () -markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan l) txt >> return () -markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) (unpackFS txt) >> return () - --- --------------------------------------------------------------------- - -markLensMAA :: (Monad m, Monoid w) => EpAnn a -> Lens a (Maybe AddEpAnn) -> EP w m (EpAnn a) -markLensMAA EpAnnNotUsed _ = return EpAnnNotUsed -markLensMAA (EpAnn anc a cs) l = - case view l a of - Nothing -> return (EpAnn anc a cs) - Just aa -> do - aa' <- markAddEpAnn aa - return (EpAnn anc (set l (Just aa') a) cs) - -markLensAA :: (Monad m, Monoid w) => EpAnn a -> Lens a AddEpAnn -> EP w m (EpAnn a) -markLensAA EpAnnNotUsed _ = return EpAnnNotUsed -markLensAA (EpAnn anc a cs) l = do - a' <- markKw (view l a) - return (EpAnn anc (set l a' a) cs) - - -markEpAnnLMS :: (Monad m, Monoid w) - => EpAnn a -> Lens a [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a) -markEpAnnLMS an l kw Nothing = markEpAnnL an l kw -markEpAnnLMS EpAnnNotUsed _ _ _ = return EpAnnNotUsed -markEpAnnLMS (EpAnn anc a cs) l kw (Just str) = do - anns <- mapM go (view l a) - return (EpAnn anc (set l anns a) cs) - where - go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn - go (AddEpAnn kw' r) - | kw' == kw = do - r' <- printStringAtAA r str - return (AddEpAnn kw' r') - | otherwise = return (AddEpAnn kw' r) - -markEpAnnLMS' :: (Monad m, Monoid w) - => EpAnn a -> Lens a AddEpAnn -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a) -markEpAnnLMS' an l _kw Nothing = markLensKwA an l -markEpAnnLMS' EpAnnNotUsed _ _ _ = return EpAnnNotUsed -markEpAnnLMS' (EpAnn anc a cs) l kw (Just str) = do - anns <- go (view l a) - return (EpAnn anc (set l anns a) cs) - where - go :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn - go (AddEpAnn kw' r) - | kw' == kw = do - r' <- printStringAtAA r str - return (AddEpAnn kw' r') - | otherwise = return (AddEpAnn kw' r) - --- --------------------------------------------------------------------- - -markLToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) - => Located (HsToken tok) -> EP w m (Located (HsToken tok)) -markLToken (L (RealSrcSpan aa mb) t) = do - epaLoc'<- printStringAtAA (EpaSpan aa mb) (symbolVal (Proxy @tok)) - case epaLoc' of - EpaSpan aa' mb' -> return (L (RealSrcSpan aa' mb') t) - _ -> return (L (RealSrcSpan aa mb ) t) -markLToken (L lt t) = return (L lt t) - -markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) - => LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs) -markToken (L NoTokenLoc t) = return (L NoTokenLoc t) -markToken (L (TokenLoc aa) t) = do - aa' <- printStringAtAA aa (symbolVal (Proxy @tok)) - return (L (TokenLoc aa') t) - -markUniToken :: forall m w tok utok. (Monad m, Monoid w, KnownSymbol tok, KnownSymbol utok) - => LHsUniToken tok utok GhcPs -> EP w m (LHsUniToken tok utok GhcPs) -markUniToken (L l HsNormalTok) = do - (L l' _) <- markToken (L l (HsTok @tok)) - return (L l' HsNormalTok) -markUniToken (L l HsUnicodeTok) = do - (L l' _) <- markToken (L l (HsTok @utok)) - return (L l' HsUnicodeTok) - --- --------------------------------------------------------------------- - -markArrow :: (Monad m, Monoid w) => HsArrow GhcPs -> EP w m (HsArrow GhcPs) -markArrow (HsUnrestrictedArrow arr) = do - arr' <- markUniToken arr - return (HsUnrestrictedArrow arr') -markArrow (HsLinearArrow (HsPct1 pct1 arr)) = do - pct1' <- markToken pct1 - arr' <- markUniToken arr - return (HsLinearArrow (HsPct1 pct1' arr')) -markArrow (HsLinearArrow (HsLolly arr)) = do - arr' <- markToken arr - return (HsLinearArrow (HsLolly arr')) -markArrow (HsExplicitMult pct t arr) = do - pct' <- markToken pct - t' <- markAnnotated t - arr' <- markUniToken arr - return (HsExplicitMult pct' t' arr') - --- --------------------------------------------------------------------- - -markAnnCloseP :: (Monad m, Monoid w) => EpAnn AnnPragma -> EP w m (EpAnn AnnPragma) -markAnnCloseP an = markEpAnnLMS' an lapr_close AnnClose (Just "#-}") - -markAnnOpenP :: (Monad m, Monoid w) => EpAnn AnnPragma -> SourceText -> String -> EP w m (EpAnn AnnPragma) -markAnnOpenP an NoSourceText txt = markEpAnnLMS' an lapr_open AnnOpen (Just txt) -markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just $ unpackFS txt) - -markAnnOpen :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> SourceText -> String -> EP w m (EpAnn [AddEpAnn]) -markAnnOpen an NoSourceText txt = markEpAnnLMS an lidl AnnOpen (Just txt) -markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just $ unpackFS txt) - -markAnnOpen' :: (Monad m, Monoid w) - => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) -markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt -markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms $ unpackFS txt - -markAnnOpen'' :: (Monad m, Monoid w) - => EpaLocation -> SourceText -> String -> EP w m EpaLocation -markAnnOpen'' el NoSourceText txt = printStringAtAA el txt -markAnnOpen'' el (SourceText txt) _ = printStringAtAA el $ unpackFS txt - --- --------------------------------------------------------------------- -{- -data AnnParen - = AnnParen { - ap_adornment :: ParenType, - ap_open :: EpaLocation, - ap_close :: EpaLocation - } deriving (Data) --} -markOpeningParen, markClosingParen :: (Monad m, Monoid w) => EpAnn AnnParen -> EP w m (EpAnn AnnParen) -markOpeningParen an = markParen an lfst -markClosingParen an = markParen an lsnd - -markParen :: (Monad m, Monoid w) => EpAnn AnnParen -> (forall a. Lens (a,a) a) -> EP w m (EpAnn AnnParen) -markParen EpAnnNotUsed _ = return (EpAnnNotUsed) -markParen (EpAnn anc (AnnParen pt o c) cs) l = do - loc' <- markKwA (view l $ kw pt) (view l (o, c)) - let (o',c') = set l loc' (o,c) - return (EpAnn anc (AnnParen pt o' c') cs) - where - kw AnnParens = (AnnOpenP, AnnCloseP) - kw AnnParensHash = (AnnOpenPH, AnnClosePH) - kw AnnParensSquare = (AnnOpenS, AnnCloseS) - --- --------------------------------------------------------------------- --- Bare bones Optics --- Base on From https://hackage.haskell.org/package/lens-tutorial-1.0.3/docs/Control-Lens-Tutorial.html - -type Lens a b = forall f . Functor f => (b -> f b) -> (a -> f a) -type Getting a b = (b -> Const b b) -> (a -> Const b a) -type ASetter a b = (b -> Identity b) -> (a -> Identity a) - -view :: MonadReader s m => Getting s a -> m a -view l = Reader.asks (getConst . l Const) -{-# INLINE view #-} - -over :: ASetter a b -> (b -> b) -> (a -> a) -over l f = runIdentity . l (Identity . f) -{-# INLINE over #-} - -set :: Lens a b -> b -> a -> a -set lens b = over lens (\_ -> b) -{-# INLINE set #-} - -{- -Question: How do I combine lenses? - -Answer: You compose them, using function composition (Yes, really!) - -You can think of the function composition operator as having this type: - -(.) :: Lens' a b -> Lens' b c -> Lens' a c --} - --- --------------------------------------------------------------------- --- Lenses - --- data AnnsModule --- = AnnsModule { --- am_main :: [AddEpAnn], --- am_decls :: AnnList --- } deriving (Data, Eq) - -lam_main :: Lens AnnsModule [AddEpAnn] -lam_main k annsModule = fmap (\newAnns -> annsModule { am_main = newAnns }) - (k (am_main annsModule)) - --- lam_decls :: Lens AnnsModule AnnList --- lam_decls k annsModule = fmap (\newAnns -> annsModule { am_decls = newAnns }) --- (k (am_decls annsModule)) - - --- data EpAnnImportDecl = EpAnnImportDecl --- { importDeclAnnImport :: EpaLocation --- , importDeclAnnPragma :: Maybe (EpaLocation, EpaLocation) --- , importDeclAnnSafe :: Maybe EpaLocation --- , importDeclAnnQualified :: Maybe EpaLocation --- , importDeclAnnPackage :: Maybe EpaLocation --- , importDeclAnnAs :: Maybe EpaLocation --- } deriving (Data) - -limportDeclAnnImport :: Lens EpAnnImportDecl EpaLocation -limportDeclAnnImport k annImp = fmap (\new -> annImp { importDeclAnnImport = new }) - (k (importDeclAnnImport annImp)) - --- limportDeclAnnPragma :: Lens EpAnnImportDecl (Maybe (EpaLocation, EpaLocation)) --- limportDeclAnnPragma k annImp = fmap (\new -> annImp { importDeclAnnPragma = new }) --- (k (importDeclAnnPragma annImp)) - -limportDeclAnnSafe :: Lens EpAnnImportDecl (Maybe EpaLocation) -limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new }) - (k (importDeclAnnSafe annImp)) - -limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe EpaLocation) -limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new }) - (k (importDeclAnnQualified annImp)) - -limportDeclAnnPackage :: Lens EpAnnImportDecl (Maybe EpaLocation) -limportDeclAnnPackage k annImp = fmap (\new -> annImp { importDeclAnnPackage = new }) - (k (importDeclAnnPackage annImp)) - --- limportDeclAnnAs :: Lens EpAnnImportDecl (Maybe EpaLocation) --- limportDeclAnnAs k annImp = fmap (\new -> annImp { importDeclAnnAs = new }) --- (k (importDeclAnnAs annImp)) - --- ------------------------------------- - --- data AnnList --- = AnnList { --- al_anchor :: Maybe Anchor, -- ^ start point of a list having layout --- al_open :: Maybe AddEpAnn, --- al_close :: Maybe AddEpAnn, --- al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword --- al_trailing :: [TrailingAnn] -- ^ items appearing after the --- -- list, such as '=>' for a --- -- context --- } deriving (Data,Eq) - -lal_open :: Lens AnnList (Maybe AddEpAnn) -lal_open k parent = fmap (\new -> parent { al_open = new }) - (k (al_open parent)) - -lal_close :: Lens AnnList (Maybe AddEpAnn) -lal_close k parent = fmap (\new -> parent { al_close = new }) - (k (al_close parent)) - -lal_rest :: Lens AnnList [AddEpAnn] -lal_rest k parent = fmap (\new -> parent { al_rest = new }) - (k (al_rest parent)) - -lal_trailing :: Lens AnnList [TrailingAnn] -lal_trailing k parent = fmap (\new -> parent { al_trailing = new }) - (k (al_trailing parent)) - --- ------------------------------------- - -lapr_rest :: Lens AnnPragma [AddEpAnn] -lapr_rest k parent = fmap (\newAnns -> parent { apr_rest = newAnns }) - (k (apr_rest parent)) - -lapr_open :: Lens AnnPragma AddEpAnn -lapr_open k parent = fmap (\new -> parent { apr_open = new }) - (k (apr_open parent)) - -lapr_close :: Lens AnnPragma AddEpAnn -lapr_close k parent = fmap (\new -> parent { apr_close = new }) - (k (apr_close parent)) - -lidl :: Lens [AddEpAnn] [AddEpAnn] -lidl k parent = fmap (\new -> new) - (k parent) - -lid :: Lens a a -lid k parent = fmap (\new -> new) - (k parent) - -lfst :: Lens (a,a) a -lfst k parent = fmap (\new -> (new, snd parent)) - (k (fst parent)) - -lsnd :: Lens (a,a) a -lsnd k parent = fmap (\new -> (fst parent, new)) - (k (snd parent)) - --- ------------------------------------- --- data AnnExplicitSum --- = AnnExplicitSum { --- aesOpen :: EpaLocation, --- aesBarsBefore :: [EpaLocation], --- aesBarsAfter :: [EpaLocation], --- aesClose :: EpaLocation --- } deriving Data - -laesOpen :: Lens AnnExplicitSum EpaLocation -laesOpen k parent = fmap (\new -> parent { aesOpen = new }) - (k (aesOpen parent)) - -laesBarsBefore :: Lens AnnExplicitSum [EpaLocation] -laesBarsBefore k parent = fmap (\new -> parent { aesBarsBefore = new }) - (k (aesBarsBefore parent)) - -laesBarsAfter :: Lens AnnExplicitSum [EpaLocation] -laesBarsAfter k parent = fmap (\new -> parent { aesBarsAfter = new }) - (k (aesBarsAfter parent)) - -laesClose :: Lens AnnExplicitSum EpaLocation -laesClose k parent = fmap (\new -> parent { aesClose = new }) - (k (aesClose parent)) - --- ------------------------------------- --- data AnnFieldLabel --- = AnnFieldLabel { --- afDot :: Maybe EpaLocation --- } deriving Data - -lafDot :: Lens AnnFieldLabel (Maybe EpaLocation) -lafDot k parent = fmap (\new -> parent { afDot = new }) - (k (afDot parent)) - --- ------------------------------------- --- data AnnProjection --- = AnnProjection { --- apOpen :: EpaLocation, -- ^ '(' --- apClose :: EpaLocation -- ^ ')' --- } deriving Data - -lapOpen :: Lens AnnProjection EpaLocation -lapOpen k parent = fmap (\new -> parent { apOpen = new }) - (k (apOpen parent)) - -lapClose :: Lens AnnProjection EpaLocation -lapClose k parent = fmap (\new -> parent { apClose = new }) - (k (apClose parent)) - --- ------------------------------------- --- data AnnsIf --- = AnnsIf { --- aiIf :: EpaLocation, --- aiThen :: EpaLocation, --- aiElse :: EpaLocation, --- aiThenSemi :: Maybe EpaLocation, --- aiElseSemi :: Maybe EpaLocation --- } deriving Data - -laiIf :: Lens AnnsIf EpaLocation -laiIf k parent = fmap (\new -> parent { aiIf = new }) - (k (aiIf parent)) - -laiThen :: Lens AnnsIf EpaLocation -laiThen k parent = fmap (\new -> parent { aiThen = new }) - (k (aiThen parent)) - -laiElse :: Lens AnnsIf EpaLocation -laiElse k parent = fmap (\new -> parent { aiElse = new }) - (k (aiElse parent)) - -laiThenSemi :: Lens AnnsIf (Maybe EpaLocation) -laiThenSemi k parent = fmap (\new -> parent { aiThenSemi = new }) - (k (aiThenSemi parent)) - -laiElseSemi :: Lens AnnsIf (Maybe EpaLocation) -laiElseSemi k parent = fmap (\new -> parent { aiElseSemi = new }) - (k (aiElseSemi parent)) - --- ------------------------------------- - --- data AnnParen --- = AnnParen { --- ap_adornment :: ParenType, --- ap_open :: EpaLocation, --- ap_close :: EpaLocation --- } deriving (Data) - --- lap_open :: Lens AnnParen EpaLocation --- lap_open k parent = fmap (\new -> parent { ap_open = new }) --- (k (ap_open parent)) - --- lap_close :: Lens AnnParen EpaLocation --- lap_close k parent = fmap (\new -> parent { ap_close = new }) --- (k (ap_close parent)) - --- ------------------------------------- --- data EpAnnHsCase = EpAnnHsCase --- { hsCaseAnnCase :: EpaLocation --- , hsCaseAnnOf :: EpaLocation --- , hsCaseAnnsRest :: [AddEpAnn] --- } deriving Data - -lhsCaseAnnCase :: Lens EpAnnHsCase EpaLocation -lhsCaseAnnCase k parent = fmap (\new -> parent { hsCaseAnnCase = new }) - (k (hsCaseAnnCase parent)) - -lhsCaseAnnOf :: Lens EpAnnHsCase EpaLocation -lhsCaseAnnOf k parent = fmap (\new -> parent { hsCaseAnnOf = new }) - (k (hsCaseAnnOf parent)) - -lhsCaseAnnsRest :: Lens EpAnnHsCase [AddEpAnn] -lhsCaseAnnsRest k parent = fmap (\new -> parent { hsCaseAnnsRest = new }) - (k (hsCaseAnnsRest parent)) - --- --------------------------------------------------------------------- - --- data HsRuleAnn --- = HsRuleAnn --- { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn) --- -- ^ The locations of 'forall' and '.' for forall'd type vars --- -- Using AddEpAnn to capture possible unicode variants --- , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn) --- -- ^ The locations of 'forall' and '.' for forall'd term vars --- -- Using AddEpAnn to capture possible unicode variants --- , ra_rest :: [AddEpAnn] --- } deriving (Data, Eq) - -lra_tyanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn)) -lra_tyanns k parent = fmap (\new -> parent { ra_tyanns = new }) - (k (ra_tyanns parent)) - -ff :: Maybe (a,b) -> (Maybe a,Maybe b) -ff Nothing = (Nothing, Nothing) -ff (Just (a,b)) = (Just a, Just b) - - -gg :: (Maybe a,Maybe b) -> Maybe (a,b) -gg (Nothing, Nothing) = Nothing -gg (Just a, Just b) = Just (a,b) -gg _ = error "gg:expecting two Nothing or two Just" - -lff :: Lens (Maybe (a,b)) (Maybe a,Maybe b) -lff k parent = fmap (\new -> gg new) - (k (ff parent)) - --- (.) :: Lens' a b -> Lens' b c -> Lens' a c -lra_tyanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn) -lra_tyanns_fst = lra_tyanns . lff . lfst - -lra_tyanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn) -lra_tyanns_snd = lra_tyanns . lff . lsnd - -lra_tmanns :: Lens HsRuleAnn (Maybe (AddEpAnn, AddEpAnn)) -lra_tmanns k parent = fmap (\new -> parent { ra_tmanns = new }) - (k (ra_tmanns parent)) - -lra_tmanns_fst :: Lens HsRuleAnn (Maybe AddEpAnn) -lra_tmanns_fst = lra_tmanns . lff . lfst - -lra_tmanns_snd :: Lens HsRuleAnn (Maybe AddEpAnn) -lra_tmanns_snd = lra_tmanns . lff . lsnd - -lra_rest :: Lens HsRuleAnn [AddEpAnn] -lra_rest k parent = fmap (\new -> parent { ra_rest = new }) - (k (ra_rest parent)) - - --- --------------------------------------------------------------------- --- data GrhsAnn --- = GrhsAnn { --- ga_vbar :: Maybe EpaLocation, -- TODO:AZ do we need this? --- ga_sep :: AddEpAnn -- ^ Match separator location --- } deriving (Data) - -lga_vbar :: Lens GrhsAnn (Maybe EpaLocation) -lga_vbar k parent = fmap (\new -> parent { ga_vbar = new }) - (k (ga_vbar parent)) - -lga_sep :: Lens GrhsAnn AddEpAnn -lga_sep k parent = fmap (\new -> parent { ga_sep = new }) - (k (ga_sep parent)) - --- --------------------------------------------------------------------- --- data AnnSig --- = AnnSig { --- asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option --- asRest :: [AddEpAnn] --- } deriving Data - -lasDcolon :: Lens AnnSig AddEpAnn -lasDcolon k parent = fmap (\new -> parent { asDcolon = new }) - (k (asDcolon parent)) - -lasRest :: Lens AnnSig [AddEpAnn] -lasRest k parent = fmap (\new -> parent { asRest = new }) - (k (asRest parent)) - --- --------------------------------------------------------------------- --- data EpAnnSumPat = EpAnnSumPat --- { sumPatParens :: [AddEpAnn] --- , sumPatVbarsBefore :: [EpaLocation] --- , sumPatVbarsAfter :: [EpaLocation] --- } deriving Data - -lsumPatParens :: Lens EpAnnSumPat [AddEpAnn] -lsumPatParens k parent = fmap (\new -> parent { sumPatParens = new }) - (k (sumPatParens parent)) - -lsumPatVbarsBefore :: Lens EpAnnSumPat [EpaLocation] -lsumPatVbarsBefore k parent = fmap (\new -> parent { sumPatVbarsBefore = new }) - (k (sumPatVbarsBefore parent)) - -lsumPatVbarsAfter :: Lens EpAnnSumPat [EpaLocation] -lsumPatVbarsAfter k parent = fmap (\new -> parent { sumPatVbarsAfter = new }) - (k (sumPatVbarsAfter parent)) - --- End of lenses --- --------------------------------------------------------------------- - -markLensKwA :: (Monad m, Monoid w) - => EpAnn a -> Lens a AddEpAnn -> EP w m (EpAnn a) -markLensKwA EpAnnNotUsed _ = return EpAnnNotUsed -markLensKwA (EpAnn anc a cs) l = do - loc <- markKw (view l a) - return (EpAnn anc (set l loc a) cs) - -markLensKw :: (Monad m, Monoid w) - => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a) -markLensKw EpAnnNotUsed _ _ = return EpAnnNotUsed -markLensKw (EpAnn anc a cs) l kw = do - loc <- markKwA kw (view l a) - return (EpAnn anc (set l loc a) cs) - -markAnnKwL :: (Monad m, Monoid w) - => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a) -markAnnKwL = markLensKw - -markAnnKwAllL :: (Monad m, Monoid w) - => EpAnn a -> Lens a [EpaLocation] -> AnnKeywordId -> EP w m (EpAnn a) -markAnnKwAllL EpAnnNotUsed _ _ = return EpAnnNotUsed -markAnnKwAllL (EpAnn anc a cs) l kw = do - anns <- mapM (markKwA kw) (view l a) - return (EpAnn anc (set l anns a) cs) - -markLensKwM :: (Monad m, Monoid w) - => EpAnn a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m (EpAnn a) -markLensKwM EpAnnNotUsed _ _ = return EpAnnNotUsed -markLensKwM (EpAnn anc a cs) l kw = do - new <- go (view l a) - return (EpAnn anc (set l new a) cs) - where - go Nothing = return Nothing - go (Just s) = Just <$> markKwA kw s - --- --------------------------------------------------------------------- - -markALocatedA :: (Monad m, Monoid w) => EpAnn AnnListItem -> EP w m (EpAnn AnnListItem) -markALocatedA EpAnnNotUsed = return EpAnnNotUsed -markALocatedA (EpAnn anc a cs) = do - t <- markTrailing (lann_trailing a) - return (EpAnn anc (a { lann_trailing = t }) cs) - -markEpAnnL :: (Monad m, Monoid w) - => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann) -markEpAnnL EpAnnNotUsed _ _ = return EpAnnNotUsed -markEpAnnL (EpAnn anc a cs) l kw = do - anns <- mark' (view l a) kw - return (EpAnn anc (set l anns a) cs) - -markEpAnnAllL :: (Monad m, Monoid w) - => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann) -markEpAnnAllL EpAnnNotUsed _ _ = return EpAnnNotUsed -markEpAnnAllL (EpAnn anc a cs) l kw = do - anns <- mapM doit (view l a) - return (EpAnn anc (set l anns a) cs) - where - doit an@(AddEpAnn ka _) - = if ka == kw - then markKw an - else return an - -markAddEpAnn :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn -markAddEpAnn a@(AddEpAnn kw _) = do - r <- mark' [a] kw - case r of - [a'] -> return a' - _ -> error "Should not happen: markAddEpAnn" - -mark' :: (Monad m, Monoid w) => [AddEpAnn] -> AnnKeywordId -> EP w m [AddEpAnn] -mark' anns kw = do - case find' kw anns of - (lead, Just aa, end) -> do - aa' <- markKw aa - return (lead ++ [aa'] ++ end) - (_lead, Nothing, _end) -> case find' (unicodeAnn kw) anns of - (leadu, Just aau, endu) -> do - aau' <- markKw aau - return (leadu ++ [aau'] ++ endu) - (_,Nothing,_) -> return anns - --- | Find for update, returning lead section of the list, item if --- found, and tail of the list -find' :: AnnKeywordId -> [AddEpAnn] -> ([AddEpAnn], Maybe AddEpAnn, [AddEpAnn]) -find' kw anns = (lead, middle, end) - where - (lead, rest) = break (\(AddEpAnn k _) -> k == kw) anns - (middle,end) = case rest of - [] -> (Nothing, []) - (x:xs) -> (Just x, xs) - -markKw :: (Monad m, Monoid w) => AddEpAnn -> EP w m AddEpAnn -markKw an = markKwC CaptureComments an - -markKwC :: (Monad m, Monoid w) => CaptureComments -> AddEpAnn -> EP w m AddEpAnn -markKwC capture (AddEpAnn kw ss) = do - ss' <- markKwAC capture kw ss - return (AddEpAnn kw ss') - --- | This should be the main driver of the process, managing printing keywords. --- It returns the 'EpaDelta' variant of the passed in 'EpaLocation' -markKwA :: (Monad m, Monoid w) => AnnKeywordId -> EpaLocation -> EP w m EpaLocation -markKwA kw aa = markKwAC CaptureComments kw aa - -markKwAC :: (Monad m, Monoid w) - => CaptureComments -> AnnKeywordId -> EpaLocation -> EP w m EpaLocation -markKwAC capture kw aa = printStringAtAAC capture aa (keywordToString kw) - --- | Print a keyword encoded in a 'TrailingAnn' -markKwT :: (Monad m, Monoid w) => TrailingAnn -> EP w m TrailingAnn -markKwT (AddSemiAnn ss) = AddSemiAnn <$> markKwA AnnSemi ss -markKwT (AddCommaAnn ss) = AddCommaAnn <$> markKwA AnnComma ss -markKwT (AddVbarAnn ss) = AddVbarAnn <$> markKwA AnnVbar ss - --- --------------------------------------------------------------------- - -markAnnList :: (Monad m, Monoid w) - => Bool -> EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a) -markAnnList reallyTrail ann action = do - markAnnListA reallyTrail ann $ \a -> do - r <- action - return (a,r) - -markAnnListA :: (Monad m, Monoid w) - => Bool -> EpAnn AnnList - -> (EpAnn AnnList -> EP w m (EpAnn AnnList, a)) - -> EP w m (EpAnn AnnList, a) -markAnnListA _ EpAnnNotUsed action = do - action EpAnnNotUsed -markAnnListA reallyTrail an action = do - debugM $ "markAnnListA: an=" ++ showAst an - an0 <- markLensMAA an lal_open - an1 <- if (not reallyTrail) - then markTrailingL an0 lal_trailing - else return an0 - an2 <- markEpAnnAllL an1 lal_rest AnnSemi - (an3, r) <- action an2 - an4 <- markLensMAA an3 lal_close - an5 <- if reallyTrail - then markTrailingL an4 lal_trailing - else return an4 - debugM $ "markAnnListA: an5=" ++ showAst an - return (an5, r) - --- --------------------------------------------------------------------- - -printComments :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () -printComments ss = do - cs <- commentAllocation ss - debugM $ "printComments: (ss): " ++ showPprUnsafe (rs2range ss) - -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentAnchor cs) - mapM_ printOneComment cs - --- --------------------------------------------------------------------- - -printOneComment :: (Monad m, Monoid w) => Comment -> EP w m () -printOneComment c@(Comment _str loc _r _mo) = do - debugM $ "printOneComment:c=" ++ showGhc c - dp <-case anchor_op loc of - MovedAnchor dp -> return dp - _ -> do - pe <- getPriorEndD - let dp = ss2delta pe (anchor loc) - debugM $ "printOneComment:(dp,pe,anchor loc)=" ++ showGhc (dp,pe,ss2pos $ anchor loc) - adjustDeltaForOffsetM dp - mep <- getExtraDP - dp' <- case mep of - Just (Anchor _ (MovedAnchor edp)) -> do - debugM $ "printOneComment:edp=" ++ show edp - ddd <- fmap unTweakDelta $ adjustDeltaForOffsetM edp - debugM $ "printOneComment:ddd=" ++ show ddd - fmap unTweakDelta $ adjustDeltaForOffsetM edp - _ -> return dp - -- Start of debug printing - -- LayoutStartCol dOff <- getLayoutOffsetD - -- debugM $ "printOneComment:(dp,dp',dOff)=" ++ showGhc (dp,dp',dOff) - -- End of debug printing - -- setPriorEndD (ss2posEnd (anchor loc)) - updateAndApplyComment c dp' - printQueuedComment (anchor loc) c dp' - --- | For comment-related deltas starting on a new line we have an --- off-by-one problem. Adjust -unTweakDelta :: DeltaPos -> DeltaPos -unTweakDelta (SameLine d) = SameLine d -unTweakDelta (DifferentLine l d) = DifferentLine l (d+1) - - -updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () -updateAndApplyComment (Comment str anc pp mo) dp = do - -- debugM $ "updateAndApplyComment: (dp,anc',co)=" ++ showAst (dp,anc',co) - applyComment (Comment str anc' pp mo) - where - anc' = anc { anchor_op = op} - - (r,c) = ss2posEnd pp - la = anchor anc - dp'' = if r == 0 - then (ss2delta (r,c+0) la) - else (ss2delta (r,c) la) - dp' = if pp == anchor anc - then dp - else dp'' - op' = case dp' of - SameLine n -> if n >= 0 - then MovedAnchor dp' - else MovedAnchor dp - _ -> MovedAnchor dp' - op = if str == "" && op' == MovedAnchor (SameLine 0) -- EOF comment - then MovedAnchor dp - -- else op' - else MovedAnchor dp - --- --------------------------------------------------------------------- - -commentAllocation :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment] -commentAllocation ss = do - cs <- getUnallocatedComments - -- Note: The CPP comment injection may change the file name in the - -- RealSrcSpan, which affects comparison, as the Ord instance for - -- RealSrcSpan compares the file first. So we sort via ss2pos - -- TODO: this is inefficient, use Pos all the way through - let (earlier,later) = partition (\(Comment _str loc _r _mo) -> (ss2pos $ anchor loc) <= (ss2pos ss)) cs - putUnallocatedComments later - -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) - return earlier - --- --------------------------------------------------------------------- - -markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast -markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a - --- --------------------------------------------------------------------- - -markTopLevelList :: (Monad m, Monoid w) => ExactPrint ast => [ast] -> EP w m [ast] -markTopLevelList ls = mapM (\a -> setLayoutTopLevelP $ markAnnotated a) ls - --- --------------------------------------------------------------------- --- End of utility functions --- --------------------------------------------------------------------- --- Start of ExactPrint instances --- --------------------------------------------------------------------- - --- | Bare Located elements are simply stripped off without further --- processing. -instance (ExactPrint a) => ExactPrint (Located a) where - getAnnotationEntry (L l _) = case l of - UnhelpfulSpan _ -> NoEntryVal - _ -> Entry (hackSrcSpanToAnchor l) emptyComments NoFlushComments CanUpdateAnchorOnly - - setAnnotationAnchor (L _ a) anc _cs = (L (hackAnchorToSrcSpan anc) a) - `debug` ("setAnnotationAnchor(Located):" ++ showAst anc) - - exact (L l a) = L l <$> markAnnotated a - -instance (ExactPrint a) => ExactPrint (LocatedA a) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor la anc cs = setAnchorAn la anc cs - exact (L la a) = do - debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la) - a' <- markAnnotated a - ann' <- markALocatedA (ann la) - return (L (la { ann = ann'}) a') - -instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor la anc cs = setAnchorAn la anc cs - exact (L la a) = do - a' <- markAnnotated a - return (L la a') - -instance (ExactPrint a) => ExactPrint [a] where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor ls _ _ = ls - exact ls = mapM markAnnotated ls - -instance (ExactPrint a) => ExactPrint (Maybe a) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor ma _ _ = ma - exact ma = mapM markAnnotated ma - --- --------------------------------------------------------------------- - --- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' -instance ExactPrint (HsModule GhcPs) where - getAnnotationEntry hsmod = fromAnn' (hsmodAnn $ hsmodExt hsmod) - -- A bit pointless actually changing anything here - setAnnotationAnchor hsmod anc cs = setAnchorHsModule hsmod anc cs - `debug` ("setAnnotationAnchor hsmod called" ++ showAst (anc,cs)) - - exact hsmod@(HsModule {hsmodExt = XModulePs { hsmodAnn = EpAnnNotUsed }}) = withPpr hsmod >> return hsmod - exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do - - let mbDoc' = mbDoc - -- mbDoc' <- markAnnotated mbDoc - - (an0, mmn' , mdeprec', mexports') <- - case mmn of - Nothing -> return (an, mmn, mdeprec, mexports) - Just m -> do - an0 <- markEpAnnL an lam_main AnnModule - m' <- markAnnotated m - - mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec - - mexports' <- setLayoutTopLevelP $ markAnnotated mexports - - an1 <- setLayoutTopLevelP $ markEpAnnL an0 lam_main AnnWhere - - return (an1, Just m', mdeprec', mexports') - - lo0 <- case lo of - ExplicitBraces open close -> do - open' <- markToken open - return (ExplicitBraces open' close) - _ -> return lo - - am_decls' <- markTrailing (am_decls $ anns an0) - imports' <- markTopLevelList imports - decls' <- markTopLevelList (filter removeDocDecl decls) - - lo1 <- case lo0 of - ExplicitBraces open close -> do - close' <- markToken close - return (ExplicitBraces open close') - _ -> return lo - - -- Print EOF - case am_eof $ anns an of - Nothing -> return () - Just (pos, prior) -> do - debugM $ "am_eof:" ++ showGhc (pos, prior) - setEofPos (Just (pos, prior)) - - let anf = an0 { anns = (anns an0) { am_decls = am_decls' }} - -- debugM $ "HsModule, anf=" ++ showAst anf - - return (HsModule (XModulePs anf lo1 mdeprec' mbDoc') mmn' mexports' imports' decls') - - -removeDocDecl :: LHsDecl GhcPs -> Bool -removeDocDecl (L _ DocD{}) = False -removeDocDecl _ = True - --- --------------------------------------------------------------------- - -instance ExactPrint ModuleName where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor n _anc cs = n - `debug` ("ModuleName.setAnnotationAnchor:cs=" ++ showAst cs) - exact n = do - debugM $ "ModuleName: " ++ showPprUnsafe n - withPpr n - --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedP (WarningTxt GhcPs)) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - - exact (L (SrcSpanAnn an l) (WarningTxt mb_cat (L la src) ws)) = do - an0 <- markAnnOpenP an src "{-# WARNING" - mb_cat' <- markAnnotated mb_cat - an1 <- markEpAnnL an0 lapr_rest AnnOpenS - ws' <- markAnnotated ws - an2 <- markEpAnnL an1 lapr_rest AnnCloseS - an3 <- markAnnCloseP an2 - return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat' (L la src) ws')) - - exact (L (SrcSpanAnn an l) (DeprecatedTxt (L ls src) ws)) = do - an0 <- markAnnOpenP an src "{-# DEPRECATED" - an1 <- markEpAnnL an0 lapr_rest AnnOpenS - ws' <- markAnnotated ws - an2 <- markEpAnnL an1 lapr_rest AnnCloseS - an3 <- markAnnCloseP an2 - return (L (SrcSpanAnn an3 l) (DeprecatedTxt (L ls src) ws')) - -instance ExactPrint InWarningCategory where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (InWarningCategory tkIn source (L l wc)) = do - tkIn' <- markLToken tkIn - L _ (_,wc') <- markAnnotated (L l (source, wc)) - return (InWarningCategory tkIn' source (L l wc')) - -instance ExactPrint (SourceText, WarningCategory) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (st, WarningCategory wc) = do - case st of - NoSourceText -> printStringAdvance $ "\"" ++ (unpackFS wc) ++ "\"" - SourceText src -> printStringAdvance $ (unpackFS src) - return (st, WarningCategory wc) - --- --------------------------------------------------------------------- - -instance ExactPrint (ImportDecl GhcPs) where - getAnnotationEntry idecl = fromAnn (ideclAnn $ ideclExt idecl) - setAnnotationAnchor idecl anc cs = idecl { ideclExt - = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc cs} } - - exact x@(ImportDecl{ ideclExt = XImportDeclPass{ ideclAnn = EpAnnNotUsed } }) = withPpr x - exact (ImportDecl (XImportDeclPass ann msrc impl) - modname mpkg src safeflag qualFlag mAs hiding) = do - - ann0 <- markLensKw ann limportDeclAnnImport AnnImport - let (EpAnn _anc an _cs) = ann0 - - -- "{-# SOURCE" and "#-}" - importDeclAnnPragma' <- - case msrc of - SourceText _txt -> do - debugM $ "ImportDecl sourcetext" - case importDeclAnnPragma an of - Just (mo, mc) -> do - mo' <- markAnnOpen'' mo msrc "{-# SOURCE" - mc' <- printStringAtAA mc "#-}" - return $ Just (mo', mc') - Nothing -> do - _ <- markAnnOpen' Nothing msrc "{-# SOURCE" - printStringAtLsDelta (SameLine 1) "#-}" - return Nothing - NoSourceText -> return (importDeclAnnPragma an) - ann1 <- if safeflag - then (markLensKwM ann0 limportDeclAnnSafe AnnSafe) - else return ann0 - ann2 <- - case qualFlag of - QualifiedPre -- 'qualified' appears in prepositive position. - -> printStringAtMLocL ann1 limportDeclAnnQualified "qualified" - _ -> return ann1 - ann3 <- - case mpkg of - RawPkgQual (StringLiteral src' v _) -> - printStringAtMLocL ann2 limportDeclAnnPackage (sourceTextToString src' (show v)) - _ -> return ann2 - modname' <- markAnnotated modname - - ann4 <- - case qualFlag of - QualifiedPost -- 'qualified' appears in postpositive position. - -> printStringAtMLocL ann3 limportDeclAnnQualified "qualified" - _ -> return ann3 - - (importDeclAnnAs', mAs') <- - case mAs of - Nothing -> return (importDeclAnnAs an, Nothing) - Just m0 -> do - a <- printStringAtMLoc' (importDeclAnnAs an) "as" - m'' <- markAnnotated m0 - return (a, Just m'') - - hiding' <- - case hiding of - Nothing -> return hiding - Just (isHiding,lie) -> do - lie' <- markAnnotated lie - return (Just (isHiding, lie')) - - let (EpAnn anc' an' cs') = ann4 - let an2 = an' { importDeclAnnAs = importDeclAnnAs' - , importDeclAnnPragma = importDeclAnnPragma' - } - - return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl) - modname' mpkg src safeflag qualFlag mAs' hiding') - - --- --------------------------------------------------------------------- - -instance ExactPrint HsDocString where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ = a - - -- exact ds = do - -- (printStringAdvance . exactPrintHsDocString) ds - -- return ds - exact (MultiLineDocString decorator (x :| xs)) = do - printStringAdvance ("-- " ++ printDecorator decorator) - pe <- getPriorEndD - debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x) - x' <- markAnnotated x - xs' <- markAnnotated (map dedentDocChunk xs) - return (MultiLineDocString decorator (x' :| xs')) - exact x = do - -- TODO: can this happen? - debugM $ "Not exact printing:" ++ showAst x - return x - - -instance ExactPrint HsDocStringChunk where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ = a - exact chunk = do - printStringAdvance ("--" ++ unpackHDSC chunk) - return chunk - - -instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ = a - exact (WithHsDocIdentifiers ds ids) = do - ds' <- exact ds - return (WithHsDocIdentifiers ds' ids) - --- --------------------------------------------------------------------- - -instance ExactPrint (HsDecl GhcPs) where - getAnnotationEntry (TyClD _ _) = NoEntryVal - getAnnotationEntry (InstD _ _) = NoEntryVal - getAnnotationEntry (DerivD _ _) = NoEntryVal - getAnnotationEntry (ValD _ _) = NoEntryVal - getAnnotationEntry (SigD _ _) = NoEntryVal - getAnnotationEntry (KindSigD _ _) = NoEntryVal - getAnnotationEntry (DefD _ _) = NoEntryVal - getAnnotationEntry (ForD _ _) = NoEntryVal - getAnnotationEntry (WarningD _ _) = NoEntryVal - getAnnotationEntry (AnnD _ _) = NoEntryVal - getAnnotationEntry (RuleD _ _) = NoEntryVal - getAnnotationEntry (SpliceD _ _) = NoEntryVal - getAnnotationEntry (DocD _ _) = NoEntryVal - getAnnotationEntry (RoleAnnotD _ _) = NoEntryVal - - -- We do not recurse, the generic traversal using this feature - -- should do that for us. - setAnnotationAnchor d _ _ = d - - exact (TyClD x d) = TyClD x <$> markAnnotated d - exact (InstD x d) = InstD x <$> markAnnotated d - exact (DerivD x d) = DerivD x <$> markAnnotated d - exact (ValD x d) = ValD x <$> markAnnotated d - exact (SigD x d) = SigD x <$> markAnnotated d - exact (KindSigD x d) = KindSigD x <$> markAnnotated d - exact (DefD x d) = DefD x <$> markAnnotated d - exact (ForD x d) = ForD x <$> markAnnotated d - exact (WarningD x d) = WarningD x <$> markAnnotated d - exact (AnnD x d) = AnnD x <$> markAnnotated d - exact (RuleD x d) = RuleD x <$> markAnnotated d - exact (SpliceD x d) = SpliceD x <$> markAnnotated d - exact (DocD x d) = DocD x <$> markAnnotated d - exact (RoleAnnotD x d) = RoleAnnotD x <$> markAnnotated d - --- --------------------------------------------------------------------- - -instance ExactPrint (InstDecl GhcPs) where - getAnnotationEntry (ClsInstD _ _) = NoEntryVal - getAnnotationEntry (DataFamInstD _ _) = NoEntryVal - getAnnotationEntry (TyFamInstD _ _) = NoEntryVal - - setAnnotationAnchor d _ _ = d - - - exact (ClsInstD a cid) = do - cid' <- markAnnotated cid - return (ClsInstD a cid') - exact (DataFamInstD a decl) = do - d' <- markAnnotated (DataFamInstDeclWithContext noAnn TopLevel decl) - return (DataFamInstD a (dc_d d')) - exact (TyFamInstD a eqn) = do - eqn' <- markAnnotated eqn - return (TyFamInstD a eqn') - --- --------------------------------------------------------------------- - -data DataFamInstDeclWithContext - = DataFamInstDeclWithContext - { _dc_a :: EpAnn [AddEpAnn] - , _dc_f :: TopLevelFlag - , dc_d :: DataFamInstDecl GhcPs - } - -instance ExactPrint DataFamInstDeclWithContext where - getAnnotationEntry (DataFamInstDeclWithContext _ _ (DataFamInstDecl (FamEqn { feqn_ext = an}))) - = fromAnn an - setAnnotationAnchor (DataFamInstDeclWithContext a c (DataFamInstDecl fe)) anc cs - = (DataFamInstDeclWithContext a c (DataFamInstDecl (fe { feqn_ext = (setAnchorEpa (feqn_ext fe) anc cs)}))) - exact (DataFamInstDeclWithContext an c d) = do - debugM $ "starting DataFamInstDeclWithContext:an=" ++ showAst an - (an', d') <- exactDataFamInstDecl an c d - return (DataFamInstDeclWithContext an' c d') - --- --------------------------------------------------------------------- - -exactDataFamInstDecl :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] -> TopLevelFlag -> DataFamInstDecl GhcPs - -> EP w m (EpAnn [AddEpAnn], DataFamInstDecl GhcPs) -exactDataFamInstDecl an top_lvl - (DataFamInstDecl (FamEqn { feqn_ext = an2 - , feqn_tycon = tycon - , feqn_bndrs = bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = defn })) = do - (an', an2', tycon', bndrs', _, _mc, defn') <- exactDataDefn an2 pp_hdr defn - -- See Note [an and an2 in exactDataFamInstDecl] - return - (an', - DataFamInstDecl ( FamEqn { feqn_ext = an2' - , feqn_tycon = tycon' - , feqn_bndrs = bndrs' - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = defn' })) - `debug` ("exactDataFamInstDecl: defn' derivs:" ++ showAst (dd_derivs defn')) - where - pp_hdr :: (Monad m, Monoid w) - => Maybe (LHsContext GhcPs) - -> EP w m ( EpAnn [AddEpAnn] - , LocatedN RdrName - , HsOuterTyVarBndrs () GhcPs - , HsTyPats GhcPs - , Maybe (LHsContext GhcPs)) - pp_hdr mctxt = do - an0 <- case top_lvl of - TopLevel -> markEpAnnL an lidl AnnInstance -- TODO: maybe in toplevel - NotTopLevel -> return an - exactHsFamInstLHS an0 tycon bndrs pats fixity mctxt - -{- -Note [an and an2 in exactDataFamInstDecl] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The exactDataFamInstDecl function is called to render a -DataFamInstDecl within its surrounding context. This context is -rendered via the 'pp_hdr' function, which uses the exact print -annotations from that context, named 'an'. The EPAs used for -rendering the DataDefn are contained in the FamEqn, and are called -'an2'. - --} - --- --------------------------------------------------------------------- - -instance ExactPrint (DerivDecl GhcPs) where - getAnnotationEntry (DerivDecl {deriv_ext = an} ) = fromAnn an - setAnnotationAnchor dd anc cs = dd { deriv_ext = setAnchorEpa (deriv_ext dd) anc cs } - exact (DerivDecl an typ ms mov) = do - an0 <- markEpAnnL an lidl AnnDeriving - ms' <- mapM markAnnotated ms - an1 <- markEpAnnL an0 lidl AnnInstance - mov' <- mapM markAnnotated mov - typ' <- markAnnotated typ - return (DerivDecl an1 typ' ms' mov') - --- --------------------------------------------------------------------- - -instance ExactPrint (ForeignDecl GhcPs) where - getAnnotationEntry (ForeignImport an _ _ _) = fromAnn an - getAnnotationEntry (ForeignExport an _ _ _) = fromAnn an - - setAnnotationAnchor (ForeignImport an a b c) anc cs = ForeignImport (setAnchorEpa an anc cs) a b c - setAnnotationAnchor (ForeignExport an a b c) anc cs = ForeignExport (setAnchorEpa an anc cs) a b c - - exact (ForeignImport an n ty fimport) = do - an0 <- markEpAnnL an lidl AnnForeign - an1 <- markEpAnnL an0 lidl AnnImport - - fimport' <- markAnnotated fimport - - n' <- markAnnotated n - an2 <- markEpAnnL an1 lidl AnnDcolon - ty' <- markAnnotated ty - return (ForeignImport an2 n' ty' fimport') - - exact (ForeignExport an n ty fexport) = do - an0 <- markEpAnnL an lidl AnnForeign - an1 <- markEpAnnL an0 lidl AnnExport - fexport' <- markAnnotated fexport - n' <- markAnnotated n - an2 <- markEpAnnL an1 lidl AnnDcolon - ty' <- markAnnotated ty - return (ForeignExport an2 n' ty' fexport') - --- --------------------------------------------------------------------- - -instance ExactPrint (ForeignImport GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (CImport (L ls src) cconv safety@(L ll _) mh imp) = do - cconv' <- markAnnotated cconv - unless (ll == noSrcSpan) $ markAnnotated safety >> return () - unless (ls == noSrcSpan) $ markExternalSourceText ls src "" >> return () - return (CImport (L ls src) cconv' safety mh imp) - --- --------------------------------------------------------------------- - -instance ExactPrint (ForeignExport GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (CExport (L ls src) spec) = do - debugM $ "CExport starting" - spec' <- markAnnotated spec - unless (ls == noSrcSpan) $ markExternalSourceText ls src "" - return (CExport (L ls src) spec') - --- --------------------------------------------------------------------- - -instance ExactPrint CExportSpec where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (CExportStatic st lbl cconv) = do - debugM $ "CExportStatic starting" - cconv' <- markAnnotated cconv - return (CExportStatic st lbl cconv') - --- --------------------------------------------------------------------- - -instance ExactPrint Safety where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact = withPpr - --- --------------------------------------------------------------------- - -instance ExactPrint CCallConv where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact = withPpr - --- --------------------------------------------------------------------- - -instance ExactPrint (WarnDecls GhcPs) where - getAnnotationEntry (Warnings (an,_) _) = fromAnn an - setAnnotationAnchor (Warnings (an,a) b) anc cs = Warnings ((setAnchorEpa an anc cs),a) b - - exact (Warnings (an,src) warns) = do - an0 <- markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED - warns' <- markAnnotated warns - an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") - return (Warnings (an1,src) warns') - --- --------------------------------------------------------------------- - -instance ExactPrint (WarnDecl GhcPs) where - getAnnotationEntry (Warning an _ _) = fromAnn an - setAnnotationAnchor (Warning an a b) anc cs = Warning (setAnchorEpa an anc cs) a b - - exact (Warning an lns (WarningTxt mb_cat src ls )) = do - mb_cat' <- markAnnotated mb_cat - lns' <- markAnnotated lns - an0 <- markEpAnnL an lidl AnnOpenS -- "[" - ls' <- markAnnotated ls - an1 <- markEpAnnL an0 lidl AnnCloseS -- "]" - return (Warning an1 lns' (WarningTxt mb_cat' src ls')) - - exact (Warning an lns (DeprecatedTxt src ls)) = do - lns' <- markAnnotated lns - an0 <- markEpAnnL an lidl AnnOpenS -- "[" - ls' <- markAnnotated ls - an1 <- markEpAnnL an0 lidl AnnCloseS -- "]" - return (Warning an1 lns' (DeprecatedTxt src ls')) - --- --------------------------------------------------------------------- - -instance ExactPrint StringLiteral where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact l@(StringLiteral src fs mcomma) = do - printSourceText src (show (unpackFS fs)) - mapM_ (\r -> printStringAtRs r ",") mcomma - return l - --- --------------------------------------------------------------------- - -instance ExactPrint FastString where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. - -- exact fs = printStringAdvance (show (unpackFS fs)) - exact fs = printStringAdvance (unpackFS fs) >> return fs - --- --------------------------------------------------------------------- - -instance ExactPrint (RuleDecls GhcPs) where - getAnnotationEntry (HsRules (an,_) _) = fromAnn an - setAnnotationAnchor (HsRules (an,a) b) anc cs = HsRules ((setAnchorEpa an anc cs),a) b - exact (HsRules (an, src) rules) = do - an0 <- - case src of - NoSourceText -> markEpAnnLMS an lidl AnnOpen (Just "{-# RULES") - SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just $ unpackFS srcTxt) - rules' <- markAnnotated rules - an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") - return (HsRules (an1,src) rules') - --- --------------------------------------------------------------------- - -instance ExactPrint (RuleDecl GhcPs) where - getAnnotationEntry (HsRule {rd_ext = (an,_)}) = fromAnn an - setAnnotationAnchor r@(HsRule {rd_ext = (an,a)}) anc cs - = r { rd_ext = (setAnchorEpa an anc cs, a)} - exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do - debugM "HsRule entered" - (L ln' _) <- markAnnotated (L ln (nsrc, n)) - debugM "HsRule after ln" - an0 <- markActivation an lra_rest act - debugM "HsRule after act" - (an1, mtybndrs') <- - case mtybndrs of - Nothing -> return (an0, Nothing) - Just bndrs -> do - an1 <- markLensMAA an0 lra_tyanns_fst -- AnnForall - bndrs' <- mapM markAnnotated bndrs - an2 <- markLensMAA an1 lra_tyanns_snd -- AnnDot - return (an2, Just bndrs') - - an2 <- markLensMAA an1 lra_tmanns_fst -- AnnForall - termbndrs' <- mapM markAnnotated termbndrs - an3 <- markLensMAA an2 lra_tmanns_snd -- AnnDot - - lhs' <- markAnnotated lhs - an4 <- markEpAnnL an3 lra_rest AnnEqual - rhs' <- markAnnotated rhs - return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs') - -markActivation :: (Monad m, Monoid w) - => EpAnn a -> Lens a [AddEpAnn] -> Activation -> EP w m (EpAnn a) -markActivation an l act = do - case act of - ActiveBefore src phase -> do - an0 <- markEpAnnL an l AnnOpenS -- '[' - an1 <- markEpAnnL an0 l AnnTilde -- ~ - an2 <- markEpAnnLMS an1 l AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) - an3 <- markEpAnnL an2 l AnnCloseS -- ']' - return an3 - ActiveAfter src phase -> do - an0 <- markEpAnnL an l AnnOpenS -- '[' - an1 <- markEpAnnLMS an0 l AnnVal (Just (toSourceTextWithSuffix src (show phase) "")) - an2 <- markEpAnnL an1 l AnnCloseS -- ']' - return an2 - NeverActive -> do - an0 <- markEpAnnL an l AnnOpenS -- '[' - an1 <- markEpAnnL an0 l AnnTilde -- ~ - an2 <- markEpAnnL an1 l AnnCloseS -- ']' - return an2 - _ -> return an - --- --------------------------------------------------------------------- - -instance ExactPrint (SpliceDecl GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (SpliceDecl x splice flag) = do - splice' <- markAnnotated splice - return (SpliceDecl x splice' flag) - --- --------------------------------------------------------------------- - -instance ExactPrint (DocDecl GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact v = return v - -- exact v = case v of - -- (DocCommentNext ds) -> DocCommentNext <$> exact ds - -- (DocCommentPrev ds) -> DocCommentPrev <$> exact ds - -- (DocCommentNamed s ds) -> DocCommentNamed s <$> exact ds - -- (DocGroup i ds) -> DocGroup i <$> exact ds - --- --------------------------------------------------------------------- - -instance ExactPrint (RoleAnnotDecl GhcPs) where - getAnnotationEntry (RoleAnnotDecl an _ _) = fromAnn an - setAnnotationAnchor (RoleAnnotDecl an a b) anc cs = RoleAnnotDecl (setAnchorEpa an anc cs) a b - exact (RoleAnnotDecl an ltycon roles) = do - an0 <- markEpAnnL an lidl AnnType - an1 <- markEpAnnL an0 lidl AnnRole - ltycon' <- markAnnotated ltycon - let markRole (L l (Just r)) = do - (L _ r') <- markAnnotated (L l r) - return (L l (Just r')) - markRole (L l Nothing) = do - printStringAtSs (locA l) "_" - return (L l Nothing) - roles' <- mapM markRole roles - return (RoleAnnotDecl an1 ltycon' roles') - --- --------------------------------------------------------------------- - -instance ExactPrint Role where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact = withPpr - --- --------------------------------------------------------------------- - -instance ExactPrint (RuleBndr GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (RuleBndr x ln) = do - ln' <- markAnnotated ln - return (RuleBndr x ln') - exact (RuleBndrSig an ln (HsPS x ty)) = do - an0 <- markEpAnnL an lidl AnnOpenP -- "(" - ln' <- markAnnotated ln - an1 <- markEpAnnL an0 lidl AnnDcolon - ty' <- markAnnotated ty - an2 <- markEpAnnL an1 lidl AnnCloseP -- ")" - return (RuleBndrSig an2 ln' (HsPS x ty')) - --- --------------------------------------------------------------------- - -instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where - getAnnotationEntry (FamEqn { feqn_ext = an}) = fromAnn an - setAnnotationAnchor fe anc cs = fe {feqn_ext = setAnchorEpa (feqn_ext fe) anc cs} - exact (FamEqn { feqn_ext = an - , feqn_tycon = tycon - , feqn_bndrs = bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = rhs }) = do - (an0, tycon', bndrs', pats', _) <- exactHsFamInstLHS an tycon bndrs pats fixity Nothing - an1 <- markEpAnnL an0 lidl AnnEqual - rhs' <- markAnnotated rhs - return (FamEqn { feqn_ext = an1 - , feqn_tycon = tycon' - , feqn_bndrs = bndrs' - , feqn_pats = pats' - , feqn_fixity = fixity - , feqn_rhs = rhs' }) - --- --------------------------------------------------------------------- - -exactHsFamInstLHS :: - (Monad m, Monoid w) - => EpAnn [AddEpAnn] - -> LocatedN RdrName - -> HsOuterTyVarBndrs () GhcPs - -> HsTyPats GhcPs - -> LexicalFixity - -> Maybe (LHsContext GhcPs) - -> EP w m ( EpAnn [AddEpAnn] - , LocatedN RdrName - , HsOuterTyVarBndrs () GhcPs - , HsTyPats GhcPs, Maybe (LHsContext GhcPs)) -exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do - an0 <- markEpAnnL an lidl AnnForall - bndrs' <- markAnnotated bndrs - an1 <- markEpAnnL an0 lidl AnnDot - mb_ctxt' <- mapM markAnnotated mb_ctxt - (an2, thing', typats') <- exact_pats an1 typats - return (an2, thing', bndrs', typats', mb_ctxt') - where - exact_pats :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] -> HsTyPats GhcPs -> EP w m (EpAnn [AddEpAnn], LocatedN RdrName, HsTyPats GhcPs) - exact_pats an' (patl:patr:pats) - | Infix <- fixity - = let exact_op_app = do - an0 <- markEpAnnAllL an' lidl AnnOpenP - patl' <- markAnnotated patl - thing' <- markAnnotated thing - patr' <- markAnnotated patr - an1 <- markEpAnnAllL an0 lidl AnnCloseP - return (an1, thing', [patl',patr']) - in case pats of - [] -> exact_op_app - _ -> do - (an0, thing', p) <- exact_op_app - pats' <- mapM markAnnotated pats - return (an0, thing', p++pats') - - exact_pats an' pats = do - an0 <- markEpAnnAllL an' lidl AnnOpenP - thing' <- markAnnotated thing - pats' <- markAnnotated pats - an1 <- markEpAnnAllL an0 lidl AnnCloseP - return (an1, thing', pats') - --- --------------------------------------------------------------------- - -instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) - => ExactPrint (HsArg GhcPs tm ty) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact a@(HsValArg tm) = markAnnotated tm >> return a - exact a@(HsTypeArg at ty) = markToken at >> markAnnotated ty >> return a - exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source - --- --------------------------------------------------------------------- - -instance ExactPrint (ClsInstDecl GhcPs) where - getAnnotationEntry cid = fromAnn (fst $ cid_ext cid) - setAnnotationAnchor cid anc cs - = cid { cid_ext = (setAnchorEpa (fst $ cid_ext cid) anc cs, (snd $ cid_ext cid)) } - - exact (ClsInstDecl { cid_ext = (an, sortKey) - , cid_poly_ty = inst_ty, cid_binds = binds - , cid_sigs = sigs, cid_tyfam_insts = ats - , cid_overlap_mode = mbOverlap - , cid_datafam_insts = adts }) - = do - (an0, mbOverlap', inst_ty') <- top_matter - an1 <- markEpAnnL an0 lidl AnnOpenC - an2 <- markEpAnnAllL an1 lid AnnSemi - ds <- withSortKey sortKey - (prepareListAnnotationA ats - ++ prepareListAnnotationF an adts - ++ prepareListAnnotationA (bagToList binds) - ++ prepareListAnnotationA sigs - ) - an3 <- markEpAnnL an2 lidl AnnCloseC -- '}' - let - ats' = undynamic ds - adts' = undynamic ds - binds' = listToBag $ undynamic ds - sigs' = undynamic ds - return (ClsInstDecl { cid_ext = (an3, sortKey) - , cid_poly_ty = inst_ty', cid_binds = binds' - , cid_sigs = sigs', cid_tyfam_insts = ats' - , cid_overlap_mode = mbOverlap' - , cid_datafam_insts = adts' }) - - where - top_matter = do - an0 <- markEpAnnL an lidl AnnInstance - mo <- mapM markAnnotated mbOverlap - it <- markAnnotated inst_ty - an1 <- markEpAnnL an0 lidl AnnWhere -- Optional - return (an1, mo,it) - --- --------------------------------------------------------------------- - -instance ExactPrint (TyFamInstDecl GhcPs) where - getAnnotationEntry (TyFamInstDecl an _) = fromAnn an - setAnnotationAnchor (TyFamInstDecl an a) anc cs = TyFamInstDecl (setAnchorEpa an anc cs) a - - exact d@(TyFamInstDecl { tfid_xtn = an, tfid_eqn = eqn }) = do - an0 <- markEpAnnL an lidl AnnType - an1 <- markEpAnnL an0 lidl AnnInstance - eqn' <- markAnnotated eqn - return (d { tfid_xtn = an1, tfid_eqn = eqn' }) - --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedP OverlapMode) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - - -- NOTE: NoOverlap is only used in the typechecker - exact (L (SrcSpanAnn an l) (NoOverlap src)) = do - an0 <- markAnnOpenP an src "{-# NO_OVERLAP" - an1 <- markAnnCloseP an0 - return (L (SrcSpanAnn an1 l) (NoOverlap src)) - - exact (L (SrcSpanAnn an l) (Overlappable src)) = do - an0 <- markAnnOpenP an src "{-# OVERLAPPABLE" - an1 <- markAnnCloseP an0 - return (L (SrcSpanAnn an1 l) (Overlappable src)) - - exact (L (SrcSpanAnn an l) (Overlapping src)) = do - an0 <- markAnnOpenP an src "{-# OVERLAPPING" - an1 <- markAnnCloseP an0 - return (L (SrcSpanAnn an1 l) (Overlapping src)) - - exact (L (SrcSpanAnn an l) (Overlaps src)) = do - an0 <- markAnnOpenP an src "{-# OVERLAPS" - an1 <- markAnnCloseP an0 - return (L (SrcSpanAnn an1 l) (Overlaps src)) - - exact (L (SrcSpanAnn an l) (Incoherent src)) = do - an0 <- markAnnOpenP an src "{-# INCOHERENT" - an1 <- markAnnCloseP an0 - return (L (SrcSpanAnn an1 l) (Incoherent src)) - - exact (L (SrcSpanAnn an l) (NonCanonical src)) = do - an0 <- markAnnOpenP an src "{-# INCOHERENT" - an1 <- markAnnCloseP an0 - return (L (SrcSpanAnn an1 l) (Incoherent src)) - --- --------------------------------------------------------------------- - -instance ExactPrint (HsBind GhcPs) where - getAnnotationEntry FunBind{} = NoEntryVal - getAnnotationEntry PatBind{pat_ext=an} = fromAnn an - getAnnotationEntry VarBind{} = NoEntryVal - getAnnotationEntry PatSynBind{} = NoEntryVal - - setAnnotationAnchor pb@PatBind{} anc cs = pb { pat_ext = setAnchorEpa (pat_ext pb) anc cs} - setAnnotationAnchor a _ _ = a - - exact (FunBind x fid matches) = do - matches' <- markAnnotated matches - let - fun_id' = case unLoc (mg_alts matches') of - [] -> fid - (L _ m:_) -> case m_ctxt m of - FunRhs f _ _ -> f - _ -> fid - return (FunBind x fun_id' matches') - - exact (PatBind x pat grhss) = do - pat' <- markAnnotated pat - grhss' <- markAnnotated grhss - return (PatBind x pat' grhss') - exact (PatSynBind x bind) = do - bind' <- markAnnotated bind - return (PatSynBind x bind') - - exact x = error $ "HsBind: exact for " ++ showAst x - --- --------------------------------------------------------------------- - -instance ExactPrint (PatSynBind GhcPs GhcPs) where - getAnnotationEntry (PSB { psb_ext = an}) = fromAnn an - setAnnotationAnchor p anc cs = p { psb_ext = setAnchorEpa (psb_ext p) anc cs} - - exact (PSB{ psb_ext = an - , psb_id = psyn, psb_args = details - , psb_def = pat - , psb_dir = dir }) = do - an0 <- markEpAnnL an lidl AnnPattern - (an1, psyn', details') <- - case details of - InfixCon v1 v2 -> do - v1' <- markAnnotated v1 - psyn' <- markAnnotated psyn - v2' <- markAnnotated v2 - return (an0, psyn',InfixCon v1' v2') - PrefixCon tvs vs -> do - psyn' <- markAnnotated psyn - tvs' <- markAnnotated tvs - vs' <- markAnnotated vs - return (an0, psyn', PrefixCon tvs' vs') - RecCon vs -> do - psyn' <- markAnnotated psyn - an1 <- markEpAnnL an0 lidl AnnOpenC -- '{' - vs' <- markAnnotated vs - an2 <- markEpAnnL an1 lidl AnnCloseC -- '}' - return (an2, psyn', RecCon vs') - - (an2, pat', dir') <- - case dir of - Unidirectional -> do - an2 <- markEpAnnL an1 lidl AnnLarrow - pat' <- markAnnotated pat - return (an2, pat', dir) - ImplicitBidirectional -> do - an2 <- markEpAnnL an1 lidl AnnEqual - pat' <- markAnnotated pat - return (an2, pat', dir) - ExplicitBidirectional mg -> do - an2 <- markEpAnnL an1 lidl AnnLarrow - pat' <- markAnnotated pat - an3 <- markEpAnnL an2 lidl AnnWhere - mg' <- markAnnotated mg - return (an3, pat', ExplicitBidirectional mg') - - return (PSB{ psb_ext = an2 - , psb_id = psyn', psb_args = details' - , psb_def = pat' - , psb_dir = dir' }) - - --- --------------------------------------------------------------------- - -instance ExactPrint (RecordPatSynField GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact r@(RecordPatSynField { recordPatSynField = v }) = markAnnotated v - >> return r - --- --------------------------------------------------------------------- - -instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry (Match ann _ _ _) = fromAnn ann - setAnnotationAnchor (Match an a b c) anc cs = Match (setAnchorEpa an anc cs) a b c - - exact (Match an mctxt pats grhss) = - exactMatch (Match an mctxt pats grhss) - --- ------------------------------------- - -instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry (Match ann _ _ _) = fromAnn ann - setAnnotationAnchor (Match an a b c) anc cs = Match (setAnchorEpa an anc cs) a b c - - exact (Match an mctxt pats grhss) = - exactMatch (Match an mctxt pats grhss) - --- --------------------------------------------------------------------- - -exactMatch :: (Monad m, Monoid w) => (ExactPrint (GRHSs GhcPs body)) => (Match GhcPs body) -> EP w m (Match GhcPs body) -exactMatch (Match an mctxt pats grhss) = do - - debugM $ "exact Match entered" - - (an0, mctxt', pats') <- - case mctxt of - FunRhs fun fixity strictness -> do - debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun - an0' <- - case strictness of - SrcStrict -> markEpAnnL an lidl AnnBang - _ -> pure an - case fixity of - Prefix -> do - an' <- annotationsToComments an0' lidl [AnnOpenP,AnnCloseP] - fun' <- markAnnotated fun - pats' <- markAnnotated pats - return (an', FunRhs fun' fixity strictness, pats') - Infix -> - case pats of - (p1:p2:rest) - | null rest -> do - p1' <- markAnnotated p1 - fun' <- markAnnotated fun - p2' <- markAnnotated p2 - return (an0', FunRhs fun' fixity strictness, [p1',p2']) - | otherwise -> do - an0 <- markEpAnnL an0' lidl AnnOpenP - p1' <- markAnnotated p1 - fun' <- markAnnotated fun - p2' <- markAnnotated p2 - an1 <- markEpAnnL an0 lidl AnnCloseP - rest' <- mapM markAnnotated rest - return (an1, FunRhs fun' fixity strictness, p1':p2':rest') - _ -> panic "FunRhs" - LambdaExpr -> do - an0' <- markEpAnnL an lidl AnnLam - pats' <- markAnnotated pats - return (an0', LambdaExpr, pats') - CaseAlt -> do - pats' <- markAnnotated pats - return (an, CaseAlt, pats') - LamCaseAlt v -> do - pats' <- markAnnotated pats - return (an, LamCaseAlt v, pats') - _ -> do - mctxt' <- withPpr mctxt - return (an, mctxt', pats) - - grhss' <- markAnnotated grhss - - return (Match an0 mctxt' pats' grhss') - --- --------------------------------------------------------------------- - -instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry (GRHSs _ _ _) = NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (GRHSs cs grhss binds) = do - addCommentsA $ priorComments cs - addCommentsA $ getFollowingComments cs - grhss' <- markAnnotated grhss - binds' <- markAnnotated binds - -- The comments will be added back as they are printed - return (GRHSs emptyComments grhss' binds') - - -instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry (GRHSs _ _ _) = NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (GRHSs cs grhss binds) = do - addCommentsA $ priorComments cs - addCommentsA $ getFollowingComments cs - grhss' <- markAnnotated grhss - binds' <- markAnnotated binds - -- The comments will be added back as they are printed - return (GRHSs emptyComments grhss' binds') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsLocalBinds GhcPs) where - getAnnotationEntry (HsValBinds an _) = fromAnn an - getAnnotationEntry (HsIPBinds{}) = NoEntryVal - getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal - - setAnnotationAnchor (HsValBinds an a) anc cs = HsValBinds (setAnchorEpaL an anc cs) a - setAnnotationAnchor a _ _ = a - - exact (HsValBinds an valbinds) = do - debugM $ "exact HsValBinds: an=" ++ showAst an - an0 <- markEpAnnL an lal_rest AnnWhere - - let manc = case an of - EpAnnNotUsed -> Nothing - _ -> al_anchor $ anns an - - case manc of - Just anc -> do - when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc) - _ -> return () - - (an1, valbinds') <- markAnnList False an0 $ markAnnotatedWithLayout valbinds - debugM $ "exact HsValBinds: an1=" ++ showAst an1 - return (HsValBinds an1 valbinds') - - exact (HsIPBinds an bs) = do - (as, ipb) <- markAnnList True an (markEpAnnL an lal_rest AnnWhere - >> markAnnotated bs - >>= \bs' -> return (HsIPBinds an bs'::HsLocalBinds GhcPs)) - case ipb of - HsIPBinds _ bs' -> return (HsIPBinds as bs'::HsLocalBinds GhcPs) - _ -> error "should not happen HsIPBinds" - exact b@(EmptyLocalBinds _) = return b - - --- --------------------------------------------------------------------- -instance ExactPrint (HsValBindsLR GhcPs GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (ValBinds sortKey binds sigs) = do - ds <- setLayoutBoth $ withSortKey sortKey - (prepareListAnnotationA (bagToList binds) - ++ prepareListAnnotationA sigs - ) - let - binds' = listToBag $ undynamic ds - sigs' = undynamic ds - return (ValBinds sortKey binds' sigs') - exact (XValBindsLR _) = panic "XValBindsLR" - -undynamic :: Typeable a => [Dynamic] -> [a] -undynamic ds = mapMaybe fromDynamic ds - --- --------------------------------------------------------------------- - -instance ExactPrint (HsIPBinds GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact b@(IPBinds _ binds) = setLayoutBoth $ markAnnotated binds >> return b - --- --------------------------------------------------------------------- - -instance ExactPrint (IPBind GhcPs) where - getAnnotationEntry (IPBind an _ _) = fromAnn an - setAnnotationAnchor (IPBind an a b) anc cs = IPBind (setAnchorEpa an anc cs) a b - - exact (IPBind an lr rhs) = do - lr' <- markAnnotated lr - an0 <- markEpAnnL an lidl AnnEqual - rhs' <- markAnnotated rhs - return (IPBind an0 lr' rhs') - - --- --------------------------------------------------------------------- - -instance ExactPrint HsIPName where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact i@(HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs)) >> return i - --- --------------------------------------------------------------------- --- Managing lists which have been separated, e.g. Sigs and Binds - -prepareListAnnotationF :: (Monad m, Monoid w) => - EpAnn [AddEpAnn] -> [LDataFamInstDecl GhcPs] -> [(RealSrcSpan,EP w m Dynamic)] -prepareListAnnotationF an ls = map (\b -> (realSrcSpan $ getLocA b, go b)) ls - where - go (L l a) = do - d' <- markAnnotated (DataFamInstDeclWithContext an NotTopLevel a) - return (toDyn (L l (dc_d d'))) - -prepareListAnnotationA :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => [LocatedAn an a] -> [(RealSrcSpan,EP w m Dynamic)] -prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,go b)) ls - where - go b = do - b' <- markAnnotated b - return (toDyn b') - -withSortKey :: (Monad m, Monoid w) => AnnSortKey -> [(RealSrcSpan, EP w m Dynamic)] -> EP w m [Dynamic] -withSortKey annSortKey xs = do - debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey - let ordered = case annSortKey of - NoAnnSortKey -> sortBy orderByFst xs - -- Just keys -> error $ "withSortKey: keys" ++ show keys - AnnSortKey keys -> orderByKey xs keys - -- `debug` ("withSortKey:" ++ - -- showPprUnsafe (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs), - -- map fst xs, - -- keys) - -- ) - mapM snd ordered - -orderByFst :: Ord a => (a, b1) -> (a, b2) -> Ordering -orderByFst (a,_) (b,_) = compare a b - --- --------------------------------------------------------------------- - -instance ExactPrint (Sig GhcPs) where - getAnnotationEntry (TypeSig a _ _) = fromAnn a - getAnnotationEntry (PatSynSig a _ _) = fromAnn a - getAnnotationEntry (ClassOpSig a _ _ _) = fromAnn a - getAnnotationEntry (FixSig a _) = fromAnn a - getAnnotationEntry (InlineSig a _ _) = fromAnn a - getAnnotationEntry (SpecSig a _ _ _) = fromAnn a - getAnnotationEntry (SpecInstSig (a, _) _) = fromAnn a - getAnnotationEntry (MinimalSig (a, _) _) = fromAnn a - getAnnotationEntry (SCCFunSig (a, _) _ _) = fromAnn a - getAnnotationEntry (CompleteMatchSig (a, _) _ _) = fromAnn a - - setAnnotationAnchor (TypeSig a x y) anc cs = (TypeSig (setAnchorEpa a anc cs) x y) - setAnnotationAnchor (PatSynSig a x y) anc cs = (PatSynSig (setAnchorEpa a anc cs) x y) - setAnnotationAnchor (ClassOpSig a x y z) anc cs = (ClassOpSig (setAnchorEpa a anc cs) x y z) - setAnnotationAnchor (FixSig a x) anc cs = (FixSig (setAnchorEpa a anc cs) x) - setAnnotationAnchor (InlineSig a x y) anc cs = (InlineSig (setAnchorEpa a anc cs) x y) - setAnnotationAnchor (SpecSig a x y z) anc cs = (SpecSig (setAnchorEpa a anc cs) x y z) - setAnnotationAnchor (SpecInstSig (a,x) y) anc cs = (SpecInstSig ((setAnchorEpa a anc cs),x) y) - setAnnotationAnchor (MinimalSig (a,x) y) anc cs = (MinimalSig ((setAnchorEpa a anc cs),x) y) - setAnnotationAnchor (SCCFunSig (a,x) y z) anc cs = (SCCFunSig ((setAnchorEpa a anc cs),x) y z) - setAnnotationAnchor (CompleteMatchSig (a,x) y z) anc cs = (CompleteMatchSig ((setAnchorEpa a anc cs),x) y z) - - exact (TypeSig an vars ty) = do - (an', vars', ty') <- exactVarSig an vars ty - return (TypeSig an' vars' ty') - - exact (PatSynSig an lns typ) = do - an0 <- markEpAnnL an lasRest AnnPattern - lns' <- markAnnotated lns - an1 <- markLensAA an0 lasDcolon - typ' <- markAnnotated typ - return (PatSynSig an1 lns' typ') - - exact (ClassOpSig an is_deflt vars ty) - | is_deflt = do - an0 <- markEpAnnL an lasRest AnnDefault - (an1, vars',ty') <- exactVarSig an0 vars ty - return (ClassOpSig an1 is_deflt vars' ty') - | otherwise = do - (an0, vars',ty') <- exactVarSig an vars ty - return (ClassOpSig an0 is_deflt vars' ty') - - exact (FixSig an (FixitySig x names (Fixity src v fdir))) = do - let fixstr = case fdir of - InfixL -> "infixl" - InfixR -> "infixr" - InfixN -> "infix" - an0 <- markEpAnnLMS an lidl AnnInfix (Just fixstr) - an1 <- markEpAnnLMS an0 lidl AnnVal (Just (sourceTextToString src (show v))) - names' <- markAnnotated names - return (FixSig an1 (FixitySig x names' (Fixity src v fdir))) - - exact (InlineSig an ln inl) = do - an0 <- markAnnOpen an (inl_src inl) "{-# INLINE" - an1 <- markActivation an0 id (inl_act inl) - ln' <- markAnnotated ln - debugM $ "InlineSig:an=" ++ showAst an - p <- getPosP - debugM $ "InlineSig: p=" ++ show p - an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") - debugM $ "InlineSig:done" - return (InlineSig an2 ln' inl) - - exact (SpecSig an ln typs inl) = do - an0 <- markAnnOpen an (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE - an1 <- markActivation an0 lidl (inl_act inl) - ln' <- markAnnotated ln - an2 <- markEpAnnL an1 lidl AnnDcolon - typs' <- markAnnotated typs - an3 <- markEpAnnLMS an2 lidl AnnClose (Just "#-}") - return (SpecSig an3 ln' typs' inl) - - exact (SpecInstSig (an,src) typ) = do - an0 <- markAnnOpen an src "{-# SPECIALISE" - an1 <- markEpAnnL an0 lidl AnnInstance - typ' <- markAnnotated typ - an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") - return (SpecInstSig (an2,src) typ') - - exact (MinimalSig (an,src) formula) = do - an0 <- markAnnOpen an src "{-# MINIMAL" - formula' <- markAnnotated formula - an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") - return (MinimalSig (an1,src) formula') - - exact (SCCFunSig (an,src) ln ml) = do - an0 <- markAnnOpen an src "{-# SCC" - ln' <- markAnnotated ln - ml' <- markAnnotated ml - an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") - return (SCCFunSig (an1,src) ln' ml') - - exact (CompleteMatchSig (an,src) cs mty) = do - an0 <- markAnnOpen an src "{-# COMPLETE" - cs' <- markAnnotated cs - (an1, mty') <- - case mty of - Nothing -> return (an0, mty) - Just ty -> do - an1 <- markEpAnnL an0 lidl AnnDcolon - ty' <- markAnnotated ty - return (an1, Just ty') - an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") - return (CompleteMatchSig (an2,src) cs' mty') - --- --------------------------------------------------------------------- - -exactVarSig :: (Monad m, Monoid w, ExactPrint a) - => EpAnn AnnSig -> [LocatedN RdrName] -> a -> EP w m (EpAnn AnnSig, [LocatedN RdrName], a) -exactVarSig an vars ty = do - vars' <- mapM markAnnotated vars - an0 <- markLensAA an lasDcolon - ty' <- markAnnotated ty - return (an0, vars', ty') - --- --------------------------------------------------------------------- - -instance ExactPrint (StandaloneKindSig GhcPs) where - getAnnotationEntry (StandaloneKindSig an _ _) = fromAnn an - setAnnotationAnchor (StandaloneKindSig an a b) anc cs = StandaloneKindSig (setAnchorEpa an anc cs) a b - - exact (StandaloneKindSig an vars sig) = do - an0 <- markEpAnnL an lidl AnnType - vars' <- markAnnotated vars - an1 <- markEpAnnL an0 lidl AnnDcolon - sig' <- markAnnotated sig - return (StandaloneKindSig an1 vars' sig') - --- --------------------------------------------------------------------- - -instance ExactPrint (DefaultDecl GhcPs) where - getAnnotationEntry (DefaultDecl an _) = fromAnn an - setAnnotationAnchor (DefaultDecl an a) anc cs = DefaultDecl (setAnchorEpa an anc cs) a - - exact (DefaultDecl an tys) = do - an0 <- markEpAnnL an lidl AnnDefault - an1 <- markEpAnnL an0 lidl AnnOpenP - tys' <- markAnnotated tys - an2 <- markEpAnnL an1 lidl AnnCloseP - return (DefaultDecl an2 tys') - --- --------------------------------------------------------------------- - -instance ExactPrint (AnnDecl GhcPs) where - getAnnotationEntry (HsAnnotation (an, _) _ _) = fromAnn an - setAnnotationAnchor (HsAnnotation (an,a) b c) anc cs = HsAnnotation ((setAnchorEpa an anc cs),a) b c - - exact (HsAnnotation (an, src) prov e) = do - an0 <- markAnnOpenP an src "{-# ANN" - (an1, prov') <- - case prov of - (ValueAnnProvenance n) -> do - n' <- markAnnotated n - return (an0, ValueAnnProvenance n') - (TypeAnnProvenance n) -> do - an1 <- markEpAnnL an0 lapr_rest AnnType - n' <- markAnnotated n - return (an1, TypeAnnProvenance n') - ModuleAnnProvenance -> do - an1 <- markEpAnnL an lapr_rest AnnModule - return (an1, prov) - - e' <- markAnnotated e - an2 <- markAnnCloseP an1 - return (HsAnnotation (an2,src) prov' e') - --- --------------------------------------------------------------------- - -instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (BF.Var x) = do - x' <- markAnnotated x - return (BF.Var x') - exact (BF.Or ls) = do - ls' <- markAnnotated ls - return (BF.Or ls') - exact (BF.And ls) = do - ls' <- markAnnotated ls - return (BF.And ls') - exact (BF.Parens x) = do - x' <- markAnnotated x - return (BF.Parens x') - --- --------------------------------------------------------------------- - -instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (HsWC x ty) = do - ty' <- markAnnotated ty - return (HsWC x ty') - --- --------------------------------------------------------------------- - -instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry (GRHS an _ _) = fromAnn an - setAnnotationAnchor (GRHS an a b) anc cs = GRHS (setAnchorEpa an anc cs) a b - - exact (GRHS an guards expr) = do - debugM $ "GRHS comments:" ++ showGhc (comments an) - an0 <- if null guards - then return an - else markLensKwM an lga_vbar AnnVbar - guards' <- markAnnotated guards - debugM $ "GRHS before matchSeparator" - an1 <- markLensAA an0 lga_sep -- Mark the matchSeparator for these GRHSs - debugM $ "GRHS after matchSeparator" - expr' <- markAnnotated expr - return (GRHS an1 guards' expr') - -instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry (GRHS ann _ _) = fromAnn ann - setAnnotationAnchor (GRHS an a b) anc cs = GRHS (setAnchorEpa an anc cs) a b - - exact (GRHS an guards expr) = do - an0 <- markLensKwM an lga_vbar AnnVbar - guards' <- markAnnotated guards - an1 <- markLensAA an0 lga_sep -- Mark the matchSeparator for these GRHSs - expr' <- markAnnotated expr - return (GRHS an1 guards' expr') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsExpr GhcPs) where - getAnnotationEntry (HsVar{}) = NoEntryVal - getAnnotationEntry (HsUnboundVar an _) = fromAnn an - getAnnotationEntry (HsRecSel{}) = NoEntryVal - getAnnotationEntry (HsOverLabel an _ _) = fromAnn an - getAnnotationEntry (HsIPVar an _) = fromAnn an - getAnnotationEntry (HsOverLit an _) = fromAnn an - getAnnotationEntry (HsLit an _) = fromAnn an - getAnnotationEntry (HsLam _ _) = NoEntryVal - getAnnotationEntry (HsLamCase an _ _) = fromAnn an - getAnnotationEntry (HsApp an _ _) = fromAnn an - getAnnotationEntry (HsAppType _ _ _ _) = NoEntryVal - getAnnotationEntry (OpApp an _ _ _) = fromAnn an - getAnnotationEntry (NegApp an _ _) = fromAnn an - getAnnotationEntry (HsPar an _ _ _) = fromAnn an - getAnnotationEntry (SectionL an _ _) = fromAnn an - getAnnotationEntry (SectionR an _ _) = fromAnn an - getAnnotationEntry (ExplicitTuple an _ _) = fromAnn an - getAnnotationEntry (ExplicitSum an _ _ _) = fromAnn an - getAnnotationEntry (HsCase an _ _) = fromAnn an - getAnnotationEntry (HsIf an _ _ _) = fromAnn an - getAnnotationEntry (HsMultiIf an _) = fromAnn an - getAnnotationEntry (HsLet an _ _ _ _) = fromAnn an - getAnnotationEntry (HsDo an _ _) = fromAnn an - getAnnotationEntry (ExplicitList an _) = fromAnn an - getAnnotationEntry (RecordCon an _ _) = fromAnn an - getAnnotationEntry (RecordUpd an _ _) = fromAnn an - getAnnotationEntry (HsGetField an _ _) = fromAnn an - getAnnotationEntry (HsProjection an _) = fromAnn an - getAnnotationEntry (ExprWithTySig an _ _) = fromAnn an - getAnnotationEntry (ArithSeq an _ _) = fromAnn an - getAnnotationEntry (HsTypedBracket an _) = fromAnn an - getAnnotationEntry (HsUntypedBracket an _) = fromAnn an - getAnnotationEntry (HsTypedSplice (_, an) _) = fromAnn an - getAnnotationEntry (HsUntypedSplice an _) = fromAnn an - getAnnotationEntry (HsProc an _ _) = fromAnn an - getAnnotationEntry (HsStatic an _) = fromAnn an - getAnnotationEntry (HsPragE{}) = NoEntryVal - - setAnnotationAnchor a@(HsVar{}) _ _s = a - setAnnotationAnchor (HsUnboundVar an a) anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a) - setAnnotationAnchor a@(HsRecSel{}) _ _s = a - setAnnotationAnchor (HsOverLabel an s a) anc cs = (HsOverLabel (setAnchorEpa an anc cs) s a) - setAnnotationAnchor (HsIPVar an a) anc cs = (HsIPVar (setAnchorEpa an anc cs) a) - setAnnotationAnchor (HsOverLit an a) anc cs = (HsOverLit (setAnchorEpa an anc cs) a) - setAnnotationAnchor (HsLit an a) anc cs = (HsLit (setAnchorEpa an anc cs) a) - setAnnotationAnchor a@(HsLam _ _) _ _s = a - setAnnotationAnchor (HsLamCase an a b) anc cs = (HsLamCase (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsApp an a b) anc cs = (HsApp (setAnchorEpa an anc cs) a b) - setAnnotationAnchor a@(HsAppType {}) _ _s = a - setAnnotationAnchor (OpApp an a b c) anc cs = (OpApp (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (NegApp an a b) anc cs = (NegApp (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsPar an a b c) anc cs = (HsPar (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (SectionL an a b) anc cs = (SectionL (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (SectionR an a b) anc cs = (SectionR (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (ExplicitTuple an a b) anc cs = (ExplicitTuple (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (ExplicitSum an a b c) anc cs = (ExplicitSum (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (HsCase an a b) anc cs = (HsCase (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsIf an a b c) anc cs = (HsIf (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (HsMultiIf an a) anc cs = (HsMultiIf (setAnchorEpa an anc cs) a) - setAnnotationAnchor (HsLet an a b c d) anc cs = (HsLet (setAnchorEpa an anc cs) a b c d) - setAnnotationAnchor (HsDo an a b) anc cs = (HsDo (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (ExplicitList an a) anc cs = (ExplicitList (setAnchorEpa an anc cs) a) - setAnnotationAnchor (RecordCon an a b) anc cs = (RecordCon (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (RecordUpd an a b) anc cs = (RecordUpd (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsGetField an a b) anc cs = (HsGetField (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsProjection an a) anc cs = (HsProjection (setAnchorEpa an anc cs) a) - setAnnotationAnchor (ExprWithTySig an a b) anc cs = (ExprWithTySig (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (ArithSeq an a b) anc cs = (ArithSeq (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsTypedBracket an a) anc cs = (HsTypedBracket (setAnchorEpa an anc cs) a) - setAnnotationAnchor (HsUntypedBracket an a) anc cs = (HsUntypedBracket (setAnchorEpa an anc cs) a) - setAnnotationAnchor (HsTypedSplice (x,an) e) anc cs = (HsTypedSplice (x,(setAnchorEpa an anc cs)) e) - setAnnotationAnchor (HsUntypedSplice an e) anc cs = (HsUntypedSplice (setAnchorEpa an anc cs) e) - setAnnotationAnchor (HsProc an a b) anc cs = (HsProc (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsStatic an a) anc cs = (HsStatic (setAnchorEpa an anc cs) a) - setAnnotationAnchor a@(HsPragE{}) _ _s = a - - exact (HsVar x n) = do - n' <- markAnnotated n - return (HsVar x n') - exact x@(HsUnboundVar an _) = do - case an of - EpAnnNotUsed -> withPpr x - EpAnn _ (EpAnnUnboundVar (ob,cb) l) _ -> do - printStringAtAA ob "`" >> return () - printStringAtAA l "_" >> return () - printStringAtAA cb "`" >> return () - return x - exact x@(HsOverLabel _ src l) = do - printStringAtLsDelta (SameLine 0) "#" - case src of - NoSourceText -> printStringAtLsDelta (SameLine 0) (unpackFS l) - SourceText txt -> printStringAtLsDelta (SameLine 0) (unpackFS txt) - return x - - exact x@(HsIPVar _ (HsIPName n)) - = printStringAdvance ("?" ++ unpackFS n) >> return x - - exact x@(HsOverLit _an ol) = do - let str = case ol_val ol of - HsIntegral (IL src _ _) -> src - HsFractional (FL { fl_text = src }) -> src - HsIsString src _ -> src - case str of - SourceText s -> printStringAdvance (unpackFS s) >> return () - NoSourceText -> withPpr x >> return () - return x - - exact (HsLit an lit) = do - lit' <- withPpr lit - return (HsLit an lit') - exact (HsLam x mg) = do - mg' <- markAnnotated mg - return (HsLam x mg') - - exact (HsLamCase an lc_variant mg) = do - an0 <- markEpAnnL an lidl AnnLam - an1 <- markEpAnnL an0 lidl (case lc_variant of LamCase -> AnnCase - LamCases -> AnnCases) - mg' <- markAnnotated mg - return (HsLamCase an1 lc_variant mg') - - exact (HsApp an e1 e2) = do - p <- getPosP - debugM $ "HsApp entered. p=" ++ show p - e1' <- markAnnotated e1 - e2' <- markAnnotated e2 - return (HsApp an e1' e2') - exact (HsAppType ss fun at arg) = do - fun' <- markAnnotated fun - at' <- markToken at - arg' <- markAnnotated arg - return (HsAppType ss fun' at' arg') - exact (OpApp an e1 e2 e3) = do - e1' <- markAnnotated e1 - e2' <- markAnnotated e2 - e3' <- markAnnotated e3 - return (OpApp an e1' e2' e3') - - exact (NegApp an e s) = do - an0 <- markEpAnnL an lidl AnnMinus - e' <- markAnnotated e - return (NegApp an0 e' s) - - exact (HsPar an lpar e rpar) = do - lpar' <- markToken lpar - e' <- markAnnotated e - debugM $ "HsPar closing paren" - rpar' <- markToken rpar - debugM $ "HsPar done" - return (HsPar an lpar' e' rpar') - - exact (SectionL an expr op) = do - expr' <- markAnnotated expr - op' <- markAnnotated op - return (SectionL an expr' op') - - exact (SectionR an op expr) = do - op' <- markAnnotated op - expr' <- markAnnotated expr - return (SectionR an op' expr') - - exact (ExplicitTuple an args b) = do - an0 <- if b == Boxed then markEpAnnL an lidl AnnOpenP - else markEpAnnL an lidl AnnOpenPH - - args' <- mapM markAnnotated args - - an1 <- if b == Boxed then markEpAnnL an0 lidl AnnCloseP - else markEpAnnL an0 lidl AnnClosePH - debugM $ "ExplicitTuple done" - return (ExplicitTuple an1 args' b) - - exact (ExplicitSum an alt arity expr) = do - an0 <- markLensKw an laesOpen AnnOpenPH - an1 <- markAnnKwAllL an0 laesBarsBefore AnnVbar - expr' <- markAnnotated expr - an2 <- markAnnKwAllL an1 laesBarsAfter AnnVbar - an3 <- markLensKw an2 laesClose AnnClosePH - return (ExplicitSum an3 alt arity expr') - - exact (HsCase an e alts) = do - an0 <- markAnnKwL an lhsCaseAnnCase AnnCase - e' <- markAnnotated e - an1 <- markAnnKwL an0 lhsCaseAnnOf AnnOf - an2 <- markEpAnnL an1 lhsCaseAnnsRest AnnOpenC - an3 <- markEpAnnAllL an2 lhsCaseAnnsRest AnnSemi - alts' <- setLayoutBoth $ markAnnotated alts - an4 <- markEpAnnL an3 lhsCaseAnnsRest AnnCloseC - return (HsCase an4 e' alts') - - exact (HsIf an e1 e2 e3) = do - an0 <- markAnnKwL an laiIf AnnIf - e1' <- markAnnotated e1 - an1 <- markLensKwM an0 laiThenSemi AnnSemi - an2 <- markAnnKwL an1 laiThen AnnThen - e2' <- markAnnotated e2 - an3 <- markLensKwM an2 laiElseSemi AnnSemi - an4 <- markAnnKwL an3 laiElse AnnElse - e3' <- markAnnotated e3 - return (HsIf an4 e1' e2' e3') - - exact (HsMultiIf an mg) = do - an0 <- markEpAnnL an lidl AnnIf - an1 <- markEpAnnL an0 lidl AnnOpenC -- optional - mg' <- markAnnotated mg - an2 <- markEpAnnL an1 lidl AnnCloseC -- optional - return (HsMultiIf an2 mg') - - exact (HsLet an tkLet binds tkIn e) = do - setLayoutBoth $ do -- Make sure the 'in' gets indented too - tkLet' <- markToken tkLet - debugM $ "HSlet:binds coming" - binds' <- setLayoutBoth $ markAnnotated binds - debugM $ "HSlet:binds done" - tkIn' <- markToken tkIn - debugM $ "HSlet:expr coming" - e' <- markAnnotated e - return (HsLet an tkLet' binds' tkIn' e') - - exact (HsDo an do_or_list_comp stmts) = do - debugM $ "HsDo" - (an',stmts') <- markAnnListA True an $ \a -> exactDo a do_or_list_comp stmts - return (HsDo an' do_or_list_comp stmts') - - exact (ExplicitList an es) = do - debugM $ "ExplicitList start" - an0 <- markLensMAA an lal_open - es' <- markAnnotated es - an1 <- markLensMAA an0 lal_close - debugM $ "ExplicitList end" - return (ExplicitList an1 es') - exact (RecordCon an con_id binds) = do - con_id' <- markAnnotated con_id - an0 <- markEpAnnL an lidl AnnOpenC - binds' <- markAnnotated binds - an1 <- markEpAnnL an0 lidl AnnCloseC - return (RecordCon an1 con_id' binds') - exact (RecordUpd an expr fields) = do - expr' <- markAnnotated expr - an0 <- markEpAnnL an lidl AnnOpenC - fields' <- markAnnotated fields - an1 <- markEpAnnL an0 lidl AnnCloseC - return (RecordUpd an1 expr' fields') - exact (HsGetField an expr field) = do - expr' <- markAnnotated expr - field' <- markAnnotated field - return (HsGetField an expr' field') - exact (HsProjection an flds) = do - an0 <- markAnnKwL an lapOpen AnnOpenP - flds' <- mapM markAnnotated flds - an1 <- markAnnKwL an0 lapClose AnnCloseP - return (HsProjection an1 flds') - exact (ExprWithTySig an expr sig) = do - expr' <- markAnnotated expr - an0 <- markEpAnnL an lidl AnnDcolon - sig' <- markAnnotated sig - return (ExprWithTySig an0 expr' sig') - exact (ArithSeq an s seqInfo) = do - an0 <- markEpAnnL an lidl AnnOpenS -- '[' - (an1, seqInfo') <- - case seqInfo of - From e -> do - e' <- markAnnotated e - an' <- markEpAnnL an0 lidl AnnDotdot - return (an', From e') - FromTo e1 e2 -> do - e1' <- markAnnotated e1 - an' <- markEpAnnL an0 lidl AnnDotdot - e2' <- markAnnotated e2 - return (an', FromTo e1' e2') - FromThen e1 e2 -> do - e1' <- markAnnotated e1 - an' <- markEpAnnL an0 lidl AnnComma - e2' <- markAnnotated e2 - an'' <- markEpAnnL an' lidl AnnDotdot - return (an'', FromThen e1' e2') - FromThenTo e1 e2 e3 -> do - e1' <- markAnnotated e1 - an' <- markEpAnnL an0 lidl AnnComma - e2' <- markAnnotated e2 - an'' <- markEpAnnL an' lidl AnnDotdot - e3' <- markAnnotated e3 - return (an'', FromThenTo e1' e2' e3') - an2 <- markEpAnnL an1 lidl AnnCloseS -- ']' - return (ArithSeq an2 s seqInfo') - - - exact (HsTypedBracket an e) = do - an0 <- markEpAnnLMS an lidl AnnOpen (Just "[||") - an1 <- markEpAnnLMS an0 lidl AnnOpenE (Just "[e||") - e' <- markAnnotated e - an2 <- markEpAnnLMS an1 lidl AnnClose (Just "||]") - return (HsTypedBracket an2 e') - - exact (HsUntypedBracket an (ExpBr a e)) = do - an0 <- markEpAnnL an lidl AnnOpenEQ -- "[|" - an1 <- markEpAnnL an0 lidl AnnOpenE -- "[e|" -- optional - e' <- markAnnotated e - an2 <- markEpAnnL an1 lidl AnnCloseQ -- "|]" - return (HsUntypedBracket an2 (ExpBr a e')) - - exact (HsUntypedBracket an (PatBr a e)) = do - an0 <- markEpAnnLMS an lidl AnnOpen (Just "[p|") - e' <- markAnnotated e - an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" - return (HsUntypedBracket an1 (PatBr a e')) - - exact (HsUntypedBracket an (DecBrL a e)) = do - an0 <- markEpAnnLMS an lidl AnnOpen (Just "[d|") - an1 <- markEpAnnL an0 lidl AnnOpenC - e' <- markAnnotated e - an2 <- markEpAnnL an1 lidl AnnCloseC - an3 <- markEpAnnL an2 lidl AnnCloseQ -- "|]" - return (HsUntypedBracket an3 (DecBrL a e')) - - exact (HsUntypedBracket an (TypBr a e)) = do - an0 <- markEpAnnLMS an lidl AnnOpen (Just "[t|") - e' <- markAnnotated e - an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" - return (HsUntypedBracket an1 (TypBr a e')) - - exact (HsUntypedBracket an (VarBr a b e)) = do - (an0, e') <- if b - then do - an' <- markEpAnnL an lidl AnnSimpleQuote - e' <- markAnnotated e - return (an', e') - else do - an' <- markEpAnnL an lidl AnnThTyQuote - e' <- markAnnotated e - return (an', e') - return (HsUntypedBracket an0 (VarBr a b e')) - - exact (HsTypedSplice (x,an) s) = do - an0 <- markEpAnnL an lidl AnnDollarDollar - s' <- exact s - return (HsTypedSplice (x,an0) s') - exact (HsUntypedSplice an s) = do - s' <- exact s - return (HsUntypedSplice an s') - - exact (HsProc an p c) = do - debugM $ "HsProc start" - an0 <- markEpAnnL an lidl AnnProc - p' <- markAnnotated p - an1 <- markEpAnnL an0 lidl AnnRarrow - debugM $ "HsProc after AnnRarrow" - c' <- markAnnotated c - return (HsProc an1 p' c') - - exact (HsStatic an e) = do - an0 <- markEpAnnL an lidl AnnStatic - e' <- markAnnotated e - return (HsStatic an0 e') - - exact (HsPragE a prag e) = do - prag' <- markAnnotated prag - e' <- markAnnotated e - return (HsPragE a prag' e') - exact x = error $ "exact HsExpr for:" ++ showAst x - --- --------------------------------------------------------------------- - -exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => EpAnn AnnList -> HsDoFlavour -> LocatedAn an a - -> EP w m (EpAnn AnnList, LocatedAn an a) -exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an GhciStmtCtxt stmts = markEpAnnL an lal_rest AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an ListComp stmts = markMaybeDodgyStmts an stmts -exactDo an MonadComp stmts = markMaybeDodgyStmts an stmts - -exactMdo :: (Monad m, Monoid w) - => EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EP w m (EpAnn AnnList) -exactMdo an Nothing kw = markEpAnnL an lal_rest kw -exactMdo an (Just module_name) kw = markEpAnnLMS an lal_rest kw (Just n) - where - n = (moduleNameString module_name) ++ "." ++ (keywordToString kw) - -markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => EpAnn AnnList -> LocatedAn an a -> EP w m (EpAnn AnnList, LocatedAn an a) -markMaybeDodgyStmts an stmts = - if isGoodSrcSpan (getLocA stmts) - then do - r <- markAnnotatedWithLayout stmts - return (an, r) - else return (an, stmts) - --- --------------------------------------------------------------------- -instance ExactPrint (HsPragE GhcPs) where - getAnnotationEntry HsPragSCC{} = NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (HsPragSCC (an,st) sl) = do - an0 <- markAnnOpenP an st "{-# SCC" - let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl) - an1 <- markEpAnnLMS an0 lapr_rest AnnVal (Just txt) -- optional - an2 <- markEpAnnLMS an1 lapr_rest AnnValStr (Just txt) -- optional - an3 <- markAnnCloseP an2 - return (HsPragSCC (an3,st) sl) - - --- --------------------------------------------------------------------- - -instance ExactPrint (HsUntypedSplice GhcPs) where - getAnnotationEntry (HsUntypedSpliceExpr an _) = fromAnn an - getAnnotationEntry (HsQuasiQuote _ _ _) = NoEntryVal - - setAnnotationAnchor (HsUntypedSpliceExpr an e) anc cs = HsUntypedSpliceExpr (setAnchorEpa an anc cs) e - setAnnotationAnchor a@HsQuasiQuote {} _ _ = a - - exact (HsUntypedSpliceExpr an e) = do - an0 <- markEpAnnL an lidl AnnDollar - e' <- markAnnotated e - return (HsUntypedSpliceExpr an0 e') - - exact (HsQuasiQuote an q (L l fs)) = do - -- The quasiquote string does not honour layout offsets. Store - -- the colOffset for now. - -- TODO: use local? - oldOffset <- getLayoutOffsetP - EPState{pMarkLayout} <- get - unless pMarkLayout $ setLayoutOffsetP 0 - printStringAdvance - -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 - ("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]") - unless pMarkLayout $ setLayoutOffsetP oldOffset - return (HsQuasiQuote an q (L l fs)) - --- --------------------------------------------------------------------- - --- TODO:AZ: combine these instances -instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (MG x matches) = do - -- TODO:AZ use SortKey, in MG ann. - matches' <- if isGoodSrcSpan (getLocA matches) - then markAnnotated matches - else return matches - return (MG x matches') - -instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (MG x matches) = do - -- TODO:AZ use SortKey, in MG ann. - matches' <- if isGoodSrcSpan (getLocA matches) - then markAnnotated matches - else return matches - return (MG x matches') - --- --------------------------------------------------------------------- - -instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (HsRecFields fields mdot) = do - fields' <- markAnnotated fields - case mdot of - Nothing -> return () - Just (L ss _) -> - printStringAtSs ss ".." >> return () - -- Note: mdot contains the SrcSpan where the ".." appears, if present - return (HsRecFields fields' mdot) - --- --------------------------------------------------------------------- - -instance (ExactPrint body) - => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) body) where - getAnnotationEntry x = fromAnn (hfbAnn x) - setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun) - exact (HsFieldBind an f arg isPun) = do - debugM $ "HsFieldBind" - f' <- markAnnotated f - (an0, arg') <- if isPun then return (an, arg) - else do - an0 <- markEpAnnL an lidl AnnEqual - arg' <- markAnnotated arg - return (an0, arg') - return (HsFieldBind an0 f' arg' isPun) - --- --------------------------------------------------------------------- - -instance (ExactPrint body) - => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) body) where - getAnnotationEntry x = fromAnn (hfbAnn x) - setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun) - - exact (HsFieldBind an f arg isPun) = do - debugM $ "HsFieldBind FieldLabelStrings" - f' <- markAnnotated f - (an0, arg') <- if isPun then return (an, arg) - else do - an0 <- markEpAnnL an lidl AnnEqual - arg' <- markAnnotated arg - return (an0, arg') - return (HsFieldBind an0 f' arg' isPun) - --- --------------------------------------------------------------------- - -instance (ExactPrint (LocatedA body)) - => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where - getAnnotationEntry x = fromAnn (hfbAnn x) - setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun) - exact (HsFieldBind an f arg isPun) = do - debugM $ "HsRecUpdField" - f' <- markAnnotated f - an0 <- if isPun then return an - else markEpAnnL an lidl AnnEqual - arg' <- if ((locA $ getLoc arg) == noSrcSpan ) - then return arg - else markAnnotated arg - return (HsFieldBind an0 f' arg' isPun) - --- --------------------------------------------------------------------- -instance ExactPrint (LHsRecUpdFields GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact flds@(RegularRecUpdFields { recUpdFields = rbinds }) = do - debugM $ "RegularRecUpdFields" - rbinds' <- markAnnotated rbinds - return $ flds { recUpdFields = rbinds' } - exact flds@(OverloadedRecUpdFields { olRecUpdFields = pbinds }) = do - debugM $ "OverloadedRecUpdFields" - pbinds' <- markAnnotated pbinds - return $ flds { olRecUpdFields = pbinds' } - --- --------------------------------------------------------------------- - -instance ExactPrint (FieldLabelStrings GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (FieldLabelStrings fs) = FieldLabelStrings <$> markAnnotated fs - --- --------------------------------------------------------------------- - -instance ExactPrint (DotFieldOcc GhcPs) where - getAnnotationEntry (DotFieldOcc an _) = fromAnn an - - setAnnotationAnchor (DotFieldOcc an a) anc cs = DotFieldOcc (setAnchorEpa an anc cs) a - - exact (DotFieldOcc an (L loc (FieldLabelString fs))) = do - an0 <- markLensKwM an lafDot AnnDot - -- The field name has a SrcSpanAnnN, print it as a - -- LocatedN RdrName - L loc' _ <- markAnnotated (L loc (mkVarUnqual fs)) - return (DotFieldOcc an0 (L loc' (FieldLabelString fs))) - --- --------------------------------------------------------------------- - -instance ExactPrint (HsTupArg GhcPs) where - getAnnotationEntry (Present an _) = fromAnn an - getAnnotationEntry (Missing an) = fromAnn an - - setAnnotationAnchor (Present an a) anc cs = Present (setAnchorEpa an anc cs) a - setAnnotationAnchor (Missing an) anc cs = Missing (setAnchorEpa an anc cs) - - exact (Present a e) = Present a <$> markAnnotated e - - exact a@(Missing EpAnnNotUsed) = return a - exact a@(Missing _) = printStringAdvance "," >> return a - --- --------------------------------------------------------------------- - -instance ExactPrint (HsCmdTop GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (HsCmdTop a cmd) = HsCmdTop a <$> markAnnotated cmd - --- --------------------------------------------------------------------- - -instance ExactPrint (HsCmd GhcPs) where - getAnnotationEntry (HsCmdArrApp an _ _ _ _) = fromAnn an - getAnnotationEntry (HsCmdArrForm an _ _ _ _ ) = fromAnn an - getAnnotationEntry (HsCmdApp an _ _ ) = fromAnn an - getAnnotationEntry (HsCmdLam {}) = NoEntryVal - getAnnotationEntry (HsCmdPar an _ _ _) = fromAnn an - getAnnotationEntry (HsCmdCase an _ _) = fromAnn an - getAnnotationEntry (HsCmdLamCase an _ _) = fromAnn an - getAnnotationEntry (HsCmdIf an _ _ _ _) = fromAnn an - getAnnotationEntry (HsCmdLet an _ _ _ _) = fromAnn an - getAnnotationEntry (HsCmdDo an _) = fromAnn an - - setAnnotationAnchor (HsCmdArrApp an a b c d) anc cs = (HsCmdArrApp (setAnchorEpa an anc cs) a b c d) - setAnnotationAnchor (HsCmdArrForm an a b c d ) anc cs = (HsCmdArrForm (setAnchorEpa an anc cs) a b c d ) - setAnnotationAnchor (HsCmdApp an a b ) anc cs = (HsCmdApp (setAnchorEpa an anc cs) a b ) - setAnnotationAnchor a@(HsCmdLam {}) _ _s = a - setAnnotationAnchor (HsCmdPar an a b c) anc cs = (HsCmdPar (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (HsCmdCase an a b) anc cs = (HsCmdCase (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsCmdLamCase an a b) anc cs = (HsCmdLamCase (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsCmdIf an a b c d) anc cs = (HsCmdIf (setAnchorEpa an anc cs) a b c d) - setAnnotationAnchor (HsCmdLet an a b c d) anc cs = (HsCmdLet (setAnchorEpa an anc cs) a b c d) - setAnnotationAnchor (HsCmdDo an a) anc cs = (HsCmdDo (setAnchorEpa an anc cs) a) - - exact (HsCmdArrApp an arr arg o isRightToLeft) = do - if isRightToLeft - then do - arr' <- markAnnotated arr - an0 <- markKw (anns an) - arg' <- markAnnotated arg - let an1 = an{anns = an0} - return (HsCmdArrApp an1 arr' arg' o isRightToLeft) - else do - arg' <- markAnnotated arg - an0 <- markKw (anns an) - arr' <- markAnnotated arr - let an1 = an {anns = an0} - return (HsCmdArrApp an1 arr' arg' o isRightToLeft) - - exact (HsCmdArrForm an e fixity mf cs) = do - an0 <- markLensMAA an lal_open - (e',cs') <- case (fixity, cs) of - (Infix, (arg1:argrest)) -> do - arg1' <- markAnnotated arg1 - e' <- markAnnotated e - argrest' <- markAnnotated argrest - return (e', arg1':argrest') - (Prefix, _) -> do - e' <- markAnnotated e - cs' <- markAnnotated cs - return (e', cs') - (Infix, []) -> error "Not possible" - an1 <- markLensMAA an0 lal_close - return (HsCmdArrForm an1 e' fixity mf cs') - - exact (HsCmdApp an e1 e2) = do - e1' <- markAnnotated e1 - e2' <- markAnnotated e2 - return (HsCmdApp an e1' e2') - - exact (HsCmdLam a match) = do - match' <- markAnnotated match - return (HsCmdLam a match') - - exact (HsCmdPar an lpar e rpar) = do - lpar' <- markToken lpar - e' <- markAnnotated e - rpar' <- markToken rpar - return (HsCmdPar an lpar' e' rpar') - - exact (HsCmdCase an e alts) = do - an0 <- markLensKw an lhsCaseAnnCase AnnCase - e' <- markAnnotated e - an1 <- markLensKw an0 lhsCaseAnnOf AnnOf - an2 <- markEpAnnL an1 lhsCaseAnnsRest AnnOpenC - an3 <- markEpAnnAllL an2 lhsCaseAnnsRest AnnSemi - alts' <- markAnnotated alts - an4 <- markEpAnnL an3 lhsCaseAnnsRest AnnCloseC - return (HsCmdCase an4 e' alts') - - exact (HsCmdLamCase an lc_variant matches) = do - an0 <- markEpAnnL an lidl AnnLam - an1 <- markEpAnnL an0 lidl (case lc_variant of LamCase -> AnnCase - LamCases -> AnnCases) - matches' <- markAnnotated matches - return (HsCmdLamCase an1 lc_variant matches') - - exact (HsCmdIf an a e1 e2 e3) = do - an0 <- markLensKw an laiIf AnnIf - e1' <- markAnnotated e1 - an1 <- markLensKwM an0 laiThenSemi AnnSemi - an2 <- markLensKw an1 laiThen AnnThen - e2' <- markAnnotated e2 - an3 <- markLensKwM an2 laiElseSemi AnnSemi - an4 <- markLensKw an3 laiElse AnnElse - e3' <- markAnnotated e3 - return (HsCmdIf an4 a e1' e2' e3') - - exact (HsCmdLet an tkLet binds tkIn e) = do - setLayoutBoth $ do -- Make sure the 'in' gets indented too - tkLet' <- markToken tkLet - binds' <- setLayoutBoth $ markAnnotated binds - tkIn' <- markToken tkIn - e' <- markAnnotated e - return (HsCmdLet an tkLet' binds' tkIn' e') - - exact (HsCmdDo an es) = do - debugM $ "HsCmdDo" - an0 <- markEpAnnL an lal_rest AnnDo - es' <- markAnnotated es - return (HsCmdDo an0 es') - --- --------------------------------------------------------------------- - -instance ( - ExactPrint (LocatedA (body GhcPs)), - Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, - Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL, - (ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) - => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where - getAnnotationEntry (LastStmt _ _ _ _) = NoEntryVal - getAnnotationEntry (BindStmt an _ _) = fromAnn an - getAnnotationEntry (ApplicativeStmt _ _ _) = NoEntryVal - getAnnotationEntry (BodyStmt _ _ _ _) = NoEntryVal - getAnnotationEntry (LetStmt an _) = fromAnn an - getAnnotationEntry (ParStmt _ _ _ _) = NoEntryVal - getAnnotationEntry (TransStmt an _ _ _ _ _ _ _ _) = fromAnn an - getAnnotationEntry (RecStmt an _ _ _ _ _ _) = fromAnn an - - ----------------------------------------------------------------- - - setAnnotationAnchor a@(LastStmt _ _ _ _) _ _s = a - setAnnotationAnchor (BindStmt an a b) anc cs = (BindStmt (setAnchorEpa an anc cs) a b) - setAnnotationAnchor a@(ApplicativeStmt _ _ _) _ _s = a - setAnnotationAnchor a@(BodyStmt _ _ _ _) _ _s = a - setAnnotationAnchor (LetStmt an a) anc cs = (LetStmt (setAnchorEpa an anc cs) a) - setAnnotationAnchor a@(ParStmt _ _ _ _) _ _s = a - setAnnotationAnchor (TransStmt an a b c d e f g h) anc cs = (TransStmt (setAnchorEpa an anc cs) a b c d e f g h) - setAnnotationAnchor (RecStmt an a b c d e f) anc cs = (RecStmt (setAnchorEpa an anc cs) a b c d e f) - - ----------------------------------------------------------------- - - exact (LastStmt a body b c) = do - debugM $ "LastStmt" - body' <- markAnnotated body - return (LastStmt a body' b c) - - exact (BindStmt an pat body) = do - debugM $ "BindStmt" - pat' <- markAnnotated pat - an0 <- markEpAnnL an lidl AnnLarrow - body' <- markAnnotated body - return (BindStmt an0 pat' body') - - exact (ApplicativeStmt _ _body _) = do - error $ "ApplicativeStmt is introduced in the renamer" - - exact (BodyStmt a body b c) = do - debugM $ "BodyStmt" - body' <- markAnnotated body - return (BodyStmt a body' b c) - - exact (LetStmt an binds) = do - debugM $ "LetStmt" - an0 <- markEpAnnL an lidl AnnLet - binds' <- markAnnotated binds - return (LetStmt an0 binds') - - exact (ParStmt a pbs b c) = do - debugM $ "ParStmt" - pbs' <- markAnnotated pbs - return (ParStmt a pbs' b c) - - exact (TransStmt an form stmts b using by c d e) = do - debugM $ "TransStmt" - stmts' <- markAnnotated stmts - (an', by', using') <- exactTransStmt an by using form - return (TransStmt an' form stmts' b using' by' c d e) - - exact (RecStmt an stmts a b c d e) = do - debugM $ "RecStmt" - an0 <- markEpAnnL an lal_rest AnnRec - (an1, stmts') <- markAnnList True an0 (markAnnotated stmts) - return (RecStmt an1 stmts' a b c d e) - --- --------------------------------------------------------------------- - -instance ExactPrint (ParStmtBlock GhcPs GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (ParStmtBlock a stmts b c) = do - stmts' <- markAnnotated stmts - return (ParStmtBlock a stmts' b c) - -exactTransStmt :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm - -> EP w m (EpAnn [AddEpAnn], Maybe (LHsExpr GhcPs), (LHsExpr GhcPs)) -exactTransStmt an by using ThenForm = do - debugM $ "exactTransStmt:ThenForm" - an0 <- markEpAnnL an lidl AnnThen - using' <- markAnnotated using - case by of - Nothing -> return (an0, by, using') - Just b -> do - an1 <- markEpAnnL an0 lidl AnnBy - b' <- markAnnotated b - return (an1, Just b', using') -exactTransStmt an by using GroupForm = do - debugM $ "exactTransStmt:GroupForm" - an0 <- markEpAnnL an lidl AnnThen - an1 <- markEpAnnL an0 lidl AnnGroup - (an2, by') <- case by of - Nothing -> return (an1, by) - Just b -> do - an2 <- markEpAnnL an1 lidl AnnBy - b' <- markAnnotated b - return (an2, Just b') - an3 <- markEpAnnL an2 lidl AnnUsing - using' <- markAnnotated using - return (an3, by', using') - --- --------------------------------------------------------------------- - -instance ExactPrint (TyClDecl GhcPs) where - getAnnotationEntry (FamDecl { }) = NoEntryVal - getAnnotationEntry (SynDecl { tcdSExt = an }) = fromAnn an - getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an - getAnnotationEntry (ClassDecl { tcdCExt = (an, _) }) = fromAnn an - - setAnnotationAnchor a@FamDecl{} _ _s = a - setAnnotationAnchor x@SynDecl{} anc cs = x { tcdSExt = setAnchorEpa (tcdSExt x) anc cs } - setAnnotationAnchor x@DataDecl{} anc cs = x { tcdDExt = setAnchorEpa (tcdDExt x) anc cs } - setAnnotationAnchor x@ClassDecl{} anc cs = x { tcdCExt = (setAnchorEpa an anc cs, a) } - where - (an,a) = tcdCExt x - - exact (FamDecl a decl) = do - decl' <- markAnnotated decl - return (FamDecl a decl') - - exact (SynDecl { tcdSExt = an - , tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity - , tcdRhs = rhs }) = do - -- There may be arbitrary parens around parts of the constructor - -- that are infix. Turn these into comments so that they feed - -- into the right place automatically - an0 <- annotationsToComments an lidl [AnnOpenP,AnnCloseP] - an1 <- markEpAnnL an0 lidl AnnType - - (_anx, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing - an2 <- markEpAnnL an1 lidl AnnEqual - rhs' <- markAnnotated rhs - return (SynDecl { tcdSExt = an2 - , tcdLName = ltycon', tcdTyVars = tyvars', tcdFixity = fixity - , tcdRhs = rhs' }) - - -- TODO: add a workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/20452 - exact (DataDecl { tcdDExt = an, tcdLName = ltycon, tcdTyVars = tyvars - , tcdFixity = fixity, tcdDataDefn = defn }) = do - (_, an', ltycon', tyvars', _, _mctxt', defn') <- - exactDataDefn an (exactVanillaDeclHead ltycon tyvars fixity) defn - return (DataDecl { tcdDExt = an', tcdLName = ltycon', tcdTyVars = tyvars' - , tcdFixity = fixity, tcdDataDefn = defn' }) - - -- ----------------------------------- - - exact (ClassDecl {tcdCExt = (an, sortKey), - tcdLayout = lo, - tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdFDs = fds, - tcdSigs = sigs, tcdMeths = methods, - tcdATs = ats, tcdATDefs = at_defs, - tcdDocs = _docs}) - -- TODO: add a test that demonstrates tcdDocs - | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part - = do - (an0, fds', lclas', tyvars',context') <- top_matter - an1 <- markEpAnnL an0 lidl AnnOpenC - an2 <- markEpAnnL an1 lidl AnnCloseC - return (ClassDecl {tcdCExt = (an2, sortKey), - tcdLayout = lo, - tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', - tcdFixity = fixity, - tcdFDs = fds', - tcdSigs = sigs, tcdMeths = methods, - tcdATs = ats, tcdATDefs = at_defs, - tcdDocs = _docs}) - - | otherwise -- Laid out - = do - (an0, fds', lclas', tyvars',context') <- top_matter - an1 <- markEpAnnL an0 lidl AnnOpenC - an2 <- markEpAnnAllL an1 lidl AnnSemi - ds <- withSortKey sortKey - (prepareListAnnotationA sigs - ++ prepareListAnnotationA (bagToList methods) - ++ prepareListAnnotationA ats - ++ prepareListAnnotationA at_defs - -- ++ prepareListAnnotation docs - ) - an3 <- markEpAnnL an2 lidl AnnCloseC - let - sigs' = undynamic ds - methods' = listToBag $ undynamic ds - ats' = undynamic ds - at_defs' = undynamic ds - return (ClassDecl {tcdCExt = (an3, sortKey), - tcdLayout = lo, - tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', - tcdFixity = fixity, - tcdFDs = fds', - tcdSigs = sigs', tcdMeths = methods', - tcdATs = ats', tcdATDefs = at_defs', - tcdDocs = _docs}) - where - top_matter = do - an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] - an0 <- markEpAnnL an' lidl AnnClass - (_, lclas', tyvars',_,context') <- exactVanillaDeclHead lclas tyvars fixity context - (an1, fds') <- if (null fds) - then return (an0, fds) - else do - an1 <- markEpAnnL an0 lidl AnnVbar - fds' <- markAnnotated fds - return (an1, fds') - an2 <- markEpAnnL an1 lidl AnnWhere - return (an2, fds', lclas', tyvars',context') - - --- --------------------------------------------------------------------- - -instance ExactPrint (FunDep GhcPs) where - getAnnotationEntry (FunDep an _ _) = fromAnn an - setAnnotationAnchor (FunDep an a b) anc cs = FunDep (setAnchorEpa an anc cs) a b - - exact (FunDep an ls rs') = do - ls' <- markAnnotated ls - an0 <- markEpAnnL an lidl AnnRarrow - rs'' <- markAnnotated rs' - return (FunDep an0 ls' rs'') - --- --------------------------------------------------------------------- - -instance ExactPrint (FamilyDecl GhcPs) where - getAnnotationEntry (FamilyDecl { fdExt = an }) = fromAnn an - setAnnotationAnchor x anc cs = x { fdExt = setAnchorEpa (fdExt x) anc cs} - - exact (FamilyDecl { fdExt = an - , fdInfo = info - , fdTopLevel = top_level - , fdLName = ltycon - , fdTyVars = tyvars - , fdFixity = fixity - , fdResultSig = L lr result - , fdInjectivityAnn = mb_inj }) = do - an0 <- exactFlavour an info - an1 <- exact_top_level an0 - an2 <- annotationsToComments an1 lidl [AnnOpenP,AnnCloseP] - (_, ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing - (an3, result') <- exact_kind an2 - (an4, mb_inj') <- - case mb_inj of - Nothing -> return (an3, mb_inj) - Just inj -> do - an4 <- markEpAnnL an3 lidl AnnVbar - inj' <- markAnnotated inj - return (an4, Just inj') - (an5, info') <- - case info of - ClosedTypeFamily mb_eqns -> do - an5 <- markEpAnnL an4 lidl AnnWhere - an6 <- markEpAnnL an5 lidl AnnOpenC - (an7, mb_eqns') <- - case mb_eqns of - Nothing -> do - an7 <- markEpAnnL an6 lidl AnnDotdot - return (an7, mb_eqns) - Just eqns -> do - eqns' <- markAnnotated eqns - return (an6, Just eqns') - an8 <- markEpAnnL an7 lidl AnnCloseC - return (an8, ClosedTypeFamily mb_eqns') - _ -> return (an4, info) - return (FamilyDecl { fdExt = an5 - , fdInfo = info' - , fdTopLevel = top_level - , fdLName = ltycon' - , fdTyVars = tyvars' - , fdFixity = fixity - , fdResultSig = L lr result' - , fdInjectivityAnn = mb_inj' }) - where - exact_top_level an' = - case top_level of - TopLevel -> markEpAnnL an' lidl AnnFamily - NotTopLevel -> do - -- It seems that in some kind of legacy - -- mode the 'family' keyword is still - -- accepted. - markEpAnnL an' lidl AnnFamily - - exact_kind an' = - case result of - NoSig _ -> return (an', result) - KindSig x kind -> do - an0 <- markEpAnnL an' lidl AnnDcolon - kind' <- markAnnotated kind - return (an0, KindSig x kind') - TyVarSig x tv_bndr -> do - an0 <- markEpAnnL an' lidl AnnEqual - tv_bndr' <- markAnnotated tv_bndr - return (an0, TyVarSig x tv_bndr') - - -exactFlavour :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> FamilyInfo GhcPs -> EP w m (EpAnn [AddEpAnn]) -exactFlavour an DataFamily = markEpAnnL an lidl AnnData -exactFlavour an OpenTypeFamily = markEpAnnL an lidl AnnType -exactFlavour an (ClosedTypeFamily {}) = markEpAnnL an lidl AnnType - --- --------------------------------------------------------------------- - -exactDataDefn - :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] - -> (Maybe (LHsContext GhcPs) -> EP w m (EpAnn [AddEpAnn] - , LocatedN RdrName - , a - , b - , Maybe (LHsContext GhcPs))) -- Printing the header - -> HsDataDefn GhcPs - -> EP w m ( EpAnn [AddEpAnn] -- ^ from exactHdr - , EpAnn [AddEpAnn] -- ^ updated one passed in - , LocatedN RdrName, a, b, Maybe (LHsContext GhcPs), HsDataDefn GhcPs) -exactDataDefn an exactHdr - (HsDataDefn { dd_ext = x, dd_ctxt = context - , dd_cType = mb_ct - , dd_kindSig = mb_sig - , dd_cons = condecls, dd_derivs = derivings }) = do - - an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] - - an0 <- case condecls of - DataTypeCons is_type_data _ -> do - an0' <- if is_type_data - then markEpAnnL an' lidl AnnType - else return an' - markEpAnnL an0' lidl AnnData - NewTypeCon _ -> markEpAnnL an' lidl AnnNewtype - - an1 <- markEpAnnL an0 lidl AnnInstance -- optional - mb_ct' <- mapM markAnnotated mb_ct - (anx, ln', tvs', b, mctxt') <- exactHdr context - (an2, mb_sig') <- case mb_sig of - Nothing -> return (an1, Nothing) - Just kind -> do - an2 <- markEpAnnL an1 lidl AnnDcolon - kind' <- markAnnotated kind - return (an2, Just kind') - an3 <- if (needsWhere condecls) - then markEpAnnL an2 lidl AnnWhere - else return an2 - an4 <- markEpAnnL an3 lidl AnnOpenC - (an5, condecls') <- exact_condecls an4 (toList condecls) - let condecls'' = case condecls of - DataTypeCons d _ -> DataTypeCons d condecls' - NewTypeCon _ -> case condecls' of - [decl] -> NewTypeCon decl - _ -> panic "exacprint NewTypeCon" - an6 <- markEpAnnL an5 lidl AnnCloseC - derivings' <- mapM markAnnotated derivings - return (anx, an6, ln', tvs', b, mctxt', - (HsDataDefn { dd_ext = x, dd_ctxt = context - , dd_cType = mb_ct' - , dd_kindSig = mb_sig' - , dd_cons = condecls'', dd_derivs = derivings' })) - - -exactVanillaDeclHead :: (Monad m, Monoid w) - => LocatedN RdrName - -> LHsQTyVars GhcPs - -> LexicalFixity - -> Maybe (LHsContext GhcPs) - -> EP w m ( EpAnn [AddEpAnn] - , LocatedN RdrName - , LHsQTyVars GhcPs - , (), Maybe (LHsContext GhcPs)) -exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context = do - let - exact_tyvars (varl:varsr) - | hvarsr : tvarsr@(_ : _) <- varsr - , fixity == Infix = do - varl' <- markAnnotated varl - thing' <- markAnnotated thing - hvarsr' <- markAnnotated hvarsr - tvarsr' <- markAnnotated tvarsr - return (thing', varl':hvarsr':tvarsr') - | fixity == Infix = do - varl' <- markAnnotated varl - thing' <- markAnnotated thing - varsr' <- markAnnotated varsr - return (thing', varl':varsr') - | otherwise = do - thing' <- markAnnotated thing - vs <- mapM markAnnotated (varl:varsr) - return (thing', vs) - exact_tyvars [] = do - thing' <- markAnnotated thing - return (thing', []) - context' <- mapM markAnnotated context - (thing', tyvars') <- exact_tyvars tyvars - return (EpAnnNotUsed, thing', tvs { hsq_explicit = tyvars' }, (), context') - --- --------------------------------------------------------------------- - -instance ExactPrint (InjectivityAnn GhcPs) where - getAnnotationEntry (InjectivityAnn an _ _) = fromAnn an - setAnnotationAnchor (InjectivityAnn an a b) anc cs = InjectivityAnn (setAnchorEpa an anc cs) a b - exact (InjectivityAnn an lhs rhs) = do - an0 <- markEpAnnL an lidl AnnVbar - lhs' <- markAnnotated lhs - an1 <- markEpAnnL an0 lidl AnnRarrow - rhs' <- mapM markAnnotated rhs - return (InjectivityAnn an1 lhs' rhs') - --- --------------------------------------------------------------------- - -class Typeable flag => ExactPrintTVFlag flag where - exactTVDelimiters :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] -> flag -> EP w m (HsTyVarBndr flag GhcPs) - -> EP w m (EpAnn [AddEpAnn], (HsTyVarBndr flag GhcPs)) - -instance ExactPrintTVFlag () where - exactTVDelimiters an _ thing_inside = do - an0 <- markEpAnnAllL an lid AnnOpenP - r <- thing_inside - an1 <- markEpAnnAllL an0 lid AnnCloseP - return (an1, r) - -instance ExactPrintTVFlag Specificity where - exactTVDelimiters an s thing_inside = do - an0 <- markEpAnnAllL an lid open - r <- thing_inside - an1 <- markEpAnnAllL an0 lid close - return (an1, r) - where - (open, close) = case s of - SpecifiedSpec -> (AnnOpenP, AnnCloseP) - InferredSpec -> (AnnOpenC, AnnCloseC) - -instance ExactPrintTVFlag (HsBndrVis GhcPs) where - exactTVDelimiters an0 bvis thing_inside = do - case bvis of - HsBndrRequired -> return () - HsBndrInvisible at -> markToken at >> return () - an1 <- markEpAnnAllL an0 lid AnnOpenP - r <- thing_inside - an2 <- markEpAnnAllL an1 lid AnnCloseP - return (an2, r) - -instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where - getAnnotationEntry (UserTyVar an _ _) = fromAnn an - getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an - - setAnnotationAnchor (UserTyVar an a b) anc cs = UserTyVar (setAnchorEpa an anc cs) a b - setAnnotationAnchor (KindedTyVar an a b c) anc cs = KindedTyVar (setAnchorEpa an anc cs) a b c - - exact (UserTyVar an flag n) = do - r <- exactTVDelimiters an flag $ do - n' <- markAnnotated n - return (UserTyVar an flag n') - case r of - (an', UserTyVar _ flag'' n'') -> return (UserTyVar an' flag'' n'') - _ -> error "KindedTyVar should never happen here" - exact (KindedTyVar an flag n k) = do - r <- exactTVDelimiters an flag $ do - n' <- markAnnotated n - an0 <- markEpAnnL an lidl AnnDcolon - k' <- markAnnotated k - return (KindedTyVar an0 flag n' k') - case r of - (an',KindedTyVar _ flag'' n'' k'') -> return (KindedTyVar an' flag'' n'' k'') - _ -> error "UserTyVar should never happen here" - --- --------------------------------------------------------------------- - -instance ExactPrint (HsType GhcPs) where - getAnnotationEntry (HsForAllTy _ _ _) = NoEntryVal - getAnnotationEntry (HsQualTy _ _ _) = NoEntryVal - getAnnotationEntry (HsTyVar an _ _) = fromAnn an - getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal - getAnnotationEntry (HsAppKindTy _ _ _ _) = NoEntryVal - getAnnotationEntry (HsFunTy an _ _ _) = fromAnn an - getAnnotationEntry (HsListTy an _) = fromAnn an - getAnnotationEntry (HsTupleTy an _ _) = fromAnn an - getAnnotationEntry (HsSumTy an _) = fromAnn an - getAnnotationEntry (HsOpTy an _ _ _ _) = fromAnn an - getAnnotationEntry (HsParTy an _) = fromAnn an - getAnnotationEntry (HsIParamTy an _ _) = fromAnn an - getAnnotationEntry (HsStarTy _ _) = NoEntryVal - getAnnotationEntry (HsKindSig an _ _) = fromAnn an - getAnnotationEntry (HsSpliceTy _ _) = NoEntryVal - getAnnotationEntry (HsDocTy an _ _) = fromAnn an - getAnnotationEntry (HsBangTy an _ _) = fromAnn an - getAnnotationEntry (HsRecTy an _) = fromAnn an - getAnnotationEntry (HsExplicitListTy an _ _) = fromAnn an - getAnnotationEntry (HsExplicitTupleTy an _) = fromAnn an - getAnnotationEntry (HsTyLit _ _) = NoEntryVal - getAnnotationEntry (HsWildCardTy _) = NoEntryVal - getAnnotationEntry (XHsType _) = NoEntryVal - - setAnnotationAnchor a@(HsForAllTy _ _ _) _ _s = a - setAnnotationAnchor a@(HsQualTy _ _ _) _ _s = a - setAnnotationAnchor (HsTyVar an a b) anc cs = (HsTyVar (setAnchorEpa an anc cs) a b) - setAnnotationAnchor a@(HsAppTy _ _ _) _ _s = a - setAnnotationAnchor a@(HsAppKindTy _ _ _ _) _ _s = a - setAnnotationAnchor (HsFunTy an a b c) anc cs = (HsFunTy (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (HsListTy an a) anc cs = (HsListTy (setAnchorEpa an anc cs) a) - setAnnotationAnchor (HsTupleTy an a b) anc cs = (HsTupleTy (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsSumTy an a) anc cs = (HsSumTy (setAnchorEpa an anc cs) a) - setAnnotationAnchor a@(HsOpTy _ _ _ _ _) _ _s = a - setAnnotationAnchor (HsParTy an a) anc cs = (HsParTy (setAnchorEpa an anc cs) a) - setAnnotationAnchor (HsIParamTy an a b) anc cs = (HsIParamTy (setAnchorEpa an anc cs) a b) - setAnnotationAnchor a@(HsStarTy _ _) _ _s = a - setAnnotationAnchor (HsKindSig an a b) anc cs = (HsKindSig (setAnchorEpa an anc cs) a b) - setAnnotationAnchor a@(HsSpliceTy _ _) _ _s = a - setAnnotationAnchor (HsDocTy an a b) anc cs = (HsDocTy (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsBangTy an a b) anc cs = (HsBangTy (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsRecTy an a) anc cs = (HsRecTy (setAnchorEpa an anc cs) a) - setAnnotationAnchor (HsExplicitListTy an a b) anc cs = (HsExplicitListTy (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsExplicitTupleTy an a) anc cs = (HsExplicitTupleTy (setAnchorEpa an anc cs) a) - setAnnotationAnchor a@(HsTyLit _ _) _ _s = a - setAnnotationAnchor a@(HsWildCardTy _) _ _s = a - setAnnotationAnchor a@(XHsType _) _ _s = a - - exact (HsForAllTy { hst_xforall = an - , hst_tele = tele, hst_body = ty }) = do - tele' <- markAnnotated tele - ty' <- markAnnotated ty - return (HsForAllTy { hst_xforall = an - , hst_tele = tele', hst_body = ty' }) - - exact (HsQualTy an ctxt ty) = do - ctxt' <- markAnnotated ctxt - ty' <- markAnnotated ty - return (HsQualTy an ctxt' ty') - exact (HsTyVar an promoted name) = do - an0 <- if (promoted == IsPromoted) - then markEpAnnL an lidl AnnSimpleQuote - else return an - name' <- markAnnotated name - return (HsTyVar an0 promoted name') - exact (HsAppTy an t1 t2) = do - t1' <- markAnnotated t1 - t2' <- markAnnotated t2 - return (HsAppTy an t1' t2') - exact (HsAppKindTy ss ty at ki) = do - ty' <- markAnnotated ty - at' <- markToken at - ki' <- markAnnotated ki - return (HsAppKindTy ss ty' at' ki') - exact (HsFunTy an mult ty1 ty2) = do - ty1' <- markAnnotated ty1 - mult' <- markArrow mult - ty2' <- markAnnotated ty2 - return (HsFunTy an mult' ty1' ty2') - exact (HsListTy an tys) = do - an0 <- markOpeningParen an - tys' <- markAnnotated tys - an1 <- markClosingParen an0 - return (HsListTy an1 tys') - exact (HsTupleTy an con tys) = do - an0 <- markOpeningParen an - tys' <- markAnnotated tys - an1 <- markClosingParen an0 - return (HsTupleTy an1 con tys') - exact (HsSumTy an tys) = do - an0 <- markOpeningParen an - tys' <- markAnnotated tys - an1 <- markClosingParen an0 - return (HsSumTy an1 tys') - exact (HsOpTy an promoted t1 lo t2) = do - an0 <- if (isPromoted promoted) - then markEpAnnL an lidl AnnSimpleQuote - else return an - t1' <- markAnnotated t1 - lo' <- markAnnotated lo - t2' <- markAnnotated t2 - return (HsOpTy an0 promoted t1' lo' t2') - exact (HsParTy an ty) = do - an0 <- markOpeningParen an - ty' <- markAnnotated ty - an1 <- markClosingParen an0 - return (HsParTy an1 ty') - exact (HsIParamTy an n t) = do - n' <- markAnnotated n - an0 <- markEpAnnL an lidl AnnDcolon - t' <- markAnnotated t - return (HsIParamTy an0 n' t') - exact (HsStarTy an isUnicode) = do - if isUnicode - then printStringAdvance "\x2605" -- Unicode star - else printStringAdvance "*" - return (HsStarTy an isUnicode) - exact (HsKindSig an ty k) = do - ty' <- markAnnotated ty - an0 <- markEpAnnL an lidl AnnDcolon - k' <- markAnnotated k - return (HsKindSig an0 ty' k') - exact (HsSpliceTy a splice) = do - splice' <- markAnnotated splice - return (HsSpliceTy a splice') - exact (HsDocTy an ty doc) = do - ty' <- markAnnotated ty - -- doc' <- markAnnotated doc - return (HsDocTy an ty' doc) - exact (HsBangTy an (HsSrcBang mt up str) ty) = do - an0 <- - case mt of - NoSourceText -> return an - SourceText src -> do - debugM $ "HsBangTy: src=" ++ showAst src - an0 <- markEpAnnLMS an lid AnnOpen (Just $ unpackFS src) - an1 <- markEpAnnLMS an0 lid AnnClose (Just "#-}") - debugM $ "HsBangTy: done unpackedness" - return an1 - an1 <- - case str of - SrcLazy -> markEpAnnL an0 lidl AnnTilde - SrcStrict -> markEpAnnL an0 lidl AnnBang - NoSrcStrict -> return an0 - ty' <- markAnnotated ty - return (HsBangTy an1 (HsSrcBang mt up str) ty') - exact (HsExplicitListTy an prom tys) = do - an0 <- if (isPromoted prom) - then markEpAnnL an lidl AnnSimpleQuote - else return an - an1 <- markEpAnnL an0 lidl AnnOpenS - tys' <- markAnnotated tys - an2 <- markEpAnnL an1 lidl AnnCloseS - return (HsExplicitListTy an2 prom tys') - exact (HsExplicitTupleTy an tys) = do - an0 <- markEpAnnL an lidl AnnSimpleQuote - an1 <- markEpAnnL an0 lidl AnnOpenP - tys' <- markAnnotated tys - an2 <- markEpAnnL an1 lidl AnnCloseP - return (HsExplicitTupleTy an2 tys') - exact (HsTyLit a lit) = do - case lit of - (HsNumTy src v) -> printSourceText src (show v) - (HsStrTy src v) -> printSourceText src (show v) - (HsCharTy src v) -> printSourceText src (show v) - return (HsTyLit a lit) - exact t@(HsWildCardTy _) = printStringAdvance "_" >> return t - exact x@(HsRecTy _ _) = error $ "missing match for HsType:" ++ showAst x - exact x@(XHsType _) = error $ "missing match for HsType:" ++ showAst x - - --- --------------------------------------------------------------------- - -instance ExactPrint (HsForAllTelescope GhcPs) where - getAnnotationEntry (HsForAllVis an _) = fromAnn an - getAnnotationEntry (HsForAllInvis an _) = fromAnn an - - setAnnotationAnchor (HsForAllVis an a) anc cs = HsForAllVis (setAnchorEpa an anc cs) a - setAnnotationAnchor (HsForAllInvis an a) anc cs = HsForAllInvis (setAnchorEpa an anc cs) a - - exact (HsForAllVis an bndrs) = do - an0 <- markLensAA an lfst -- AnnForall - bndrs' <- markAnnotated bndrs - an1 <- markLensAA an0 lsnd -- AnnRarrow - return (HsForAllVis an1 bndrs') - - exact (HsForAllInvis an bndrs) = do - an0 <- markLensAA an lfst -- AnnForall - bndrs' <- markAnnotated bndrs - an1 <- markLensAA an0 lsnd -- AnnDot - return (HsForAllInvis an1 bndrs') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsDerivingClause GhcPs) where - getAnnotationEntry d@(HsDerivingClause{}) = fromAnn (deriv_clause_ext d) - setAnnotationAnchor x anc cs = (x { deriv_clause_ext = setAnchorEpa (deriv_clause_ext x) anc cs}) - `debug` ("setAnnotationAnchor HsDerivingClause: (anc,cs):" ++ showAst (anc,cs)) - - exact (HsDerivingClause { deriv_clause_ext = an - , deriv_clause_strategy = dcs - , deriv_clause_tys = dct }) = do - an0 <- markEpAnnL an lidl AnnDeriving - exact_strat_before - dct' <- markAnnotated dct - exact_strat_after - return (HsDerivingClause { deriv_clause_ext = an0 - , deriv_clause_strategy = dcs - , deriv_clause_tys = dct' }) - where - (exact_strat_before, exact_strat_after) = - case dcs of - Just v@(L _ ViaStrategy{}) -> (pure (), markAnnotated v >> pure ()) - _ -> (mapM_ markAnnotated dcs, pure ()) - --- --------------------------------------------------------------------- - -instance ExactPrint (DerivStrategy GhcPs) where - getAnnotationEntry (StockStrategy an) = fromAnn an - getAnnotationEntry (AnyclassStrategy an) = fromAnn an - getAnnotationEntry (NewtypeStrategy an) = fromAnn an - getAnnotationEntry (ViaStrategy (XViaStrategyPs an _)) = fromAnn an - - setAnnotationAnchor (StockStrategy an) anc cs = (StockStrategy (setAnchorEpa an anc cs)) - setAnnotationAnchor (AnyclassStrategy an) anc cs = (AnyclassStrategy (setAnchorEpa an anc cs)) - setAnnotationAnchor (NewtypeStrategy an) anc cs = (NewtypeStrategy (setAnchorEpa an anc cs)) - setAnnotationAnchor (ViaStrategy (XViaStrategyPs an a)) anc cs = (ViaStrategy (XViaStrategyPs (setAnchorEpa an anc cs) a)) - - exact (StockStrategy an) = do - an0 <- markEpAnnL an lid AnnStock - return (StockStrategy an0) - exact (AnyclassStrategy an) = do - an0 <- markEpAnnL an lid AnnAnyclass - return (AnyclassStrategy an0) - exact (NewtypeStrategy an) = do - an0 <- markEpAnnL an lid AnnNewtype - return (NewtypeStrategy an0) - exact (ViaStrategy (XViaStrategyPs an ty)) = do - an0 <- markEpAnnL an lid AnnVia - ty' <- markAnnotated ty - return (ViaStrategy (XViaStrategyPs an0 ty')) - --- --------------------------------------------------------------------- - -instance (ExactPrint a) => ExactPrint (LocatedC a) where - getAnnotationEntry (L sann _) = fromAnn sann - setAnnotationAnchor = setAnchorAn - - exact (L (SrcSpanAnn EpAnnNotUsed l) a) = do - a' <- markAnnotated a - return (L (SrcSpanAnn EpAnnNotUsed l) a') - exact (L (SrcSpanAnn (EpAnn anc (AnnContext ma opens closes) cs) l) a) = do - opens' <- mapM (markKwA AnnOpenP) opens - a' <- markAnnotated a - closes' <- mapM (markKwA AnnCloseP) closes - ma' <- case ma of - Just (UnicodeSyntax, r) -> Just . (UnicodeSyntax,) <$> markKwA AnnDarrowU r - Just (NormalSyntax, r) -> Just . (NormalSyntax,) <$> markKwA AnnDarrow r - Nothing -> pure Nothing - return (L (SrcSpanAnn (EpAnn anc (AnnContext ma' opens' closes') cs) l) a') - --- --------------------------------------------------------------------- - -instance ExactPrint (DerivClauseTys GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (DctSingle x ty) = do - ty' <- markAnnotated ty - return (DctSingle x ty') - exact (DctMulti x tys) = do - tys' <- markAnnotated tys - return (DctMulti x tys') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsSigType GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (HsSig a bndrs ty) = do - bndrs' <- markAnnotated bndrs - ty' <- markAnnotated ty - return (HsSig a bndrs' ty') - --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedN RdrName) where - getAnnotationEntry (L sann _) = fromAnn sann - setAnnotationAnchor = setAnchorAn - - exact x@(L (SrcSpanAnn EpAnnNotUsed l) n) = do - _ <- printUnicode (spanAsAnchor l) n - return x - exact (L (SrcSpanAnn (EpAnn anc ann cs) ll) n) = do - ann' <- - case ann of - NameAnn a o l c t -> do - mn <- markName a o (Just (l,n)) c - case mn of - (o', (Just (l',_n)), c') -> do -- (o', (Just (l',n')), c') - t' <- markTrailing t - return (NameAnn a o' l' c' t') - _ -> error "ExactPrint (LocatedN RdrName)" - NameAnnCommas a o commas c t -> do - let (kwo,kwc) = adornments a - (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o) - commas' <- forM commas (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnComma loc)) - (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c) - t' <- markTrailing t - return (NameAnnCommas a o' commas' c' t') - NameAnnBars a o bars c t -> do - let (kwo,kwc) = adornments a - (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o) - bars' <- forM bars (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnVbar loc)) - (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c) - t' <- markTrailing t - return (NameAnnBars a o' bars' c' t') - NameAnnOnly a o c t -> do - (o',_,c') <- markName a o Nothing c - t' <- markTrailing t - return (NameAnnOnly a o' c' t') - NameAnnRArrow unicode o nl c t -> do - o' <- case o of - Just o0 -> do - (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn AnnOpenP o0) - return (Just o') - Nothing -> return Nothing - (AddEpAnn _ nl') <- - if unicode - then markKwC NoCaptureComments (AddEpAnn AnnRarrowU nl) - else markKwC NoCaptureComments (AddEpAnn AnnRarrow nl) - c' <- case c of - Just c0 -> do - (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn AnnCloseP c0) - return (Just c') - Nothing -> return Nothing - t' <- markTrailing t - return (NameAnnRArrow unicode o' nl' c' t') - NameAnnQuote q name t -> do - debugM $ "NameAnnQuote" - (AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q) - (L name' _) <- markAnnotated (L name n) - t' <- markTrailing t - return (NameAnnQuote q' name' t') - NameAnnTrailing t -> do - _anc' <- printUnicode anc n - t' <- markTrailing t - return (NameAnnTrailing t') - return (L (SrcSpanAnn (EpAnn anc ann' cs) ll) n) - -locFromAdd :: AddEpAnn -> EpaLocation -locFromAdd (AddEpAnn _ loc) = loc - -printUnicode :: (Monad m, Monoid w) => Anchor -> RdrName -> EP w m Anchor -printUnicode anc n = do - let str = case (showPprUnsafe n) of - -- TODO: unicode support? - "forall" -> if spanLength (anchor anc) == 1 then "∀" else "forall" - s -> s - loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str - case loc of - EpaSpan _ _ -> return anc - EpaDelta dp [] -> return anc { anchor_op = MovedAnchor dp } - EpaDelta _ _cs -> error "printUnicode should not capture comments" - - -markName :: (Monad m, Monoid w) - => NameAdornment -> EpaLocation -> Maybe (EpaLocation,RdrName) -> EpaLocation - -> EP w m (EpaLocation, Maybe (EpaLocation,RdrName), EpaLocation) -markName adorn open mname close = do - let (kwo,kwc) = adornments adorn - (AddEpAnn _ open') <- markKwC CaptureComments (AddEpAnn kwo open) - mname' <- - case mname of - Nothing -> return Nothing - Just (name, a) -> do - name' <- printStringAtAAC CaptureComments name (showPprUnsafe a) - return (Just (name',a)) - (AddEpAnn _ close') <- markKwC CaptureComments (AddEpAnn kwc close) - return (open', mname', close') - -adornments :: NameAdornment -> (AnnKeywordId, AnnKeywordId) -adornments NameParens = (AnnOpenP, AnnCloseP) -adornments NameParensHash = (AnnOpenPH, AnnClosePH) -adornments NameBackquotes = (AnnBackquote, AnnBackquote) -adornments NameSquare = (AnnOpenS, AnnCloseS) - - -markTrailingL :: (Monad m, Monoid w) => EpAnn a -> Lens a [TrailingAnn] -> EP w m (EpAnn a) -markTrailingL EpAnnNotUsed _ = return EpAnnNotUsed -markTrailingL (EpAnn anc an cs) l = do - ts <- mapM markKwT (view l an) - return (EpAnn anc (set l ts an) cs) - -markTrailing :: (Monad m, Monoid w) => [TrailingAnn] -> EP w m [TrailingAnn] -markTrailing ts = do - p <- getPosP - debugM $ "markTrailing:" ++ showPprUnsafe (p,ts) - mapM markKwT ts - --- --------------------------------------------------------------------- - --- based on pp_condecls in Decls.hs -exact_condecls :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] -> [LConDecl GhcPs] -> EP w m (EpAnn [AddEpAnn],[LConDecl GhcPs]) -exact_condecls an cs - | gadt_syntax -- In GADT syntax - = do - cs' <- mapM markAnnotated cs - return (an, cs') - | otherwise -- In H98 syntax - = do - an0 <- markEpAnnL an lidl AnnEqual - cs' <- mapM markAnnotated cs - return (an0, cs') - where - gadt_syntax = case cs of - [] -> False - (L _ ConDeclH98{} : _) -> False - (L _ ConDeclGADT{} : _) -> True - --- --------------------------------------------------------------------- - -instance ExactPrint (ConDecl GhcPs) where - getAnnotationEntry x@(ConDeclGADT{}) = fromAnn (con_g_ext x) - getAnnotationEntry x@(ConDeclH98{}) = fromAnn (con_ext x) - - setAnnotationAnchor x@ConDeclGADT{} anc cs = x { con_g_ext = setAnchorEpa (con_g_ext x) anc cs} - setAnnotationAnchor x@ConDeclH98{} anc cs = x { con_ext = setAnchorEpa (con_ext x) anc cs} - --- based on pprConDecl - exact (ConDeclH98 { con_ext = an - , con_name = con - , con_forall = has_forall - , con_ex_tvs = ex_tvs - , con_mb_cxt = mcxt - , con_args = args - , con_doc = doc }) = do - -- doc' <- mapM markAnnotated doc - an0 <- if has_forall - then markEpAnnL an lidl AnnForall - else return an - ex_tvs' <- mapM markAnnotated ex_tvs - an1 <- if has_forall - then markEpAnnL an0 lidl AnnDot - else return an0 - mcxt' <- mapM markAnnotated mcxt - an2 <- if (isJust mcxt) - then markEpAnnL an1 lidl AnnDarrow - else return an1 - - (con', args') <- exact_details args - return (ConDeclH98 { con_ext = an2 - , con_name = con' - , con_forall = has_forall - , con_ex_tvs = ex_tvs' - , con_mb_cxt = mcxt' - , con_args = args' - , con_doc = doc }) - - where - -- -- In ppr_details: let's not print the multiplicities (they are always 1, by - -- -- definition) as they do not appear in an actual declaration. - exact_details (InfixCon t1 t2) = do - t1' <- markAnnotated t1 - con' <- markAnnotated con - t2' <- markAnnotated t2 - return (con', InfixCon t1' t2') - exact_details (PrefixCon tyargs tys) = do - con' <- markAnnotated con - tyargs' <- markAnnotated tyargs - tys' <- markAnnotated tys - return (con', PrefixCon tyargs' tys') - exact_details (RecCon fields) = do - con' <- markAnnotated con - fields' <- markAnnotated fields - return (con', RecCon fields') - - -- ----------------------------------- - - exact (ConDeclGADT { con_g_ext = an - , con_names = cons - , con_dcolon = dcol - , con_bndrs = bndrs - , con_mb_cxt = mcxt, con_g_args = args - , con_res_ty = res_ty, con_doc = doc }) = do - -- doc' <- mapM markAnnotated doc - cons' <- mapM markAnnotated cons - dcol' <- markUniToken dcol - an1 <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] - - -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558 - bndrs' <- case bndrs of - L _ (HsOuterImplicit _) -> return bndrs - _ -> markAnnotated bndrs - - mcxt' <- mapM markAnnotated mcxt - an2 <- if (isJust mcxt) - then markEpAnnL an1 lidl AnnDarrow - else return an1 - args' <- - case args of - (PrefixConGADT args0) -> do - args0' <- mapM markAnnotated args0 - return (PrefixConGADT args0') - (RecConGADT fields rarr) -> do - fields' <- markAnnotated fields - rarr' <- markUniToken rarr - return (RecConGADT fields' rarr') - res_ty' <- markAnnotated res_ty - return (ConDeclGADT { con_g_ext = an2 - , con_names = cons' - , con_dcolon = dcol' - , con_bndrs = bndrs' - , con_mb_cxt = mcxt', con_g_args = args' - , con_res_ty = res_ty', con_doc = doc }) - --- --------------------------------------------------------------------- - -instance ExactPrint Void where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact x = return x - --- --------------------------------------------------------------------- - -instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where - getAnnotationEntry (HsOuterImplicit _) = NoEntryVal - getAnnotationEntry (HsOuterExplicit an _) = fromAnn an - - setAnnotationAnchor (HsOuterImplicit a) _ _ = HsOuterImplicit a - setAnnotationAnchor (HsOuterExplicit an a) anc cs = HsOuterExplicit (setAnchorEpa an anc cs) a - - exact b@(HsOuterImplicit _) = pure b - exact (HsOuterExplicit an bndrs) = do - an0 <- markLensAA an lfst -- "forall" - bndrs' <- markAnnotated bndrs - an1 <- markLensAA an0 lsnd -- "." - return (HsOuterExplicit an1 bndrs') - --- --------------------------------------------------------------------- - -instance ExactPrint (ConDeclField GhcPs) where - getAnnotationEntry f@(ConDeclField{}) = fromAnn (cd_fld_ext f) - - setAnnotationAnchor x anc cs = x { cd_fld_ext = setAnchorEpa (cd_fld_ext x) anc cs} - - exact (ConDeclField an names ftype mdoc) = do - names' <- markAnnotated names - an0 <- markEpAnnL an lidl AnnDcolon - ftype' <- markAnnotated ftype - -- mdoc' <- mapM markAnnotated mdoc - return (ConDeclField an0 names' ftype' mdoc) - --- --------------------------------------------------------------------- - -instance ExactPrint (FieldOcc GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact f@(FieldOcc _ n) = markAnnotated n >> return f - --- --------------------------------------------------------------------- - -instance ExactPrint (AmbiguousFieldOcc GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact f@(Unambiguous _ n) = markAnnotated n >> return f - exact f@(Ambiguous _ n) = markAnnotated n >> return f - --- --------------------------------------------------------------------- - -instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (HsScaled arr t) = do - t' <- markAnnotated t - arr' <- markArrow arr - return (HsScaled arr' t') - --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedP CType) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - - exact x@(L (SrcSpanAnn EpAnnNotUsed _) ct) = withPpr ct >> return x - exact (L (SrcSpanAnn an ll) - (CType stp mh (stct,ct))) = do - an0 <- markAnnOpenP an stp "{-# CTYPE" - an1 <- case mh of - Nothing -> return an0 - Just (Header srcH _h) -> - markEpAnnLMS an0 lapr_rest AnnHeader (Just (toSourceTextWithSuffix srcH "" "")) - an2 <- markEpAnnLMS an1 lapr_rest AnnVal (Just (toSourceTextWithSuffix stct (unpackFS ct) "")) - an3 <- markAnnCloseP an2 - return (L (SrcSpanAnn an3 ll) - (CType stp mh (stct,ct))) - --- --------------------------------------------------------------------- - -instance ExactPrint (SourceText, RuleName) where - -- We end up at the right place from the Located wrapper - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (st, rn) - = printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "") - >> return (st, rn) - - --- ===================================================================== --- LocatedL instances start -- --- --- Each is dealt with specifically, as they have --- different wrapping annotations in the al_rest zone. --- --- In future, the annotation could perhaps be improved, with an --- 'al_pre' and 'al_post' set of annotations to be simply sorted and --- applied. --- --------------------------------------------------------------------- - -instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - - exact (L (SrcSpanAnn an l) ies) = do - debugM $ "LocatedL [LIE" - an0 <- markEpAnnL an lal_rest AnnHiding - p <- getPosP - debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p - (an1, ies') <- markAnnList True an0 (markAnnotated ies) - return (L (SrcSpanAnn an1 l) ies') - -instance (ExactPrint (Match GhcPs (LocatedA body))) - => ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA body))]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L la a) = do - let an = ann la - debugM $ "LocatedL [LMatch" - -- TODO: markAnnList? - an0 <- markEpAnnAllL an lal_rest AnnWhere - an1 <- markLensMAA an0 lal_open - an2 <- markEpAnnAllL an1 lal_rest AnnSemi - a' <- markAnnotated a - an3 <- markLensMAA an2 lal_close - return (L (la { ann = an3}) a') - -instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L (SrcSpanAnn an l) stmts) = do - debugM $ "LocatedL [ExprLStmt" - (an'', stmts') <- markAnnList True an $ do - case snocView stmts of - Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do - debugM $ "LocatedL [ExprLStmt: snocView" - ls' <- markAnnotated ls - initStmts' <- markAnnotated initStmts - return (initStmts' ++ [ls']) - _ -> do - markAnnotated stmts - return (L (SrcSpanAnn an'' l) stmts') - --- instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where -instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L (SrcSpanAnn ann l) es) = do - debugM $ "LocatedL [CmdLStmt" - an0 <- markLensMAA ann lal_open - es' <- mapM markAnnotated es - an1 <- markLensMAA an0 lal_close - return (L (SrcSpanAnn an1 l) es') - -instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L (SrcSpanAnn an l) fs) = do - debugM $ "LocatedL [LConDeclField" - (an', fs') <- markAnnList True an (markAnnotated fs) - return (L (SrcSpanAnn an' l) fs') - -instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L (SrcSpanAnn an l) bf) = do - debugM $ "LocatedL [LBooleanFormula" - (an', bf') <- markAnnList True an (markAnnotated bf) - return (L (SrcSpanAnn an' l) bf') - --- --------------------------------------------------------------------- --- LocatedL instances end -- --- ===================================================================== - -instance ExactPrint (IE GhcPs) where - getAnnotationEntry (IEVar _ _) = NoEntryVal - getAnnotationEntry (IEThingAbs (_, an) _) = fromAnn an - getAnnotationEntry (IEThingAll (_, an) _) = fromAnn an - getAnnotationEntry (IEThingWith (_, an) _ _ _) = fromAnn an - getAnnotationEntry (IEModuleContents (_, an) _)= fromAnn an - getAnnotationEntry (IEGroup _ _ _) = NoEntryVal - getAnnotationEntry (IEDoc _ _) = NoEntryVal - getAnnotationEntry (IEDocNamed _ _) = NoEntryVal - - setAnnotationAnchor a@(IEVar _ _) _ _s = a - setAnnotationAnchor (IEThingAbs (depr, an) a) anc cs = (IEThingAbs (depr, setAnchorEpa an anc cs) a) - setAnnotationAnchor (IEThingAll (depr, an) a) anc cs = (IEThingAll (depr, setAnchorEpa an anc cs) a) - setAnnotationAnchor (IEThingWith (depr, an) a b c) anc cs = (IEThingWith (depr, setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (IEModuleContents (depr, an) a) anc cs = (IEModuleContents (depr, setAnchorEpa an anc cs) a) - setAnnotationAnchor a@(IEGroup _ _ _) _ _s = a - setAnnotationAnchor a@(IEDoc _ _) _ _s = a - setAnnotationAnchor a@(IEDocNamed _ _) _ _s = a - - exact (IEVar depr ln) = do - depr' <- markAnnotated depr - ln' <- markAnnotated ln - return (IEVar depr' ln') - exact (IEThingAbs (depr, an) thing) = do - depr' <- markAnnotated depr - thing' <- markAnnotated thing - return (IEThingAbs (depr', an) thing') - exact (IEThingAll (depr, an) thing) = do - depr' <- markAnnotated depr - thing' <- markAnnotated thing - an0 <- markEpAnnL an lidl AnnOpenP - an1 <- markEpAnnL an0 lidl AnnDotdot - an2 <- markEpAnnL an1 lidl AnnCloseP - return (IEThingAll (depr', an2) thing') - - exact (IEThingWith (depr, an) thing wc withs) = do - depr' <- markAnnotated depr - thing' <- markAnnotated thing - an0 <- markEpAnnL an lidl AnnOpenP - (an1, wc', withs') <- - case wc of - NoIEWildcard -> do - withs'' <- markAnnotated withs - return (an0, wc, withs'') - IEWildcard pos -> do - let (bs, as) = splitAt pos withs - bs' <- markAnnotated bs - an1 <- markEpAnnL an0 lidl AnnDotdot - an2 <- markEpAnnL an1 lidl AnnComma - as' <- markAnnotated as - return (an2, wc, bs'++as') - an2 <- markEpAnnL an1 lidl AnnCloseP - return (IEThingWith (depr', an2) thing' wc' withs') - - exact (IEModuleContents (depr, an) m) = do - depr' <- markAnnotated depr - an0 <- markEpAnnL an lidl AnnModule - m' <- markAnnotated m - return (IEModuleContents (depr', an0) m') - - -- These three exist to not error out, but are no-ops The contents - -- appear as "normal" comments too, which we process instead. - exact (IEGroup x lev doc) = do - return (IEGroup x lev doc) - exact (IEDoc x doc) = do - return (IEDoc x doc) - exact (IEDocNamed x str) = do - return (IEDocNamed x str) - --- --------------------------------------------------------------------- - -instance ExactPrint (IEWrappedName GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (IEName x n) = do - n' <- markAnnotated n - return (IEName x n') - exact (IEPattern r n) = do - r' <- printStringAtAA r "pattern" - n' <- markAnnotated n - return (IEPattern r' n') - exact (IEType r n) = do - r' <- printStringAtAA r "type" - n' <- markAnnotated n - return (IEType r' n') - --- --------------------------------------------------------------------- - -instance ExactPrint (Pat GhcPs) where - getAnnotationEntry (WildPat _) = NoEntryVal - getAnnotationEntry (VarPat _ _) = NoEntryVal - getAnnotationEntry (LazyPat an _) = fromAnn an - getAnnotationEntry (AsPat an _ _ _) = fromAnn an - getAnnotationEntry (ParPat an _ _ _) = fromAnn an - getAnnotationEntry (BangPat an _) = fromAnn an - getAnnotationEntry (ListPat an _) = fromAnn an - getAnnotationEntry (TuplePat an _ _) = fromAnn an - getAnnotationEntry (SumPat an _ _ _) = fromAnn an - getAnnotationEntry (ConPat an _ _) = fromAnn an - getAnnotationEntry (ViewPat an _ _) = fromAnn an - getAnnotationEntry (SplicePat _ _) = NoEntryVal - getAnnotationEntry (LitPat _ _) = NoEntryVal - getAnnotationEntry (NPat an _ _ _) = fromAnn an - getAnnotationEntry (NPlusKPat an _ _ _ _ _) = fromAnn an - getAnnotationEntry (SigPat an _ _) = fromAnn an - - setAnnotationAnchor a@(WildPat _) _ _s = a - setAnnotationAnchor a@(VarPat _ _) _ _s = a - setAnnotationAnchor (LazyPat an a) anc cs = (LazyPat (setAnchorEpa an anc cs) a) - setAnnotationAnchor (AsPat an a at b) anc cs = (AsPat (setAnchorEpa an anc cs) a at b) - setAnnotationAnchor (ParPat an a b c) anc cs = (ParPat (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (BangPat an a) anc cs = (BangPat (setAnchorEpa an anc cs) a) - setAnnotationAnchor (ListPat an a) anc cs = (ListPat (setAnchorEpa an anc cs) a) - setAnnotationAnchor (TuplePat an a b) anc cs = (TuplePat (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (SumPat an a b c) anc cs = (SumPat (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (ConPat an a b) anc cs = (ConPat (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (ViewPat an a b) anc cs = (ViewPat (setAnchorEpa an anc cs) a b) - setAnnotationAnchor a@(SplicePat _ _) _ _s = a - setAnnotationAnchor a@(LitPat _ _) _ _s = a - setAnnotationAnchor (NPat an a b c) anc cs = (NPat (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (NPlusKPat an a b c d e) anc cs = (NPlusKPat (setAnchorEpa an anc cs) a b c d e) - setAnnotationAnchor (SigPat an a b) anc cs = (SigPat (setAnchorEpa an anc cs) a b) - - exact (WildPat w) = do - anchor <- getAnchorU - debugM $ "WildPat:anchor=" ++ show anchor - _ <- printStringAtRs anchor "_" - return (WildPat w) - exact (VarPat x n) = do - -- The parser inserts a placeholder value for a record pun rhs. This must be - -- filtered. - let pun_RDR = "pun-right-hand-side" - n' <- if (showPprUnsafe n /= pun_RDR) - then markAnnotated n - else return n - return (VarPat x n') - exact (LazyPat an pat) = do - an0 <- markEpAnnL an lidl AnnTilde - pat' <- markAnnotated pat - return (LazyPat an0 pat') - exact (AsPat an n at pat) = do - n' <- markAnnotated n - at' <- markToken at - pat' <- markAnnotated pat - return (AsPat an n' at' pat') - exact (ParPat an lpar pat rpar) = do - lpar' <- markToken lpar - pat' <- markAnnotated pat - rpar' <- markToken rpar - return (ParPat an lpar' pat' rpar') - - exact (BangPat an pat) = do - an0 <- markEpAnnL an lidl AnnBang - pat' <- markAnnotated pat - return (BangPat an0 pat') - - exact (ListPat an pats) = do - (an', pats') <- markAnnList True an (markAnnotated pats) - return (ListPat an' pats') - - exact (TuplePat an pats boxity) = do - an0 <- case boxity of - Boxed -> markEpAnnL an lidl AnnOpenP - Unboxed -> markEpAnnL an lidl AnnOpenPH - pats' <- markAnnotated pats - an1 <- case boxity of - Boxed -> markEpAnnL an0 lidl AnnCloseP - Unboxed -> markEpAnnL an0 lidl AnnClosePH - return (TuplePat an1 pats' boxity) - - exact (SumPat an pat alt arity) = do - an0 <- markEpAnnL an lsumPatParens AnnOpenPH - an1 <- markAnnKwAllL an0 lsumPatVbarsBefore AnnVbar - pat' <- markAnnotated pat - an2 <- markAnnKwAllL an1 lsumPatVbarsAfter AnnVbar - an3 <- markEpAnnL an2 lsumPatParens AnnClosePH - return (SumPat an3 pat' alt arity) - - -- | ConPat an con args) - exact (ConPat an con details) = do - (an', con', details') <- exactUserCon an con details - return (ConPat an' con' details') - exact (ViewPat an expr pat) = do - expr' <- markAnnotated expr - an0 <- markEpAnnL an lidl AnnRarrow - pat' <- markAnnotated pat - return (ViewPat an0 expr' pat') - exact (SplicePat x splice) = do - splice' <- markAnnotated splice - return (SplicePat x splice') - exact p@(LitPat _ lit) = printStringAdvance (hsLit2String lit) >> return p - exact (NPat an ol mn z) = do - an0 <- if (isJust mn) - then markEpAnnL an lidl AnnMinus - else return an - ol' <- markAnnotated ol - return (NPat an0 ol' mn z) - - -- | NPlusKPat an n lit1 lit2 _ _) - exact (NPlusKPat an n k lit2 a b) = do - n' <- markAnnotated n - an' <- printStringAtAAL an lid "+" - k' <- markAnnotated k - return (NPlusKPat an' n' k' lit2 a b) - - exact (SigPat an pat sig) = do - pat' <- markAnnotated pat - an0 <- markEpAnnL an lidl AnnDcolon - sig' <- markAnnotated sig - return (SigPat an0 pat' sig') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsPatSigType GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact (HsPS an ty) = do - ty' <- markAnnotated ty - return (HsPS an ty') - --- --------------------------------------------------------------------- - -instance ExactPrint (HsOverLit GhcPs) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - - exact ol = - let str = case ol_val ol of - HsIntegral (IL src _ _) -> src - HsFractional (FL{ fl_text = src }) -> src - HsIsString src _ -> src - in - case str of - SourceText s -> printStringAdvance (unpackFS s) >> return ol - NoSourceText -> return ol - --- --------------------------------------------------------------------- - -hsLit2String :: HsLit GhcPs -> String -hsLit2String lit = - case lit of - HsChar src v -> toSourceTextWithSuffix src v "" - HsCharPrim src p -> toSourceTextWithSuffix src p "" - HsString src v -> toSourceTextWithSuffix src v "" - HsStringPrim src v -> toSourceTextWithSuffix src v "" - HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v "" - HsIntPrim src v -> toSourceTextWithSuffix src v "" - HsWordPrim src v -> toSourceTextWithSuffix src v "" - HsInt8Prim src v -> toSourceTextWithSuffix src v "" - HsInt16Prim src v -> toSourceTextWithSuffix src v "" - HsInt32Prim src v -> toSourceTextWithSuffix src v "" - HsInt64Prim src v -> toSourceTextWithSuffix src v "" - HsWord8Prim src v -> toSourceTextWithSuffix src v "" - HsWord16Prim src v -> toSourceTextWithSuffix src v "" - HsWord32Prim src v -> toSourceTextWithSuffix src v "" - HsWord64Prim src v -> toSourceTextWithSuffix src v "" - HsInteger src v _ -> toSourceTextWithSuffix src v "" - HsRat _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl "" - HsFloatPrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "#" - HsDoublePrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "##" - -toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String -toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix -toSourceTextWithSuffix (SourceText txt) _alt suffix = unpackFS txt ++ suffix - -sourceTextToString :: SourceText -> String -> String -sourceTextToString NoSourceText alt = alt -sourceTextToString (SourceText txt) _ = unpackFS txt - --- --------------------------------------------------------------------- - -exactUserCon :: (Monad m, Monoid w, ExactPrint con) - => EpAnn [AddEpAnn] -> con -> HsConPatDetails GhcPs - -> EP w m (EpAnn [AddEpAnn], con, HsConPatDetails GhcPs) -exactUserCon an c (InfixCon p1 p2) = do - p1' <- markAnnotated p1 - c' <- markAnnotated c - p2' <- markAnnotated p2 - return (an, c', InfixCon p1' p2') -exactUserCon an c details = do - c' <- markAnnotated c - an0 <- markEpAnnL an lidl AnnOpenC - details' <- exactConArgs details - an1 <- markEpAnnL an0 lidl AnnCloseC - return (an1, c', details') - -instance ExactPrint (HsConPatTyArg GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ = a - exact (HsConPatTyArg at tyarg) = do - at' <- markToken at - tyarg' <- markAnnotated tyarg - return (HsConPatTyArg at' tyarg') - -exactConArgs :: (Monad m, Monoid w) - => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs) -exactConArgs (PrefixCon tyargs pats) = do - tyargs' <- markAnnotated tyargs - pats' <- markAnnotated pats - return (PrefixCon tyargs' pats') -exactConArgs (InfixCon p1 p2) = do - p1' <- markAnnotated p1 - p2' <- markAnnotated p2 - return (InfixCon p1' p2') -exactConArgs (RecCon rpats) = do - rpats' <- markAnnotated rpats - return (RecCon rpats') - --- --------------------------------------------------------------------- - -entryFromLocatedA :: LocatedAn ann a -> Entry -entryFromLocatedA (L la _) = fromAnn la - --- ===================================================================== --- Utility stuff --- --------------------------------------------------------------------- - --- |This should be the final point where things are mode concrete, --- before output. --- NOTE: despite the name, this is the ghc-exactprint final output for --- the PRINT phase. -printStringAtLsDelta :: (Monad m, Monoid w) => DeltaPos -> String -> EP w m () -printStringAtLsDelta cl s = do - p <- getPosP - colOffset <- getLayoutOffsetP - if isGoodDeltaWithOffset cl colOffset - then do - dprior <- getPriorEndD - printStringAt (undelta p cl colOffset) s - -- `debug` ("printStringAtLsDelta:(cl,colOffset):" ++ show (cl,colOffset,s)) - p' <- getPosP - dafter <- getPriorEndD - setPriorEndASTPD (dprior,dafter) - - debugM $ "printStringAtLsDelta:(pos,p,p',d,s):" ++ show (undelta p cl colOffset,p,p',dafter,s) - else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s)) - --- --------------------------------------------------------------------- - -isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool -isGoodDeltaWithOffset dp colOffset = isGoodDelta (deltaPos l c) - where (l,c) = undelta (0,0) dp colOffset - --- | Print a comment, using the current layout offset to convert the --- @DeltaPos@ to an absolute position. -printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m () -printQueuedComment _loc Comment{commentContents} dp = do - p <- getPosP - d <- getPriorEndD - colOffset <- getLayoutOffsetP - let (dr,dc) = undelta (0,0) dp colOffset - -- do not lose comments against the left margin - when (isGoodDelta (deltaPos dr (max 0 dc))) $ do - printCommentAt (undelta p dp colOffset) commentContents - p' <- getPosP - d' <- getPriorEndD - debugM $ "printQueuedComment: (p,p',d,d')=" ++ show (p,p',d,d') - debugM $ "printQueuedComment: (p,p',dp,colOffset,undelta)=" ++ show (p,p',dp,colOffset,undelta p dp colOffset) - ------------------------------------------------------------------------- - -setLayoutBoth :: (Monad m, Monoid w) => EP w m a -> EP w m a -setLayoutBoth k = do - oldLHS <- getLayoutOffsetD - oldAnchorOffset <- getLayoutOffsetP - debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) - modify (\a -> a { dMarkLayout = True - , pMarkLayout = True } ) - let reset = do - debugM $ "setLayoutBoth:reset: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) - modify (\a -> a { dMarkLayout = False - , dLHS = oldLHS - , pMarkLayout = False - , pLHS = oldAnchorOffset} ) - k <* reset - --- Use 'local', designed for this -setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m a -> EP w m a -setLayoutTopLevelP k = do - debugM $ "setLayoutTopLevelP entered" - oldAnchorOffset <- getLayoutOffsetP - modify (\a -> a { pMarkLayout = False - , pLHS = 1} ) - r <- k - debugM $ "setLayoutTopLevelP:resetting" - setLayoutOffsetP oldAnchorOffset - return r - ------------------------------------------------------------------------- - -getPosP :: (Monad m, Monoid w) => EP w m Pos -getPosP = gets epPos - -setPosP :: (Monad m, Monoid w) => Pos -> EP w m () -setPosP l = do - debugM $ "setPosP:" ++ show l - modify (\s -> s {epPos = l}) - -getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor) -getExtraDP = gets uExtraDP - -setExtraDP :: (Monad m, Monoid w) => Maybe Anchor -> EP w m () -setExtraDP md = do - debugM $ "setExtraDP:" ++ show md - modify (\s -> s {uExtraDP = md}) - -getPriorEndD :: (Monad m, Monoid w) => EP w m Pos -getPriorEndD = gets dPriorEndPosition - -getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan -getAnchorU = gets uAnchorSpan - -setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m () -setPriorEndD pe = do - setPriorEndNoLayoutD pe - -setPriorEndNoLayoutD :: (Monad m, Monoid w) => Pos -> EP w m () -setPriorEndNoLayoutD pe = do - debugM $ "setPriorEndNoLayoutD:pe=" ++ show pe - modify (\s -> s { dPriorEndPosition = pe }) - -setPriorEndASTD :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () -setPriorEndASTD pe = setPriorEndASTPD (rs2range pe) - -setPriorEndASTPD :: (Monad m, Monoid w) => (Pos,Pos) -> EP w m () -setPriorEndASTPD pe@(fm,to) = do - debugM $ "setPriorEndASTD:pe=" ++ show pe - when True $ setLayoutStartD (snd fm) - modify (\s -> s { dPriorEndPosition = to } ) - -setLayoutStartD :: (Monad m, Monoid w) => Int -> EP w m () -setLayoutStartD p = do - EPState{dMarkLayout} <- get - when dMarkLayout $ do - debugM $ "setLayoutStartD: setting dLHS=" ++ show p - modify (\s -> s { dMarkLayout = False - , dLHS = LayoutStartCol p}) - -getLayoutOffsetD :: (Monad m, Monoid w) => EP w m LayoutStartCol -getLayoutOffsetD = gets dLHS - -setAnchorU :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () -setAnchorU rss = do - debugM $ "setAnchorU:" ++ show (rs2range rss) - modify (\s -> s { uAnchorSpan = rss }) - -getEofPos :: (Monad m, Monoid w) => EP w m (Maybe (RealSrcSpan, RealSrcSpan)) -getEofPos = gets epEof - -setEofPos :: (Monad m, Monoid w) => Maybe (RealSrcSpan, RealSrcSpan) -> EP w m () -setEofPos l = modify (\s -> s {epEof = l}) - --- --------------------------------------------------------------------- - -getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment] -getUnallocatedComments = gets epComments - -putUnallocatedComments :: (Monad m, Monoid w) => [Comment] -> EP w m () -putUnallocatedComments cs = modify (\s -> s { epComments = cs } ) - --- | Push a fresh stack frame for the applied comments gatherer -pushAppliedComments :: (Monad m, Monoid w) => EP w m () -pushAppliedComments = modify (\s -> s { epCommentsApplied = []:(epCommentsApplied s) }) - --- | Return the comments applied since the last call --- takeAppliedComments, and clear them, not popping the stack -takeAppliedComments :: (Monad m, Monoid w) => EP w m [Comment] -takeAppliedComments = do - ccs <- gets epCommentsApplied - case ccs of - [] -> do - modify (\s -> s { epCommentsApplied = [] }) - return [] - h:t -> do - modify (\s -> s { epCommentsApplied = []:t }) - return (reverse h) - --- | Return the comments applied since the last call --- takeAppliedComments, and clear them, popping the stack -takeAppliedCommentsPop :: (Monad m, Monoid w) => EP w m [Comment] -takeAppliedCommentsPop = do - ccs <- gets epCommentsApplied - case ccs of - [] -> do - modify (\s -> s { epCommentsApplied = [] }) - return [] - h:t -> do - modify (\s -> s { epCommentsApplied = t }) - return (reverse h) - --- | Mark a comment as being applied. This is used to update comments --- when doing delta processing -applyComment :: (Monad m, Monoid w) => Comment -> EP w m () -applyComment c = do - ccs <- gets epCommentsApplied +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates #-} + +module Language.Haskell.GHC.ExactPrint.ExactPrint + ( + ExactPrint(..) + , exactPrint + , exactPrintWithOptions + , makeDeltaAst + + -- * Configuration + , EPOptions(epTokenPrint, epWhitespacePrint) + , stringOptions + , epOptions + , deltaOptions + + -- * Utility + , setAnchorAn + ) where + +import GHC +import GHC.Base (NonEmpty(..)) +import GHC.Core.Coercion.Axiom (Role(..)) +import qualified GHC.Data.BooleanFormula as BF +import GHC.Data.FastString +import qualified GHC.Data.Strict as Strict +import GHC.TypeLits +import GHC.Types.Basic hiding (EP) +import GHC.Types.Fixity +import GHC.Types.ForeignCall +import GHC.Types.Name.Reader +import GHC.Types.PkgQual +import GHC.Types.SourceText +import GHC.Types.SrcLoc +import GHC.Types.Var +import GHC.Unit.Module.Warnings +import GHC.Utils.Misc +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Utils.Panic + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.Monad (forM, when, unless) +import Control.Monad.Identity (Identity(..)) +import qualified Control.Monad.Reader as Reader +import Control.Monad.RWS (MonadReader, RWST, evalRWST, tell, modify, get, gets, ask) +import Control.Monad.Trans (lift) +import Data.Data ( Data ) +import Data.Dynamic +import Data.Foldable +import Data.Functor.Const +import Data.Typeable +import Data.List ( partition, sort, sortBy) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe ( isJust, mapMaybe ) +import Data.Void + +import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Types + +-- --------------------------------------------------------------------- + +exactPrint :: ExactPrint ast => ast -> String +exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast)) + +-- | The additional option to specify the printing configuration. +exactPrintWithOptions :: (ExactPrint ast, Monoid b, Monad m) + => EPOptions m b + -> ast + -> m (ast, b) +exactPrintWithOptions r ast = + runEP r (markAnnotated ast) + +-- | Transform concrete annotations into relative annotations. +-- This should be unnecessary from GHC 9.10 +makeDeltaAst :: ExactPrint ast => ast -> ast +makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast)) + +------------------------------------------------------ + +type EP w m a = RWST (EPOptions m w) (EPWriter w) EPState m a + +runEP :: (Monad m) + => EPOptions m w + -> EP w m a -> m (a, w) +runEP epReader action = do + (ast, w) <- evalRWST action epReader defaultEPState + return (ast, output w) + +-- --------------------------------------------------------------------- + +defaultEPState :: EPState +defaultEPState = EPState + { uAnchorSpan = badRealSrcSpan + , uExtraDP = Nothing + , uExtraDPReturn = Nothing + , pAcceptSpan = False + + , epPos = (1,1) + , pMarkLayout = False + , pLHS = LayoutStartCol 1 + + , dPriorEndPosition = (1,1) + , dMarkLayout = False + , dLHS = LayoutStartCol 1 + + , epComments = [] + , epCommentsApplied = [] + , epEof = Nothing + } + + +-- --------------------------------------------------------------------- +-- The EP monad and basic combinators + +-- | The R part of RWS. The environment. Updated via 'local' as we +-- enter a new AST element, having a different anchor point. +data EPOptions m a = EPOptions + { epTokenPrint :: String -> m a + , epWhitespacePrint :: String -> m a + } + +-- | Helper to create a 'EPOptions' +epOptions :: (String -> m a) + -> (String -> m a) + -> EPOptions m a +epOptions tokenPrint wsPrint = EPOptions + { epWhitespacePrint = wsPrint + , epTokenPrint = tokenPrint + } + +-- | Options which can be used to print as a normal String. +stringOptions :: EPOptions Identity String +stringOptions = epOptions return return + +-- | Options which can be used to simply update the AST to be in delta +-- form, without generating output +deltaOptions :: EPOptions Identity () +deltaOptions = epOptions (\_ -> return ()) (\_ -> return ()) + +data EPWriter a = EPWriter + { output :: !a } + +instance Monoid w => Semigroup (EPWriter w) where + (EPWriter a) <> (EPWriter b) = EPWriter (a <> b) + +instance Monoid w => Monoid (EPWriter w) where + mempty = EPWriter mempty + +data EPState = EPState + { uAnchorSpan :: !RealSrcSpan -- ^ in pre-changed AST + -- reference frame, from + -- Annotation + , uExtraDP :: !(Maybe EpaLocation) -- ^ Used to anchor a + -- list + , uExtraDPReturn :: !(Maybe (SrcSpan, DeltaPos)) + -- ^ Used to return Delta version of uExtraDP + , pAcceptSpan :: Bool -- ^ When we have processed an + -- entry of EpaDelta, accept the + -- next `EpaSpan` start as the + -- current output position. i.e. do + -- not advance epPos. Achieved by + -- setting dPriorEndPosition to the + -- end of the span. + + -- Print phase + , epPos :: !Pos -- ^ Current output position + , pMarkLayout :: !Bool + , pLHS :: !LayoutStartCol + + -- Delta phase + , dPriorEndPosition :: !Pos -- ^ End of Position reached + -- when processing the + -- preceding element + , dMarkLayout :: !Bool + , dLHS :: !LayoutStartCol + + -- Shared + , epComments :: ![Comment] + , epCommentsApplied :: ![[Comment]] + , epEof :: !(Maybe (RealSrcSpan, RealSrcSpan)) + } + +-- --------------------------------------------------------------------- + +-- AZ:TODO: this can just be a function :: (EpAnn a) -> Entry +class HasEntry ast where + fromAnn :: ast -> Entry + +class HasTrailing a where + trailing :: a -> [TrailingAnn] + setTrailing :: a -> [TrailingAnn] -> a + +setAnchorEpa :: (HasTrailing an) + => EpAnn an -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> EpAnn an +setAnchorEpa (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing an ts) cs + +setAnchorHsModule :: HsModule GhcPs -> EpaLocation -> EpAnnComments -> HsModule GhcPs +setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} } + where + anc' = anc + an' = setAnchorEpa (hsmodAnn $ hsmodExt hsmod) anc' [] cs + +setAnchorAn :: (HasTrailing an) + => LocatedAn an a -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> LocatedAn an a +setAnchorAn (L (EpAnn _ an _) a) anc ts cs = (L (EpAnn anc (setTrailing an ts) cs) a) + -- `debug` ("setAnchorAn: anc=" ++ showAst anc) + +setAnchorEpaL :: EpAnn (AnnList l) -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> EpAnn (AnnList l) +setAnchorEpaL (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing (an {al_anchor = Nothing}) ts) cs + +-- --------------------------------------------------------------------- + +-- | Key entry point. Switches to an independent AST element with its +-- own annotation, calculating new offsets, etc +markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a +markAnnotated a = enterAnn (getAnnotationEntry a) a + +-- | For HsModule, because we do not have a proper SrcSpan, we must +-- indicate to flush trailing comments when done. +data FlushComments = FlushComments + | NoFlushComments + deriving (Eq, Show) + +-- | For GenLocated SrcSpan, we construct an entry location but cannot update it. +data CanUpdateAnchor = CanUpdateAnchor + | CanUpdateAnchorOnly + | NoCanUpdateAnchor + deriving (Eq, Show, Data) + +data Entry = Entry EpaLocation [TrailingAnn] EpAnnComments FlushComments CanUpdateAnchor + | NoEntryVal + +-- | For flagging whether to capture comments in an EpaDelta or not +data CaptureComments = CaptureComments + | NoCaptureComments + +mkEntry :: EpaLocation -> [TrailingAnn] -> EpAnnComments -> Entry +mkEntry anc ts cs = Entry anc ts cs NoFlushComments CanUpdateAnchor + +instance (HasTrailing a) => HasEntry (EpAnn a) where + fromAnn (EpAnn anc a cs) = mkEntry anc (trailing a) cs + +-- --------------------------------------------------------------------- + +instance HasTrailing NoEpAnns where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing EpaLocation where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing EpAnnSumPat where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing (AnnList a) where + trailing a = al_trailing a + setTrailing a ts = a { al_trailing = ts } + +instance HasTrailing AnnListItem where + trailing a = lann_trailing a + setTrailing a ts = a { lann_trailing = ts } + +instance HasTrailing AnnPragma where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnContext where + trailing (AnnContext ma _opens _closes) + = case ma of + Just r -> [AddDarrowAnn r] + _ -> [] + + setTrailing a [AddDarrowAnn r] = a{ac_darrow = Just r} + setTrailing a [] = a{ac_darrow = Nothing} + setTrailing a ts = error $ "Cannot setTrailing " ++ showAst ts ++ " for " ++ showAst a + + +instance HasTrailing AnnParen where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnsIf where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing EpAnnHsCase where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnFieldLabel where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnProjection where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnExplicitSum where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing GrhsAnn where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnSig where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing HsRuleBndrsAnn where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing EpAnnImportDecl where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing AnnsModule where + -- Report none, as all are used internally + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing NameAnn where + trailing a = nann_trailing a + setTrailing a ts = a { nann_trailing = ts } + +instance HasTrailing Bool where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing (TokForall, TokRarrow) where + trailing _ = [] + setTrailing a _ = a + +instance HasTrailing (TokForall, EpToken ".") where + trailing _ = [] + setTrailing a _ = a + +-- --------------------------------------------------------------------- + +fromAnn' :: (HasEntry a) => a -> Entry +fromAnn' an = case fromAnn an of + NoEntryVal -> NoEntryVal + Entry a ts c _ u -> Entry a ts c FlushComments u + +-- --------------------------------------------------------------------- + +astId :: (Typeable a) => a -> String +astId a = show (typeOf a) + +cua :: (Monad m, Monoid w) => CanUpdateAnchor -> EP w m [a] -> EP w m [a] +cua CanUpdateAnchor f = f +cua CanUpdateAnchorOnly _ = return [] +cua NoCanUpdateAnchor _ = return [] + +-- | "Enter" an annotation, by using the associated 'anchor' field as +-- the new reference point for calculating all DeltaPos positions. +-- This is the heart of the exact printing process. +-- +-- This is combination of the ghc=exactprint Delta.withAST and +-- Print.exactPC functions and effectively does the delta processing +-- immediately followed by the print processing. JIT ghc-exactprint. +enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a +enterAnn NoEntryVal a = do + p <- getPosP + debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a) + r <- exact a + debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a) + return r +enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do + acceptSpan <- getAcceptSpan + setAcceptSpan False + case anchor' of + EpaDelta _ _ _ -> setAcceptSpan True + _ -> return () + p <- getPosP + pe0 <- getPriorEndD + debugM $ "enterAnn:starting:(anchor',p,pe,a) =" ++ show (showAst anchor', p, pe0, astId a) + prevAnchor <- getAnchorU + let curAnchor = case anchor' of + EpaSpan (RealSrcSpan r _) -> r + _ -> prevAnchor + debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor) + case canUpdateAnchor of + CanUpdateAnchor -> pushAppliedComments + _ -> return () + case anchor' of + EpaDelta _ _ dcs -> do + debugM $ "enterAnn:Delta:Flushing comments" + flushComments [] + debugM $ "enterAnn:Delta:Printing prior comments:" ++ showGhc (priorComments cs) + mapM_ printOneComment (concatMap tokComment $ priorComments cs) + debugM $ "enterAnn:Delta:Printing EpaDelta comments:" ++ showGhc dcs + mapM_ printOneComment (concatMap tokComment dcs) + _ -> do + debugM $ "enterAnn:Adding comments:" ++ showGhc (priorComments cs) + addCommentsA (priorComments cs) + debugM $ "enterAnn:Added comments" + printCommentsBefore curAnchor + priorCs <- cua canUpdateAnchor takeAppliedComments -- no pop + -- ------------------------- + case anchor' of + EpaDelta _ dp _ -> do + debugM $ "enterAnn: EpaDelta:" ++ show dp + -- Set the original anchor as prior end, so the rest of this AST + -- fragment has a reference + setPriorEndNoLayoutD (ss2pos curAnchor) + _ -> do + if acceptSpan + then setPriorEndNoLayoutD (ss2pos curAnchor) + else return () + + -- ------------------------- + if ((fst $ fst $ rs2range curAnchor) >= 0) + then + setAnchorU curAnchor + else + debugM $ "enterAnn: not calling setAnchorU for : " ++ show (rs2range curAnchor) + -- ------------------------------------------------------------------- + -- Make sure the running dPriorEndPosition gets updated according to + -- the change in the current anchor. + + -- Compute the distance from dPriorEndPosition to the start of the new span. + + -- While processing in the context of the prior anchor, we choose to + -- enter a new Anchor, which has a defined position relative to the + -- prior anchor, even if we do not actively output anything at that + -- point. + -- Is this edp? + + -- ------------------------------------------------------------------- + -- The first part corresponds to the delta phase, so should only use + -- delta phase variables ----------------------------------- + -- Calculate offset required to get to the start of the SrcSPan + !off <- getLayoutOffsetD + priorEndAfterComments <- getPriorEndD + let edp' = adjustDeltaForOffset + -- Use the propagated offset if one is set + -- Note that we need to use the new offset if it has + -- changed. + off (ss2delta priorEndAfterComments curAnchor) + debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor) + let edp'' = case anchor' of + EpaDelta _ dp _ -> dp + _ -> edp' + -- --------------------------------------------- + med <- getExtraDP + setExtraDP Nothing + let (edp, medr) = case med of + Nothing -> (edp'', Nothing) + Just (EpaDelta _ dp _) -> (dp, Nothing) + -- Replace original with desired one. Allows all + -- list entry values to be DP (1,0) + Just (EpaSpan ss@(RealSrcSpan r _)) -> (dp, Just (ss, dp)) + where + dp = adjustDeltaForOffset + off (ss2delta priorEndAfterComments r) + Just (EpaSpan (UnhelpfulSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r + when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ showAst (med,edp) + when (isJust medr) $ setExtraDPReturn medr + -- --------------------------------------------- + -- Preparation complete, perform the action + let spanStart = ss2pos curAnchor + when (priorEndAfterComments < spanStart) (do + debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart + modify (\s -> s { dPriorEndPosition = spanStart } )) + + debugM $ "enterAnn: (anchor', curAnchor):" ++ show (anchor', rs2range curAnchor) + -- debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp) + p0 <- getPosP + d <- getPriorEndD + debugM $ "enterAnn: (posp, posd)=" ++ show (p0,d) + + -- end of delta phase processing + -- ------------------------------------------------------------------- + -- start of print phase processing + + advance edp + debugM $ "enterAnn:exact a starting:" ++ show (showAst anchor') + a' <- exact a + debugM $ "enterAnn:exact a done:" ++ show (showAst anchor') + + -- Core recursive exactprint done, start end of Entry processing + + when (flush == FlushComments) $ do + debugM $ "flushing comments in enterAnn:" ++ showAst (cs, getFollowingComments cs) + flushComments (getFollowingComments cs) + debugM $ "flushing comments in enterAnn done" + + !eof <- getEofPos + case eof of + Nothing -> return () + Just (pos, prior) -> do + let dp = if pos == prior + then (DifferentLine 1 0) + else adjustDeltaForOffset off (origDelta pos prior) + debugM $ "EOF:(pos,posend,prior,off,dp) =" ++ show (ss2pos pos, ss2posEnd pos, ss2pos prior, off, dp) + printStringAtLsDelta dp "" + setEofPos Nothing -- Only do this once + + -- Deal with exit from the current anchor + when (flush == NoFlushComments) $ do + printCommentsIn curAnchor -- Make sure all comments in the span are printed + + p1 <- getPosP + pe1 <- getPriorEndD + debugM $ "enterAnn:done:(anchor,p,pe,a) =" ++ show (showAst anchor', p1, pe1, astId a') + + case anchor' of + EpaDelta _ _ _ -> return () + EpaSpan (RealSrcSpan rss _) -> do + setAcceptSpan False + setPriorEndD (snd $ rs2range rss) + EpaSpan _ -> return () + + -- Outside the anchor, mark any trailing + postCs <- cua canUpdateAnchor takeAppliedCommentsPop + following <- if (flush == NoFlushComments) + then do + let (before, after) = splitAfterTrailingAnns trailing_anns + (getFollowingComments cs) + addCommentsA before + return after + else return [] + !trailing' <- markTrailing trailing_anns + addCommentsA following + + -- Update original anchor, comments based on the printing process + -- TODO:AZ: probably need to put something appropriate in instead of noSrcSpan + let newAnchor = case anchor' of + EpaSpan s -> EpaDelta s edp [] + _ -> EpaDelta noSrcSpan edp [] + let r = case canUpdateAnchor of + CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) + CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments + NoCanUpdateAnchor -> a' + return r + +-- --------------------------------------------------------------------- + +-- | Split the span following comments into ones that occur prior to +-- the last trailing ann, and ones after. +splitAfterTrailingAnns :: [TrailingAnn] -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) +splitAfterTrailingAnns [] cs = ([], cs) +splitAfterTrailingAnns tas cs = (before, after) + where + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + (before, after) = case reverse (concatMap trailing_loc tas) of + [] -> ([],cs) + (s:_) -> (b,a) + where + s_pos = ss2pos s + (b,a) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > s_pos) + cs + +-- --------------------------------------------------------------------- + +addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () +addCommentsA csNew = addComments False (concatMap tokComment csNew) + +{- +TODO: When we addComments, some may have an anchor that is no longer +valid, as it has been moved and has an anchor_op. + +Does an Anchor even make sense for a comment, perhaps it should be an +EpaLocation? + +How do we sort them? do we assign a location based on when we add them +to the list, based on the current output pos? Except the offset is a +delta compared to a reference location. Need to nail the concept of +the reference location. + +By definition it is the current anchor, so work against that. And that +also means that the first entry comment that has moved should not have +a line offset. +-} +addComments :: (Monad m, Monoid w) => Bool -> [Comment] -> EP w m () +addComments sortNeeded csNew = do + debugM $ "addComments:csNew" ++ show csNew + cs <- getUnallocatedComments + debugM $ "addComments:cs" ++ show cs + -- We can only sort the comments if we are in the first phase, + -- where all comments have locations. If any have EpaDelta the + -- sort will fail, so we do not try. + if sortNeeded && all noDelta (csNew ++ cs) + then putUnallocatedComments (sort (cs ++ csNew)) + else putUnallocatedComments (cs ++ csNew) + +noDelta :: Comment -> Bool +noDelta c = case commentLoc c of + EpaSpan _ -> True + _ -> False + +-- --------------------------------------------------------------------- + +-- | Just before we print out the EOF comments, flush the remaining +-- ones in the state. +flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () +flushComments !trailing_anns = do + debugM $ "flushComments entered: " ++ showAst trailing_anns + addCommentsA trailing_anns + debugM $ "flushComments after addCommentsA" + cs <- getUnallocatedComments + debugM $ "flushComments: got cs" + debugM $ "flushing comments starting: cs" ++ showAst cs + mapM_ printOneComment cs + putUnallocatedComments [] + debugM $ "flushing comments done" + +-- --------------------------------------------------------------------- + +epTokensToComments :: (Monad m, Monoid w) + => String -> [EpToken tok] -> EP w m () +epTokensToComments kw toks + = addComments True (concatMap (\tok -> + case tok of + EpTok ss -> [mkKWComment kw (epaToNoCommentsLocation ss)] + NoEpTok -> []) toks) + +-- --------------------------------------------------------------------- + +-- Temporary function to simply reproduce the "normal" pretty printer output +withPpr :: (Monad m, Monoid w, Outputable a) => a -> EP w m a +withPpr a = do + ss <- getAnchorU + debugM $ "withPpr: ss=" ++ show ss + printStringAtRs' ss (showPprUnsafe a) + return a + +-- --------------------------------------------------------------------- + +-- | An AST fragment with an annotation must be able to return the +-- requirements for nesting another one, captured in an 'Entry', and +-- to be able to use the rest of the exactprint machinery to print the +-- element. In the analogy to Outputable, 'exact' plays the role of +-- 'ppr'. +class (Typeable a) => ExactPrint a where + getAnnotationEntry :: a -> Entry + setAnnotationAnchor :: a -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> a + exact :: (Monad m, Monoid w) => a -> EP w m a + +-- --------------------------------------------------------------------- +-- Start of utility functions +-- --------------------------------------------------------------------- + +printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m () +printSourceText (NoSourceText) txt = printStringAdvance txt >> return () +printSourceText (SourceText txt) _ = printStringAdvance (unpackFS txt) >> return () + +printSourceTextAA :: (Monad m, Monoid w) => SourceText -> String -> EP w m () +printSourceTextAA (NoSourceText) txt = printStringAdvanceA txt >> return () +printSourceTextAA (SourceText txt) _ = printStringAdvanceA (unpackFS txt) >> return () + +-- --------------------------------------------------------------------- + +printStringAtRs :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m EpaLocation +printStringAtRs pa str = printStringAtRsC CaptureComments pa str + +printStringAtRsC :: (Monad m, Monoid w) + => CaptureComments -> RealSrcSpan -> String -> EP w m EpaLocation +printStringAtRsC capture pa str = do + debugM $ "printStringAtRsC: pa=" ++ showAst pa + printCommentsBefore pa + pe <- getPriorEndD + debugM $ "printStringAtRsC:pe=" ++ show pe + let p = ss2delta pe pa + p' <- adjustDeltaForOffsetM p + debugM $ "printStringAtRsC:(p,p')=" ++ show (p,p') + printStringAtLsDelta p' str + setPriorEndASTD pa + cs' <- case capture of + CaptureComments -> takeAppliedComments + NoCaptureComments -> return [] + debugM $ "printStringAtRsC:cs'=" ++ show cs' + debugM $ "printStringAtRsC:p'=" ++ showAst p' + debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta noSrcSpan p' NoComments) + debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta noSrcSpan p' (map comment2LEpaComment cs')) + return (EpaDelta (RealSrcSpan pa Strict.Nothing) p' (map comment2LEpaComment cs')) + +printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m () +printStringAtRs' pa str = printStringAtRsC NoCaptureComments pa str >> return () + +-- --------------------------------------------------------------------- + +printStringAtMLoc' :: (Monad m, Monoid w) + => Maybe EpaLocation -> String -> EP w m (Maybe EpaLocation) +printStringAtMLoc' (Just aa) s = Just <$> printStringAtAA aa s +printStringAtMLoc' Nothing s = do + printStringAtLsDelta (SameLine 1) s + return (Just (EpaDelta noSrcSpan (SameLine 1) [])) + +printStringAtMLocL :: (Monad m, Monoid w) + => EpAnn a -> Lens a (Maybe EpaLocation) -> String -> EP w m (EpAnn a) +printStringAtMLocL (EpAnn anc an cs) l s = do + r <- go (view l an) s + return (EpAnn anc (set l r an) cs) + where + go (Just aa) str = Just <$> printStringAtAA aa str + go Nothing str = do + printStringAtLsDelta (SameLine 1) str + return (Just (EpaDelta noSrcSpan (SameLine 1) [])) + +printStringAdvanceA :: (Monad m, Monoid w) => String -> EP w m () +printStringAdvanceA str = printStringAtAA (EpaDelta noSrcSpan (SameLine 0) []) str >> return () + +printStringAtAA :: (Monad m, Monoid w) => EpaLocation -> String -> EP w m EpaLocation +printStringAtAA el str = printStringAtAAC CaptureComments el str + +printStringAtNC :: (Monad m, Monoid w) => NoCommentsLocation -> String -> EP w m NoCommentsLocation +printStringAtNC el str = do + el' <- printStringAtAAC NoCaptureComments (noCommentsToEpaLocation el) str + return (epaToNoCommentsLocation el') + +printStringAtAAC :: (Monad m, Monoid w) + => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation +printStringAtAAC capture (EpaSpan (RealSrcSpan r _)) s = printStringAtRsC capture r s +printStringAtAAC _capture (EpaSpan ss@(UnhelpfulSpan _)) _s = error $ "printStringAtAAC:ss=" ++ show ss +printStringAtAAC capture (EpaDelta ss d cs) s = do + mapM_ printOneComment $ concatMap tokComment cs + pe1 <- getPriorEndD + p1 <- getPosP + printStringAtLsDelta d s + p2 <- getPosP + pe2 <- getPriorEndD + debugM $ "printStringAtAA:(pe1,pe2,p1,p2)=" ++ show (pe1,pe2,p1,p2) + setPriorEndASTPD (pe1,pe2) + cs' <- case capture of + CaptureComments -> takeAppliedComments + NoCaptureComments -> return [] + debugM $ "printStringAtAA:(pe1,pe2,p1,p2,cs')=" ++ show (pe1,pe2,p1,p2,cs') + return (EpaDelta ss d (map comment2LEpaComment cs')) + +-- --------------------------------------------------------------------- + +markExternalSourceTextE :: (Monad m, Monoid w) => EpaLocation -> SourceText -> String -> EP w m EpaLocation +markExternalSourceTextE l NoSourceText txt = printStringAtAA l txt +markExternalSourceTextE l (SourceText txt) _ = printStringAtAA l (unpackFS txt) + +-- --------------------------------------------------------------------- + +markLensBracketsO :: (Monad m, Monoid w) + => EpAnn a -> Lens a AnnListBrackets -> EP w m (EpAnn a) +markLensBracketsO epann l = markLensBracketsO' epann (lepa . l) + +markLensBracketsO' :: (Monad m, Monoid w) + => a -> Lens a AnnListBrackets -> EP w m a +markLensBracketsO' a l = + case view l a of + ListParens o c -> do + o' <- markEpToken o + return (set l (ListParens o' c) a) + ListBraces o c -> do + o' <- markEpToken o + return (set l (ListBraces o' c) a) + ListSquare o c -> do + o' <- markEpToken o + return (set l (ListSquare o' c) a) + ListBanana o c -> do + o' <- markEpUniToken o + return (set l (ListBanana o' c) a) + ListNone -> return (set l ListNone a) + +markLensBracketsC :: (Monad m, Monoid w) + => EpAnn a -> Lens a AnnListBrackets -> EP w m (EpAnn a) +markLensBracketsC epann l = markLensBracketsC' epann (lepa . l) + +markLensBracketsC' :: (Monad m, Monoid w) + => a -> Lens a AnnListBrackets -> EP w m a +markLensBracketsC' a l = + case view l a of + ListParens o c -> do + c' <- markEpToken c + return (set l (ListParens o c') a) + ListBraces o c -> do + c' <- markEpToken c + return (set l (ListBraces o c') a) + ListSquare o c -> do + c' <- markEpToken c + return (set l (ListSquare o c') a) + ListBanana o c -> do + c' <- markEpUniToken c + return (set l (ListBanana o c') a) + ListNone -> return (set l ListNone a) + +-- ------------------------------------- + +markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) + => EpToken tok -> EP w m (EpToken tok) +markEpToken NoEpTok = return NoEpTok +markEpToken (EpTok aa) = do + aa' <- printStringAtAA aa (symbolVal (Proxy @tok)) + return (EpTok aa') + +markEpToken1 :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) + => [EpToken tok] -> EP w m [EpToken tok] +markEpToken1 [] = return [] +markEpToken1 (h:t) = do + h' <- markEpToken h + return (h':t) + +markEpUniToken :: forall m w tok utok . (Monad m, Monoid w, KnownSymbol tok, KnownSymbol utok) + => EpUniToken tok utok -> EP w m (EpUniToken tok utok) +markEpUniToken NoEpUniTok = return NoEpUniTok +markEpUniToken (EpUniTok aa isUnicode) = do + aa' <- case isUnicode of + NormalSyntax -> printStringAtAA aa (symbolVal (Proxy @tok)) + UnicodeSyntax -> printStringAtAA aa (symbolVal (Proxy @utok)) + return (EpUniTok aa' isUnicode) + +-- --------------------------------------------------------------------- + +markAnnOpen' :: (Monad m, Monoid w) + => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) +markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt +markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms $ unpackFS txt + +markAnnOpen'' :: (Monad m, Monoid w) + => EpaLocation -> SourceText -> String -> EP w m EpaLocation +markAnnOpen'' el NoSourceText txt = printStringAtAA el txt +markAnnOpen'' el (SourceText txt) _ = printStringAtAA el $ unpackFS txt + +-- --------------------------------------------------------------------- + +markOpeningParen, markClosingParen :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen +markOpeningParen an = markParenO an +markClosingParen an = markParenC an + +markParenO :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen +markParenO (AnnParens o c) = do + o' <- markEpToken o + return (AnnParens o' c) +markParenO (AnnParensHash o c) = do + o' <- markEpToken o + return (AnnParensHash o' c) +markParenO (AnnParensSquare o c) = do + o' <- markEpToken o + return (AnnParensSquare o' c) + +markParenC :: (Monad m, Monoid w) => AnnParen -> EP w m AnnParen +markParenC (AnnParens o c) = do + c' <- markEpToken c + return (AnnParens o c') +markParenC (AnnParensHash o c) = do + c' <- markEpToken c + return (AnnParensHash o c') +markParenC (AnnParensSquare o c) = do + c' <- markEpToken c + return (AnnParensSquare o c') + +-- --------------------------------------------------------------------- +-- Bare bones Optics +-- Base on From https://hackage.haskell.org/package/lens-tutorial-1.0.3/docs/Control-Lens-Tutorial.html + +type Lens a b = forall f . Functor f => (b -> f b) -> (a -> f a) +type Getting a b = (b -> Const b b) -> (a -> Const b a) +type ASetter a b = (b -> Identity b) -> (a -> Identity a) + +view :: MonadReader s m => Getting s a -> m a +view l = Reader.asks (getConst . l Const) +{-# INLINE view #-} + +over :: ASetter a b -> (b -> b) -> (a -> a) +over l f = runIdentity . l (Identity . f) +{-# INLINE over #-} + +set :: Lens a b -> b -> a -> a +set lens b = over lens (\_ -> b) +{-# INLINE set #-} + +{- +Question: How do I combine lenses? + +Answer: You compose them, using function composition (Yes, really!) + +You can think of the function composition operator as having this type: + +(.) :: Lens' a b -> Lens' b c -> Lens' a c +-} + +-- --------------------------------------------------------------------- +-- Lenses + +-- data EpAnn ann +-- = EpAnn { entry :: !Anchor +-- , anns :: !ann +-- , comments :: !EpAnnComments +-- } + +lepa :: Lens (EpAnn a) a +lepa k epAnn = fmap (\newAnns -> epAnn { anns = newAnns }) + (k (anns epAnn)) + +-- data AnnsModule +-- = AnnsModule { +-- am_sig :: Maybe (EpToken "signature"), +-- am_mod :: Maybe (EpToken "module"), +-- am_where :: Maybe (EpToken "where"), +-- am_decls :: [TrailingAnn], +-- am_cs :: [LEpaComment], +-- am_eof :: Maybe (RealSrcSpan, RealSrcSpan) +-- } deriving (Data, Eq) + +lam_mod :: Lens AnnsModule (EpToken "module") +lam_mod k annsModule = fmap (\newAnns -> annsModule { am_mod = newAnns }) + (k (am_mod annsModule)) + +lam_where :: Lens AnnsModule (EpToken "where") +lam_where k annsModule = fmap (\newAnns -> annsModule { am_where = newAnns }) + (k (am_where annsModule)) + +-- lam_decls :: Lens AnnsModule AnnList +-- lam_decls k annsModule = fmap (\newAnns -> annsModule { am_decls = newAnns }) +-- (k (am_decls annsModule)) + + +-- data EpAnnImportDecl = EpAnnImportDecl +-- { importDeclAnnImport :: EpToken "import" -- ^ The location of the @import@ keyword +-- , importDeclAnnPragma :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively +-- , importDeclAnnSafe :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword +-- , importDeclAnnLevel :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword +-- , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword +-- , importDeclAnnPackage :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@) +-- , importDeclAnnAs :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword +-- } deriving (Data) + +limportDeclAnnImport :: Lens EpAnnImportDecl (EpToken "import") +limportDeclAnnImport k annImp = fmap (\new -> annImp { importDeclAnnImport = new }) + (k (importDeclAnnImport annImp)) + +-- limportDeclAnnPragma :: Lens EpAnnImportDecl (Maybe (EpaLocation, EpaLocation)) +-- limportDeclAnnPragma k annImp = fmap (\new -> annImp { importDeclAnnPragma = new }) +-- (k (importDeclAnnPragma annImp)) + +limportDeclAnnSafe :: Lens EpAnnImportDecl (Maybe (EpToken "safe")) +limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new }) + (k (importDeclAnnSafe annImp)) + +limportDeclAnnLevel :: Lens EpAnnImportDecl (Maybe EpAnnLevel) +limportDeclAnnLevel k annImp = fmap (\new -> annImp { importDeclAnnLevel = new }) + (k (importDeclAnnLevel annImp)) + +limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe (EpToken "qualified")) +limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new }) + (k (importDeclAnnQualified annImp)) + +limportDeclAnnPackage :: Lens EpAnnImportDecl (Maybe EpaLocation) +limportDeclAnnPackage k annImp = fmap (\new -> annImp { importDeclAnnPackage = new }) + (k (importDeclAnnPackage annImp)) + +-- limportDeclAnnAs :: Lens EpAnnImportDecl (Maybe EpaLocation) +-- limportDeclAnnAs k annImp = fmap (\new -> annImp { importDeclAnnAs = new }) +-- (k (importDeclAnnAs annImp)) + +-- ------------------------------------- + +-- data AnnList +-- = AnnList { +-- al_anchor :: Maybe Anchor, -- ^ start point of a list having layout +-- al_brackets :: !AnnListBrackets, +-- al_semis :: [EpToken ";"], -- decls +-- al_rest :: !a, +-- al_trailing :: [TrailingAnn] -- ^ items appearing after the +-- -- list, such as '=>' for a +-- -- context +-- } deriving (Data,Eq) + +lal_brackets :: Lens (AnnList l) AnnListBrackets +lal_brackets k parent = fmap (\new -> parent { al_brackets = new }) + (k (al_brackets parent)) + +lal_semis :: Lens (AnnList l) [EpToken ";"] +lal_semis k parent = fmap (\new -> parent { al_semis = new }) + (k (al_semis parent)) + +lal_rest :: Lens (AnnList l) l +lal_rest k parent = fmap (\new -> parent { al_rest = new }) + (k (al_rest parent)) + +-- ------------------------------------- + +lfst :: Lens (a,b) a +lfst k parent = fmap (\new -> (new, snd parent)) + (k (fst parent)) + +lsnd :: Lens (b,a) a +lsnd k parent = fmap (\new -> (fst parent, new)) + (k (snd parent)) + +-- ------------------------------------- +-- data AnnExplicitSum +-- = AnnExplicitSum { +-- aesOpen :: EpaLocation, +-- aesBarsBefore :: [EpToken "|"], +-- aesBarsAfter :: [EpToken "|"], +-- aesClose :: EpaLocation +-- } deriving Data + +laesOpen :: Lens AnnExplicitSum EpaLocation +laesOpen k parent = fmap (\new -> parent { aesOpen = new }) + (k (aesOpen parent)) + +laesBarsBefore :: Lens AnnExplicitSum [EpToken "|"] +laesBarsBefore k parent = fmap (\new -> parent { aesBarsBefore = new }) + (k (aesBarsBefore parent)) + +laesBarsAfter :: Lens AnnExplicitSum [EpToken "|"] +laesBarsAfter k parent = fmap (\new -> parent { aesBarsAfter = new }) + (k (aesBarsAfter parent)) + +laesClose :: Lens AnnExplicitSum EpaLocation +laesClose k parent = fmap (\new -> parent { aesClose = new }) + (k (aesClose parent)) + +-- ------------------------------------- +-- data AnnFieldLabel +-- = AnnFieldLabel { +-- afDot :: Maybe (EpToken ".") +-- } deriving Data + +lafDot :: Lens AnnFieldLabel (Maybe (EpToken ".")) +lafDot k parent = fmap (\new -> parent { afDot = new }) + (k (afDot parent)) + +-- ------------------------------------- +-- data AnnProjection +-- = AnnProjection { +-- apOpen :: EpToken "(", +-- apClose :: EpToken ")" +-- } deriving Data + +lapOpen :: Lens AnnProjection (EpToken "(") +lapOpen k parent = fmap (\new -> parent { apOpen = new }) + (k (apOpen parent)) + +lapClose :: Lens AnnProjection (EpToken ")") +lapClose k parent = fmap (\new -> parent { apClose = new }) + (k (apClose parent)) + +-- ------------------------------------- +-- data AnnsIf +-- = AnnsIf { +-- aiIf :: EpToken "if", +-- aiThen :: EpToken "then", +-- aiElse :: EpToken "else", +-- aiThenSemi :: Maybe (EpToken ";"), +-- aiElseSemi :: Maybe (EpToken ";") +-- } deriving Data + +laiIf :: Lens AnnsIf (EpToken "if") +laiIf k parent = fmap (\new -> parent { aiIf = new }) + (k (aiIf parent)) + +laiThen :: Lens AnnsIf (EpToken "then") +laiThen k parent = fmap (\new -> parent { aiThen = new }) + (k (aiThen parent)) + +laiElse :: Lens AnnsIf (EpToken "else") +laiElse k parent = fmap (\new -> parent { aiElse = new }) + (k (aiElse parent)) + +laiThenSemi :: Lens AnnsIf (Maybe (EpToken ";")) +laiThenSemi k parent = fmap (\new -> parent { aiThenSemi = new }) + (k (aiThenSemi parent)) + +laiElseSemi :: Lens AnnsIf (Maybe (EpToken ";")) +laiElseSemi k parent = fmap (\new -> parent { aiElseSemi = new }) + (k (aiElseSemi parent)) + +-- ------------------------------------- + +-- data AnnParen +-- = AnnParen { +-- ap_adornment :: ParenType, +-- ap_open :: EpaLocation, +-- ap_close :: EpaLocation +-- } deriving (Data) + +-- lap_open :: Lens AnnParen EpaLocation +-- lap_open k parent = fmap (\new -> parent { ap_open = new }) +-- (k (ap_open parent)) + +-- lap_close :: Lens AnnParen EpaLocation +-- lap_close k parent = fmap (\new -> parent { ap_close = new }) +-- (k (ap_close parent)) + +-- ------------------------------------- +-- data EpAnnHsCase = EpAnnHsCase +-- { hsCaseAnnCase :: EpToken "case" +-- , hsCaseAnnOf :: EpToken "of" +-- } deriving Data + +lhsCaseAnnCase :: Lens EpAnnHsCase (EpToken "case") +lhsCaseAnnCase k parent = fmap (\new -> parent { hsCaseAnnCase = new }) + (k (hsCaseAnnCase parent)) + +lhsCaseAnnOf :: Lens EpAnnHsCase (EpToken "of") +lhsCaseAnnOf k parent = fmap (\new -> parent { hsCaseAnnOf = new }) + (k (hsCaseAnnOf parent)) + +-- --------------------------------------------------------------------- + +-- data HsRuleBndrsAnn +-- = HsRuleBndrsAnn +-- { rb_tyanns :: Maybe (TokForall, EpToken ".") +-- , rb_tmanns :: Maybe (TokForall, EpToken ".") +-- } + +lrb_tyanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken ".")) +lrb_tyanns k parent = fmap (\new -> parent { rb_tyanns = new }) + (k (rb_tyanns parent)) + +ff :: Maybe (a,b) -> (Maybe a,Maybe b) +ff Nothing = (Nothing, Nothing) +ff (Just (a,b)) = (Just a, Just b) + + +gg :: (Maybe a,Maybe b) -> Maybe (a,b) +gg (Nothing, Nothing) = Nothing +gg (Just a, Just b) = Just (a,b) +gg _ = error "gg:expecting two Nothing or two Just" + +lff :: Lens (Maybe (a,b)) (Maybe a,Maybe b) +lff k parent = fmap (\new -> gg new) + (k (ff parent)) + +-- (.) :: Lens' a b -> Lens' b c -> Lens' a c +lrb_tyanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall) +lrb_tyanns_fst = lrb_tyanns . lff . lfst + +lrb_tyanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken ".")) +lrb_tyanns_snd = lrb_tyanns . lff . lsnd + +lrb_tmanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken ".")) +lrb_tmanns k parent = fmap (\new -> parent { rb_tmanns = new }) + (k (rb_tmanns parent)) + +lrb_tmanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall) +lrb_tmanns_fst = lrb_tmanns . lff . lfst + +lrb_tmanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken ".")) +lrb_tmanns_snd = lrb_tmanns . lff . lsnd + +-- --------------------------------------------------------------------- +-- data GrhsAnn +-- = GrhsAnn { +-- ga_vbar :: Maybe (EpToken "|"), +-- ga_sep :: Either (EpToken "=") TokRarrow -- ^ Match separator location, `=` or `->` +-- } deriving (Data) + +lga_vbar :: Lens GrhsAnn (Maybe (EpToken "|")) +lga_vbar k parent = fmap (\new -> parent { ga_vbar = new }) + (k (ga_vbar parent)) + +lga_sep :: Lens GrhsAnn (Either (EpToken "=") TokRarrow) +lga_sep k parent = fmap (\new -> parent { ga_sep = new }) + (k (ga_sep parent)) + +-- --------------------------------------------------------------------- +-- data EpAnnSumPat = EpAnnSumPat +-- { sumPatParens :: (EpaLocation, EpaLocation) +-- , sumPatVbarsBefore :: [EpToken "|"] +-- , sumPatVbarsAfter :: [EpToken "|"] +-- } deriving Data + +lsumPatParens :: Lens EpAnnSumPat (EpaLocation, EpaLocation) +lsumPatParens k parent = fmap (\new -> parent { sumPatParens = new }) + (k (sumPatParens parent)) + +lsumPatVbarsBefore :: Lens EpAnnSumPat [EpToken "|"] +lsumPatVbarsBefore k parent = fmap (\new -> parent { sumPatVbarsBefore = new }) + (k (sumPatVbarsBefore parent)) + +lsumPatVbarsAfter :: Lens EpAnnSumPat [EpToken "|"] +lsumPatVbarsAfter k parent = fmap (\new -> parent { sumPatVbarsAfter = new }) + (k (sumPatVbarsAfter parent)) + +-- --------------------------------------------------------------------- +-- data EpAnnLam = EpAnnLam +-- { epl_lambda :: EpToken "\\" -- ^ Location of '\' keyword +-- , epl_case :: Maybe EpaLocation -- ^ Location of 'case' or +-- -- 'cases' keyword, depending +-- -- on related 'HsLamVariant'. +-- } deriving Data + +lepl_lambda :: Lens EpAnnLam (EpToken "\\") +lepl_lambda k parent = fmap (\new -> parent { epl_lambda = new }) + (k (epl_lambda parent)) + +lepl_case :: Lens EpAnnLam (Maybe EpaLocation) +lepl_case k parent = fmap (\new -> parent { epl_case = new }) + (k (epl_case parent)) + + +-- End of lenses +-- --------------------------------------------------------------------- + +-- markLensKw' :: (Monad m, Monoid w) +-- => EpAnn a -> Lens a EpaLocation -> AnnKeywordId -> EP w m (EpAnn a) +-- markLensKw' (EpAnn anc a cs) l kw = do +-- loc <- markKwA kw (view l a) +-- return (EpAnn anc (set l loc a) cs) + +-- markLensKw :: (Monad m, Monoid w) +-- => a -> Lens a EpaLocation -> AnnKeywordId -> EP w m a +-- markLensKw a l kw = do +-- loc <- markKwA kw (view l a) +-- return (set l loc a) + + +-- markLensKwM :: (Monad m, Monoid w) +-- => EpAnn a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m (EpAnn a) +-- markLensKwM (EpAnn anc a cs) l kw = do +-- new <- go (view l a) +-- return (EpAnn anc (set l new a) cs) +-- where +-- go Nothing = return Nothing +-- go (Just s) = Just <$> markKwA kw s + +-- markLensKwM' :: (Monad m, Monoid w) +-- => a -> Lens a (Maybe EpaLocation) -> AnnKeywordId -> EP w m a +-- markLensKwM' a l kw = do +-- loc <- mapM (markKwA kw) (view l a) +-- return (set l loc a) + +markLensTok :: (Monad m, Monoid w, KnownSymbol sym) + => EpAnn a -> Lens a (EpToken sym) -> EP w m (EpAnn a) +markLensTok (EpAnn anc a cs) l = do + new <- markEpToken (view l a) + return (EpAnn anc (set l new a) cs) + +-- --------------------------------------------------------------------- + +markLensFun' :: (Monad m, Monoid w) + => EpAnn ann -> Lens ann t -> (t -> EP w m t) -> EP w m (EpAnn ann) +markLensFun' epann l f = markLensFun epann (lepa . l) f + +markLensFun :: (Monad m, Monoid w) + => ann -> Lens ann t -> (t -> EP w m t) -> EP w m ann +markLensFun a l f = do + t' <- f (view l a) + return (set l t' a) + +-- ------------------------------------- + +markEpAnnAllLT :: (Monad m, Monoid w, KnownSymbol tok) + => EpAnn ann -> Lens ann [EpToken tok] -> EP w m (EpAnn ann) +markEpAnnAllLT (EpAnn anc a cs) l = do + anns <- mapM markEpToken (view l a) + return (EpAnn anc (set l anns a) cs) + +markEpAnnAllLT' :: (Monad m, Monoid w, KnownSymbol tok) + => ann -> Lens ann [EpToken tok] -> EP w m ann +markEpAnnAllLT' a l = do + anns <- mapM markEpToken (view l a) + return (set l anns a) + +markEpaLocationAll :: (Monad m, Monoid w) + => [EpaLocation] -> String -> EP w m [EpaLocation] +markEpaLocationAll locs str = mapM (\l -> printStringAtAA l str) locs + +-- | Print a keyword encoded in a 'TrailingAnn' +markKwT :: (Monad m, Monoid w) => TrailingAnn -> EP w m TrailingAnn +markKwT (AddSemiAnn tok) = AddSemiAnn <$> markEpToken tok +markKwT (AddCommaAnn tok) = AddCommaAnn <$> markEpToken tok +markKwT (AddVbarAnn tok) = AddVbarAnn <$> markEpToken tok +markKwT (AddDarrowAnn tok) = AddDarrowAnn <$> markEpUniToken tok + +-- --------------------------------------------------------------------- + +markAnnList :: (Monad m, Monoid w) + => EpAnn (AnnList l) -> EP w m a -> EP w m (EpAnn (AnnList l), a) +markAnnList ann action = do + markAnnListA ann $ \a -> do + r <- action + return (a,r) + +markAnnList' :: (Monad m, Monoid w) + => AnnList l -> EP w m a -> EP w m (AnnList l, a) +markAnnList' ann action = do + markAnnListA' ann $ \a -> do + r <- action + return (a,r) + +markAnnListA :: (Monad m, Monoid w) + => EpAnn (AnnList l) + -> (EpAnn (AnnList l) -> EP w m (EpAnn (AnnList l), a)) + -> EP w m (EpAnn (AnnList l), a) +markAnnListA an action = do + an0 <- markLensBracketsO an lal_brackets + an1 <- markEpAnnAllLT an0 lal_semis + (an2, r) <- action an1 + an3 <- markLensBracketsC an2 lal_brackets + return (an3, r) + +markAnnListA' :: (Monad m, Monoid w) + => AnnList l + -> (AnnList l -> EP w m (AnnList l, a)) + -> EP w m (AnnList l , a) +markAnnListA' an action = do + an0 <- markLensBracketsO' an lal_brackets + an1 <- markEpAnnAllLT' an0 lal_semis + (an2, r) <- action an1 + an3 <- markLensBracketsC' an2 lal_brackets + return (an3, r) + +-- --------------------------------------------------------------------- + +printCommentsBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () +printCommentsBefore ss = do + cs <- commentAllocationBefore ss + debugM $ "printCommentsBefore: (ss): " ++ showPprUnsafe (rs2range ss) + -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) + mapM_ printOneComment cs + +printCommentsIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () +printCommentsIn ss = do + cs <- commentAllocationIn ss + debugM $ "printCommentsIn: (ss): " ++ showPprUnsafe (rs2range ss) + -- debugM $ "printComments: (ss,comment locations): " ++ showPprUnsafe (rs2range ss,map commentLoc cs) + mapM_ printOneComment cs + debugM $ "printCommentsIn:done" + +-- --------------------------------------------------------------------- + +printOneComment :: (Monad m, Monoid w) => Comment -> EP w m () +printOneComment c@(Comment _str loc _r _mo) = do + debugM $ "printOneComment:c=" ++ showGhc c + dp <-case loc of + EpaDelta _ dp _ -> return dp + EpaSpan (RealSrcSpan r _) -> do + pe <- getPriorEndD + debugM $ "printOneComment:pe=" ++ showGhc pe + let dp = ss2delta pe r + debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc) + adjustDeltaForOffsetM dp + EpaSpan (UnhelpfulSpan _) -> return (SameLine 0) + mep <- getExtraDP + dp' <- case mep of + Just (EpaDelta _ edp _) -> do + debugM $ "printOneComment:edp=" ++ show edp + return edp + _ -> return dp + -- Start of debug printing + LayoutStartCol dOff <- getLayoutOffsetD + debugM $ "printOneComment:(dp,dp',dOff,loc)=" ++ showGhc (dp,dp',dOff,loc) + -- End of debug printing + updateAndApplyComment c dp' + printQueuedComment c dp' + +updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () +updateAndApplyComment (Comment str anc pp mo) dp = do + applyComment (Comment str anc' pp mo) + where + ss = case anc of + EpaSpan ss' -> ss' + _ -> noSrcSpan + anc' = EpaDelta ss dp NoComments + +-- --------------------------------------------------------------------- + +commentAllocationBefore :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment] +commentAllocationBefore ss = do + cs <- getUnallocatedComments + -- Note: The CPP comment injection may change the file name in the + -- RealSrcSpan, which affects comparison, as the Ord instance for + -- RealSrcSpan compares the file first. So we sort via ss2pos + -- TODO: this is inefficient, use Pos all the way through + let (earlier,later) = partition (\(Comment _str loc _r _mo) -> + case loc of + EpaSpan (RealSrcSpan r _) -> (ss2pos r) <= (ss2pos ss) + _ -> True -- Choose one + ) cs + putUnallocatedComments later + -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) + return earlier + +commentAllocationIn :: (Monad m, Monoid w) => RealSrcSpan -> EP w m [Comment] +commentAllocationIn ss = do + cs <- getUnallocatedComments + -- Note: The CPP comment injection may change the file name in the + -- RealSrcSpan, which affects comparison, as the Ord instance for + -- RealSrcSpan compares the file first. So we sort via ss2pos + -- TODO: this is inefficient, use Pos all the way through + let (earlier,later) = partition (\(Comment _str loc _r _mo) -> + case loc of + EpaSpan (RealSrcSpan r _) -> (ss2posEnd r) <= (ss2posEnd ss) + _ -> True -- Choose one + ) cs + putUnallocatedComments later + -- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later) + return earlier +-- --------------------------------------------------------------------- + +markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast +markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a + +-- --------------------------------------------------------------------- +-- End of utility functions +-- --------------------------------------------------------------------- +-- Start of ExactPrint instances +-- --------------------------------------------------------------------- + +-- | Bare Located elements are simply stripped off without further +-- processing. +instance (ExactPrint a) => ExactPrint (Located a) where + getAnnotationEntry (L l _) = case l of + UnhelpfulSpan _ -> NoEntryVal + _ -> Entry (EpaSpan l) [] emptyComments NoFlushComments CanUpdateAnchorOnly + + setAnnotationAnchor (L l a) _anc _ts _cs = L l a + + exact (L l a) = L l <$> markAnnotated a + +instance (ExactPrint a) => ExactPrint (LocatedE a) where + getAnnotationEntry (L l _) = Entry l [] emptyComments NoFlushComments CanUpdateAnchorOnly + setAnnotationAnchor (L _ a) anc _ts _cs = L anc a + + exact (L la a) = do + debugM $ "LocatedE a:la loc=" ++ show (ss2range $ locA la) + a' <- markAnnotated a + return (L la a') + +instance (ExactPrint a) => ExactPrint (LocatedA a) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs + exact (L la a) = do + debugM $ "LocatedA a:la loc=" ++ show (ss2range $ locA la) + a' <- markAnnotated a + return (L la a') + +instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs + exact (L la a) = do + a' <- markAnnotated a + return (L la a') + +instance (ExactPrint a) => ExactPrint [a] where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor ls _ _ _ = ls + exact ls = mapM markAnnotated ls + +instance (ExactPrint a) => ExactPrint (Maybe a) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor ma _ _ _ = ma + exact ma = mapM markAnnotated ma + +instance (ExactPrint a) => ExactPrint (NonEmpty a) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor ls _ _ _ = ls + exact ls = mapM markAnnotated ls + +-- --------------------------------------------------------------------- + +-- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' +instance ExactPrint (HsModule GhcPs) where + getAnnotationEntry hsmod = fromAnn' (hsmodAnn $ hsmodExt hsmod) + -- A bit pointless actually changing anything here + setAnnotationAnchor hsmod anc _ts cs = setAnchorHsModule hsmod anc cs + `debug` ("setAnnotationAnchor hsmod called" ++ showAst (anc,cs)) + + exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do + + let mbDoc' = mbDoc + + (an0, mmn' , mdeprec', mexports') <- + case mmn of + Nothing -> return (an, mmn, mdeprec, mexports) + Just m -> do + an0 <- markLensTok an lam_mod + m' <- markAnnotated m + + mdeprec' <- markAnnotated mdeprec + + mexports' <- markAnnotated mexports + + an1 <- markLensTok an0 lam_where + + return (an1, Just m', mdeprec', mexports') + + lo0 <- case lo of + EpExplicitBraces open close -> do + open' <- markEpToken open + return (EpExplicitBraces open' close) + _ -> return lo + + am_decls' <- markTrailing (am_decls $ anns an0) + + mid <- markAnnotated (HsModuleImpDecls (am_cs $ anns an0) imports decls) + let imports' = id_imps mid + let decls' = id_decls mid + + lo1 <- case lo0 of + EpExplicitBraces open close -> do + close' <- markEpToken close + return (EpExplicitBraces open close') + _ -> return lo + + -- Print EOF + case am_eof $ anns an of + Nothing -> return () + Just (pos, prior) -> do + debugM $ "am_eof:" ++ showGhc (pos, prior) + setEofPos (Just (pos, prior)) + + let anf = an0 { anns = (anns an0) { am_decls = am_decls', am_cs = [] }} + debugM $ "HsModule, anf=" ++ showAst anf + + return (HsModule (XModulePs anf lo1 mdeprec' mbDoc') mmn' mexports' imports' decls') + +-- --------------------------------------------------------------------- + +-- | This is used to ensure the comments are updated into the right +-- place for makeDeltaAst. +data HsModuleImpDecls + = HsModuleImpDecls { + id_cs :: [LEpaComment], + id_imps :: [LImportDecl GhcPs], + id_decls :: [LHsDecl GhcPs] + } deriving Data + +instance ExactPrint HsModuleImpDecls where + -- Use an UnhelpfulSpan for the anchor, we are only interested in the comments + getAnnotationEntry mid = mkEntry (EpaSpan (UnhelpfulSpan UnhelpfulNoLocationInfo)) [] (EpaComments (id_cs mid)) + setAnnotationAnchor mid _anc _ cs = mid { id_cs = priorComments cs ++ getFollowingComments cs } + `debug` ("HsModuleImpDecls.setAnnotationAnchor:cs=" ++ showAst cs) + exact (HsModuleImpDecls cs imports decls) = do + imports' <- mapM markAnnotated imports + decls' <- mapM markAnnotated (filter notDocDecl decls) + return (HsModuleImpDecls cs imports' decls') + + +-- --------------------------------------------------------------------- + +instance ExactPrint ModuleName where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor n _anc _ cs = n + `debug` ("ModuleName.setAnnotationAnchor:cs=" ++ showAst cs) + exact n = do + debugM $ "ModuleName: " ++ showPprUnsafe n + withPpr n + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP (WarningTxt GhcPs)) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + + exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt mb_cat src ws)) = do + o' <- markAnnOpen'' o src "{-# WARNING" + mb_cat' <- markAnnotated mb_cat + os' <- markEpToken os + ws' <- markAnnotated ws + cs' <- markEpToken cs + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt mb_cat' src ws')) + + exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do + o' <- markAnnOpen'' o src "{-# DEPRECATED" + os' <- markEpToken os + ws' <- markAnnotated ws + cs' <- markEpToken cs + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws')) + +instance ExactPrint InWarningCategory where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (InWarningCategory tkIn source (L l wc)) = do + tkIn' <- markEpToken tkIn + L l' (_,wc') <- markAnnotated (L l (source, wc)) + return (InWarningCategory tkIn' source (L l' wc')) + +instance ExactPrint (SourceText, WarningCategory) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (st, WarningCategory wc) = do + case st of + NoSourceText -> printStringAdvance $ "\"" ++ (unpackFS wc) ++ "\"" + SourceText src -> printStringAdvance $ (unpackFS src) + return (st, WarningCategory wc) + +-- --------------------------------------------------------------------- + +instance ExactPrint (ImportDecl GhcPs) where + getAnnotationEntry idecl = fromAnn (ideclAnn $ ideclExt idecl) + setAnnotationAnchor idecl anc ts cs = idecl { ideclExt + = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc ts cs} } + + exact (ImportDecl (XImportDeclPass ann msrc impl) + modname mpkg src st safeflag qualFlag mAs hiding) = do + + ann0 <- markLensFun' ann limportDeclAnnImport markEpToken + let (EpAnn _anc an _cs) = ann0 + + -- "{-# SOURCE" and "#-}" + importDeclAnnPragma' <- + case msrc of + SourceText _txt -> do + debugM $ "ImportDecl sourcetext" + case importDeclAnnPragma an of + Just (mo, mc) -> do + mo' <- markAnnOpen'' mo msrc "{-# SOURCE" + mc' <- markEpToken mc + return $ Just (mo', mc') + Nothing -> do + _ <- markAnnOpen' Nothing msrc "{-# SOURCE" + printStringAtLsDelta (SameLine 1) "#-}" + return Nothing + NoSourceText -> return (importDeclAnnPragma an) + -- pre level + ann0' <- case st of + LevelStylePre _ -> markLensFun' ann0 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann0 + + + ann1 <- if safeflag + then markLensFun' ann0' limportDeclAnnSafe (\mt -> mapM markEpToken mt) + else return ann0' + ann2 <- + case qualFlag of + QualifiedPre -- 'qualified' appears in prepositive position. + -> markLensFun' ann1 limportDeclAnnQualified (\ml -> mapM markEpToken ml) + _ -> return ann1 + ann3 <- + case mpkg of + RawPkgQual (StringLiteral src' v _) -> + printStringAtMLocL ann2 limportDeclAnnPackage (sourceTextToString src' (show v)) + _ -> return ann2 + modname' <- markAnnotated modname + + -- post level + ann3' <- case st of + LevelStylePost _ -> markLensFun' ann3 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann3 + + ann4 <- + case qualFlag of + QualifiedPost -- 'qualified' appears in postpositive position. + -> markLensFun' ann3' limportDeclAnnQualified (\ml -> mapM markEpToken ml) + _ -> return ann3' + + (importDeclAnnAs', mAs') <- + case mAs of + Nothing -> return (importDeclAnnAs an, Nothing) + Just m0 -> do + a <- mapM markEpToken (importDeclAnnAs an) + m'' <- markAnnotated m0 + return (a, Just m'') + + hiding' <- + case hiding of + Nothing -> return hiding + Just (isHiding,lie) -> do + lie' <- markAnnotated lie + return (Just (isHiding, lie')) + + let (EpAnn anc' an' cs') = ann4 + let an2 = an' { importDeclAnnAs = importDeclAnnAs' + , importDeclAnnPragma = importDeclAnnPragma' + } + + return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl) + modname' mpkg src st safeflag qualFlag mAs' hiding') + +markEpAnnLevel :: (Monad m, Monoid w) => EpAnnLevel -> EP w m EpAnnLevel +markEpAnnLevel (EpAnnLevelSplice tok) = EpAnnLevelSplice <$> markEpToken tok +markEpAnnLevel (EpAnnLevelQuote tok) = EpAnnLevelQuote <$> markEpToken tok + +-- --------------------------------------------------------------------- + +instance ExactPrint HsDocString where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (MultiLineDocString decorator (x :| xs)) = do + printStringAdvance ("-- " ++ printDecorator decorator) + pe <- getPriorEndD + debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x) + x' <- markAnnotated x + xs' <- markAnnotated (map dedentDocChunk xs) + return (MultiLineDocString decorator (x' :| xs')) + exact x = do + -- TODO: can this happen? + debugM $ "Not exact printing:" ++ showAst x + return x + + +instance ExactPrint HsDocStringChunk where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact chunk = do + printStringAdvance ("--" ++ unpackHDSC chunk) + return chunk + + +instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (WithHsDocIdentifiers ds ids) = do + ds' <- exact ds + return (WithHsDocIdentifiers ds' ids) + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsDecl GhcPs) where + getAnnotationEntry (TyClD _ _) = NoEntryVal + getAnnotationEntry (InstD _ _) = NoEntryVal + getAnnotationEntry (DerivD _ _) = NoEntryVal + getAnnotationEntry (ValD _ _) = NoEntryVal + getAnnotationEntry (SigD _ _) = NoEntryVal + getAnnotationEntry (KindSigD _ _) = NoEntryVal + getAnnotationEntry (DefD _ _) = NoEntryVal + getAnnotationEntry (ForD _ _) = NoEntryVal + getAnnotationEntry (WarningD _ _) = NoEntryVal + getAnnotationEntry (AnnD _ _) = NoEntryVal + getAnnotationEntry (RuleD _ _) = NoEntryVal + getAnnotationEntry (SpliceD _ _) = NoEntryVal + getAnnotationEntry (DocD _ _) = NoEntryVal + getAnnotationEntry (RoleAnnotD _ _) = NoEntryVal + + -- We do not recurse, the generic traversal using this feature + -- should do that for us. + setAnnotationAnchor d _ _ _ = d + + exact (TyClD x d) = TyClD x <$> markAnnotated d + exact (InstD x d) = InstD x <$> markAnnotated d + exact (DerivD x d) = DerivD x <$> markAnnotated d + exact (ValD x d) = ValD x <$> markAnnotated d + exact (SigD x d) = SigD x <$> markAnnotated d + exact (KindSigD x d) = KindSigD x <$> markAnnotated d + exact (DefD x d) = DefD x <$> markAnnotated d + exact (ForD x d) = ForD x <$> markAnnotated d + exact (WarningD x d) = WarningD x <$> markAnnotated d + exact (AnnD x d) = AnnD x <$> markAnnotated d + exact (RuleD x d) = RuleD x <$> markAnnotated d + exact (SpliceD x d) = SpliceD x <$> markAnnotated d + exact (DocD x d) = DocD x <$> markAnnotated d + exact (RoleAnnotD x d) = RoleAnnotD x <$> markAnnotated d + +-- --------------------------------------------------------------------- + +instance ExactPrint (InstDecl GhcPs) where + getAnnotationEntry (ClsInstD _ _) = NoEntryVal + getAnnotationEntry (DataFamInstD _ _) = NoEntryVal + getAnnotationEntry (TyFamInstD _ _) = NoEntryVal + + setAnnotationAnchor d _ _ _ = d + + + exact (ClsInstD a cid) = do + cid' <- markAnnotated cid + return (ClsInstD a cid') + exact (DataFamInstD a decl) = do + decl' <- markAnnotated decl + return (DataFamInstD a decl') + exact (TyFamInstD a eqn) = do + eqn' <- markAnnotated eqn + return (TyFamInstD a eqn') + +-- --------------------------------------------------------------------- + +instance ExactPrint (DataFamInstDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact d = do + d' <- exactDataFamInstDecl d + return d' + +-- --------------------------------------------------------------------- + +exactDataFamInstDecl :: (Monad m, Monoid w) + => DataFamInstDecl GhcPs + -> EP w m (DataFamInstDecl GhcPs) +exactDataFamInstDecl + (DataFamInstDecl (FamEqn { feqn_ext = (ops, cps, eq) + , feqn_tycon = tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = defn })) = do + ((ops', cps'), tycon', bndrs', pats', defn') <- exactDataDefn pp_hdr defn + return + (DataFamInstDecl ( FamEqn { feqn_ext = (ops', cps', eq) + , feqn_tycon = tycon' + , feqn_bndrs = bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = defn' })) + `debug` ("exactDataFamInstDecl: defn' derivs:" ++ showAst (dd_derivs defn')) + where + pp_hdr :: (Monad m, Monoid w) + => Maybe (LHsContext GhcPs) + -> EP w m ( ([EpToken "("], [EpToken ")"] ) + , LocatedN RdrName + , HsOuterTyVarBndrs () GhcPs + , HsFamEqnPats GhcPs + , Maybe (LHsContext GhcPs)) + pp_hdr mctxt = exactHsFamInstLHS ops cps tycon bndrs pats fixity mctxt + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (DerivDecl (mw, (td,ti)) typ ms mov) = do + td' <- markEpToken td + ms' <- mapM markAnnotated ms + ti' <- markEpToken ti + mw' <- mapM markAnnotated mw + mov' <- mapM markAnnotated mov + typ' <- markAnnotated typ + return (DerivDecl (mw', (td',ti')) typ' ms' mov') + +-- --------------------------------------------------------------------- + +instance ExactPrint (ForeignDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (ForeignImport (tf,ti,td) n ty fimport) = do + tf' <- markEpToken tf + ti' <- markEpToken ti + + fimport' <- markAnnotated fimport + + n' <- markAnnotated n + td' <- markEpUniToken td + ty' <- markAnnotated ty + return (ForeignImport (tf',ti',td') n' ty' fimport') + + exact (ForeignExport (tf,te,td) n ty fexport) = do + tf' <- markEpToken tf + te' <- markEpToken te + fexport' <- markAnnotated fexport + n' <- markAnnotated n + td' <- markEpUniToken td + ty' <- markAnnotated ty + return (ForeignExport (tf',te',td') n' ty' fexport') + +-- --------------------------------------------------------------------- + +instance ExactPrint (ForeignImport GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (CImport (L ls src) cconv safety@(L l _) mh imp) = do + cconv' <- markAnnotated cconv + safety' <- if notDodgyE l + then markAnnotated safety + else return safety + ls' <- if notDodgyE ls + then markExternalSourceTextE ls src "" + else return ls + return (CImport (L ls' src) cconv' safety' mh imp) + +-- --------------------------------------------------------------------- + +instance ExactPrint (ForeignExport GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (CExport (L ls src) spec) = do + debugM $ "CExport starting" + spec' <- markAnnotated spec + ls' <- if notDodgyE ls + then markExternalSourceTextE ls src "" + else return ls + return (CExport (L ls' src) spec') + +-- --------------------------------------------------------------------- + +instance ExactPrint CExportSpec where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (CExportStatic st lbl cconv) = do + debugM $ "CExportStatic starting" + cconv' <- markAnnotated cconv + return (CExportStatic st lbl cconv') + +-- --------------------------------------------------------------------- + +instance ExactPrint Safety where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint CCallConv where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint (WarnDecls GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (Warnings ((o,c),src) warns) = do + o' <- markAnnOpen'' o src "{-# WARNING" -- Note: might be {-# DEPRECATED + warns' <- markAnnotated warns + c' <- markEpToken c + return (Warnings ((o',c'),src) warns') + +-- --------------------------------------------------------------------- + +instance ExactPrint (WarnDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (Warning (ns_spec, (o,c)) lns (WarningTxt mb_cat src ls )) = do + mb_cat' <- markAnnotated mb_cat + ns_spec' <- exactNsSpec ns_spec + lns' <- markAnnotated lns + o' <- markEpToken o + ls' <- markAnnotated ls + c' <- markEpToken c + return (Warning (ns_spec', (o',c')) lns' (WarningTxt mb_cat' src ls')) + + exact (Warning (ns_spec, (o,c)) lns (DeprecatedTxt src ls)) = do + ns_spec' <- exactNsSpec ns_spec + lns' <- markAnnotated lns + o' <- markEpToken o + ls' <- markAnnotated ls + c' <- markEpToken c + return (Warning (ns_spec', (o',c')) lns' (DeprecatedTxt src ls')) + +exactNsSpec :: (Monad m, Monoid w) => NamespaceSpecifier -> EP w m NamespaceSpecifier +exactNsSpec NoNamespaceSpecifier = pure NoNamespaceSpecifier +exactNsSpec (TypeNamespaceSpecifier type_) = do + type_' <- markEpToken type_ + pure (TypeNamespaceSpecifier type_') +exactNsSpec (DataNamespaceSpecifier data_) = do + data_' <- markEpToken data_ + pure (DataNamespaceSpecifier data_') + +-- --------------------------------------------------------------------- + +instance ExactPrint StringLiteral where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (StringLiteral src fs mcomma) = do + printSourceTextAA src (show (unpackFS fs)) + mcomma' <- mapM (\r -> printStringAtNC r ",") mcomma + return (StringLiteral src fs mcomma') + +-- --------------------------------------------------------------------- + +instance ExactPrint FastString where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. + -- exact fs = printStringAdvance (show (unpackFS fs)) + exact fs = printStringAdvance (unpackFS fs) >> return fs + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleDecls GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (HsRules ((o,c), src) rules) = do + o' <- + case src of + NoSourceText -> printStringAtAA o "{-# RULES" + SourceText srcTxt -> printStringAtAA o (unpackFS srcTxt) + rules' <- markAnnotated rules + c' <- markEpToken c + return (HsRules ((o',c'),src) rules') + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsRule ((ann_act, ann_eq),nsrc) (L ln n) act bndrs lhs rhs) = do + (L ln' _) <- markAnnotated (L ln (nsrc, n)) + ann_act' <- markActivation ann_act act + bndrs' <- markAnnotated bndrs + lhs' <- markAnnotated lhs + ann_eq' <- markEpToken ann_eq + rhs' <- markAnnotated rhs + return (HsRule ((ann_act', ann_eq'),nsrc) (L ln' n) act bndrs' lhs' rhs') + +markActivation :: (Monad m, Monoid w) + => ActivationAnn -> Activation -> EP w m ActivationAnn +markActivation (ActivationAnn o c t v) act = do + case act of + ActiveBefore src phase -> do + o' <- markEpToken o -- '[' + t' <- mapM markEpToken t -- ~ + v' <- mapM (\val -> printStringAtAA val (toSourceTextWithSuffix src (show phase) "")) v + c' <- markEpToken c -- ']' + return (ActivationAnn o' c' t' v') + ActiveAfter src phase -> do + o' <- markEpToken o -- '[' + v' <- mapM (\val -> printStringAtAA val (toSourceTextWithSuffix src (show phase) "")) v + c' <- markEpToken c -- ']' + return (ActivationAnn o' c' t v') + NeverActive -> do + o' <- markEpToken o -- '[' + t' <- mapM markEpToken t -- ~ + c' <- markEpToken c -- ']' + return (ActivationAnn o' c' t' v) + _ -> return (ActivationAnn o c t v) + +-- --------------------------------------------------------------------- + +instance ExactPrint (SpliceDecl GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (SpliceDecl x splice flag) = do + splice' <- markAnnotated splice + return (SpliceDecl x splice' flag) + +-- --------------------------------------------------------------------- + +instance ExactPrint (DocDecl GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + -- We print these as plain comments instead, do a NOP here. + exact v = return v + +-- --------------------------------------------------------------------- + +instance ExactPrint (RoleAnnotDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (RoleAnnotDecl (tt,tr) ltycon roles) = do + tt' <- markEpToken tt + tr' <- markEpToken tr + ltycon' <- markAnnotated ltycon + let markRole (L l (Just r)) = do + (L l' r') <- markAnnotated (L l r) + return (L l' (Just r')) + markRole (L l Nothing) = do + e' <- printStringAtAA (entry l) "_" + return (L (l { entry = e'}) Nothing) + roles' <- mapM markRole roles + return (RoleAnnotDecl (tt',tr') ltycon' roles') + +-- --------------------------------------------------------------------- + +instance ExactPrint Role where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact = withPpr + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleBndrs GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (RuleBndrs an0 mtybndrs termbndrs) = do + (an2, mtybndrs') <- + case mtybndrs of + Nothing -> return (an0, Nothing) + Just bndrs -> do + an1 <- markLensFun an0 lrb_tyanns_fst (traverse markEpUniToken) -- AnnForall + bndrs' <- mapM markAnnotated bndrs + an2 <- markLensFun an1 lrb_tyanns_snd (traverse markEpToken) -- AnnDot + return (an2, Just bndrs') + + an3 <- markLensFun an2 lrb_tmanns_fst (traverse markEpUniToken) -- AnnForall + termbndrs' <- mapM markAnnotated termbndrs + an4 <- markLensFun an3 lrb_tmanns_snd (traverse markEpToken) -- AnnDot + return (RuleBndrs an4 mtybndrs' termbndrs') + +-- --------------------------------------------------------------------- + +instance ExactPrint (RuleBndr GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (RuleBndr x ln) = do + ln' <- markAnnotated ln + return (RuleBndr x ln') + exact (RuleBndrSig (AnnTyVarBndr os cs ap dc) ln (HsPS x ty)) = do + os' <- markEpaLocationAll os "(" + ln' <- markAnnotated ln + dc' <- markEpUniToken dc + ty' <- markAnnotated ty + cs' <- markEpaLocationAll cs ")" + return (RuleBndrSig (AnnTyVarBndr os' cs' ap dc') ln' (HsPS x ty')) + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor fe _ _ _s = fe + exact (FamEqn { feqn_ext = (ops, cps, eq) + , feqn_tycon = tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = rhs }) = do + ((ops', cps'), tycon', bndrs', pats',_) <- exactHsFamInstLHS ops cps tycon bndrs pats fixity Nothing + eq' <- markEpToken eq + rhs' <- markAnnotated rhs + return (FamEqn { feqn_ext = (ops', cps', eq') + , feqn_tycon = tycon' + , feqn_bndrs = bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = rhs' }) + +-- --------------------------------------------------------------------- + +exactHsFamInstLHS :: + (Monad m, Monoid w) + => [EpToken "("] + -> [EpToken ")"] + -> LocatedN RdrName + -> HsOuterTyVarBndrs () GhcPs + -> HsFamEqnPats GhcPs + -> LexicalFixity + -> Maybe (LHsContext GhcPs) + -> EP w m ( ([EpToken "("], [EpToken ")"]) + , LocatedN RdrName + , HsOuterTyVarBndrs () GhcPs + , HsFamEqnPats GhcPs, Maybe (LHsContext GhcPs)) +exactHsFamInstLHS ops cps thing bndrs typats fixity mb_ctxt = do + -- TODO:AZ: do these ans exist? They are in the binders now + -- an0 <- markEpAnnL an lidl AnnForall + bndrs' <- markAnnotated bndrs + -- an1 <- markEpAnnL an0 lidl AnnDot + mb_ctxt' <- mapM markAnnotated mb_ctxt + (ops', cps', thing', typats') <- exact_pats ops cps typats + return ((ops', cps'), thing', bndrs', typats', mb_ctxt') + where + exact_pats :: (Monad m, Monoid w) + => [EpToken "("] -> [EpToken ")"] -> HsFamEqnPats GhcPs + -> EP w m ([EpToken "("], [EpToken ")"], LocatedN RdrName, HsFamEqnPats GhcPs) + exact_pats ops1 cps1 (patl:patr:pats) + | Infix <- fixity + = let exact_op_app = do + ops' <- mapM markEpToken ops1 + patl' <- markAnnotated patl + thing' <- markAnnotated thing + patr' <- markAnnotated patr + cps' <- mapM markEpToken cps1 + return (ops', cps', thing', [patl',patr']) + in case pats of + [] -> exact_op_app + _ -> do + (ops', cps', thing', p) <- exact_op_app + pats' <- mapM markAnnotated pats + return (ops', cps', thing', p++pats') + + exact_pats ops0 cps0 pats = do + ops' <- mapM markEpToken ops0 + thing' <- markAnnotated thing + pats' <- markAnnotated pats + cps' <- mapM markEpToken cps0 + return (ops', cps', thing', pats') + +-- --------------------------------------------------------------------- + +instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) + => ExactPrint (HsArg GhcPs tm ty) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsValArg x tm) = do + tm' <- markAnnotated tm + return (HsValArg x tm') + exact (HsTypeArg at ty) = do + at' <- markEpToken at + ty' <- markAnnotated ty + return (HsTypeArg at' ty') + exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source + +-- --------------------------------------------------------------------- + +instance ExactPrint (ClsInstDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (ClsInstDecl { cid_ext = (mbWarn, AnnClsInstDecl i w oc semis cc, sortKey) + , cid_poly_ty = inst_ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap + , cid_datafam_insts = adts }) + = do + (mbWarn', i', w', mbOverlap', inst_ty') <- top_matter + oc' <- markEpToken oc + semis' <- mapM markEpToken semis + (sortKey', ds) <- withSortKey sortKey + [(ClsAtTag, prepareListAnnotationA ats), + (ClsAtdTag, prepareListAnnotationF adts), + (ClsMethodTag, prepareListAnnotationA binds), + (ClsSigTag, prepareListAnnotationA sigs) + ] + cc' <- markEpToken cc + let + ats' = undynamic ds + adts' = undynamic ds + binds' = undynamic ds + sigs' = undynamic ds + return (ClsInstDecl { cid_ext = (mbWarn', AnnClsInstDecl i' w' oc' semis' cc', sortKey') + , cid_poly_ty = inst_ty', cid_binds = binds' + , cid_sigs = sigs', cid_tyfam_insts = ats' + , cid_overlap_mode = mbOverlap' + , cid_datafam_insts = adts' }) + + where + top_matter = do + i' <- markEpToken i + mw <- mapM markAnnotated mbWarn + mo <- mapM markAnnotated mbOverlap + it <- markAnnotated inst_ty + w' <- markEpToken w -- Optional + return (mw, i', w', mo,it) + +-- --------------------------------------------------------------------- + +instance ExactPrint (TyFamInstDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact d@(TyFamInstDecl { tfid_xtn = (tt,ti), tfid_eqn = eqn }) = do + tt' <- markEpToken tt + ti' <- markEpToken ti + eqn' <- markAnnotated eqn + return (d { tfid_xtn = (tt',ti'), tfid_eqn = eqn' }) + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP OverlapMode) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + + -- NOTE: NoOverlap is only used in the typechecker + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NoOverlap src)) = do + o' <- markAnnOpen'' o src "{-# NO_OVERLAP" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (NoOverlap src)) + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlappable src)) = do + o' <- markAnnOpen'' o src "{-# OVERLAPPABLE" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlappable src)) + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlapping src)) = do + o' <- markAnnOpen'' o src "{-# OVERLAPPING" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlapping src)) + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlaps src)) = do + o' <- markAnnOpen'' o src "{-# OVERLAPS" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlaps src)) + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Incoherent src)) = do + o' <- markAnnOpen'' o src "{-# INCOHERENT" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src)) + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NonCanonical src)) = do + o' <- markAnnOpen'' o src "{-# INCOHERENT" + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src)) + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsBind GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (FunBind x fid matches) = do + matches' <- markAnnotated matches + let + fun_id' = case unLoc (mg_alts matches') of + [] -> fid + (L _ m:_) -> case m_ctxt m of + FunRhs f _ _ _ -> f + _ -> fid + return (FunBind x fun_id' matches') + + exact (PatBind x pat q grhss) = do + (q', pat') <- markMultAnnOf q (markAnnotated pat) + grhss' <- markAnnotated grhss + return (PatBind x pat' q' grhss') + exact (PatSynBind x bind) = do + bind' <- markAnnotated bind + return (PatSynBind x bind') + + exact x = error $ "HsBind: exact for " ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (PatSynBind GhcPs GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (PSB{ psb_ext = AnnPSB ap ao ac al ae + , psb_id = psyn, psb_args = details + , psb_def = pat + , psb_dir = dir }) = do + ap' <- markEpToken ap + (ao', ac', psyn', details') <- + case details of + InfixCon v1 v2 -> do + v1' <- markAnnotated v1 + psyn' <- markAnnotated psyn + v2' <- markAnnotated v2 + return (ao, ac, psyn',InfixCon v1' v2') + PrefixCon vs -> do + psyn' <- markAnnotated psyn + vs' <- markAnnotated vs + return (ao, ac, psyn', PrefixCon vs') + RecCon vs -> do + psyn' <- markAnnotated psyn + ao' <- mapM markEpToken ao + vs' <- markAnnotated vs + ac' <- mapM markEpToken ac + return (ao', ac', psyn', RecCon vs') + + (al', ae', pat', dir') <- + case dir of + Unidirectional -> do + al' <- mapM markEpUniToken al + pat' <- markAnnotated pat + return (al', ae, pat', dir) + ImplicitBidirectional -> do + ae' <- mapM markEpToken ae + pat' <- markAnnotated pat + return (al, ae', pat', dir) + ExplicitBidirectional mg -> do + al' <- mapM markEpUniToken al + pat' <- markAnnotated pat + mg' <- markAnnotated mg + return (al', ae, pat', ExplicitBidirectional mg') + + return (PSB{ psb_ext = AnnPSB ap' ao' ac' al' ae' + , psb_id = psyn', psb_args = details' + , psb_def = pat' + , psb_dir = dir' }) + + +-- --------------------------------------------------------------------- + +instance ExactPrint (RecordPatSynField GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (RecordPatSynField f v) = do + f' <- markAnnotated f + return (RecordPatSynField f' v) + +-- --------------------------------------------------------------------- + +instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (Match an mctxt pats grhss) = + exactMatch (Match an mctxt pats grhss) + +-- ------------------------------------- + +instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (Match an mctxt pats grhss) = + exactMatch (Match an mctxt pats grhss) + +-- --------------------------------------------------------------------- + +exactMatch :: (Monad m, Monoid w, ExactPrint (GRHSs GhcPs body)) + => (Match GhcPs body) -> EP w m (Match GhcPs body) +exactMatch (Match an mctxt pats grhss) = do + + debugM $ "exact Match entered" + + (mctxt', pats') <- + case mctxt of + FunRhs fun fixity strictness (AnnFunRhs strict opens closes) -> do + debugM $ "exact Match FunRhs:" ++ showPprUnsafe fun + strict' <- markEpToken strict + case fixity of + Prefix -> do + epTokensToComments "(" opens + epTokensToComments ")" closes + fun' <- markAnnotated fun + pats' <- markAnnotated pats + return (FunRhs fun' fixity strictness (AnnFunRhs strict' [] []), pats') + Infix -> + case pats of + L l (p1:p2:rest) + | null rest -> do + p1' <- markAnnotated p1 + fun' <- markAnnotated fun + p2' <- markAnnotated p2 + return (FunRhs fun' fixity strictness (AnnFunRhs strict' [] []), L l [p1',p2']) + | otherwise -> do + opens' <- markEpToken1 opens + p1' <- markAnnotated p1 + fun' <- markAnnotated fun + p2' <- markAnnotated p2 + closes' <- markEpToken1 closes + rest' <- mapM markAnnotated rest + return (FunRhs fun' fixity strictness (AnnFunRhs strict' opens' closes'), L l (p1':p2':rest')) + _ -> panic "FunRhs" + + LamAlt v -> do + pats' <- markAnnotated pats + return (LamAlt v, pats') + + CaseAlt -> do + pats' <- markAnnotated pats + return (CaseAlt, pats') + + _ -> do + mctxt' <- withPpr mctxt + return (mctxt', pats) + + grhss' <- markAnnotated grhss + + return (Match an mctxt' pats' grhss') + +-- --------------------------------------------------------------------- + +instance ExactPrint (GRHSs GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry (GRHSs _ _ _) = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (GRHSs cs grhss binds) = do + addCommentsA $ priorComments cs + addCommentsA $ getFollowingComments cs + grhss' <- markAnnotated grhss + binds' <- markAnnotated binds + -- The comments will be added back as they are printed + return (GRHSs emptyComments grhss' binds') + + +instance ExactPrint (GRHSs GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry (GRHSs _ _ _) = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (GRHSs cs grhss binds) = do + addCommentsA $ priorComments cs + addCommentsA $ getFollowingComments cs + grhss' <- markAnnotated grhss + binds' <- markAnnotated binds + -- The comments will be added back as they are printed + return (GRHSs emptyComments grhss' binds') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsLocalBinds GhcPs) where + getAnnotationEntry (HsValBinds an _) = fromAnn an + getAnnotationEntry (HsIPBinds{}) = NoEntryVal + getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal + + setAnnotationAnchor (HsValBinds an a) anc ts cs = HsValBinds (setAnchorEpaL an anc ts cs) a + setAnnotationAnchor a _ _ _ = a + + exact (HsValBinds an valbinds) = do + an0 <- markLensFun' an lal_rest markEpToken -- 'where' + + case al_anchor $ anns an of + Just anc -> do + when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc) + _ -> return () + + (an1, valbinds') <- markAnnList an0 $ markAnnotatedWithLayout valbinds + debugM $ "exact HsValBinds: an1=" ++ showAst an1 + medr <- getExtraDPReturn + an2 <- case medr of + Nothing -> return an1 + Just (ss,dp) -> do + setExtraDPReturn Nothing + return $ an1 { anns = (anns an1) { al_anchor = Just (EpaDelta ss dp []) }} + return (HsValBinds an2 valbinds') + + exact (HsIPBinds an bs) = do + (an2,bs') <- markAnnListA an $ \an0 -> do + an1 <- markLensFun' an0 lal_rest markEpToken + bs' <- markAnnotated bs + return (an1, bs') + return (HsIPBinds an2 bs') + exact b@(EmptyLocalBinds _) = return b + + +-- --------------------------------------------------------------------- +instance ExactPrint (HsValBindsLR GhcPs GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (ValBinds sortKey binds sigs) = do + decls <- setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs) + let + binds' = concatMap decl2Bind decls + sigs' = concatMap decl2Sig decls + sortKey' = captureOrderBinds decls + return (ValBinds sortKey' binds' sigs') + exact (XValBindsLR _) = panic "XValBindsLR" + +undynamic :: Typeable a => [Dynamic] -> [a] +undynamic ds = mapMaybe fromDynamic ds + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsIPBinds GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (IPBinds x binds) = setLayoutBoth $ do + binds' <- markAnnotated binds + return (IPBinds x binds') + +-- --------------------------------------------------------------------- + +instance ExactPrint (IPBind GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (IPBind an lr rhs) = do + lr' <- markAnnotated lr + an0 <- markEpToken an + rhs' <- markAnnotated rhs + return (IPBind an0 lr' rhs') + + +-- --------------------------------------------------------------------- + +instance ExactPrint HsIPName where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact i@(HsIPName fs) = printStringAdvanceA ("?" ++ (unpackFS fs)) >> return i + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + +prepareListAnnotationF :: (Monad m, Monoid w) => + [LDataFamInstDecl GhcPs] -> [(RealSrcSpan,EP w m Dynamic)] +prepareListAnnotationF ls = map (\b -> (realSrcSpan $ getLocA b, go b)) ls + where + go (L l a) = do + (L l' d') <- markAnnotated (L l a) + return (toDyn (L l' d')) + +prepareListAnnotationA :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) + => [LocatedAn an a] -> [(RealSrcSpan,EP w m Dynamic)] +prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,go b)) ls + where + go b = do + b' <- markAnnotated b + return (toDyn b') + +withSortKey :: (Monad m, Monoid w) + => AnnSortKey DeclTag -> [(DeclTag, [(RealSrcSpan, EP w m Dynamic)])] + -> EP w m (AnnSortKey DeclTag, [Dynamic]) +withSortKey annSortKey xs = do + debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey + let (sk, ordered) = case annSortKey of + NoAnnSortKey -> (annSortKey', map snd os) + where + doOne (tag, ds) = map (\d -> (tag, d)) ds + xsExpanded = concatMap doOne xs + os = sortBy orderByFst $ xsExpanded + annSortKey' = AnnSortKey (map fst os) + AnnSortKey _keys -> (annSortKey, orderedDecls annSortKey (Map.fromList xs)) + ordered' <- mapM snd ordered + return (sk, ordered') + +orderByFst :: Ord a => (t, (a,b1)) -> (t, (a, b2)) -> Ordering +orderByFst (_,(a,_)) (_,(b,_)) = compare a b + +-- --------------------------------------------------------------------- + +instance ExactPrint (Sig GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (TypeSig (AnnSig dc mp md) vars ty) = do + (dc', vars', ty') <- exactVarSig dc vars ty + return (TypeSig (AnnSig dc' mp md) vars' ty') + + exact (PatSynSig (AnnSig dc mp md) lns typ) = do + mp' <- mapM markEpToken mp + lns' <- markAnnotated lns + dc' <- markEpUniToken dc + typ' <- markAnnotated typ + return (PatSynSig (AnnSig dc' mp' md) lns' typ') + + exact (ClassOpSig (AnnSig dc mp md) is_deflt vars ty) + | is_deflt = do + md' <- mapM markEpToken md + (dc', vars',ty') <- exactVarSig dc vars ty + return (ClassOpSig (AnnSig dc' mp md') is_deflt vars' ty') + | otherwise = do + (dc', vars',ty') <- exactVarSig dc vars ty + return (ClassOpSig (AnnSig dc' mp md) is_deflt vars' ty') + + exact (FixSig ((af, ma),src) (FixitySig ns names (Fixity v fdir))) = do + let fixstr = case fdir of + InfixL -> "infixl" + InfixR -> "infixr" + InfixN -> "infix" + af' <- printStringAtAA af fixstr + ma' <- mapM (\l -> printStringAtAA l (sourceTextToString src (show v))) ma + ns' <- markAnnotated ns + names' <- markAnnotated names + return (FixSig ((af',ma'),src) (FixitySig ns' names' (Fixity v fdir))) + + exact (InlineSig (o,c,act) ln inl) = do + o' <- markAnnOpen'' o (inl_src inl) "{-# INLINE" + act' <- markActivation act (inl_act inl) + ln' <- markAnnotated ln + c' <- markEpToken c + return (InlineSig (o', c', act') ln' inl) + + exact (SpecSig (AnnSpecSig o c dc act) ln typs inl) = do + o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE + act' <- markActivation act (inl_act inl) + ln' <- markAnnotated ln + dc' <- traverse markEpUniToken dc + typs' <- markAnnotated typs + c' <- markEpToken c + return (SpecSig (AnnSpecSig o' c' dc' act') ln' typs' inl) + + exact (SpecSigE (AnnSpecSig o c dc act) bndrs expr inl) = do + o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE + act' <- markActivation act (inl_act inl) + bndrs' <- markAnnotated bndrs + expr' <- markAnnotated expr + c' <- markEpToken c + return (SpecSigE (AnnSpecSig o' c' dc act') bndrs' expr' inl) + + exact (SpecInstSig ((o,i,c),src) typ) = do + o' <- markAnnOpen'' o src "{-# SPECIALISE" + i' <- markEpToken i + typ' <- markAnnotated typ + c' <- markEpToken c + return (SpecInstSig ((o',i',c'),src) typ') + + exact (MinimalSig ((o,c),src) formula) = do + o' <- markAnnOpen'' o src "{-# MINIMAL" + formula' <- markAnnotated formula + c' <- markEpToken c + return (MinimalSig ((o',c'),src) formula') + + exact (SCCFunSig ((o,c),src) ln ml) = do + o' <- markAnnOpen'' o src "{-# SCC" + ln' <- markAnnotated ln + ml' <- markAnnotated ml + c' <- markEpToken c + return (SCCFunSig ((o',c'),src) ln' ml') + + exact (CompleteMatchSig ((o,md,c),src) cs mty) = do + o' <- markAnnOpen'' o src "{-# COMPLETE" + cs' <- mapM markAnnotated cs + (md', mty') <- + case mty of + Nothing -> return (md, mty) + Just ty -> do + md' <- mapM markEpUniToken md + ty' <- markAnnotated ty + return (md', Just ty') + c' <- markEpToken c + return (CompleteMatchSig ((o',md',c'),src) cs' mty') + +-- --------------------------------------------------------------------- + +instance ExactPrint NamespaceSpecifier where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact NoNamespaceSpecifier = return NoNamespaceSpecifier + exact (TypeNamespaceSpecifier typeTok) = do + typeTok' <- markEpToken typeTok + return (TypeNamespaceSpecifier typeTok') + exact (DataNamespaceSpecifier dataTok) = do + dataTok' <- markEpToken dataTok + return (DataNamespaceSpecifier dataTok') + +-- --------------------------------------------------------------------- + +exactVarSig :: (Monad m, Monoid w, ExactPrint a) + => TokDcolon -> [LocatedN RdrName] -> a -> EP w m (TokDcolon, [LocatedN RdrName], a) +exactVarSig dc vars ty = do + vars' <- mapM markAnnotated vars + dc' <- markEpUniToken dc + ty' <- markAnnotated ty + return (dc', vars', ty') + +-- --------------------------------------------------------------------- + +instance ExactPrint (StandaloneKindSig GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (StandaloneKindSig (tt,td) vars sig) = do + tt' <- markEpToken tt + vars' <- markAnnotated vars + td' <- markEpUniToken td + sig' <- markAnnotated sig + return (StandaloneKindSig (tt',td') vars' sig') + +-- --------------------------------------------------------------------- + +instance ExactPrint (DefaultDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (DefaultDecl (d,op,cp) cl tys) = do + d' <- markEpToken d + cl' <- markAnnotated cl + op' <- markEpToken op + tys' <- markAnnotated tys + cp' <- markEpToken cp + return (DefaultDecl (d',op',cp') cl' tys') + +-- --------------------------------------------------------------------- + +instance ExactPrint (AnnDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsAnnotation (AnnPragma o c s l1 l2 t m, src) prov e) = do + o' <- markAnnOpen'' o src "{-# ANN" + (t', m', prov') <- + case prov of + (ValueAnnProvenance n) -> do + n' <- markAnnotated n + return (t, m, ValueAnnProvenance n') + (TypeAnnProvenance n) -> do + t' <- markEpToken t + n' <- markAnnotated n + return (t', m, TypeAnnProvenance n') + ModuleAnnProvenance -> do + m' <- markEpToken m + return (t, m', prov) + + e' <- markAnnotated e + c' <- markEpToken c + return (HsAnnotation (AnnPragma o' c' s l1 l2 t' m',src) prov' e') + +-- --------------------------------------------------------------------- + +instance ExactPrint (BF.BooleanFormula GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (BF.Var x) = do + x' <- markAnnotated x + return (BF.Var x') + exact (BF.Or ls) = do + ls' <- markAnnotated ls + return (BF.Or ls') + exact (BF.And ls) = do + ls' <- markAnnotated ls + return (BF.And ls') + exact (BF.Parens x) = do + x' <- markAnnotated x + return (BF.Parens x') + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) => ExactPrint (HsWildCardBndrs GhcPs body) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _= a + exact (HsWC x ty) = do + ty' <- markAnnotated ty + return (HsWC x ty') + +-- --------------------------------------------------------------------- + +instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry (GRHS an _ _) = fromAnn an + setAnnotationAnchor (GRHS an a b) anc ts cs = GRHS (setAnchorEpa an anc ts cs) a b + + exact (GRHS an guards expr) = do + an0 <- if null guards + then return an + else markLensFun' an lga_vbar (\mt -> mapM markEpToken mt) + guards' <- markAnnotated guards + -- Mark the matchSeparator for these GRHSs + an1 <- markLensFun' an0 lga_sep (\s -> case s of + Left tok -> Left <$> markEpToken tok + Right tok -> Right <$> markEpUniToken tok) + expr' <- markAnnotated expr + return (GRHS an1 guards' expr') + +instance ExactPrint (GRHS GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry (GRHS ann _ _) = fromAnn ann + setAnnotationAnchor (GRHS an a b) anc ts cs = GRHS (setAnchorEpa an anc ts cs) a b + + exact (GRHS an guards expr) = do + an0 <- markLensFun' an lga_vbar (\mt -> mapM markEpToken mt) + guards' <- markAnnotated guards + -- Mark the matchSeparator for these GRHSs + an1 <- markLensFun' an0 lga_sep (\s -> case s of + Left tok -> Left <$> markEpToken tok + Right tok -> Right <$> markEpUniToken tok) + expr' <- markAnnotated expr + return (GRHS an1 guards' expr') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsExpr GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a + + exact (HsVar x n) = do + -- The parser inserts a placeholder value for a record pun rhs. This must be + -- filtered. + let pun_RDR = "pun-right-hand-side" + n' <- if (showPprUnsafe n /= pun_RDR) + then markAnnotated n + else return n + return (HsVar x n') + exact (HsHole (HoleVar n)) = do + let pun_RDR = "pun-right-hand-side" + n' <- if (showPprUnsafe n /= pun_RDR) + then markAnnotated n + else return n + return (HsHole (HoleVar n')) + -- TODO: Adapt 'HoleError' to include the 'SourceText': + exact (HsHole HoleError) = error "Cannot exact print HoleError" + exact x@(HsOverLabel src l) = do + printStringAdvanceA "#" >> return () + case src of + NoSourceText -> printStringAdvanceA (unpackFS l) >> return () + SourceText txt -> printStringAdvanceA (unpackFS txt) >> return () + return x + + exact x@(HsIPVar _ (HsIPName n)) + = printStringAdvance ("?" ++ unpackFS n) >> return x + + exact x@(HsOverLit _an ol) = do + let str = case ol_val ol of + HsIntegral (IL src _ _) -> src + HsFractional (FL { fl_text = src }) -> src + HsIsString src _ -> src + case str of + SourceText s -> printStringAdvance (unpackFS s) >> return () + NoSourceText -> withPpr x >> return () + return x + + exact (HsLit an lit) = do + lit' <- withPpr lit + return (HsLit an lit') + + exact (HsLam an lam_variant mg) = do + an0 <- markLensFun an lepl_lambda markEpToken + an1 <- case lam_variant of + LamSingle -> return an0 + LamCase -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "case") ml) + LamCases -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "cases") ml) + mg' <- markAnnotated mg + return (HsLam an1 lam_variant mg') + + exact (HsApp an e1 e2) = do + p <- getPosP + debugM $ "HsApp entered. p=" ++ show p + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + return (HsApp an e1' e2') + exact (HsAppType at fun arg) = do + fun' <- markAnnotated fun + at' <- markEpToken at + arg' <- markAnnotated arg + return (HsAppType at' fun' arg') + exact (OpApp x e1 e2 e3) = do + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + e3' <- markAnnotated e3 + return (OpApp x e1' e2' e3') + + exact (NegApp an e s) = do + an0 <- markEpToken an + e' <- markAnnotated e + return (NegApp an0 e' s) + + exact (HsPar (lpar, rpar) e) = do + lpar' <- markEpToken lpar + e' <- markAnnotated e + debugM $ "HsPar closing paren" + rpar' <- markEpToken rpar + debugM $ "HsPar done" + return (HsPar (lpar', rpar') e') + + exact (SectionL an expr op) = do + expr' <- markAnnotated expr + op' <- markAnnotated op + return (SectionL an expr' op') + + exact (SectionR an op expr) = do + op' <- markAnnotated op + expr' <- markAnnotated expr + return (SectionR an op' expr') + + exact (ExplicitTuple (o,c) args b) = do + o0 <- if b == Boxed then printStringAtAA o "(" + else printStringAtAA o "(#" + + args' <- mapM markAnnotated args + + c0 <- if b == Boxed then printStringAtAA c ")" + else printStringAtAA c "#)" + debugM $ "ExplicitTuple done" + return (ExplicitTuple (o0,c0) args' b) + + exact (ExplicitSum an alt arity expr) = do + an0 <- markLensFun an laesOpen (\loc -> printStringAtAA loc "(#") + an1 <- markLensFun an0 laesBarsBefore (\locs -> mapM markEpToken locs) + expr' <- markAnnotated expr + an2 <- markLensFun an1 laesBarsAfter (\locs -> mapM markEpToken locs) + an3 <- markLensFun an2 laesClose (\loc -> printStringAtAA loc "#)") + return (ExplicitSum an3 alt arity expr') + + exact (HsCase an e alts) = do + an0 <- markLensFun an lhsCaseAnnCase markEpToken + e' <- markAnnotated e + an1 <- markLensFun an0 lhsCaseAnnOf markEpToken + alts' <- setLayoutBoth $ markAnnotated alts + return (HsCase an1 e' alts') + + exact (HsIf an e1 e2 e3) = do + an0 <- markLensFun an laiIf markEpToken + e1' <- markAnnotated e1 + an1 <- markLensFun an0 laiThenSemi (\mt -> mapM markEpToken mt) + an2 <- markLensFun an1 laiThen markEpToken + e2' <- markAnnotated e2 + an3 <- markLensFun an2 laiElseSemi (\mt -> mapM markEpToken mt) + an4 <- markLensFun an3 laiElse markEpToken + e3' <- markAnnotated e3 + return (HsIf an4 e1' e2' e3') + + exact (HsMultiIf (i,o,c) mg) = do + i0 <- markEpToken i + o0 <- markEpToken o + mg' <- markAnnotated mg + c0 <- markEpToken c + return (HsMultiIf (i0,o0,c0) mg') + + exact (HsLet (tkLet, tkIn) binds e) = do + setLayoutBoth $ do -- Make sure the 'in' gets indented too + tkLet' <- markEpToken tkLet + binds' <- setLayoutBoth $ markAnnotated binds + tkIn' <- markEpToken tkIn + e' <- markAnnotated e + return (HsLet (tkLet',tkIn') binds' e') + + exact (HsDo an do_or_list_comp stmts) = do + debugM $ "HsDo" + (an',stmts') <- markAnnListA' an $ \a -> exactDo a do_or_list_comp stmts + return (HsDo an' do_or_list_comp stmts') + + exact (ExplicitList an es) = do + debugM $ "ExplicitList start" + an0 <- markLensBracketsO' an lal_brackets + es' <- markAnnotated es + an1 <- markLensBracketsC' an0 lal_brackets + debugM $ "ExplicitList end" + return (ExplicitList an1 es') + exact (RecordCon (open, close) con_id binds) = do + con_id' <- markAnnotated con_id + open' <- mapM markEpToken open + binds' <- markAnnotated binds + close' <- mapM markEpToken close + return (RecordCon (open',close') con_id' binds') + exact (RecordUpd (open, close) expr fields) = do + expr' <- markAnnotated expr + open' <- mapM markEpToken open + fields' <- markAnnotated fields + close' <- mapM markEpToken close + return (RecordUpd (open', close') expr' fields') + exact (HsGetField an expr field) = do + expr' <- markAnnotated expr + field' <- markAnnotated field + return (HsGetField an expr' field') + exact (HsProjection an flds) = do + an0 <- markLensFun an lapOpen markEpToken + flds' <- mapM markAnnotated flds + an1 <- markLensFun an0 lapClose markEpToken + return (HsProjection an1 flds') + exact (ExprWithTySig an expr sig) = do + expr' <- markAnnotated expr + an0 <- markEpUniToken an + sig' <- markAnnotated sig + return (ExprWithTySig an0 expr' sig') + exact (ArithSeq (AnnArithSeq o mc dd c) s seqInfo) = do + o' <- markEpToken o + (mc', dd', seqInfo') <- + case seqInfo of + From e -> do + e' <- markAnnotated e + dd' <- markEpToken dd + return (mc, dd', From e') + FromTo e1 e2 -> do + e1' <- markAnnotated e1 + dd' <- markEpToken dd + e2' <- markAnnotated e2 + return (mc, dd', FromTo e1' e2') + FromThen e1 e2 -> do + e1' <- markAnnotated e1 + mc' <- mapM markEpToken mc + e2' <- markAnnotated e2 + dd' <- markEpToken dd + return (mc', dd', FromThen e1' e2') + FromThenTo e1 e2 e3 -> do + e1' <- markAnnotated e1 + mc' <- mapM markEpToken mc + e2' <- markAnnotated e2 + dd' <- markEpToken dd + e3' <- markAnnotated e3 + return (mc', dd', FromThenTo e1' e2' e3') + c' <- markEpToken c + return (ArithSeq (AnnArithSeq o' mc' dd' c') s seqInfo') + + + exact (HsTypedBracket (o,c) e) = do + o' <- case o of + BracketNoE t -> BracketNoE <$> markEpToken t + BracketHasE t -> BracketHasE <$> markEpToken t + e' <- markAnnotated e + c' <- markEpToken c + return (HsTypedBracket (o',c') e') + + exact (HsUntypedBracket a (ExpBr (o,c) e)) = do + o' <- case o of + BracketNoE t -> BracketNoE <$> markEpUniToken t + BracketHasE t -> BracketHasE <$> markEpToken t + e' <- markAnnotated e + c' <- markEpUniToken c + return (HsUntypedBracket a (ExpBr (o',c') e')) + + exact (HsUntypedBracket a (PatBr (o,c) e)) = do + o' <- markEpToken o + e' <- markAnnotated e + c' <- markEpUniToken c + return (HsUntypedBracket a (PatBr (o',c') e')) + + exact (HsUntypedBracket a (DecBrL (o,c, (oc,cc)) e)) = do + o' <- markEpToken o + oc' <- markEpToken oc + e' <- markAnnotated e + cc' <- markEpToken cc + c' <- markEpUniToken c + return (HsUntypedBracket a (DecBrL (o',c',(oc',cc')) e')) + + exact (HsUntypedBracket a (TypBr (o,c) e)) = do + o' <- markEpToken o + e' <- markAnnotated e + c' <- markEpUniToken c + return (HsUntypedBracket a (TypBr (o',c') e')) + + exact (HsUntypedBracket a (VarBr an b e)) = do + (an0, e') <- if b + then do + an' <- printStringAtAA an "'" + e' <- markAnnotated e + return (an', e') + else do + an' <- printStringAtAA an "''" + e' <- markAnnotated e + return (an', e') + return (HsUntypedBracket a (VarBr an0 b e')) + + exact (HsTypedSplice an s) = do + s' <- markAnnotated s + return (HsTypedSplice an s') + + exact (HsUntypedSplice an s) = do + s' <- markAnnotated s + return (HsUntypedSplice an s') + + exact (HsProc (pr,r) p c) = do + debugM $ "HsProc start" + pr' <- markEpToken pr + p' <- markAnnotated p + r' <- markEpUniToken r + c' <- markAnnotated c + return (HsProc (pr',r') p' c') + + exact (HsStatic an e) = do + an0 <- markEpToken an + e' <- markAnnotated e + return (HsStatic an0 e') + + exact (HsPragE a prag e) = do + prag' <- markAnnotated prag + e' <- markAnnotated e + return (HsPragE a prag' e') + + exact (HsEmbTy toktype t) = do + toktype' <- markEpToken toktype + t' <- markAnnotated t + return (HsEmbTy toktype' t') + + exact (HsFunArr _ mult arg res) = do + (mult', arg') <- markMultAnnOf mult (markAnnotated arg) + res' <- markAnnotated res + return (HsFunArr noExtField mult' arg' res') + + exact (HsForAll _ tele body) = do + tele' <- markAnnotated tele + body' <- markAnnotated body + return (HsForAll noExtField tele' body') + + exact (HsQual _ ctxt body) = do + ctxt' <- markAnnotated ctxt + body' <- markAnnotated body + return (HsQual noExtField ctxt' body') + + exact x = error $ "exact HsExpr for:" ++ showAst x + +-- --------------------------------------------------------------------- + +exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) + => AnnList EpaLocation -> HsDoFlavour -> LocatedAn an a + -> EP w m (AnnList EpaLocation, LocatedAn an a) +exactDo an (DoExpr m) stmts = exactMdo an m "do" >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an GhciStmtCtxt stmts = markLensFun an lal_rest (\l -> printStringAtAA l "do") >>= + \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an (MDoExpr m) stmts = exactMdo an m "mdo" >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an ListComp stmts = markMaybeDodgyStmts an stmts +exactDo an MonadComp stmts = markMaybeDodgyStmts an stmts + +exactMdo :: (Monad m, Monoid w) + => AnnList EpaLocation -> Maybe ModuleName -> String -> EP w m (AnnList EpaLocation) +exactMdo an Nothing kw = markLensFun an lal_rest (\l -> printStringAtAA l kw) +exactMdo an (Just module_name) kw = markLensFun an lal_rest (\l -> printStringAtAA l n) + where + n = (moduleNameString module_name) ++ "." ++ kw + +markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) + => AnnList l -> LocatedAn an a -> EP w m (AnnList l, LocatedAn an a) +markMaybeDodgyStmts an stmts = + if notDodgy stmts + then do + r <- markAnnotatedWithLayout stmts + return (an, r) + else return (an, stmts) + +notDodgy :: GenLocated (EpAnn ann) a -> Bool +notDodgy (L (EpAnn anc _ _) _) = notDodgyE anc + +notDodgyE :: EpaLocation -> Bool +notDodgyE anc = + case anc of + EpaSpan s -> isGoodSrcSpan s + EpaDelta{} -> True + +-- --------------------------------------------------------------------- +instance ExactPrint (HsPragE GhcPs) where + getAnnotationEntry HsPragSCC{} = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsPragSCC (AnnPragma o c s l1 l2 t m,st) sl) = do + o' <- markAnnOpen'' o st "{-# SCC" + l1' <- printStringAtAA l1 (sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl)) + c' <- markEpToken c + return (HsPragSCC (AnnPragma o' c' s l1' l2 t m,st) sl) + +instance ExactPrint (HsTypedSplice GhcPs) where + getAnnotationEntry _ = NoEntryVal + + setAnnotationAnchor a _ _ _ = a + + exact (HsTypedSpliceExpr an e) = do + an0 <- markEpToken an + e' <- markAnnotated e + return (HsTypedSpliceExpr an0 e') + + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsUntypedSplice GhcPs) where + getAnnotationEntry _ = NoEntryVal + + setAnnotationAnchor a _ _ _= a + + exact (HsUntypedSpliceExpr an e) = do + an0 <- markEpToken an + e' <- markAnnotated e + return (HsUntypedSpliceExpr an0 e') + + exact (HsQuasiQuote an q (L l fs)) = do + -- The quasiquote string does not honour layout offsets. Store + -- the colOffset for now. + -- TODO: use local? + oldOffset <- getLayoutOffsetP + EPState{pMarkLayout} <- get + unless pMarkLayout $ setLayoutOffsetP 0 + printStringAdvance + -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 + ("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]") + unless pMarkLayout $ setLayoutOffsetP oldOffset + return (HsQuasiQuote an q (L l fs)) + +-- --------------------------------------------------------------------- + +-- TODO:AZ: combine these instances +instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (MG x matches) = do + -- TODO:AZ use SortKey, in MG ann. + matches' <- markAnnotated matches + return (MG x matches') + +instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (MG x matches) = do + -- TODO:AZ use SortKey, in MG ann. + matches' <- if notDodgy matches + then markAnnotated matches + else return matches + return (MG x matches') + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (HsRecFields x fields mdot) = do + fields' <- markAnnotated fields + mdot' <- case mdot of + Nothing -> return Nothing + Just (L ss d) -> do + ss' <- printStringAtAA ss ".." + return $ Just (L ss' d) + -- Note: mdot contains the SrcSpan where the ".." appears, if present + return (HsRecFields x fields' mdot') + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) + => ExactPrint (HsFieldBind (LocatedA (FieldOcc GhcPs)) body) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsFieldBind an f arg isPun) = do + debugM $ "HsFieldBind" + f' <- markAnnotated f + (an0, arg') <- if isPun then return (an, arg) + else do + an0 <- mapM markEpToken an + arg' <- markAnnotated arg + return (an0, arg') + return (HsFieldBind an0 f' arg' isPun) + +-- --------------------------------------------------------------------- + +instance (ExactPrint body) + => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) body) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsFieldBind an f arg isPun) = do + debugM $ "HsFieldBind FieldLabelStrings" + f' <- markAnnotated f + (an0, arg') <- if isPun then return (an, arg) + else do + an0 <- mapM markEpToken an + arg' <- markAnnotated arg + return (an0, arg') + return (HsFieldBind an0 f' arg' isPun) + +-- --------------------------------------------------------------------- + +instance ExactPrint (LHsRecUpdFields GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact flds@(RegularRecUpdFields { recUpdFields = rbinds }) = do + debugM $ "RegularRecUpdFields" + rbinds' <- markAnnotated rbinds + return $ flds { recUpdFields = rbinds' } + exact flds@(OverloadedRecUpdFields { olRecUpdFields = pbinds }) = do + debugM $ "OverloadedRecUpdFields" + pbinds' <- markAnnotated pbinds + return $ flds { olRecUpdFields = pbinds' } + +-- --------------------------------------------------------------------- + +instance ExactPrint (FieldLabelStrings GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (FieldLabelStrings fs) = FieldLabelStrings <$> markAnnotated fs + +-- --------------------------------------------------------------------- + +instance ExactPrint (DotFieldOcc GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (DotFieldOcc an (L loc (FieldLabelString fs))) = do + an0 <- markLensFun an lafDot (\ml -> mapM markEpToken ml) + -- The field name has a SrcSpanAnnN, print it as a + -- LocatedN RdrName + L loc' _ <- markAnnotated (L loc (mkVarUnqual fs)) + return (DotFieldOcc an0 (L loc' (FieldLabelString fs))) + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsTupArg GhcPs) where + getAnnotationEntry (Present _ _) = NoEntryVal + getAnnotationEntry (Missing (EpAnn _ False _)) = NoEntryVal + getAnnotationEntry (Missing an) = fromAnn an + + setAnnotationAnchor (Present a b) _ _ _ = Present a b + setAnnotationAnchor (Missing an) anc ts cs = Missing (setAnchorEpa an anc ts cs) + + exact (Present a e) = Present a <$> markAnnotated e + + exact a@(Missing (EpAnn _ False _)) = return a + exact a@(Missing _) = printStringAdvance "," >> return a + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsCmdTop GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (HsCmdTop a cmd) = HsCmdTop a <$> markAnnotated cmd + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsCmd GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsCmdArrApp (isU, l) arr arg HsFirstOrderApp True) = do + arr' <- markAnnotated arr + l' <- case isU of + UnicodeSyntax -> printStringAtAA l "⤙" + NormalSyntax -> printStringAtAA l "-<" + arg' <- markAnnotated arg + return (HsCmdArrApp (isU, l') arr' arg' HsFirstOrderApp True) + exact (HsCmdArrApp (isU, l) arr arg HsFirstOrderApp False) = do + arg' <- markAnnotated arg + l' <- case isU of + UnicodeSyntax -> printStringAtAA l "⤚" + NormalSyntax -> printStringAtAA l ">-" + arr' <- markAnnotated arr + return (HsCmdArrApp (isU, l') arr' arg' HsFirstOrderApp False) + exact (HsCmdArrApp (isU, l) arr arg HsHigherOrderApp True) = do + arr' <- markAnnotated arr + l' <- case isU of + UnicodeSyntax -> printStringAtAA l "⤛" + NormalSyntax -> printStringAtAA l "-<<" + arg' <- markAnnotated arg + return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp True) + exact (HsCmdArrApp (isU, l) arr arg HsHigherOrderApp False) = do + arg' <- markAnnotated arg + l' <- case isU of + UnicodeSyntax -> printStringAtAA l "⤜" + NormalSyntax -> printStringAtAA l ">>-" + arr' <- markAnnotated arr + return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp False) + + exact (HsCmdArrForm an e fixity cs) = do + an0 <- markLensBracketsO' an lal_brackets + (e',cs') <- case (fixity, cs) of + (Infix, (arg1:argrest)) -> do + arg1' <- markAnnotated arg1 + e' <- markAnnotated e + argrest' <- markAnnotated argrest + return (e', arg1':argrest') + (Prefix, _) -> do + e' <- markAnnotated e + cs' <- markAnnotated cs + return (e', cs') + (Infix, []) -> error "Not possible" + an1 <- markLensBracketsC' an0 lal_brackets + return (HsCmdArrForm an1 e' fixity cs') + + exact (HsCmdApp an e1 e2) = do + e1' <- markAnnotated e1 + e2' <- markAnnotated e2 + return (HsCmdApp an e1' e2') + + exact (HsCmdLam an lam_variant matches) = do + an0 <- markLensFun an lepl_lambda markEpToken + an1 <- case lam_variant of + LamSingle -> return an0 + LamCase -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "case") ml) + LamCases -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "cases") ml) + matches' <- markAnnotated matches + return (HsCmdLam an1 lam_variant matches') + + exact (HsCmdPar (lpar, rpar) e) = do + lpar' <- markEpToken lpar + e' <- markAnnotated e + rpar' <- markEpToken rpar + return (HsCmdPar (lpar', rpar') e') + + exact (HsCmdCase an e alts) = do + an0 <- markLensFun an lhsCaseAnnCase markEpToken + e' <- markAnnotated e + an1 <- markLensFun an0 lhsCaseAnnOf markEpToken + alts' <- markAnnotated alts + return (HsCmdCase an1 e' alts') + + exact (HsCmdIf an a e1 e2 e3) = do + an0 <- markLensFun an laiIf markEpToken + e1' <- markAnnotated e1 + an1 <- markLensFun an0 laiThenSemi (\mt -> mapM markEpToken mt) + an2 <- markLensFun an1 laiThen markEpToken + e2' <- markAnnotated e2 + an3 <- markLensFun an2 laiElseSemi (\mt -> mapM markEpToken mt) + an4 <- markLensFun an3 laiElse markEpToken + e3' <- markAnnotated e3 + return (HsCmdIf an4 a e1' e2' e3') + + exact (HsCmdLet (tkLet, tkIn) binds e) = do + setLayoutBoth $ do -- Make sure the 'in' gets indented too + tkLet' <- markEpToken tkLet + binds' <- setLayoutBoth $ markAnnotated binds + tkIn' <- markEpToken tkIn + e' <- markAnnotated e + return (HsCmdLet (tkLet', tkIn') binds' e') + + exact (HsCmdDo an es) = do + debugM $ "HsCmdDo" + an0 <- markLensFun an lal_rest (\l -> printStringAtAA l "do") + es' <- markAnnotated es + return (HsCmdDo an0 es') + +-- --------------------------------------------------------------------- + +instance ( + ExactPrint (LocatedA (body GhcPs)), + Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, + Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW, + (ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) + => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a + + exact (LastStmt a body b c) = do + debugM $ "LastStmt" + body' <- markAnnotated body + return (LastStmt a body' b c) + + exact (BindStmt an pat body) = do + debugM $ "BindStmt" + pat' <- markAnnotated pat + an0 <- markEpUniToken an + body' <- markAnnotated body + return (BindStmt an0 pat' body') + + exact (BodyStmt a body b c) = do + debugM $ "BodyStmt" + body' <- markAnnotated body + return (BodyStmt a body' b c) + + exact (LetStmt tlet binds) = do + debugM $ "LetStmt" + tlet' <- markEpToken tlet + binds' <- markAnnotated binds + return (LetStmt tlet' binds') + + exact (ParStmt a pbs b c) = do + debugM $ "ParStmt" + pbs' <- markAnnotated pbs + return (ParStmt a pbs' b c) + + exact (TransStmt an form stmts b using by c d e) = do + debugM $ "TransStmt" + stmts' <- markAnnotated stmts + (an', by', using') <- exactTransStmt an by using form + return (TransStmt an' form stmts' b using' by' c d e) + + exact (RecStmt an stmts a b c d e) = do + debugM $ "RecStmt" + an0 <- markLensFun an lal_rest markEpToken + (an1, stmts') <- markAnnList' an0 (markAnnotated stmts) + return (RecStmt an1 stmts' a b c d e) + +-- --------------------------------------------------------------------- + +instance ExactPrint (ParStmtBlock GhcPs GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (ParStmtBlock a stmts b c) = do + stmts' <- markAnnotated stmts + return (ParStmtBlock a stmts' b c) + +exactTransStmt :: (Monad m, Monoid w) + => AnnTransStmt -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm + -> EP w m (AnnTransStmt, Maybe (LHsExpr GhcPs), (LHsExpr GhcPs)) +exactTransStmt (AnnTransStmt at ag ab au) by using ThenForm = do + debugM $ "exactTransStmt:ThenForm" + at' <- markEpToken at + using' <- markAnnotated using + case by of + Nothing -> return (AnnTransStmt at' ag ab au, by, using') + Just b -> do + ab' <- mapM markEpToken ab + b' <- markAnnotated b + return ((AnnTransStmt at' ag ab' au), Just b', using') +exactTransStmt (AnnTransStmt at ag ab au) by using GroupForm = do + debugM $ "exactTransStmt:GroupForm" + at' <- markEpToken at + ag' <- mapM markEpToken ag + (ab', by') <- case by of + Nothing -> return (ab, by) + Just b -> do + ab0 <- mapM markEpToken ab + b' <- markAnnotated b + return (ab0, Just b') + au' <- mapM markEpToken au + using' <- markAnnotated using + return (AnnTransStmt at' ag' ab' au', by', using') + +-- --------------------------------------------------------------------- + +instance ExactPrint (TyClDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a + + exact (FamDecl a decl) = do + decl' <- markAnnotated decl + return (FamDecl a decl') + + exact (SynDecl { tcdSExt = AnnSynDecl ops cps t eq + , tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + , tcdRhs = rhs }) = do + -- There may be arbitrary parens around parts of the constructor + -- that are infix. Turn these into comments so that they feed + -- into the right place automatically + -- TODO: no longer sorting on insert. What now? + epTokensToComments "(" ops + epTokensToComments ")" cps + t' <- markEpToken t + + (_,ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing + eq' <- markEpToken eq + rhs' <- markAnnotated rhs + return (SynDecl { tcdSExt = AnnSynDecl [] [] t' eq' + , tcdLName = ltycon', tcdTyVars = tyvars', tcdFixity = fixity + , tcdRhs = rhs' }) + + exact (DataDecl { tcdDExt = x, tcdLName = ltycon, tcdTyVars = tyvars + , tcdFixity = fixity, tcdDataDefn = defn }) = do + (_,ltycon', tyvars', _, defn') <- + exactDataDefn (exactVanillaDeclHead ltycon tyvars fixity) defn + return (DataDecl { tcdDExt = x, tcdLName = ltycon', tcdTyVars = tyvars' + , tcdFixity = fixity, tcdDataDefn = defn' }) + + -- ----------------------------------- + + exact (ClassDecl {tcdCExt = (AnnClassDecl c ops cps vb w oc cc semis, lo, sortKey), + tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdFDs = fds, + tcdSigs = sigs, tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = _docs}) + -- TODO: add a test that demonstrates tcdDocs + | null sigs && null methods && null ats && null at_defs -- No "where" part + = do + (c', w', vb', fds', lclas', tyvars',context') <- top_matter + oc' <- markEpToken oc + cc' <- markEpToken cc + return (ClassDecl {tcdCExt = (AnnClassDecl c' [] [] vb' w' oc' cc' semis, lo, sortKey), + tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', + tcdFixity = fixity, + tcdFDs = fds', + tcdSigs = sigs, tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = _docs}) + + | otherwise -- Laid out + = do + (c', w', vb', fds', lclas', tyvars',context') <- top_matter + oc' <- markEpToken oc + semis' <- mapM markEpToken semis + (sortKey', ds) <- withSortKey sortKey + [(ClsSigTag, prepareListAnnotationA sigs), + (ClsMethodTag, prepareListAnnotationA methods), + (ClsAtTag, prepareListAnnotationA ats), + (ClsAtdTag, prepareListAnnotationA at_defs) + -- ++ prepareListAnnotation docs + ] + cc' <- markEpToken cc + let + sigs' = undynamic ds + methods' = undynamic ds + ats' = undynamic ds + at_defs' = undynamic ds + return (ClassDecl {tcdCExt = (AnnClassDecl c' [] [] vb' w' oc' cc' semis', lo, sortKey'), + tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', + tcdFixity = fixity, + tcdFDs = fds', + tcdSigs = sigs', tcdMeths = methods', + tcdATs = ats', tcdATDefs = at_defs', + tcdDocs = _docs}) + where + top_matter = do + epTokensToComments "(" ops + epTokensToComments ")" cps + c' <- markEpToken c + (_,lclas', tyvars',_,context') <- exactVanillaDeclHead lclas tyvars fixity context + (vb', fds') <- if (null fds) + then return (vb, fds) + else do + vb' <- markEpToken vb + fds' <- markAnnotated fds + return (vb', fds') + w' <- markEpToken w + return (c', w', vb', fds', lclas', tyvars',context') + + +-- --------------------------------------------------------------------- + +instance ExactPrint (FunDep GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (FunDep an ls rs') = do + ls' <- markAnnotated ls + an0 <- markEpUniToken an + rs'' <- markAnnotated rs' + return (FunDep an0 ls' rs'') + +-- --------------------------------------------------------------------- + +instance ExactPrint (FamilyDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (FamilyDecl { fdExt = AnnFamilyDecl ops cps t d f dc eq vb w oc dd cc + , fdInfo = info + , fdTopLevel = top_level + , fdLName = ltycon + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = L lr result + , fdInjectivityAnn = mb_inj }) = do + (d',t') <- exactFlavour (d,t) info + f' <- exact_top_level f + + epTokensToComments "(" ops + epTokensToComments ")" cps + (_,ltycon', tyvars',_,_) <- exactVanillaDeclHead ltycon tyvars fixity Nothing + (dc', eq', result') <- exact_kind (dc, eq) + (vb', mb_inj') <- + case mb_inj of + Nothing -> return (vb, mb_inj) + Just inj -> do + vb' <- markEpToken vb + inj' <- markAnnotated inj + return (vb', Just inj') + (w', oc', dd', cc', info') <- + case info of + ClosedTypeFamily mb_eqns -> do + w' <- markEpToken w + oc' <- markEpToken oc + (dd', mb_eqns') <- + case mb_eqns of + Nothing -> do + dd' <- markEpToken dd + return (dd', mb_eqns) + Just eqns -> do + eqns' <- markAnnotated eqns + return (dd, Just eqns') + cc' <- markEpToken cc + return (w',oc',dd',cc', ClosedTypeFamily mb_eqns') + _ -> return (w,oc,dd,cc, info) + return (FamilyDecl { fdExt = AnnFamilyDecl [] [] t' d' f' dc' eq' vb' w' oc' dd' cc' + , fdInfo = info' + , fdTopLevel = top_level + , fdLName = ltycon' + , fdTyVars = tyvars' + , fdFixity = fixity + , fdResultSig = L lr result' + , fdInjectivityAnn = mb_inj' }) + where + exact_top_level tfamily = + case top_level of + TopLevel -> markEpToken tfamily + NotTopLevel -> do + -- It seems that in some kind of legacy + -- mode the 'family' keyword is still + -- accepted. + markEpToken tfamily + + exact_kind (tdcolon, tequal) = + case result of + NoSig _ -> return (tdcolon, tequal, result) + KindSig x kind -> do + tdcolon' <- markEpUniToken tdcolon + kind' <- markAnnotated kind + return (tdcolon', tequal, KindSig x kind') + TyVarSig x tv_bndr -> do + tequal' <- markEpToken tequal + tv_bndr' <- markAnnotated tv_bndr + return (tdcolon, tequal', TyVarSig x tv_bndr') + + +exactFlavour :: (Monad m, Monoid w) => (EpToken "data", EpToken "type") -> FamilyInfo GhcPs -> EP w m (EpToken "data", EpToken "type") +exactFlavour (td,tt) DataFamily = (\td' -> (td',tt)) <$> markEpToken td +exactFlavour (td,tt) OpenTypeFamily = (td,) <$> markEpToken tt +exactFlavour (td,tt) (ClosedTypeFamily {}) = (td,) <$> markEpToken tt + +-- --------------------------------------------------------------------- + +exactDataDefn + :: (Monad m, Monoid w) + => (Maybe (LHsContext GhcPs) -> EP w m (r + , LocatedN RdrName + , a + , b + , Maybe (LHsContext GhcPs))) -- Printing the header + -> HsDataDefn GhcPs + -> EP w m ( r -- ^ from exactHdr + , LocatedN RdrName, a, b, HsDataDefn GhcPs) +exactDataDefn exactHdr + (HsDataDefn { dd_ext = AnnDataDefn ops cps t nt d i dc w oc cc eq + , dd_ctxt = context + , dd_cType = mb_ct + , dd_kindSig = mb_sig + , dd_cons = condecls, dd_derivs = derivings }) = do + + + epTokensToComments "(" ops + epTokensToComments ")" cps + + (t',nt',d') <- case condecls of + DataTypeCons is_type_data _ -> do + t' <- if is_type_data + then markEpToken t + else return t + d' <- markEpToken d + return (t',nt,d') + NewTypeCon _ -> do + nt' <- markEpToken nt + return (t, nt', d) + + i' <- markEpToken i -- optional 'instance' + mb_ct' <- mapM markAnnotated mb_ct + (anx, ln', tvs', b, mctxt') <- exactHdr context + (dc', mb_sig') <- case mb_sig of + Nothing -> return (dc, Nothing) + Just kind -> do + dc' <- markEpUniToken dc + kind' <- markAnnotated kind + return (dc', Just kind') + w' <- if (needsWhere condecls) + then markEpToken w + else return w + oc' <- markEpToken oc + (eq', condecls') <- exact_condecls eq (toList condecls) + let condecls'' = case condecls of + DataTypeCons td _ -> DataTypeCons td condecls' + NewTypeCon _ -> case condecls' of + [decl] -> NewTypeCon decl + _ -> panic "exacprint NewTypeCon" + cc' <- markEpToken cc + derivings' <- mapM markAnnotated derivings + return (anx, ln', tvs', b, + (HsDataDefn { dd_ext = AnnDataDefn [] [] t' nt' d' i' dc' w' oc' cc' eq' + , dd_ctxt = mctxt' + , dd_cType = mb_ct' + , dd_kindSig = mb_sig' + , dd_cons = condecls'', dd_derivs = derivings' })) + + +exactVanillaDeclHead :: (Monad m, Monoid w) + => LocatedN RdrName + -> LHsQTyVars GhcPs + -> LexicalFixity + -> Maybe (LHsContext GhcPs) + -> EP w m ( () -- TO allow use in exactDataDefn + , LocatedN RdrName + , LHsQTyVars GhcPs + , (), Maybe (LHsContext GhcPs)) +exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context = do + let + exact_tyvars (varl:varsr) + | hvarsr : tvarsr@(_ : _) <- varsr + , fixity == Infix = do + varl' <- markAnnotated varl + thing' <- markAnnotated thing + hvarsr' <- markAnnotated hvarsr + tvarsr' <- markAnnotated tvarsr + return (thing', varl':hvarsr':tvarsr') + | fixity == Infix = do + varl' <- markAnnotated varl + thing' <- markAnnotated thing + varsr' <- markAnnotated varsr + return (thing', varl':varsr') + | otherwise = do + thing' <- markAnnotated thing + vs <- mapM markAnnotated (varl:varsr) + return (thing', vs) + exact_tyvars [] = do + thing' <- markAnnotated thing + return (thing', []) + context' <- mapM markAnnotated context + (thing', tyvars') <- exact_tyvars tyvars + return ((), thing', tvs { hsq_explicit = tyvars' }, (), context') + +-- --------------------------------------------------------------------- + +instance ExactPrint (InjectivityAnn GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (InjectivityAnn rarrow lhs rhs) = do + lhs' <- markAnnotated lhs + rarrow' <- markEpUniToken rarrow + rhs' <- mapM markAnnotated rhs + return (InjectivityAnn rarrow' lhs' rhs') + +-- --------------------------------------------------------------------- + +class Typeable flag => ExactPrintTVFlag flag where + exactTVDelimiters :: (Monad m, Monoid w) + => AnnTyVarBndr -> flag + -> EP w m (HsTyVarBndr flag GhcPs) + -> EP w m (AnnTyVarBndr, flag, HsTyVarBndr flag GhcPs) + +instance ExactPrintTVFlag () where + exactTVDelimiters (AnnTyVarBndr os cs ap dc) flag thing_inside = do + os' <- markEpaLocationAll os "(" + r <- thing_inside + cs' <- markEpaLocationAll cs ")" + return (AnnTyVarBndr os' cs' ap dc, flag, r) + +instance ExactPrintTVFlag Specificity where + exactTVDelimiters (AnnTyVarBndr os cs ap dc) s thing_inside = do + os' <- markEpaLocationAll os open + r <- thing_inside + cs' <- markEpaLocationAll cs close + return (AnnTyVarBndr os' cs' ap dc, s, r) + where + (open, close) = case s of + SpecifiedSpec -> ("(", ")") + InferredSpec -> ("{", "}") + +instance ExactPrintTVFlag (HsBndrVis GhcPs) where + exactTVDelimiters (AnnTyVarBndr os cs ap dc) bvis thing_inside = do + bvis' <- case bvis of + HsBndrRequired _ -> return bvis + HsBndrInvisible at -> HsBndrInvisible <$> markEpToken at + os' <- markEpaLocationAll os "(" + r <- thing_inside + cs' <- markEpaLocationAll cs ")" + return (AnnTyVarBndr os' cs' ap dc, bvis', r) + +instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsTvb an flag n (HsBndrNoKind _)) = do + r <- exactTVDelimiters an flag $ do + n' <- markAnnotated n + return (HsTvb an flag n' (HsBndrNoKind noExtField)) + case r of + (an', flag', HsTvb _ _ n'' k'') -> return (HsTvb an' flag' n'' k'') + + exact (HsTvb an@(AnnTyVarBndr os cs ap dc) flag n (HsBndrKind _ k)) = do + r <- exactTVDelimiters an flag $ do + n' <- markAnnotated n + dc' <- markEpUniToken dc + k' <- markAnnotated k + let an0 = AnnTyVarBndr os cs ap dc' + return (HsTvb an0 flag n' (HsBndrKind noExtField k')) + case r of + (an',flag', HsTvb an1 _ n'' k'') -> return (HsTvb (an'{ atv_dcolon = atv_dcolon an1 }) flag' n'' k'') + +instance ExactPrint (HsBndrVar GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsBndrVar x n) = do + n' <- markAnnotated n + return (HsBndrVar x n') + exact (HsBndrWildCard t) = do + t' <- markEpToken t + return (HsBndrWildCard t') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsType GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _s = a + + exact (HsForAllTy { hst_xforall = an + , hst_tele = tele, hst_body = ty }) = do + tele' <- markAnnotated tele + ty' <- markAnnotated ty + return (HsForAllTy { hst_xforall = an + , hst_tele = tele', hst_body = ty' }) + + exact (HsQualTy an ctxt ty) = do + ctxt' <- markAnnotated ctxt + ty' <- markAnnotated ty + return (HsQualTy an ctxt' ty') + exact (HsTyVar an promoted name) = do + an0 <- if (promoted == IsPromoted) + then markEpToken an + else return an + name' <- markAnnotated name + return (HsTyVar an0 promoted name') + exact (HsAppTy an t1 t2) = do + t1' <- markAnnotated t1 + t2' <- markAnnotated t2 + return (HsAppTy an t1' t2') + exact (HsAppKindTy at ty ki) = do + ty' <- markAnnotated ty + at' <- markEpToken at + ki' <- markAnnotated ki + return (HsAppKindTy at' ty' ki') + exact (HsFunTy an mult ty1 ty2) = do + (mult', ty1') <- markMultAnnOf mult (markAnnotated ty1) + ty2' <- markAnnotated ty2 + return (HsFunTy an mult' ty1' ty2') + exact (HsListTy an tys) = do + an0 <- markOpeningParen an + tys' <- markAnnotated tys + an1 <- markClosingParen an0 + return (HsListTy an1 tys') + exact (HsTupleTy an con tys) = do + an0 <- markOpeningParen an + tys' <- markAnnotated tys + an1 <- markClosingParen an0 + return (HsTupleTy an1 con tys') + exact (HsSumTy an tys) = do + an0 <- markOpeningParen an + tys' <- markAnnotated tys + an1 <- markClosingParen an0 + return (HsSumTy an1 tys') + exact (HsOpTy x promoted t1 lo t2) = do + t1' <- markAnnotated t1 + lo' <- markAnnotated lo + t2' <- markAnnotated t2 + return (HsOpTy x promoted t1' lo' t2') + exact (HsParTy (o,c) ty) = do + o' <- markEpToken o + ty' <- markAnnotated ty + c' <- markEpToken c + return (HsParTy (o',c') ty') + exact (HsIParamTy an n t) = do + n' <- markAnnotated n + an0 <- markEpUniToken an + t' <- markAnnotated t + return (HsIParamTy an0 n' t') + exact (HsStarTy an isUnicode) = do + if isUnicode + then printStringAdvance "\x2605" -- Unicode star + else printStringAdvance "*" + return (HsStarTy an isUnicode) + exact (HsKindSig an ty k) = do + ty' <- markAnnotated ty + an0 <- markEpUniToken an + k' <- markAnnotated k + return (HsKindSig an0 ty' k') + exact (HsSpliceTy a splice) = do + splice' <- markAnnotated splice + return (HsSpliceTy a splice') + exact (HsDocTy an ty doc) = do + ty' <- markAnnotated ty + return (HsDocTy an ty' doc) + exact (XHsType (HsBangTy ann (HsSrcBang mt up str) ty)) = do + (ann', mt') <- exactBang (ann, mt) str + ty' <- markAnnotated ty + return (XHsType (HsBangTy ann' (HsSrcBang mt' up str) ty')) + exact (HsExplicitListTy (sq,o,c) prom tys) = do + sq' <- if (isPromoted prom) + then markEpToken sq + else return sq + o' <- markEpToken o + tys' <- markAnnotated tys + c' <- markEpToken c + return (HsExplicitListTy (sq',o',c') prom tys') + exact (HsExplicitTupleTy (sq, o, c) prom tys) = do + sq' <- if (isPromoted prom) + then markEpToken sq + else return sq + o' <- markEpToken o + tys' <- markAnnotated tys + c' <- markEpToken c + return (HsExplicitTupleTy (sq', o', c') prom tys') + exact (HsTyLit a lit) = do + case lit of + (HsNumTy src v) -> printSourceText src (show v) + (HsStrTy src v) -> printSourceText src (show v) + (HsCharTy src v) -> printSourceText src (show v) + return (HsTyLit a lit) + exact t@(HsWildCardTy _) = printStringAdvance "_" >> return t + exact x = error $ "missing match for HsType:" ++ showAst x + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsForAllTelescope GhcPs) where + getAnnotationEntry (HsForAllVis an _) = fromAnn an + getAnnotationEntry (HsForAllInvis an _) = fromAnn an + + setAnnotationAnchor (HsForAllVis an a) anc ts cs = HsForAllVis (setAnchorEpa an anc ts cs) a + setAnnotationAnchor (HsForAllInvis an a) anc ts cs = HsForAllInvis (setAnchorEpa an anc ts cs) a + + exact (HsForAllVis (EpAnn l (f,r) cs) bndrs) = do + f' <- markEpUniToken f + bndrs' <- markAnnotated bndrs + r' <- markEpUniToken r + return (HsForAllVis (EpAnn l (f',r') cs) bndrs') + + exact (HsForAllInvis (EpAnn l (f,d) cs) bndrs) = do + f' <- markEpUniToken f + bndrs' <- markAnnotated bndrs + d' <- markEpToken d + return (HsForAllInvis (EpAnn l (f',d') cs) bndrs') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsDerivingClause GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsDerivingClause { deriv_clause_ext = an + , deriv_clause_strategy = dcs + , deriv_clause_tys = dct }) = do + an0 <- markEpToken an + dcs0 <- case dcs of + Just (L _ ViaStrategy{}) -> return dcs + _ -> mapM markAnnotated dcs + dct' <- markAnnotated dct + dcs1 <- case dcs0 of + Just (L _ ViaStrategy{}) -> mapM markAnnotated dcs0 + _ -> return dcs0 + return (HsDerivingClause { deriv_clause_ext = an0 + , deriv_clause_strategy = dcs1 + , deriv_clause_tys = dct' }) + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivStrategy GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (StockStrategy an) = do + an0 <- markEpToken an + return (StockStrategy an0) + exact (AnyclassStrategy an) = do + an0 <- markEpToken an + return (AnyclassStrategy an0) + exact (NewtypeStrategy an) = do + an0 <- markEpToken an + return (NewtypeStrategy an0) + exact (ViaStrategy (XViaStrategyPs an ty)) = do + an0 <- markEpToken an + ty' <- markAnnotated ty + return (ViaStrategy (XViaStrategyPs an0 ty')) + +-- --------------------------------------------------------------------- + +instance (ExactPrint a) => ExactPrint (LocatedC a) where + getAnnotationEntry (L sann _) = fromAnn sann + setAnnotationAnchor = setAnchorAn + + exact (L (EpAnn anc (AnnContext ma opens closes) cs) a) = do + opens' <- mapM markEpToken opens + a' <- markAnnotated a + closes' <- mapM markEpToken closes + return (L (EpAnn anc (AnnContext ma opens' closes') cs) a') + +-- --------------------------------------------------------------------- + +instance ExactPrint (DerivClauseTys GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (DctSingle x ty) = do + ty' <- markAnnotated ty + return (DctSingle x ty') + exact (DctMulti x tys) = do + tys' <- markAnnotated tys + return (DctMulti x tys') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsSigType GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsSig a bndrs ty) = do + bndrs' <- markAnnotated bndrs + ty' <- markAnnotated ty + return (HsSig a bndrs' ty') + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedN RdrName) where + getAnnotationEntry (L sann _) = fromAnn sann + setAnnotationAnchor = setAnchorAn + + exact (L (EpAnn anc ann cs) n) = do + ann' <- + case ann of + NameAnn a l t -> do + mn <- markName a (Just (l,n)) + case mn of + (a', (Just (l',_n))) -> do + return (NameAnn a' l' t) + _ -> error "ExactPrint (LocatedN RdrName)" + NameAnnCommas a commas t -> do + a0 <- markNameAdornmentO a + commas' <- forM commas markEpToken + a1 <- markNameAdornmentC a0 + return (NameAnnCommas a1 commas' t) + NameAnnBars (o,c) bars t -> do + o' <- markEpToken o + bars' <- mapM markEpToken bars + c' <- markEpToken c + return (NameAnnBars (o',c') bars' t) + NameAnnOnly a t -> do + (a',_) <- markName a Nothing + return (NameAnnOnly a' t) + NameAnnRArrow o nl c t -> do + o' <- mapM markEpToken o + nl' <- markEpUniToken nl + c' <- mapM markEpToken c + return (NameAnnRArrow o' nl' c' t) + NameAnnQuote q name t -> do + debugM $ "NameAnnQuote" + q' <- markEpToken q + (L name' _) <- markAnnotated (L name n) + return (NameAnnQuote q' name' t) + NameAnnTrailing t -> do + _anc' <- printUnicode anc n + return (NameAnnTrailing t) + return (L (EpAnn anc ann' cs) n) + + +markNameAdornmentO :: (Monad m, Monoid w) => NameAdornment -> EP w m NameAdornment +markNameAdornmentO (NameParens o c) = do + o' <- markEpToken o + return (NameParens o' c) +markNameAdornmentO (NameParensHash o c) = do + o' <- markEpToken o + return (NameParensHash o' c) +markNameAdornmentO (NameBackquotes o c) = do + o' <- markEpToken o + return (NameBackquotes o' c) +markNameAdornmentO (NameSquare o c) = do + o' <- markEpToken o + return (NameSquare o' c) +markNameAdornmentO NameNoAdornment = return NameNoAdornment + +markNameAdornmentC :: (Monad m, Monoid w) => NameAdornment -> EP w m NameAdornment +markNameAdornmentC (NameParens o c) = do + c' <- markEpToken c + return (NameParens o c') +markNameAdornmentC (NameParensHash o c) = do + c' <- markEpToken c + return (NameParensHash o c') +markNameAdornmentC (NameBackquotes o c) = do + c' <- markEpToken c + return (NameBackquotes o c') +markNameAdornmentC (NameSquare o c) = do + c' <- markEpToken c + return (NameSquare o c') +markNameAdornmentC NameNoAdornment = return NameNoAdornment + +printUnicode :: (Monad m, Monoid w) => EpaLocation -> RdrName -> EP w m EpaLocation +printUnicode anc n = do + let str = case (showPprUnsafe n) of + -- TODO: unicode support? + "forall" -> if spanLength (epaLocationRealSrcSpan anc) == 1 then "∀" else "forall" + s -> s + loc <- printStringAtAAC NoCaptureComments (EpaDelta (getHasLoc anc) (SameLine 0) []) str + case loc of + EpaSpan _ -> return anc + EpaDelta ss dp [] -> return $ EpaDelta ss dp [] + EpaDelta _ _ _cs -> error "printUnicode should not capture comments" + + +markName :: (Monad m, Monoid w) + => NameAdornment -> Maybe (EpaLocation,RdrName) + -> EP w m (NameAdornment, Maybe (EpaLocation,RdrName)) +markName adorn mname = do + adorn0 <- markNameAdornmentO adorn + mname' <- + case mname of + Nothing -> return Nothing + Just (name, a) -> do + name' <- printStringAtAAC CaptureComments name (showPprUnsafe a) + return (Just (name',a)) + adorn1 <- markNameAdornmentC adorn0 + return (adorn1, mname') + +markTrailing :: (Monad m, Monoid w) => [TrailingAnn] -> EP w m [TrailingAnn] +markTrailing ts = do + p <- getPosP + debugM $ "markTrailing:" ++ showPprUnsafe (p,ts) + mapM markKwT ts + +-- --------------------------------------------------------------------- + +-- based on pp_condecls in Decls.hs +exact_condecls :: (Monad m, Monoid w) + => EpToken "=" -> [LConDecl GhcPs] -> EP w m (EpToken "=",[LConDecl GhcPs]) +exact_condecls eq cs + | gadt_syntax -- In GADT syntax + = do + cs' <- mapM markAnnotated cs + return (eq, cs') + | otherwise -- In H98 syntax + = do + eq0 <- markEpToken eq + cs' <- mapM markAnnotated cs + return (eq0, cs') + where + gadt_syntax = case cs of + [] -> False + (L _ ConDeclH98{} : _) -> False + (L _ ConDeclGADT{} : _) -> True + +-- --------------------------------------------------------------------- + +instance ExactPrint (ConDecl GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + +-- based on pprConDecl + exact (ConDeclH98 { con_ext = AnnConDeclH98 tforall tdot tdarrow + , con_name = con + , con_forall = has_forall + , con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt + , con_args = args + , con_doc = doc }) = do + tforall' <- if has_forall + then markEpUniToken tforall + else return tforall + ex_tvs' <- mapM markAnnotated ex_tvs + tdot' <- if has_forall + then markEpToken tdot + else return tdot + mcxt' <- mapM markAnnotated mcxt + tdarrow' <- if (isJust mcxt) + then markEpUniToken tdarrow + else return tdarrow + + (con', args') <- exact_details args + return (ConDeclH98 { con_ext = AnnConDeclH98 tforall' tdot' tdarrow' + , con_name = con' + , con_forall = has_forall + , con_ex_tvs = ex_tvs' + , con_mb_cxt = mcxt' + , con_args = args' + , con_doc = doc }) + + where + -- In ppr_details: let's not print the multiplicities (they are always 1, by + -- definition) as they do not appear in an actual declaration. + exact_details (InfixCon t1 t2) = do + t1' <- markAnnotated t1 + con' <- markAnnotated con + t2' <- markAnnotated t2 + return (con', InfixCon t1' t2') + exact_details (PrefixCon tys) = do + con' <- markAnnotated con + tys' <- markAnnotated tys + return (con', PrefixCon tys') + exact_details (RecCon fields) = do + con' <- markAnnotated con + fields' <- markAnnotated fields + return (con', RecCon fields') + + -- ----------------------------------- + + exact (ConDeclGADT { con_g_ext = AnnConDeclGADT ops cps dcol + , con_names = cons + , con_outer_bndrs = outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = mcxt, con_g_args = args + , con_res_ty = res_ty, con_doc = doc }) = do + cons' <- mapM markAnnotated cons + dcol' <- markEpUniToken dcol + epTokensToComments "(" ops + epTokensToComments ")" cps + + -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558 + outer_bndrs' <- case outer_bndrs of + L _ (HsOuterImplicit _) -> return outer_bndrs + _ -> markAnnotated outer_bndrs + + inner_bndrs' <- mapM markAnnotated inner_bndrs + + mcxt' <- mapM markAnnotated mcxt + args' <- + case args of + (PrefixConGADT x args0) -> do + args0' <- mapM markAnnotated args0 + return (PrefixConGADT x args0') + (RecConGADT rarr fields) -> do + fields' <- markAnnotated fields + rarr' <- markEpUniToken rarr + return (RecConGADT rarr' fields') + res_ty' <- markAnnotated res_ty + return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol' + , con_names = cons' + , con_outer_bndrs = outer_bndrs' + , con_inner_bndrs = inner_bndrs' + , con_mb_cxt = mcxt', con_g_args = args' + , con_res_ty = res_ty', con_doc = doc }) + +-- --------------------------------------------------------------------- + +instance ExactPrint Void where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact x = return x + +-- --------------------------------------------------------------------- + +instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) where + getAnnotationEntry (HsOuterImplicit _) = NoEntryVal + getAnnotationEntry (HsOuterExplicit an _) = fromAnn an + + setAnnotationAnchor (HsOuterImplicit a) _ _ _ = HsOuterImplicit a + setAnnotationAnchor (HsOuterExplicit an a) anc ts cs = HsOuterExplicit (setAnchorEpa an anc ts cs) a + + exact b@(HsOuterImplicit _) = pure b + exact (HsOuterExplicit (EpAnn l (f,d) cs) bndrs) = do + f' <- markEpUniToken f + bndrs' <- markAnnotated bndrs + d' <- markEpToken d + return (HsOuterExplicit (EpAnn l (f',d') cs) bndrs') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsConDeclRecField GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsConDeclRecField _ names ftype) = do + names' <- markAnnotated names + ftype' <- markAnnotated ftype + return (HsConDeclRecField noExtField names' ftype') + +-- --------------------------------------------------------------------- + +instance ExactPrint (FieldOcc GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (FieldOcc x n) = do + n' <- markAnnotated n + return (FieldOcc x n') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsConDeclField GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact cdf@(CDF { cdf_ext, cdf_bang, cdf_multiplicity, cdf_type }) = do + (mult, (an, t)) <- markMultAnnOf cdf_multiplicity ((,) <$> exactBang cdf_ext cdf_bang <*> markAnnotated cdf_type) + return (cdf { cdf_ext = an, cdf_multiplicity = mult, cdf_type = t }) + +markMultAnnOf :: (Monad m, Monoid w, ExactPrint a) => HsMultAnnOf a GhcPs -> EP w m b -> EP w m (HsMultAnnOf a GhcPs, b) +markMultAnnOf (HsUnannotated arrOrCol) tyM = do + ((), arrOrCol', ty') <- markArrOrCol (pure ()) arrOrCol tyM + return (HsUnannotated arrOrCol', ty') +markMultAnnOf (HsLinearAnn (EpPct1 pct1 arrOrCol)) tyM = do + (pct1', arrOrCol', ty') <- markArrOrCol (markEpToken pct1) arrOrCol tyM + return (HsLinearAnn (EpPct1 pct1' arrOrCol'), ty') +markMultAnnOf (HsLinearAnn (EpLolly arr)) tyM = do + ty' <- tyM + arr' <- markEpToken arr + return (HsLinearAnn (EpLolly arr'), ty') +markMultAnnOf (HsExplicitMult (pct, arrOrCol) t) tyM = do + ((pct', t'), arrOrCol', ty') <- markArrOrCol ((,) <$> markEpToken pct <*> markAnnotated t) arrOrCol tyM + return (HsExplicitMult (pct', arrOrCol') t', ty') + +markArrOrCol :: (Monad m, Monoid w) => EP w m a -> EpArrowOrColon -> EP w m b -> EP w m (a, EpArrowOrColon, b) +markArrOrCol multM (EpArrow arr) tyM = do + ty' <- tyM + mult' <- multM + arr' <- markEpUniToken arr + return (mult', EpArrow arr', ty') +markArrOrCol multM (EpColon col) tyM = do + mult' <- multM + col' <- markEpUniToken col + ty' <- tyM + return (mult', EpColon col', ty') +markArrOrCol multM EpPatBind patM = do + mult' <- multM + pat' <- patM + return (mult', EpPatBind, pat') + +exactBang :: (Monoid w, Monad m) => XConDeclField GhcPs -> SrcStrictness -> EP w m (XConDeclField GhcPs) +exactBang ((o,c,tk), mt) str = do + (o',c') <- + case mt of + NoSourceText -> return (o,c) + SourceText src -> do + debugM $ "HsBangTy: src=" ++ showAst src + o' <- printStringAtAA o (unpackFS src) + c' <- markEpToken c + return (o',c') + tk' <- + case str of + SrcLazy -> printStringAtAA tk "~" + SrcStrict -> printStringAtAA tk "!" + NoSrcStrict -> return tk + return ((o',c',tk'), mt) + +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedP CType) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + + exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType stp mh (stct,ct))) = do + o' <- markAnnOpen'' o stp "{-# CTYPE" + l1' <- case mh of + Nothing -> return l1 + Just (Header srcH _h) -> + printStringAtAA l1 (toSourceTextWithSuffix srcH "" "") + l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackFS ct) "") + c' <- markEpToken c + return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType stp mh (stct,ct))) + +-- --------------------------------------------------------------------- + +instance ExactPrint (SourceText, RuleName) where + -- We end up at the right place from the Located wrapper + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (st, rn) + = printStringAdvance (toSourceTextWithSuffix st (unpackFS rn) "") + >> return (st, rn) + + +-- ===================================================================== +-- LocatedL instances start -- +-- +-- Each is dealt with specifically, as they have +-- different wrapping annotations in the al_rest zone. +-- +-- In future, the annotation could perhaps be improved, with an +-- 'al_pre' and 'al_post' set of annotations to be simply sorted and +-- applied. +-- --------------------------------------------------------------------- + +instance ExactPrint (LocatedLI [LocatedA (IE GhcPs)]) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + + exact (L an ies) = do + debugM $ "LocatedL [LIE" + an0 <- markLensFun' an (lal_rest . lfst) markEpToken + p <- getPosP + debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p + (an1, ies') <- markAnnList an0 (markAnnotated (filter notIEDoc ies)) + return (L an1 ies') + +instance (ExactPrint (Match GhcPs (LocatedA body))) + => ExactPrint (LocatedLW [LocatedA (Match GhcPs (LocatedA body))]) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + exact (L an a) = do + debugM $ "LocatedL [LMatch" + -- TODO: markAnnList? + an0 <- markLensFun' an lal_rest markEpToken + an1 <- markLensBracketsO an0 lal_brackets + an2 <- markEpAnnAllLT an1 lal_semis + a' <- markAnnotated a + an3 <- markLensBracketsC an2 lal_brackets + return (L an3 a') + +instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + exact (L an stmts) = do + debugM $ "LocatedL [ExprLStmt" + (an'', stmts') <- markAnnList an $ do + case snocView stmts of + Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do + debugM $ "LocatedL [ExprLStmt: snocView" + ls' <- markAnnotated ls + initStmts' <- markAnnotated initStmts + return (initStmts' ++ [ls']) + _ -> do + markAnnotated stmts + return (L an'' stmts') + +instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + exact (L ann es) = do + debugM $ "LocatedL [CmdLStmt" + an0 <- markLensBracketsO ann lal_brackets + es' <- mapM markAnnotated es + an1 <- markLensBracketsC an0 lal_brackets + return (L an1 es') + +instance ExactPrint (LocatedL [LocatedA (HsConDeclRecField GhcPs)]) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + exact (L an fs) = do + debugM $ "LocatedL [LHsConDeclRecField" + (an', fs') <- markAnnList an (markAnnotated fs) + return (L an' fs') + +instance ExactPrint (LocatedL (BF.BooleanFormula GhcPs)) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor = setAnchorAn + exact (L an bf) = do + debugM $ "LocatedL [LBooleanFormula" + (an', bf') <- markAnnList an (markAnnotated bf) + return (L an' bf') + +-- --------------------------------------------------------------------- +-- LocatedL instances end -- +-- ===================================================================== + +instance ExactPrint (IE GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (IEVar depr ln doc) = do + depr' <- markAnnotated depr + ln' <- markAnnotated ln + doc' <- markAnnotated doc + return (IEVar depr' ln' doc') + exact (IEThingAbs depr thing doc) = do + depr' <- markAnnotated depr + thing' <- markAnnotated thing + doc' <- markAnnotated doc + return (IEThingAbs depr' thing' doc') + exact (IEThingAll (depr, (op,dd,cp)) thing doc) = do + depr' <- markAnnotated depr + thing' <- markAnnotated thing + op' <- markEpToken op + dd' <- markEpToken dd + cp' <- markEpToken cp + doc' <- markAnnotated doc + return (IEThingAll (depr', (op',dd',cp')) thing' doc') + + exact (IEThingWith (depr, (op,dd,c,cp)) thing wc withs doc) = do + depr' <- markAnnotated depr + thing' <- markAnnotated thing + op' <- markEpToken op + (dd',c', wc', withs') <- + case wc of + NoIEWildcard -> do + withs'' <- markAnnotated withs + return (dd, c, wc, withs'') + IEWildcard pos -> do + let (bs, as) = splitAt pos withs + bs' <- markAnnotated bs + dd' <- markEpToken dd + c' <- markEpToken c + as' <- markAnnotated as + return (dd',c', wc, bs'++as') + cp' <- markEpToken cp + doc' <- markAnnotated doc + return (IEThingWith (depr', (op',dd',c',cp')) thing' wc' withs' doc') + + exact (IEModuleContents (depr, an) m) = do + depr' <- markAnnotated depr + an0 <- markEpToken an + m' <- markAnnotated m + return (IEModuleContents (depr', an0) m') + + -- These three exist to not error out, but are no-ops The contents + -- appear as "normal" comments too, which we process instead. + exact (IEGroup x lev doc) = do + return (IEGroup x lev doc) + exact (IEDoc x doc) = do + return (IEDoc x doc) + exact (IEDocNamed x str) = do + return (IEDocNamed x str) + +-- --------------------------------------------------------------------- + +instance ExactPrint (IEWrappedName GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (IEName x n) = do + n' <- markAnnotated n + return (IEName x n') + exact (IEDefault r n) = do + r' <- markEpToken r + n' <- markAnnotated n + return (IEDefault r' n') + exact (IEPattern r n) = do + r' <- markEpToken r + n' <- markAnnotated n + return (IEPattern r' n') + exact (IEType r n) = do + r' <- markEpToken r + n' <- markAnnotated n + return (IEType r' n') + exact (IEData r n) = do + r' <- markEpToken r + n' <- markAnnotated n + return (IEData r' n') + +-- --------------------------------------------------------------------- + +instance ExactPrint (Pat GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (WildPat w) = do + anchor' <- getAnchorU + debugM $ "WildPat:anchor'=" ++ show anchor' + _ <- printStringAtRs anchor' "_" + return (WildPat w) + exact (VarPat x n) = do + -- The parser inserts a placeholder value for a record pun rhs. This must be + -- filtered. + let pun_RDR = "pun-right-hand-side" + n' <- if (showPprUnsafe n /= pun_RDR) + then markAnnotated n + else return n + return (VarPat x n') + exact (LazyPat an pat) = do + an0 <- markEpToken an + pat' <- markAnnotated pat + return (LazyPat an0 pat') + exact (AsPat at n pat) = do + n' <- markAnnotated n + at' <- markEpToken at + pat' <- markAnnotated pat + return (AsPat at' n' pat') + exact (ParPat (lpar, rpar) pat) = do + lpar' <- markEpToken lpar + pat' <- markAnnotated pat + rpar' <- markEpToken rpar + return (ParPat (lpar', rpar') pat') + + exact (BangPat an pat) = do + an0 <- markEpToken an + pat' <- markAnnotated pat + return (BangPat an0 pat') + + exact (ListPat an pats) = do + (an', pats') <- markAnnList' an (markAnnotated pats) + return (ListPat an' pats') + + exact (TuplePat (o,c) pats boxity) = do + o0 <- case boxity of + Boxed -> printStringAtAA o "(" + Unboxed -> printStringAtAA o "(#" + pats' <- markAnnotated pats + c0 <- case boxity of + Boxed -> printStringAtAA c ")" + Unboxed -> printStringAtAA c "#)" + return (TuplePat (o0,c0) pats' boxity) + + exact (SumPat an pat alt arity) = do + an0 <- markLensFun an (lsumPatParens . lfst) (\loc -> printStringAtAA loc "(#") + an1 <- markLensFun an0 lsumPatVbarsBefore (\locs -> mapM markEpToken locs) + pat' <- markAnnotated pat + an2 <- markLensFun an1 lsumPatVbarsAfter (\locs -> mapM markEpToken locs) + an3 <- markLensFun an2 (lsumPatParens . lsnd) (\loc -> printStringAtAA loc "#)") + return (SumPat an3 pat' alt arity) + + exact (OrPat an pats) = do + pats' <- markAnnotated (NE.toList pats) + return (OrPat an (NE.fromList pats')) + + exact (ConPat an con details) = do + (an', con', details') <- exactUserCon an con details + return (ConPat an' con' details') + exact (ViewPat tokarr expr pat) = do + expr' <- markAnnotated expr + an0 <- markEpUniToken tokarr + pat' <- markAnnotated pat + return (ViewPat an0 expr' pat') + exact (SplicePat x splice) = do + splice' <- markAnnotated splice + return (SplicePat x splice') + exact p@(LitPat _ lit) = printStringAdvance (hsLit2String lit) >> return p + exact (NPat an ol mn z) = do + an0 <- if (isJust mn) + then markEpToken an + else return an + ol' <- markAnnotated ol + return (NPat an0 ol' mn z) + + exact (NPlusKPat an n k lit2 a b) = do + n' <- markAnnotated n + an' <- markEpToken an + k' <- markAnnotated k + return (NPlusKPat an' n' k' lit2 a b) + + exact (SigPat an pat sig) = do + pat' <- markAnnotated pat + an0 <- markEpUniToken an + sig' <- markAnnotated sig + return (SigPat an0 pat' sig') + + exact (EmbTyPat toktype tp) = do + toktype' <- markEpToken toktype + tp' <- markAnnotated tp + return (EmbTyPat toktype' tp') + + exact (InvisPat (tokat, spec) tp) = do + tokat' <- markEpToken tokat + tp' <- markAnnotated tp + pure (InvisPat (tokat', spec) tp') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsPatSigType GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsPS an ty) = do + ty' <- markAnnotated ty + return (HsPS an ty') + +instance ExactPrint (HsTyPat GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsTP an ty) = do + ty' <- markAnnotated ty + return (HsTP an ty') + +-- --------------------------------------------------------------------- + +instance ExactPrint (HsOverLit GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact ol = + let str = case ol_val ol of + HsIntegral (IL src _ _) -> src + HsFractional (FL{ fl_text = src }) -> src + HsIsString src _ -> src + in + case str of + SourceText s -> printStringAdvance (unpackFS s) >> return ol + NoSourceText -> return ol + +-- --------------------------------------------------------------------- + +hsLit2String :: HsLit GhcPs -> String +hsLit2String lit = + case lit of + HsChar src v -> toSourceTextWithSuffix src v "" + HsCharPrim src p -> toSourceTextWithSuffix src p "" + HsString src v -> toSourceTextWithSuffix src v "" + HsMultilineString src v -> toSourceTextWithSuffix src v "" + HsStringPrim src v -> toSourceTextWithSuffix src v "" + HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v "" + HsIntPrim src v -> toSourceTextWithSuffix src v "" + HsWordPrim src v -> toSourceTextWithSuffix src v "" + HsInt8Prim src v -> toSourceTextWithSuffix src v "" + HsInt16Prim src v -> toSourceTextWithSuffix src v "" + HsInt32Prim src v -> toSourceTextWithSuffix src v "" + HsInt64Prim src v -> toSourceTextWithSuffix src v "" + HsWord8Prim src v -> toSourceTextWithSuffix src v "" + HsWord16Prim src v -> toSourceTextWithSuffix src v "" + HsWord32Prim src v -> toSourceTextWithSuffix src v "" + HsWord64Prim src v -> toSourceTextWithSuffix src v "" + HsFloatPrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "#" + HsDoublePrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "##" + +toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String +toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix +toSourceTextWithSuffix (SourceText txt) _alt suffix = unpackFS txt ++ suffix + +sourceTextToString :: SourceText -> String -> String +sourceTextToString NoSourceText alt = alt +sourceTextToString (SourceText txt) _ = unpackFS txt + +-- --------------------------------------------------------------------- + +exactUserCon :: (Monad m, Monoid w, ExactPrint con) + => (Maybe (EpToken "{"), Maybe (EpToken "}")) -> con -> HsConPatDetails GhcPs + -> EP w m ((Maybe (EpToken "{"), Maybe (EpToken "}")), con, HsConPatDetails GhcPs) +exactUserCon an c (InfixCon p1 p2) = do + p1' <- markAnnotated p1 + c' <- markAnnotated c + p2' <- markAnnotated p2 + return (an, c', InfixCon p1' p2') +exactUserCon (open,close) c details = do + c' <- markAnnotated c + open' <- mapM markEpToken open + details' <- exactConArgs details + close' <- mapM markEpToken close + return ((open', close'), c', details') + +exactConArgs :: (Monad m, Monoid w) + => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs) +exactConArgs (PrefixCon pats) = do + pats' <- markAnnotated pats + return (PrefixCon pats') +exactConArgs (InfixCon p1 p2) = do + p1' <- markAnnotated p1 + p2' <- markAnnotated p2 + return (InfixCon p1' p2') +exactConArgs (RecCon rpats) = do + rpats' <- markAnnotated rpats + return (RecCon rpats') + +-- --------------------------------------------------------------------- + +entryFromLocatedA :: (HasTrailing ann) => LocatedAn ann a -> Entry +entryFromLocatedA (L la _) = fromAnn la + +-- ===================================================================== +-- Utility stuff +-- --------------------------------------------------------------------- + +-- |This should be the final point where things are mode concrete, +-- before output. +-- NOTE: despite the name, this is the ghc-exactprint final output for +-- the PRINT phase. +printStringAtLsDelta :: (Monad m, Monoid w) => DeltaPos -> String -> EP w m () +printStringAtLsDelta cl s = do + p <- getPosP + colOffset <- getLayoutOffsetP + if isGoodDeltaWithOffset cl colOffset + then do + printStringAt (undelta p cl colOffset) s + p' <- getPosP + d <- getPriorEndD + debugM $ "printStringAtLsDelta:(pos,p,p',d,s):" ++ show (undelta p cl colOffset,p,p',d,s) + else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s)) + +-- --------------------------------------------------------------------- + +isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool +isGoodDeltaWithOffset dp colOffset = isGoodDelta (deltaPos l c) + where (l,c) = undelta (0,0) dp colOffset + +-- | Print a comment, using the current layout offset to convert the +-- @DeltaPos@ to an absolute position. +printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () +printQueuedComment Comment{commentContents} dp = do + p <- getPosP + d <- getPriorEndD + colOffset <- getLayoutOffsetP + let (dr,dc) = undelta (0,0) dp colOffset + -- do not lose comments against the left margin + when (isGoodDelta (deltaPos dr (max 0 dc))) $ do + printCommentAt (undelta p dp colOffset) commentContents + p' <- getPosP + d' <- getPriorEndD + debugM $ "printQueuedComment: (p,p',d,d')=" ++ show (p,p',d,d') + debugM $ "printQueuedComment: (p,p',dp,colOffset,undelta)=" ++ show (p,p',dp,colOffset,undelta p dp colOffset) + +------------------------------------------------------------------------ + +setLayoutBoth :: (Monad m, Monoid w) => EP w m a -> EP w m a +setLayoutBoth k = do + oldLHS <- getLayoutOffsetD + oldAnchorOffset <- getLayoutOffsetP + debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) + modify (\a -> a { dMarkLayout = True + , pMarkLayout = True } ) + let reset = do + debugM $ "setLayoutBoth:reset: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) + modify (\a -> a { dMarkLayout = False + , dLHS = oldLHS + , pMarkLayout = False + , pLHS = oldAnchorOffset} ) + k <* reset + +------------------------------------------------------------------------ + +getPosP :: (Monad m, Monoid w) => EP w m Pos +getPosP = gets epPos + +setPosP :: (Monad m, Monoid w) => Pos -> EP w m () +setPosP l = do + debugM $ "setPosP:" ++ show l + modify (\s -> s {epPos = l}) + +getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe EpaLocation) +getExtraDP = gets uExtraDP + +setExtraDP :: (Monad m, Monoid w) => Maybe EpaLocation -> EP w m () +setExtraDP md = do + debugM $ "setExtraDP:" ++ show md + modify (\s -> s {uExtraDP = md}) + +getExtraDPReturn :: (Monad m, Monoid w) => EP w m (Maybe (SrcSpan, DeltaPos)) +getExtraDPReturn = gets uExtraDPReturn + +setExtraDPReturn :: (Monad m, Monoid w) => Maybe (SrcSpan, DeltaPos) -> EP w m () +setExtraDPReturn md = do + debugM $ "setExtraDPReturn:" ++ show md + modify (\s -> s {uExtraDPReturn = md}) + +getPriorEndD :: (Monad m, Monoid w) => EP w m Pos +getPriorEndD = gets dPriorEndPosition + +getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan +getAnchorU = gets uAnchorSpan + +getAcceptSpan ::(Monad m, Monoid w) => EP w m Bool +getAcceptSpan = gets pAcceptSpan + +setAcceptSpan ::(Monad m, Monoid w) => Bool -> EP w m () +setAcceptSpan f = + modify (\s -> s { pAcceptSpan = f }) + +setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m () +setPriorEndD pe = do + setPriorEndNoLayoutD pe + +setPriorEndNoLayoutD :: (Monad m, Monoid w) => Pos -> EP w m () +setPriorEndNoLayoutD pe = do + debugM $ "setPriorEndNoLayoutD:pe=" ++ show pe + modify (\s -> s { dPriorEndPosition = pe }) + +setPriorEndASTD :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () +setPriorEndASTD pe = setPriorEndASTPD (rs2range pe) + +setPriorEndASTPD :: (Monad m, Monoid w) => (Pos,Pos) -> EP w m () +setPriorEndASTPD pe@(fm,to) = do + debugM $ "setPriorEndASTD:pe=" ++ show pe + setLayoutStartD (snd fm) + modify (\s -> s { dPriorEndPosition = to } ) + +setLayoutStartD :: (Monad m, Monoid w) => Int -> EP w m () +setLayoutStartD p = do + EPState{dMarkLayout} <- get + when dMarkLayout $ do + debugM $ "setLayoutStartD: setting dLHS=" ++ show p + modify (\s -> s { dMarkLayout = False + , dLHS = LayoutStartCol p}) + +getLayoutOffsetD :: (Monad m, Monoid w) => EP w m LayoutStartCol +getLayoutOffsetD = gets dLHS + +setAnchorU :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () +setAnchorU rss = do + debugM $ "setAnchorU:" ++ show (rs2range rss) + modify (\s -> s { uAnchorSpan = rss }) + +getEofPos :: (Monad m, Monoid w) => EP w m (Maybe (RealSrcSpan, RealSrcSpan)) +getEofPos = gets epEof + +setEofPos :: (Monad m, Monoid w) => Maybe (RealSrcSpan, RealSrcSpan) -> EP w m () +setEofPos l = modify (\s -> s {epEof = l}) + +-- --------------------------------------------------------------------- + +getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment] +getUnallocatedComments = gets epComments + +putUnallocatedComments :: (Monad m, Monoid w) => [Comment] -> EP w m () +putUnallocatedComments !cs = modify (\s -> s { epComments = cs } ) + +-- | Push a fresh stack frame for the applied comments gatherer +pushAppliedComments :: (Monad m, Monoid w) => EP w m () +pushAppliedComments = modify (\s -> s { epCommentsApplied = []:(epCommentsApplied s) }) + +-- | Return the comments applied since the last call +-- takeAppliedComments, and clear them, not popping the stack +takeAppliedComments :: (Monad m, Monoid w) => EP w m [Comment] +takeAppliedComments = do + !ccs <- gets epCommentsApplied + case ccs of + [] -> do + modify (\s -> s { epCommentsApplied = [] }) + return [] + h:t -> do + modify (\s -> s { epCommentsApplied = []:t }) + return (reverse h) + +-- | Return the comments applied since the last call +-- takeAppliedComments, and clear them, popping the stack +takeAppliedCommentsPop :: (Monad m, Monoid w) => EP w m [Comment] +takeAppliedCommentsPop = do + !ccs <- gets epCommentsApplied + case ccs of + [] -> do + modify (\s -> s { epCommentsApplied = [] }) + return [] + h:t -> do + modify (\s -> s { epCommentsApplied = t }) + return (reverse h) + +-- | Mark a comment as being applied. This is used to update comments +-- when doing delta processing +applyComment :: (Monad m, Monoid w) => Comment -> EP w m () +applyComment c = do + !ccs <- gets epCommentsApplied case ccs of [] -> modify (\s -> s { epCommentsApplied = [[c]] } ) (h:t) -> modify (\s -> s { epCommentsApplied = (c:h):t } ) diff --git a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs deleted file mode 100644 --- a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Language.Haskell.GHC.ExactPrint.Lookup - ( - keywordToString - , AnnKeywordId(..) - , Comment(..) - ) where - -import GHC (AnnKeywordId(..)) -import Language.Haskell.GHC.ExactPrint.Types - --- | Maps `AnnKeywordId` to the corresponding String representation. --- There is no specific mapping for the following constructors. --- `AnnOpen`, `AnnClose`, `AnnVal`, `AnnPackageName`, `AnnHeader`, `AnnFunId`, --- `AnnInfix` -keywordToString :: AnnKeywordId -> String -keywordToString kw = - let mkErr x = error $ "keywordToString: missing case for:" ++ show x - in - case kw of - -- Specifically handle all cases so that there are pattern match - -- warnings if new constructors are added. - AnnAnyclass -> "anyclass" - AnnOpen -> mkErr kw - AnnClose -> mkErr kw - AnnVal -> mkErr kw - AnnPackageName -> mkErr kw - AnnHeader -> mkErr kw - AnnFunId -> mkErr kw - AnnInfix -> mkErr kw - AnnValStr -> mkErr kw - AnnName -> mkErr kw - AnnAs -> "as" - AnnBang -> "!" - AnnBackquote -> "`" - AnnBy -> "by" - AnnCase -> "case" - AnnCases -> "cases" - AnnClass -> "class" - AnnCloseB -> "|)" - AnnCloseBU -> "⦈" - AnnCloseC -> "}" - AnnCloseP -> ")" - AnnClosePH -> "#)" - AnnCloseQ -> "|]" - AnnCloseQU -> "⟧" - AnnCloseS -> "]" - AnnColon -> ":" - AnnComma -> "," - AnnCommaTuple -> "," - AnnDarrow -> "=>" - AnnData -> "data" - AnnDcolon -> "::" - AnnDefault -> "default" - AnnDeriving -> "deriving" - AnnDo -> "do" - AnnDot -> "." - AnnDotdot -> ".." - AnnElse -> "else" - AnnEqual -> "=" - AnnExport -> "export" - AnnFamily -> "family" - AnnForall -> "forall" - AnnForeign -> "foreign" - AnnGroup -> "group" - AnnHiding -> "hiding" - AnnIf -> "if" - AnnImport -> "import" - AnnIn -> "in" - AnnInstance -> "instance" - AnnLam -> "\\" - AnnLarrow -> "<-" - AnnLet -> "let" - AnnLollyU -> "⊸" - AnnMdo -> "mdo" - AnnMinus -> "-" - AnnModule -> "module" - AnnNewtype -> "newtype" - AnnOf -> "of" - AnnOpenB -> "(|" - AnnOpenBU -> "⦇" - AnnOpenC -> "{" - AnnOpenE -> "[e|" - AnnOpenEQ -> "[|" - AnnOpenEQU -> "⟦" - AnnOpenP -> "(" - AnnOpenPH -> "(#" - AnnOpenS -> "[" - AnnPattern -> "pattern" - AnnPercent -> "%" - AnnPercentOne -> "%1" - AnnProc -> "proc" - AnnQualified -> "qualified" - AnnRarrow -> "->" - AnnRec -> "rec" - AnnRole -> "role" - AnnSafe -> "safe" - AnnSemi -> ";" - AnnSignature -> "signature" - AnnStock -> "stock" - AnnStatic -> "static" - AnnThen -> "then" - AnnTilde -> "~" - AnnType -> "type" - AnnUnit -> "()" - AnnUsing -> "using" - AnnVbar -> "|" - AnnWhere -> "where" - Annlarrowtail -> "-<" - Annrarrowtail -> ">-" - AnnLarrowtail -> "-<<" - AnnRarrowtail -> ">>-" - AnnSimpleQuote -> "'" - AnnThTyQuote -> "''" - AnnDollar -> "$" - AnnDollarDollar -> "$$" - AnnDarrowU -> "⇒" - AnnDcolonU -> "∷" - AnnForallU -> "∀" - AnnLarrowU -> "←" - AnnLarrowtailU -> "⤛" - AnnRarrowU -> "→" - AnnRarrowtailU -> "⤜" - AnnlarrowtailU -> "⤙" - AnnrarrowtailU -> "⤚" - AnnVia -> "via" diff --git a/src/Language/Haskell/GHC/ExactPrint/Orphans.hs b/src/Language/Haskell/GHC/ExactPrint/Orphans.hs deleted file mode 100644 --- a/src/Language/Haskell/GHC/ExactPrint/Orphans.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Language.Haskell.GHC.ExactPrint.Orphans where - -import Data.Default -import GHC hiding (EpaComment) -import GHC.Types.SrcLoc - --- --------------------------------------------------------------------- - --- --------------------------------------------------------------------- --- Orphan Default instances. See https://gitlab.haskell.org/ghc/ghc/-/issues/20372 - -{- -instance Default [a] where - def = [] --} -instance Default NameAnn where - def = mempty - -instance Default AnnList where - def = mempty - -instance Default AnnListItem where - def = mempty - -instance Default AnnPragma where - def = AnnPragma def def def - -instance Semigroup EpAnnImportDecl where - (<>) = error "unimplemented" -instance Default EpAnnImportDecl where - def = EpAnnImportDecl def Nothing Nothing Nothing Nothing Nothing - -instance Default HsRuleAnn where - def = HsRuleAnn Nothing Nothing def - -instance Default AnnSig where - def = AnnSig def def - -instance Default GrhsAnn where - def = GrhsAnn Nothing def - -instance Default EpAnnUnboundVar where - def = EpAnnUnboundVar def def - -{- -instance (Default a, Default b) => Default (a, b) where - def = (def, def) --} - -instance Default NoEpAnns where - def = NoEpAnns - -instance Default AnnParen where - def = AnnParen AnnParens def def - -instance Default AnnExplicitSum where - def = AnnExplicitSum def def def def - -instance Default EpAnnHsCase where - def = EpAnnHsCase def def def - -instance Default AnnsIf where - def = AnnsIf def def def def def - -{- -instance Default (Maybe a) where - def = Nothing --} - -instance Default AnnProjection where - def = AnnProjection def def - -instance Default AnnFieldLabel where - def = AnnFieldLabel Nothing - -instance Default EpaLocation where - def = EpaDelta (SameLine 0) [] - -instance Default AddEpAnn where - def = AddEpAnn def def - -instance Default AnnKeywordId where - def = Annlarrowtail {- gotta pick one -} - -instance Default AnnContext where - def = AnnContext Nothing [] [] - -instance Default EpAnnSumPat where - def = EpAnnSumPat def def def - -instance Semigroup RealSrcSpan where - a <> b = combineRealSrcSpans a b - -instance Default AnnsModule where - def = AnnsModule [] mempty mempty 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 @@ -279,18 +279,18 @@ where an' = case GHC.hsmodAnn $ GHC.hsmodExt p of (GHC.EpAnn a an ocs) -> GHC.EpAnn a an (rebalance ocs) - unused -> unused p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' } } rebalance :: GHC.EpAnnComments -> GHC.EpAnnComments rebalance cs = cs' where cs' = case GHC.hsmodLayout $ GHC.hsmodExt p of - GHC.ExplicitBraces _ (GHC.L (GHC.TokenLoc (GHC.EpaSpan ss _)) _) -> + GHC.EpExplicitBraces _ (GHC.EpTok (GHC.EpaSpan (GHC.RealSrcSpan ss _))) -> let pc = GHC.priorComments cs fc = GHC.getFollowingComments cs - bf (GHC.L anc _) = GHC.anchor anc > ss + bf (GHC.L anc _) = GHC.epaLocationRealSrcSpan anc > ss + (prior,f) = break bf fc cs'' = GHC.EpaCommentsBalanced (pc <> prior) f in cs'' @@ -305,17 +305,17 @@ moveComments :: GHC.EpaLocation -> GHC.LHsDecl GHC.GhcPs -> GHC.EpAnnComments -> (GHC.LHsDecl GHC.GhcPs, GHC.EpAnnComments) moveComments GHC.EpaDelta{} dd cs = (dd,cs) - moveComments _loc dd@(GHC.L (GHC.SrcSpanAnn GHC.EpAnnNotUsed _) _) cs = (dd,cs) - moveComments (GHC.EpaSpan r _) (GHC.L (GHC.SrcSpanAnn (GHC.EpAnn anc an csd) ll) a) cs = (dd,css) + moveComments (GHC.EpaSpan (GHC.UnhelpfulSpan _)) dd cs = (dd,cs) + moveComments (GHC.EpaSpan (GHC.RealSrcSpan r _)) (GHC.L (GHC.EpAnn anc an csd) a) cs = (dd,css) where -- Move any comments on the decl that occur prior to the location pc = GHC.priorComments csd fc = GHC.getFollowingComments csd - bf (GHC.L anch _) = GHC.anchor anch > r + bf (GHC.L anch _) = GHC.epaLocationRealSrcSpan anch > r (move,keep) = break bf pc csd' = GHC.EpaCommentsBalanced keep fc - dd = GHC.L (GHC.SrcSpanAnn (GHC.EpAnn anc an csd') ll) a + dd = GHC.L (GHC.EpAnn anc an csd') a css = cs <> GHC.EpaComments move (ds',an') = rebalance (GHC.hsmodDecls p, GHC.hsmodAnn $ GHC.hsmodExt p) @@ -325,11 +325,10 @@ rebalance :: ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule) -> ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule) - rebalance (ds, GHC.EpAnnNotUsed) = (ds, GHC.EpAnnNotUsed) rebalance (ds, GHC.EpAnn a an cs) = (ds1, GHC.EpAnn a an cs') where - (ds1,cs') = case break (\(GHC.AddEpAnn k _) -> k == GHC.AnnWhere) (GHC.am_main an) of - (_, (GHC.AddEpAnn _ whereLoc:_)) -> + (ds1,cs') = case GHC.am_where an of + GHC.EpTok whereLoc -> case GHC.hsmodDecls p of (d:ds0) -> (d':ds0, cs0) where (d',cs0) = moveComments whereLoc d cs @@ -349,12 +348,14 @@ -- Based on GHC backpack driver doBackPack dflags0 <- GHC.getSessionDynFlags let parser_opts0 = GHC.initParserOpts dflags0 - (_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 file - (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts + logger <- GHC.getLogger + (_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 (GHC.supportedLanguagePragmas dflags0) file + (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 src_opts -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream -- Prevent parsing of .ghc.environment.* "package environment files" (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine + logger dflags2 [GHC.noLoc "-hide-all-packages"] _ <- GHC.setSessionDynFlags dflags3 @@ -376,13 +377,15 @@ -- as long as `parseDynamicFilePragma` is impure there seems to be -- no reason to use it. dflags0 <- GHC.getSessionDynFlags + logger <- GHC.getLogger let parser_opts0 = GHC.initParserOpts dflags0 - let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.stringToStringBuffer $ s) fp - (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo + let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.supportedLanguagePragmas dflags0) (GHC.stringToStringBuffer $ s) fp + (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 pragmaInfo -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream -- Prevent parsing of .ghc.environment.* "package environment files" (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine + logger dflags2 [GHC.noLoc "-hide-all-packages"] _ <- GHC.setSessionDynFlags dflags3 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 @@ -12,7 +12,6 @@ , CppOptions(..) , defaultCppOptions - , showErrorMessages ) where import qualified GHC as GHC hiding (parseModule) @@ -25,7 +24,6 @@ import qualified GHC.Driver.Errors.Types as GHC import qualified GHC.Driver.Phases as GHC import qualified GHC.Driver.Pipeline as GHC -import qualified GHC.Fingerprint.Type as GHC import qualified GHC.Parser.Lexer as GHC import qualified GHC.Settings as GHC import qualified GHC.Types.Error as GHC @@ -60,7 +58,7 @@ defaultCppOptions = CppOptions [] [] [] -- --------------------------------------------------------------------- --- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into comments. +-- | Remove GHC style line pragmas (@{-# LINE .. #-}@) and convert them into comments. stripLinePragmas :: String -> (String, [GHC.LEpaComment]) stripLinePragmas = unlines' . unzip . findLines . lines where @@ -78,7 +76,6 @@ ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1)) in (res, Just $ mkLEpaComment pragma (GHC.spanAsAnchor ss) (GHC.realSrcSpan ss)) -- Deal with shebang/cpp directives too - -- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s) | "#!" `isPrefixOf` s = let mSrcLoc = mkSrcLoc (mkFastString "SHEBANG") ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s)) @@ -130,7 +127,6 @@ isGoodComment [Comment "" _ _ _] = False isGoodComment _ = True - toRealLocated :: GHC.Located a -> GHC.RealLocated a toRealLocated (GHC.L (GHC.RealSrcSpan s _) x) = GHC.L s x toRealLocated (GHC.L _ x) = GHC.L badRealSrcSpan x @@ -226,8 +222,7 @@ txt <- GHC.liftIO $ readFileGhc hspp_fn return (txt, buf, dflags') --- showErrorMessages :: GHC.Messages GHC.DriverMessage -> String -showErrorMessages :: (GHC.Diagnostic a) => GHC.Messages a -> String +showErrorMessages :: GHC.Messages GHC.DriverMessage -> String showErrorMessages msgs = GHC.renderWithContext GHC.defaultSDocContext $ GHC.vcat @@ -236,25 +231,33 @@ $ msgs injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags -injectCppOptions CppOptions{..} dflags = - foldr addOptP dflags (map mkDefine cppDefine ++ map mkIncludeDir cppInclude ++ map mkInclude cppFile) +injectCppOptions CppOptions{..} dflags = folded_opt where mkDefine = ("-D" ++) mkIncludeDir = ("-I" ++) mkInclude = ("-include" ++) - + file_flags = map mkDefine cppDefine ++ map mkIncludeDir cppInclude ++ map mkInclude cppFile + addFs = [addOptP, addOptJSP, addOptCmmP] + folded_opt = foldr ($) dflags (addFs <*> file_flags) addOptP :: String -> GHC.DynFlags -> GHC.DynFlags addOptP f = alterToolSettings $ \s -> s { GHC.toolSettings_opt_P = f : GHC.toolSettings_opt_P s - , GHC.toolSettings_opt_P_fingerprint = fingerprintStrings (f : GHC.toolSettings_opt_P s) + , GHC.toolSettings_opt_P_fingerprint = GHC.fingerprintStrings (f : GHC.toolSettings_opt_P s) } +addOptJSP :: String -> GHC.DynFlags -> GHC.DynFlags +addOptJSP f = alterToolSettings $ \s -> s + { GHC.toolSettings_opt_JSP = f : GHC.toolSettings_opt_JSP s + , GHC.toolSettings_opt_JSP_fingerprint = GHC.fingerprintStrings (f : GHC.toolSettings_opt_JSP s) + } +addOptCmmP :: String -> GHC.DynFlags -> GHC.DynFlags +addOptCmmP f = alterToolSettings $ \s -> s + { GHC.toolSettings_opt_CmmP = f : GHC.toolSettings_opt_CmmP s + , GHC.toolSettings_opt_CmmP_fingerprint = GHC.fingerprintStrings (f : GHC.toolSettings_opt_CmmP s) + } alterToolSettings :: (GHC.ToolSettings -> GHC.ToolSettings) -> GHC.DynFlags -> GHC.DynFlags alterToolSettings f dynFlags = dynFlags { GHC.toolSettings = f (GHC.toolSettings dynFlags) } -fingerprintStrings :: [String] -> GHC.Fingerprint -fingerprintStrings ss = GHC.fingerprintFingerprints $ map GHC.fingerprintString ss - -- --------------------------------------------------------------------- -- | Get the preprocessor directives as comment tokens from the @@ -283,12 +286,7 @@ -- --------------------------------------------------------------------- parseError :: (GHC.MonadIO m) => GHC.PState -> m b -parseError pst = do - let - -- (warns,errs) = GHC.getMessages pst dflags - -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err) - -- GHC.throwErrors (fmap GHC.mkParserErr (GHC.getErrorMessages pst)) - GHC.throwErrors (fmap GHC.GhcPsMessage (GHC.getPsErrorMessages pst)) +parseError pst = GHC.throwErrors (fmap GHC.GhcPsMessage (GHC.getPsErrorMessages pst)) -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs --- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs @@ -1,1204 +1,1183 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.GHC.ExactPrint.Transform --- --- This module is currently under heavy development, and no promises are made --- about API stability. Use with care. --- --- We welcome any feedback / contributions on this, as it is the main point of --- the library. --- ------------------------------------------------------------------------------ -module Language.Haskell.GHC.ExactPrint.Transform - ( - -- * The Transform Monad - Transform - , TransformT(..) - , hoistTransform - , runTransform - , runTransformT - , runTransformFrom - , runTransformFromT - - -- * Transform monad operations - , logTr - , logDataWithAnnsTr - , uniqueSrcSpanT - - -- ** Managing declarations, in Transform monad - , HasTransform (..) - , HasDecls (..) - , hsDeclsPatBind, hsDeclsPatBindD - , replaceDeclsPatBind, replaceDeclsPatBindD - , modifyDeclsT - , modifyValD - -- *** Utility, does not manage layout - , hsDeclsValBinds, replaceDeclsValbinds - , WithWhere(..) - - -- ** New gen functions - , noAnnSrcSpanDP - , noAnnSrcSpanDP0 - , noAnnSrcSpanDP1 - , noAnnSrcSpanDPn - , d0, d1, dn - , m0, m1, mn - , addComma - - -- ** Managing lists, Transform monad - , insertAt - , insertAtStart - , insertAtEnd - , insertAfter - , insertBefore - - -- *** Low level operations used in 'HasDecls' - , balanceComments - , balanceCommentsList - , balanceCommentsList' - , anchorEof - - -- ** Managing lists, pure functions - , captureOrder - , captureLineSpacing - , captureMatchLineSpacing - , captureTypeSigSpacing - - -- * Operations - , isUniqueSrcSpan - - -- * Pure functions - , setEntryDP - , getEntryDP - , transferEntryDP - , transferEntryDP' - , wrapSig, wrapDecl - , decl2Sig, decl2Bind - ) where - -import Language.Haskell.GHC.ExactPrint.ExactPrint -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils --- import Language.Haskell.GHC.ExactPrint.Orphans (Default(..)) - -import Control.Monad.RWS -import qualified Control.Monad.Fail as Fail - -import GHC hiding (parseModule, parsedSource) -import GHC.Data.Bag -import GHC.Data.FastString - -import Data.Data -import Data.Default -import Data.Maybe -import Data.Generics -import Data.List (sortBy) - -import Data.Functor.Identity -import Control.Monad.State - ------------------------------------------------------------------------------- --- Transformation of source elements - --- | Monad type for updating the AST and managing the annotations at the same --- time. The W state is used to generate logging information if required. -type Transform = TransformT Identity - --- |Monad transformer version of 'Transform' monad -newtype TransformT m a = TransformT { unTransformT :: RWST () [String] Int m a } - deriving (Monad,Applicative,Functor - ,MonadReader () - ,MonadWriter [String] - ,MonadState Int - ,MonadTrans - ) - -instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where - fail msg = TransformT $ RWST $ \_ _ -> Fail.fail msg - --- | Run a transformation in the 'Transform' monad, returning the updated --- annotations and any logging generated via 'logTr' -runTransform :: Transform a -> (a,Int,[String]) -runTransform f = runTransformFrom 0 f - -runTransformT :: TransformT m a -> m (a,Int,[String]) -runTransformT f = runTransformFromT 0 f - --- | Run a transformation in the 'Transform' monad, returning the updated --- annotations and any logging generated via 'logTr', allocating any new --- SrcSpans from the provided initial value. -runTransformFrom :: Int -> Transform a -> (a,Int,[String]) -runTransformFrom seed f = runRWS (unTransformT f) () seed - --- |Run a monad transformer stack for the 'TransformT' monad transformer -runTransformFromT :: Int -> TransformT m a -> m (a,Int,[String]) -runTransformFromT seed f = runRWST (unTransformT f) () seed - --- | Change inner monad of 'TransformT'. -hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a -hoistTransform nt (TransformT m) = TransformT (mapRWST nt m) - --- |Log a string to the output of the Monad -logTr :: (Monad m) => String -> TransformT m () -logTr str = tell [str] - --- |Log a representation of the given AST with annotations to the output of the --- Monad -logDataWithAnnsTr :: (Monad m) => (Data a) => String -> a -> TransformT m () -logDataWithAnnsTr str ast = do - logTr $ str ++ showAst ast - --- --------------------------------------------------------------------- - --- |If we need to add new elements to the AST, they need their own --- 'SrcSpan' for this. -uniqueSrcSpanT :: (Monad m) => TransformT m SrcSpan -uniqueSrcSpanT = do - col <- get - put (col + 1 ) - let pos = mkSrcLoc (mkFastString "ghc-exactprint") (-1) col - return $ mkSrcSpan pos pos - --- |Test whether a given 'SrcSpan' was generated by 'uniqueSrcSpanT' -isUniqueSrcSpan :: SrcSpan -> Bool -isUniqueSrcSpan ss = srcSpanStartLine' ss == -1 - -srcSpanStartLine' :: SrcSpan -> Int -srcSpanStartLine' (RealSrcSpan s _) = srcSpanStartLine s -srcSpanStartLine' _ = 0 - --- --------------------------------------------------------------------- - --- |If a list has been re-ordered or had items added, capture the new order in --- the appropriate 'AnnSortKey' attached to the 'Annotation' for the list. -captureOrder :: [LocatedA b] -> AnnSortKey -captureOrder ls = AnnSortKey $ map (rs . getLocA) ls - --- --------------------------------------------------------------------- - -captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs -captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ))))) - = L l (ValD x (FunBind a b (MG c (L d ms')))) - where - ms' :: [LMatch GhcPs (LHsExpr GhcPs)] - ms' = captureLineSpacing ms -captureMatchLineSpacing d = d - -captureLineSpacing :: Default t - => [LocatedAn t e] -> [LocatedAn t e] -captureLineSpacing [] = [] -captureLineSpacing [d] = [d] -captureLineSpacing (de1:d2:ds) = de1:captureLineSpacing (d2':ds) - where - (l1,_) = ss2pos $ rs $ getLocA de1 - (l2,_) = ss2pos $ rs $ getLocA d2 - d2' = setEntryDP d2 (deltaPos (l2-l1) 0) - --- --------------------------------------------------------------------- - -captureTypeSigSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs -captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (HsWC xw ty)))) - = (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc' rs') cs) ns (HsWC xw ty')))) - where - -- we want DPs for the distance from the end of the ns to the - -- AnnDColon, and to the start of the ty - AddEpAnn kw dca = dc - rd = case last ns of - L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll - L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor? - dc' = case dca of - EpaSpan r _ -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) []) - EpaDelta _ _ -> AddEpAnn kw dca - - -- --------------------------------- - - ty' :: LHsSigType GhcPs - ty' = case ty of - (L (SrcSpanAnn EpAnnNotUsed ll) b) - -> let - op = case dca of - EpaSpan r _ -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll)) - EpaDelta _ _ -> MovedAnchor (SameLine 1) - in (L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan ll) op) mempty emptyComments) ll) b) - (L (SrcSpanAnn (EpAnn (Anchor r op) a c) ll) b) - -> let - op' = case op of - MovedAnchor _ -> op - _ -> case dca of - EpaSpan dcr _ -> MovedAnchor (ss2delta (ss2posEnd dcr) r) - EpaDelta _ _ -> MovedAnchor (SameLine 1) - in (L (SrcSpanAnn (EpAnn (Anchor r op') a c) ll) b) - -captureTypeSigSpacing s = s - --- --------------------------------------------------------------------- - --- |Pure function to convert a 'LHsDecl' to a 'LHsBind'. This does --- nothing to any annotations that may be attached to either of the elements. --- It is used as a utility function in 'replaceDecls' -decl2Bind :: LHsDecl GhcPs -> [LHsBind GhcPs] -decl2Bind (L l (ValD _ s)) = [L l s] -decl2Bind _ = [] - --- |Pure function to convert a 'LSig' to a 'LHsBind'. This does --- nothing to any annotations that may be attached to either of the elements. --- It is used as a utility function in 'replaceDecls' -decl2Sig :: LHsDecl GhcPs -> [LSig GhcPs] -decl2Sig (L l (SigD _ s)) = [L l s] -decl2Sig _ = [] - --- --------------------------------------------------------------------- - --- |Convert a 'LSig' into a 'LHsDecl' -wrapSig :: LSig GhcPs -> LHsDecl GhcPs -wrapSig (L l s) = L l (SigD NoExtField s) - --- --------------------------------------------------------------------- - --- |Convert a 'LHsBind' into a 'LHsDecl' -wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs -wrapDecl (L l s) = L l (ValD NoExtField s) - --- --------------------------------------------------------------------- - -setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs -setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms ))))) dp - = L l' (ValD x (FunBind a b (MG c (L d ms')))) - where - L l' _ = setEntryDP decl dp - ms' :: [LMatch GhcPs (LHsExpr GhcPs)] - ms' = case ms of - [] -> [] - (m0':ms0) -> setEntryDP m0' dp : ms0 -setEntryDPDecl d dp = setEntryDP d dp - --- --------------------------------------------------------------------- - --- |Set the true entry 'DeltaPos' from the annotation for a given AST --- element. This is the 'DeltaPos' ignoring any comments. -setEntryDP :: Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a -setEntryDP (L (SrcSpanAnn EpAnnNotUsed l) a) dp - = L (SrcSpanAnn - (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) def emptyComments) - l) a -setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp - = L (SrcSpanAnn - (EpAnn (Anchor r (MovedAnchor dp)) an (EpaComments [])) - l) a -setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor d)) an cs) l) a) dp - = L (SrcSpanAnn - (EpAnn (Anchor r (MovedAnchor d')) an cs') - l) a - where - (d',cs') = case cs of - EpaComments (h:t) -> - let - (dp0,c') = go h - in - (dp0, EpaComments (c':t)) - EpaCommentsBalanced (h:t) ts -> - let - (dp0,c') = go h - in - (dp0, EpaCommentsBalanced (c':t) ts) - _ -> (dp, cs) - go (L (Anchor rr (MovedAnchor ma)) c) = (d, L (Anchor rr (MovedAnchor ma)) c) - go (L (Anchor rr _) c) = (d, L (Anchor rr (MovedAnchor dp)) c) -setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp - = case sortEpaComments (priorComments cs) of - [] -> - L (SrcSpanAnn - (EpAnn (Anchor r (MovedAnchor dp)) an cs) - l) a - (L ca c:cs') -> - L (SrcSpanAnn - (EpAnn (Anchor r (MovedAnchor edp)) an cs'') - l) a - where - cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs') - lc = last $ (L ca c:cs') - delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r - line = getDeltaLine delta - col = deltaColumn delta - edp' = if line == 0 then SameLine col - else DifferentLine line col - edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r)) - - --- --------------------------------------------------------------------- - -getEntryDP :: LocatedAn t a -> DeltaPos -getEntryDP (L (SrcSpanAnn (EpAnn (Anchor _ (MovedAnchor dp)) _ _) _) _) = dp -getEntryDP _ = SameLine 1 - --- --------------------------------------------------------------------- - -addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation -addEpaLocationDelta _off _anc (EpaDelta d cs) = EpaDelta d cs -addEpaLocationDelta off anc (EpaSpan r _) - = EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) [] - --- Set the entry DP for an element coming after an existing keyword annotation -setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t -setEntryDPFromAnchor _off (EpaDelta _ _) (L la a) = L la a -setEntryDPFromAnchor off (EpaSpan anc _) ll@(L la _) = setEntryDP ll dp' - where - r = case la of - (SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l - (SrcSpanAnn (EpAnn (Anchor r' _) _ _) _) -> r' - dp' = adjustDeltaForOffset off (ss2deltaEnd anc r) - --- --------------------------------------------------------------------- - --- |Take the annEntryDelta associated with the first item and associate it with the second. --- Also transfer any comments occuring before it. -transferEntryDP :: (Monad m, Monoid t2, Typeable t1, Typeable t2) - => LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b) -transferEntryDP (L (SrcSpanAnn EpAnnNotUsed l1) _) (L (SrcSpanAnn EpAnnNotUsed _) b) = do - logTr $ "transferEntryDP': EpAnnNotUsed,EpAnnNotUsed" - return (L (SrcSpanAnn EpAnnNotUsed l1) b) -transferEntryDP (L (SrcSpanAnn (EpAnn anc _an cs) _l1) _) (L (SrcSpanAnn EpAnnNotUsed l2) b) = do - logTr $ "transferEntryDP': EpAnn,EpAnnNotUsed" - return (L (SrcSpanAnn (EpAnn anc mempty cs) l2) b) -transferEntryDP (L (SrcSpanAnn (EpAnn anc1 an1 cs1) _l1) _) (L (SrcSpanAnn (EpAnn _anc2 an2 cs2) l2) b) = do - logTr $ "transferEntryDP': EpAnn,EpAnn" - -- Problem: if the original had preceding comments, blindly - -- transferring the location is not correct - case priorComments cs1 of - [] -> return (L (SrcSpanAnn (EpAnn anc1 (combine an1 an2) cs2) l2) b) - -- TODO: what happens if the receiving side already has comments? - (L anc _:_) -> do - logDataWithAnnsTr "transferEntryDP':priorComments anc=" anc - return (L (SrcSpanAnn (EpAnn anc1 (combine an1 an2) (cs1 <> cs2)) l2) b) -transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 an2 cs2) l2) b) = do - logTr $ "transferEntryDP': EpAnnNotUsed,EpAnn" - return (L (SrcSpanAnn (EpAnn anc2' an2 cs2) l2) b) - where - anc2' = case anc2 of - Anchor _a op -> Anchor (realSrcSpan l2) op - - --- |If a and b are the same type return first arg, else return second -combine :: (Typeable a, Typeable b) => a -> b -> b -combine x y = fromMaybe y (cast x) - --- |Take the annEntryDelta associated with the first item and associate it with the second. --- Also transfer any comments occuring before it. --- TODO: call transferEntryDP, and use pushDeclDP -transferEntryDP' :: (Monad m) => LHsDecl GhcPs -> LHsDecl GhcPs -> TransformT m (LHsDecl GhcPs) -transferEntryDP' la lb = do - (L l2 b) <- transferEntryDP la lb - return (L l2 (pushDeclDP b (SameLine 0))) - - -pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs -pushDeclDP (ValD x (FunBind a b (MG c (L d ms )))) dp - = ValD x (FunBind a b (MG c (L d' ms'))) - where - L d' _ = setEntryDP (L d ms) dp - ms' :: [LMatch GhcPs (LHsExpr GhcPs)] - ms' = case ms of - [] -> [] - (m0':ms0) -> setEntryDP m0' dp : ms0 -pushDeclDP d _dp = d - --- --------------------------------------------------------------------- - -balanceCommentsList :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] -balanceCommentsList ds = balanceCommentsList'' ds - -balanceCommentsList'' :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] -balanceCommentsList'' [] = return [] -balanceCommentsList'' [x] = return [x] -balanceCommentsList'' (a:b:ls) = do - (a',b') <- balanceComments a b - r <- balanceCommentsList'' (b':ls) - return (a':r) - --- |The GHC parser puts all comments appearing between the end of one AST --- item and the beginning of the next as 'annPriorComments' for the second one. --- This function takes two adjacent AST items and moves any 'annPriorComments' --- from the second one to the 'annFollowingComments' of the first if they belong --- to it instead. This is typically required before deleting or duplicating --- either of the AST elements. -balanceComments :: (Monad m) - => LHsDecl GhcPs -> LHsDecl GhcPs - -> TransformT m (LHsDecl GhcPs, LHsDecl GhcPs) -balanceComments first second = do - case first of - (L l (ValD x fb@(FunBind{}))) -> do - (L l' fb',second') <- balanceCommentsFB (L l fb) second - return (L l' (ValD x fb'), second') - _ -> balanceComments' first second - --- |Once 'balanceComments' has been called to move trailing comments to a --- 'FunBind', these need to be pushed down from the top level to the last --- 'Match' if that 'Match' needs to be manipulated. -balanceCommentsFB :: (Monad m) - => LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b) -balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do - logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf) - -- There are comments on lf. We need to - -- + Keep the prior ones here - -- + move the interior ones to the first match, - -- + move the trailing ones to the last match. - let - split = splitCommentsEnd (realSrcSpan $ locA lf) (epAnnComments $ ann lf) - split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sortEpaComments $ priorComments split)) - - before = sortEpaComments $ priorComments split2 - middle = sortEpaComments $ getFollowingComments split2 - after = sortEpaComments $ getFollowingComments split - - lf' = setCommentsSrcAnn lf (EpaComments before) - logTr $ "balanceCommentsFB (before, after): " ++ showAst (before, after) - let matches' = case matches of - (L lm' m':ms') -> - (L (addCommentsToSrcAnn lm' (EpaComments middle )) m':ms') - _ -> error "balanceCommentsFB" - matches'' <- balanceCommentsList' matches' - let (m,ms) = case reverse matches'' of - (L lm' m':ms') -> - (L (addCommentsToSrcAnn lm' (EpaCommentsBalanced [] after)) m',ms') - _ -> error "balanceCommentsFB" - (m',second') <- balanceComments' m second - m'' <- balanceCommentsMatch m' - let (m''',lf'') = case ms of - [] -> moveLeadingComments m'' lf' - _ -> (m'',lf') - logTr $ "balanceCommentsMatch done" - balanceComments' (L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))))) second' -balanceCommentsFB f s = balanceComments' f s - --- | Move comments on the same line as the end of the match into the --- GRHS, prior to the binds -balanceCommentsMatch :: (Monad m) - => LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs)) -balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do - logTr $ "balanceCommentsMatch: (logInfo)=" ++ showAst (logInfo) - return (L l'' (Match am mctxt pats (GRHSs xg grhss' binds'))) - where - simpleBreak (r,_) = r /= 0 - (SrcSpanAnn an1 _loc1) = l - anc1 = addCommentOrigDeltas $ epAnnComments an1 - cs1f = getFollowingComments anc1 - (move',stay') = break simpleBreak (trailingCommentsDeltas (anchorFromLocatedA (L l ())) cs1f) - move = map snd move' - stay = map snd stay' - (l'', grhss', binds', logInfo) - = case reverse grhss of - [] -> (l, [], binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan)) - (L lg g@(GRHS EpAnnNotUsed _grs _rhs):gs) - -> (l, reverse (L lg g:gs), binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan)) - (L lg (GRHS ag grs rhs):gs) -> - let - anc1' = setFollowingComments anc1 stay - an1' = setCommentsSrcAnn l anc1' - - -- --------------------------------- - (moved,bindsm) = pushTrailingComments WithWhere (EpaCommentsBalanced [] move) binds - -- --------------------------------- - - (EpAnn anc an lgc) = ag - lgc' = splitCommentsEnd (realSrcSpan $ locA lg) $ addCommentOrigDeltas lgc - ag' = if moved - then EpAnn anc an lgc' - else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move)) - -- ag' = EpAnn anc an lgc' - - in (an1', (reverse $ (L lg (GRHS ag' grs rhs):gs)), bindsm, (anc1',an1')) - -pushTrailingComments :: WithWhere -> EpAnnComments -> HsLocalBinds GhcPs -> (Bool, HsLocalBinds GhcPs) -pushTrailingComments _ _cs b@EmptyLocalBinds{} = (False, b) -pushTrailingComments _ _cs (HsIPBinds _ _) = error "TODO: pushTrailingComments:HsIPBinds" -pushTrailingComments w cs lb@(HsValBinds an _) - = (True, HsValBinds an' vb) - where - (decls, _, _ws1) = runTransform (hsDeclsValBinds lb) - (an', decls') = case reverse decls of - [] -> (addCommentsToEpAnn (spanHsLocaLBinds lb) an cs, decls) - (L la d:ds) -> (an, L (addCommentsToSrcAnn la cs) d:ds) - (vb,_ws2) = case runTransform (replaceDeclsValbinds w lb (reverse decls')) of - ((HsValBinds _ vb'), _, ws2') -> (vb', ws2') - _ -> (ValBinds NoAnnSortKey emptyBag [], []) - - -balanceCommentsList' :: (Monad m) => [LocatedA a] -> TransformT m [LocatedA a] -balanceCommentsList' [] = return [] -balanceCommentsList' [x] = return [x] -balanceCommentsList' (a:b:ls) = do - logTr $ "balanceCommentsList' entered" - (a',b') <- balanceComments' a b - r <- balanceCommentsList' (b':ls) - return (a':r) - --- |Prior to moving an AST element, make sure any trailing comments belonging to --- it are attached to it, and not the following element. Of necessity this is a --- heuristic process, to be tuned later. Possibly a variant should be provided --- with a passed-in decision function. --- The initial situation is that all comments for a given anchor appear as prior comments --- Many of these should in fact be following comments for the previous anchor -balanceComments' :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA a, LocatedA b) -balanceComments' la1 la2 = do - logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2) - logTr $ "balanceComments': (anc1)=" ++ showAst (anc1) - logTr $ "balanceComments': (cs1s)=" ++ showAst (cs1s) - logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move) - logTr $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2') - return (la1', la2') - where - simpleBreak n (r,_) = r > n - L (SrcSpanAnn an1 loc1) f = la1 - L (SrcSpanAnn an2 loc2) s = la2 - anc1 = addCommentOrigDeltas $ epAnnComments an1 - anc2 = addCommentOrigDeltas $ epAnnComments an2 - - cs1s = splitCommentsEnd (anchorFromLocatedA la1) anc1 - cs1p = priorCommentsDeltas (anchorFromLocatedA la1) (priorComments cs1s) - cs1f = trailingCommentsDeltas (anchorFromLocatedA la1) (getFollowingComments cs1s) - - cs2s = splitCommentsEnd (anchorFromLocatedA la2) anc2 - cs2p = priorCommentsDeltas (anchorFromLocatedA la2) (priorComments cs2s) - cs2f = trailingCommentsDeltas (anchorFromLocatedA la2) (getFollowingComments cs2s) - - -- Split cs1f into those that belong on an1 and ones that must move to an2 - (cs1move,cs1stay) = break (simpleBreak 1) cs1f - - (stay'',move') = break (simpleBreak 1) cs2p - -- Need to also check for comments more closely attached to la1, - -- ie trailing on the same line - (move'',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchorFromLocatedA la1) (map snd stay'')) - move = sortEpaComments $ map snd (cs1move ++ move'' ++ move') - stay = sortEpaComments $ map snd (cs1stay ++ stay') - - an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced (map snd cs1p) move) - an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced stay (map snd cs2f)) - la1' = L an1' f - la2' = L an2' s - --- | Like commentsDeltas, but calculates the delta from the end of the anchor, not the start -trailingCommentsDeltas :: RealSrcSpan -> [LEpaComment] - -> [(Int, LEpaComment)] -trailingCommentsDeltas _ [] = [] -trailingCommentsDeltas anc (la@(L l _):las) - = deltaComment anc la : trailingCommentsDeltas (anchor l) las - where - deltaComment anc' (L loc c) = (abs(ll - al), L loc c) - where - (al,_) = ss2posEnd anc' - (ll,_) = ss2pos (anchor loc) - --- AZ:TODO: this is identical to commentsDeltas -priorCommentsDeltas :: RealSrcSpan -> [LEpaComment] - -> [(Int, LEpaComment)] -priorCommentsDeltas anc cs = go anc (reverse $ sortEpaComments cs) - where - go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] - go _ [] = [] - go anc' (la@(L l _):las) = deltaComment anc' la : go (anchor l) las - - deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment) - deltaComment anc' (L loc c) = (abs(ll - al), L loc c) - where - (al,_) = ss2pos anc' - (ll,_) = ss2pos (anchor loc) - - --- --------------------------------------------------------------------- - --- | Split comments into ones occuring before the end of the reference --- span, and those after it. -splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsEnd p (EpaComments cs) = cs' - where - cmp (L (Anchor l _) _) = ss2pos l > ss2posEnd p - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> EpaCommentsBalanced before after -splitCommentsEnd p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' - where - cmp (L (Anchor l _) _) = ss2pos l > ss2posEnd p - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - --- | Split comments into ones occuring before the start of the reference --- span, and those after it. -splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsStart p (EpaComments cs) = cs' - where - cmp (L (Anchor l _) _) = ss2pos l > ss2pos p - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> EpaCommentsBalanced before after -splitCommentsStart p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' - where - cmp (L (Anchor l _) _) = ss2pos l > ss2pos p - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - -moveLeadingComments :: (Data t, Data u, Monoid t, Monoid u) - => LocatedAn t a -> SrcAnn u -> (LocatedAn t a, SrcAnn u) -moveLeadingComments from@(L (SrcSpanAnn EpAnnNotUsed _) _) to = (from, to) -moveLeadingComments (L la a) lb = (L la' a, lb') - `debug` ("moveLeadingComments: (before, after, la', lb'):" ++ showAst (before, after, la', lb')) - where - split = splitCommentsEnd (realSrcSpan $ locA la) (epAnnComments $ ann la) - before = sortEpaComments $ priorComments split - after = sortEpaComments $ getFollowingComments split - - -- TODO: need to set an entry delta on lb' to zero, and move the - -- original spacing to the first comment. - - la' = setCommentsSrcAnn la (EpaComments after) - lb' = addCommentsToSrcAnn lb (EpaCommentsBalanced before []) - --- | A GHC comment includes the span of the preceding (non-comment) --- token. Takes an original list of comments, and converts the --- 'Anchor's to have a have a `MovedAnchor` operation based on the --- original locations. -commentOrigDeltas :: [LEpaComment] -> [LEpaComment] -commentOrigDeltas [] = [] -commentOrigDeltas lcs = map commentOrigDelta lcs - -addCommentOrigDeltas :: EpAnnComments -> EpAnnComments -addCommentOrigDeltas (EpaComments cs) = EpaComments (commentOrigDeltas cs) -addCommentOrigDeltas (EpaCommentsBalanced pcs fcs) - = EpaCommentsBalanced (commentOrigDeltas pcs) (commentOrigDeltas fcs) - -addCommentOrigDeltasAnn :: (EpAnn a) -> (EpAnn a) -addCommentOrigDeltasAnn EpAnnNotUsed = EpAnnNotUsed -addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) - --- TODO: this is replicating functionality in ExactPrint. Sort out the --- import loop` -anchorFromLocatedA :: LocatedA a -> RealSrcSpan -anchorFromLocatedA (L (SrcSpanAnn an loc) _) - = case an of - EpAnnNotUsed -> realSrcSpan loc - (EpAnn anc _ _) -> anchor anc - --- | A GHC comment includes the span of the preceding token. Take an --- original comment, and convert the 'Anchor to have a have a --- `MovedAnchor` operation based on the original location, only if it --- does not already have one. -commentOrigDelta :: LEpaComment -> LEpaComment -commentOrigDelta (L (GHC.Anchor la _) (GHC.EpaComment t pp)) - = (L (GHC.Anchor la op) (GHC.EpaComment t pp)) - `debug` ("commentOrigDelta: (la, pp, r,c, op)=" ++ showAst (la, pp, r,c, op)) - where - (r,c) = ss2posEnd pp - - op' = if r == 0 - then MovedAnchor (ss2delta (r,c+1) la) - -- then MovedAnchor (ss2delta (r,c+0) la) - -- else MovedAnchor (ss2delta (r,c) la) - else MovedAnchor (tweakDelta $ ss2delta (r,c) la) - op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0) - then MovedAnchor (DifferentLine 1 0) - else op' - --- --------------------------------------------------------------------- - -balanceSameLineComments :: (Monad m) - => LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs)) -balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do - logTr $ "balanceSameLineComments: (la)=" ++ showGhc (ss2range $ locA la) - logTr $ "balanceSameLineComments: [logInfo]=" ++ showAst logInfo - return (L la' (Match anm mctxt pats (GRHSs x grhss' lb))) - where - simpleBreak n (r,_) = r > n - (la',grhss', logInfo) = case reverse grhss of - [] -> (la,grhss,[]) - (L lg g@(GRHS EpAnnNotUsed _gs _rhs):grs) -> (la,reverse $ (L lg g):grs,[]) - (L lg (GRHS ga gs rhs):grs) -> (la'',reverse $ (L lg (GRHS ga' gs rhs)):grs,[(gac,(csp,csf))]) - where - (SrcSpanAnn an1 _loc1) = la - anc1 = addCommentOrigDeltas $ epAnnComments an1 - (EpAnn anc an _) = ga :: EpAnn GrhsAnn - (csp,csf) = case anc1 of - EpaComments cs -> ([],cs) - EpaCommentsBalanced p f -> (p,f) - (move',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchor anc) csf) - move = map snd move' - stay = map snd stay' - cs1 = EpaCommentsBalanced csp stay - - gac = addCommentOrigDeltas $ epAnnComments ga - gfc = getFollowingComments gac - gac' = setFollowingComments gac (sortEpaComments $ gfc ++ move) - ga' = (EpAnn anc an gac') - - an1' = setCommentsSrcAnn la cs1 - la'' = an1' - --- --------------------------------------------------------------------- - -anchorEof :: ParsedSource -> ParsedSource -anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) - where - an' = addCommentOrigDeltasAnn an - --- --------------------------------------------------------------------- - -commentsOrigDeltasDecl :: LHsDecl GhcPs -> LHsDecl GhcPs -commentsOrigDeltasDecl (L (SrcSpanAnn an l) d) = L (SrcSpanAnn an' l) d - where - an' = addCommentOrigDeltasAnn an - --- --------------------------------------------------------------------- - --- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the --- given @DeltaPos@. -noAnnSrcSpanDP :: (Monoid ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (EpAnn ann) -noAnnSrcSpanDP l dp - = SrcSpanAnn (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty emptyComments) l - -noAnnSrcSpanDP0 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (EpAnn ann) -noAnnSrcSpanDP0 l = noAnnSrcSpanDP l (SameLine 0) - -noAnnSrcSpanDP1 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (EpAnn ann) -noAnnSrcSpanDP1 l = noAnnSrcSpanDP l (SameLine 1) - -noAnnSrcSpanDPn :: (Monoid ann) => SrcSpan -> Int -> SrcSpanAnn' (EpAnn ann) -noAnnSrcSpanDPn l s = noAnnSrcSpanDP l (SameLine s) - -d0 :: EpaLocation -d0 = EpaDelta (SameLine 0) [] - -d1 :: EpaLocation -d1 = EpaDelta (SameLine 1) [] - -dn :: Int -> EpaLocation -dn n = EpaDelta (SameLine n) [] - -m0 :: AnchorOperation -m0 = MovedAnchor $ SameLine 0 - -m1 :: AnchorOperation -m1 = MovedAnchor $ SameLine 1 - -mn :: Int -> AnchorOperation -mn n = MovedAnchor $ SameLine n - -addComma :: SrcSpanAnnA -> SrcSpanAnnA -addComma (SrcSpanAnn EpAnnNotUsed l) - = (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem [AddCommaAnn d0]) emptyComments) l) -addComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) - = (SrcSpanAnn (EpAnn anc (AnnListItem (AddCommaAnn d0:as)) cs) l) - --- --------------------------------------------------------------------- - --- | Insert a declaration into an AST element having sub-declarations --- (@HasDecls@) according to the given location function. -insertAt :: (HasDecls ast) - => (LHsDecl GhcPs - -> [LHsDecl GhcPs] - -> [LHsDecl GhcPs]) - -> ast - -> LHsDecl GhcPs - -> Transform ast -insertAt f t decl = do - oldDecls <- hsDecls t - oldDeclsb <- balanceCommentsList oldDecls - let oldDecls' = map commentsOrigDeltasDecl oldDeclsb - replaceDecls t (f decl oldDecls') - --- |Insert a declaration at the beginning or end of the subdecls of the given --- AST item -insertAtStart, insertAtEnd :: (HasDecls ast) - => ast - -> LHsDecl GhcPs - -> Transform ast - -insertAtStart = insertAt (:) -insertAtEnd = insertAt (\x xs -> xs ++ [x]) - --- |Insert a declaration at a specific location in the subdecls of the given --- AST item -insertAfter, insertBefore :: (HasDecls (LocatedA ast)) - => LocatedA old - -> LocatedA ast - -> LHsDecl GhcPs - -> Transform (LocatedA ast) -insertAfter (getLocA -> k) = insertAt findAfter - where - findAfter x xs = - case span (\(L l _) -> locA l /= k) xs of - ([],[]) -> [x] - (fs,[]) -> fs++[x] - (fs, b:bs) -> fs ++ (b : x : bs) - -- let (fs, b:bs) = span (\(L l _) -> locA l /= k) xs - -- in fs ++ (b : x : bs) -insertBefore (getLocA -> k) = insertAt findBefore - where - findBefore x xs = - let (fs, bs) = span (\(L l _) -> locA l /= k) xs - in fs ++ (x : bs) - --- ===================================================================== --- start of HasDecls instances --- ===================================================================== - --- |Provide a means to get and process the immediate child declartions of a --- given AST element. -class (Data t) => HasDecls t where --- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent - - -- | Return the 'HsDecl's that are directly enclosed in the - -- given syntax phrase. They are always returned in the wrapped 'HsDecl' - -- form, even if orginating in local decls. This is safe, as annotations - -- never attach to the wrapper, only to the wrapped item. - hsDecls :: (Monad m) => t -> TransformT m [LHsDecl GhcPs] - - -- | Replace the directly enclosed decl list by the given - -- decl list. Runs in the 'Transform' monad to be able to update list order - -- annotations, and rebalance comments and other layout changes as needed. - -- - -- For example, a call on replaceDecls for a wrapped 'FunBind' having no - -- where clause will convert - -- - -- @ - -- -- |This is a function - -- foo = x -- comment1 - -- @ - -- in to - -- - -- @ - -- -- |This is a function - -- foo = x -- comment1 - -- where - -- nn = 2 - -- @ - replaceDecls :: (Monad m) => t -> [LHsDecl GhcPs] -> TransformT m t - --- --------------------------------------------------------------------- - -instance HasDecls ParsedSource where - hsDecls (L _ (HsModule (XModulePs _ _lo _ _) _mn _exps _imps decls)) = return decls - replaceDecls (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps _decls)) decls - = do - logTr "replaceDecls LHsModule" - -- modifyAnnsT (captureOrder m decls) - return (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps decls)) - --- --------------------------------------------------------------------- - -instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where - hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = hsDeclsValBinds lb - - replaceDecls (L l (Match xm c p (GRHSs xr rhs binds))) [] - = do - logTr "replaceDecls LMatch empty decls" - binds'' <- replaceDeclsValbinds WithoutWhere binds [] - return (L l (Match xm c p (GRHSs xr rhs binds''))) - - replaceDecls m@(L l (Match xm c p (GRHSs xr rhs binds))) newBinds - = do - logTr "replaceDecls LMatch nonempty decls" - -- Need to throw in a fresh where clause if the binds were empty, - -- in the annotations. - (l', rhs') <- case binds of - EmptyLocalBinds{} -> do - logTr $ "replaceDecls LMatch empty binds" - - logDataWithAnnsTr "Match.replaceDecls:balancing comments:m" m - L l' m' <- balanceSameLineComments m - logDataWithAnnsTr "Match.replaceDecls:(m1')" (L l' m') - return (l', grhssGRHSs $ m_grhss m') - _ -> return (l, rhs) - binds'' <- replaceDeclsValbinds WithWhere binds newBinds - logDataWithAnnsTr "Match.replaceDecls:binds'" binds'' - return (L l' (Match xm c p (GRHSs xr rhs' binds''))) - --- --------------------------------------------------------------------- - -instance HasDecls (LocatedA (HsExpr GhcPs)) where - hsDecls (L _ (HsLet _ _ decls _ _ex)) = hsDeclsValBinds decls - hsDecls _ = return [] - - replaceDecls (L ll (HsLet x tkLet binds tkIn ex)) newDecls - = do - logTr "replaceDecls HsLet" - let lastAnc = realSrcSpan $ spanHsLocaLBinds binds - -- TODO: may be an intervening comment, take account for lastAnc - let (tkLet', tkIn', ex',newDecls') = case (tkLet, tkIn) of - (L (TokenLoc l) ls, L (TokenLoc i) is) -> - let - off = case l of - (EpaSpan r _) -> LayoutStartCol $ snd $ ss2pos r - (EpaDelta (SameLine _) _) -> LayoutStartCol 0 - (EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c - ex'' = setEntryDPFromAnchor off i ex - newDecls'' = case newDecls of - [] -> newDecls - (d:ds) -> setEntryDPDecl d (SameLine 0) : ds - -- in ( EpAnn a (AnnsLet l (addEpaLocationDelta off lastAnc i)) cs - in ( L (TokenLoc l) ls - , L (TokenLoc (addEpaLocationDelta off lastAnc i)) is - , ex'' - , newDecls'') - (_,_) -> (tkLet, tkIn, ex, newDecls) - binds' <- replaceDeclsValbinds WithoutWhere binds newDecls' - return (L ll (HsLet x tkLet' binds' tkIn' ex')) - - -- TODO: does this make sense? Especially as no hsDecls for HsPar - replaceDecls (L l (HsPar x lpar e rpar)) newDecls - = do - logTr "replaceDecls HsPar" - e' <- replaceDecls e newDecls - return (L l (HsPar x lpar e' rpar)) - replaceDecls old _new = error $ "replaceDecls (LHsExpr GhcPs) undefined for:" ++ showGhc old - --- --------------------------------------------------------------------- - --- | Extract the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This --- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent --- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is --- idempotent. -hsDeclsPatBindD :: (Monad m) => LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs] -hsDeclsPatBindD (L l (ValD _ d)) = hsDeclsPatBind (L l d) -hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x - --- | Extract the immediate declarations for a 'PatBind'. This --- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent --- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is --- idempotent. -hsDeclsPatBind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs] -hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb))) = hsDeclsValBinds lb -hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x - --- ------------------------------------- - --- | Replace the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This --- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent --- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is --- idempotent. -replaceDeclsPatBindD :: (Monad m) => LHsDecl GhcPs -> [LHsDecl GhcPs] - -> TransformT m (LHsDecl GhcPs) -replaceDeclsPatBindD (L l (ValD x d)) newDecls = do - (L _ d') <- replaceDeclsPatBind (L l d) newDecls - return (L l (ValD x d')) -replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x - --- | Replace the immediate declarations for a 'PatBind'. This --- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent --- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is --- idempotent. -replaceDeclsPatBind :: (Monad m) => LHsBind GhcPs -> [LHsDecl GhcPs] - -> TransformT m (LHsBind GhcPs) -replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds))) newDecls - = do - logTr "replaceDecls PatBind" - binds'' <- replaceDeclsValbinds WithWhere binds newDecls - return (L l (PatBind x a (GRHSs xr rhss binds''))) -replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x - --- --------------------------------------------------------------------- - -instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where - hsDecls (L _ (LetStmt _ lb)) = hsDeclsValBinds lb - hsDecls (L _ (LastStmt _ e _ _)) = hsDecls e - hsDecls (L _ (BindStmt _ _pat e)) = hsDecls e - hsDecls (L _ (BodyStmt _ e _ _)) = hsDecls e - hsDecls _ = return [] - - replaceDecls (L l (LetStmt x lb)) newDecls - = do - lb'' <- replaceDeclsValbinds WithWhere lb newDecls - return (L l (LetStmt x lb'')) - replaceDecls (L l (LastStmt x e d se)) newDecls - = do - e' <- replaceDecls e newDecls - return (L l (LastStmt x e' d se)) - replaceDecls (L l (BindStmt x pat e)) newDecls - = do - e' <- replaceDecls e newDecls - return (L l (BindStmt x pat e')) - - replaceDecls (L l (BodyStmt x e a b)) newDecls - = do - e' <- replaceDecls e newDecls - return (L l (BodyStmt x e' a b)) - replaceDecls x _newDecls = return x - --- ===================================================================== --- end of HasDecls instances --- ===================================================================== - --- --------------------------------------------------------------------- - --- |Look up the annotated order and sort the decls accordingly --- TODO:AZ: this should be pure -orderedDecls :: (Monad m) - => AnnSortKey -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] -orderedDecls sortKey decls = do - case sortKey of - NoAnnSortKey -> do - -- return decls - return $ sortBy (\a b -> compare (realSrcSpan $ getLocA a) (realSrcSpan $ getLocA b)) decls - AnnSortKey keys -> do - let ds = map (\s -> (rs $ getLocA s,s)) decls - ordered = map snd $ orderByKey ds keys - return ordered - --- --------------------------------------------------------------------- - -hsDeclsValBinds :: (Monad m) => HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs] -hsDeclsValBinds lb = case lb of - HsValBinds _ (ValBinds sortKey bs sigs) -> do - let - bds = map wrapDecl (bagToList bs) - sds = map wrapSig sigs - orderedDecls sortKey (bds ++ sds) - HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid" - HsIPBinds {} -> return [] - EmptyLocalBinds {} -> return [] - -data WithWhere = WithWhere - | WithoutWhere - deriving (Eq,Show) - --- | Utility function for returning decls to 'HsLocalBinds'. Use with --- care, as this does not manage the declaration order, the --- ordering should be done by the calling function from the 'HsLocalBinds' --- context in the AST. -replaceDeclsValbinds :: (Monad m) - => WithWhere - -> HsLocalBinds GhcPs -> [LHsDecl GhcPs] - -> TransformT m (HsLocalBinds GhcPs) -replaceDeclsValbinds _ _ [] = do - return (EmptyLocalBinds NoExtField) -replaceDeclsValbinds w b@(HsValBinds a _) new - = do - logTr "replaceDeclsValbinds" - let oldSpan = spanHsLocaLBinds b - an <- oldWhereAnnotation a w (realSrcSpan oldSpan) - let decs = listToBag $ concatMap decl2Bind new - let sigs = concatMap decl2Sig new - let sortKey = captureOrder new - return (HsValBinds an (ValBinds sortKey decs sigs)) -replaceDeclsValbinds _ (HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds" -replaceDeclsValbinds w (EmptyLocalBinds _) new - = do - logTr "replaceDecls HsLocalBinds" - an <- newWhereAnnotation w - let newBinds = concatMap decl2Bind new - newSigs = concatMap decl2Sig new - let decs = listToBag $ newBinds - let sigs = newSigs - let sortKey = captureOrder new - return (HsValBinds an (ValBinds sortKey decs sigs)) - -oldWhereAnnotation :: (Monad m) - => EpAnn AnnList -> WithWhere -> RealSrcSpan -> TransformT m (EpAnn AnnList) -oldWhereAnnotation EpAnnNotUsed ww _oldSpan = do - newSpan <- uniqueSrcSpanT - let w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] - WithoutWhere -> [] - let anc2' = Anchor (rs newSpan) (MovedAnchor (SameLine 1)) - (anc, anc2) <- do - newSpan' <- uniqueSrcSpanT - return ( Anchor (rs newSpan') (MovedAnchor (DifferentLine 1 2)) - , anc2') - let an = EpAnn anc - (AnnList (Just anc2) Nothing Nothing w []) - emptyComments - return an -oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = do - -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation, change the AnnList anchor to have the correct DP too - let (AnnList ancl o c _r t) = an - let w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] - WithoutWhere -> [] - (anc', ancl') <- do - case ww of - WithWhere -> return (anc, ancl) - WithoutWhere -> return (anc, ancl) - let an' = EpAnn anc' - (AnnList ancl' o c w t) - cs - return an' - -newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn AnnList) -newWhereAnnotation ww = do - newSpan <- uniqueSrcSpanT - let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2)) - let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4)) - let w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] - WithoutWhere -> [] - let an = EpAnn anc - (AnnList (Just anc2) Nothing Nothing w []) - emptyComments - return an - --- --------------------------------------------------------------------- - -type Decl = LHsDecl GhcPs -type PMatch = LMatch GhcPs (LHsExpr GhcPs) - --- |Modify a 'LHsBind' wrapped in a 'ValD'. For a 'PatBind' the --- declarations are extracted and returned after modification. For a --- 'FunBind' the supplied 'SrcSpan' is used to identify the specific --- 'Match' to be transformed, for when there are multiple of them. -modifyValD :: forall m t. (HasTransform m) - => SrcSpan - -> Decl - -> (PMatch -> [Decl] -> m ([Decl], Maybe t)) - -> m (Decl,Maybe t) -modifyValD p pb@(L ss (ValD _ (PatBind {} ))) f = - if (locA ss) == p - then do - ds <- liftT $ hsDeclsPatBindD pb - (ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds - pb' <- liftT $ replaceDeclsPatBindD pb ds' - return (pb',r) - else return (pb,Nothing) -modifyValD p ast f = do - (ast',r) <- runStateT (everywhereM (mkM doModLocal) ast) Nothing - return (ast',r) - where - doModLocal :: PMatch -> StateT (Maybe t) m PMatch - doModLocal (match@(L ss _) :: PMatch) = do - if (locA ss) == p - then do - ds <- lift $ liftT $ hsDecls match - (ds',r) <- lift $ f match ds - put r - match' <- lift $ liftT $ replaceDecls match ds' - return match' - else return match - --- --------------------------------------------------------------------- - --- |Used to integrate a @Transform@ into other Monad stacks -class (Monad m) => (HasTransform m) where - liftT :: Transform a -> m a - -instance Monad m => HasTransform (TransformT m) where - liftT = hoistTransform (return . runIdentity) - --- --------------------------------------------------------------------- - --- | Apply a transformation to the decls contained in @t@ -modifyDeclsT :: (HasDecls t,HasTransform m) - => ([LHsDecl GhcPs] -> m [LHsDecl GhcPs]) - -> t -> m t -modifyDeclsT action t = do - decls <- liftT $ hsDecls t - decls' <- action decls - liftT $ replaceDecls t decls' +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.GHC.ExactPrint.Transform +-- +-- This module is currently under heavy development, and no promises are made +-- about API stability. Use with care. +-- +-- We welcome any feedback / contributions on this, as it is the main point of +-- the library. +-- +----------------------------------------------------------------------------- +module Language.Haskell.GHC.ExactPrint.Transform + ( + -- * The Transform Monad + Transform + , TransformT(..) + , hoistTransform + , runTransform + , runTransformT + , runTransformFrom + , runTransformFromT + + -- * Transform monad operations + , logTr + , logDataWithAnnsTr + , uniqueSrcSpanT + + -- ** Managing declarations, in Transform monad + , HasTransform (..) + , HasDecls (..) + , hsDeclsPatBind, hsDeclsPatBindD + , replaceDeclsPatBind, replaceDeclsPatBindD + , modifyDeclsT + , modifyValD + -- *** Utility, does not manage layout + , hsDeclsValBinds, replaceDeclsValbinds + , WithWhere(..) + + -- ** New gen functions + , noAnnSrcSpanDP + , noAnnSrcSpanDP0 + , noAnnSrcSpanDP1 + , noAnnSrcSpanDPn + , d0, d1, dn + , addComma + + -- ** Managing lists, Transform monad + , insertAt + , insertAtStart + , insertAtEnd + , insertAfter + , insertBefore + + -- *** Low level operations used in 'HasDecls' + , balanceComments + , balanceCommentsList + , balanceCommentsListA + , anchorEof + + -- ** Managing lists, pure functions + , captureOrderBinds + , captureLineSpacing + , captureMatchLineSpacing + , captureTypeSigSpacing + + -- * Operations + , isUniqueSrcSpan + + -- * Pure functions + , setEntryDP, setEntryDPDecl + , getEntryDP + , transferEntryDP + , transferEntryDP' + , wrapSig, wrapDecl + , decl2Sig, decl2Bind + ) where + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils + +import Control.Monad.RWS +import qualified Control.Monad.Fail as Fail + +import GHC hiding (parseModule, parsedSource) +import GHC.Data.FastString +import GHC.Types.SrcLoc + +import Data.Data +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import Data.Generics + +import Data.Functor.Identity +import Control.Monad.State + +------------------------------------------------------------------------------ +-- Transformation of source elements + +-- | Monad type for updating the AST and managing the annotations at the same +-- time. The W state is used to generate logging information if required. +type Transform = TransformT Identity + +-- |Monad transformer version of 'Transform' monad +newtype TransformT m a = TransformT { unTransformT :: RWST () [String] Int m a } + deriving (Monad,Applicative,Functor + ,MonadReader () + ,MonadWriter [String] + ,MonadState Int + ,MonadTrans + ) + +instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where + fail msg = TransformT $ RWST $ \_ _ -> Fail.fail msg + +-- | Run a transformation in the 'Transform' monad, returning the updated +-- annotations and any logging generated via 'logTr' +runTransform :: Transform a -> (a,Int,[String]) +runTransform f = runTransformFrom 0 f + +runTransformT :: TransformT m a -> m (a,Int,[String]) +runTransformT f = runTransformFromT 0 f + +-- | Run a transformation in the 'Transform' monad, returning the updated +-- annotations and any logging generated via 'logTr', allocating any new +-- SrcSpans from the provided initial value. +runTransformFrom :: Int -> Transform a -> (a,Int,[String]) +runTransformFrom seed f = runRWS (unTransformT f) () seed + +-- |Run a monad transformer stack for the 'TransformT' monad transformer +runTransformFromT :: Int -> TransformT m a -> m (a,Int,[String]) +runTransformFromT seed f = runRWST (unTransformT f) () seed + +-- | Change inner monad of 'TransformT'. +hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a +hoistTransform nt (TransformT m) = TransformT (mapRWST nt m) + +-- |Log a string to the output of the Monad +logTr :: (Monad m) => String -> TransformT m () +logTr str = tell [str] + +-- |Log a representation of the given AST with annotations to the output of the +-- Monad +logDataWithAnnsTr :: (Monad m) => (Data a) => String -> a -> TransformT m () +logDataWithAnnsTr str ast = do + logTr $ str ++ showAst ast + +-- --------------------------------------------------------------------- + +-- |If we need to add new elements to the AST, they need their own +-- 'SrcSpan' for this. +-- This should no longer be needed, we use an @EpaDelta@ location instead. +uniqueSrcSpanT :: (Monad m) => TransformT m SrcSpan +uniqueSrcSpanT = do + col <- get + put (col + 1 ) + let pos = mkSrcLoc (mkFastString "ghc-exactprint") (-1) col + return $ mkSrcSpan pos pos + +-- |Test whether a given 'SrcSpan' was generated by 'uniqueSrcSpanT' +isUniqueSrcSpan :: SrcSpan -> Bool +isUniqueSrcSpan ss = srcSpanStartLine' ss == -1 + +srcSpanStartLine' :: SrcSpan -> Int +srcSpanStartLine' (RealSrcSpan s _) = srcSpanStartLine s +srcSpanStartLine' _ = 0 + +-- --------------------------------------------------------------------- + +captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs +captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ))))) + = L l (ValD x (FunBind a b (MG c (L d ms')))) + where + ms' :: [LMatch GhcPs (LHsExpr GhcPs)] + ms' = captureLineSpacing ms +captureMatchLineSpacing d = d + +captureLineSpacing :: [LocatedA e] -> [LocatedA e] +captureLineSpacing [] = [] +captureLineSpacing [d] = [d] +captureLineSpacing ds = map (\(_,_,x) -> x) $ go (map to ds) + where + to :: LocatedA e -> (Int, Int, LocatedA e) + to d = (fst $ ss2pos rss, fst $ ss2posEnd rss,d) + where + rss = rs $ getHasLoc d + + go :: [(Int, Int, LocatedA e)] -> [(Int, Int, LocatedA e)] + go [] = [] + go [d] = [d] + go ((ls1,le1,de1):(ls2,le2,d2):ds0) = (ls1,le1,de1):go ((ls2,le2,d2'):ds0) + `debug` ("captureLineSpacing: (le1,ls2,getLoc d2,getLoc d2')=" ++ showAst (le1,ls2,getLoc d2,getLoc d2')) + where + d2' = setEntryDP d2 (deltaPos (ls2-le1) 0) + +-- --------------------------------------------------------------------- + +captureTypeSigSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs +captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig NoEpUniTok mp md) ns (HsWC xw ty)))) + = (L l (SigD x (TypeSig (AnnSig NoEpUniTok mp md) ns (HsWC xw ty)))) +captureTypeSigSpacing (L l (SigD x (TypeSig (AnnSig (EpUniTok dca u) mp md) ns (HsWC xw ty)))) + = (L l (SigD x (TypeSig (AnnSig (EpUniTok dca' u) mp md) ns (HsWC xw ty')))) + where + -- we want DPs for the distance from the end of the ns to the + -- AnnDColon, and to the start of the ty + rd = case last ns of + L (EpAnn anc' _ _) _ -> epaLocationRealSrcSpan anc' + dca' = case dca of + EpaSpan ss@(RealSrcSpan r _) -> (EpaDelta ss (ss2delta (ss2posEnd rd) r) []) + _ -> dca + + -- --------------------------------- + + ty' :: LHsSigType GhcPs + ty' = case ty of + (L (EpAnn anc0 a c) b) + -> let + anc' = case anc0 of + EpaDelta _ _ _ -> anc0 + _ -> case dca of + EpaSpan ss -> EpaDelta ss (SameLine 1) [] + EpaDelta ss _ cs0 -> EpaDelta ss (SameLine 1) cs0 + in (L (EpAnn anc' a c) b) + +captureTypeSigSpacing s = s + +-- --------------------------------------------------------------------- + +setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs +setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms ))))) dp + = L l' (ValD x (FunBind a b (MG c (L d ms')))) + where + L l' _ = setEntryDP decl dp + ms' :: [LMatch GhcPs (LHsExpr GhcPs)] + ms' = case ms of + [] -> [] + (m0':ms0) -> setEntryDP m0' dp : ms0 +setEntryDPDecl d dp = setEntryDP d dp + +-- --------------------------------------------------------------------- + +-- |Set the true entry 'DeltaPos' from the annotation for a given AST +-- element. This is the 'DeltaPos' ignoring any comments. +setEntryDP :: LocatedAn t a -> DeltaPos -> LocatedAn t a +setEntryDP (L (EpAnn (EpaSpan ss@(UnhelpfulSpan _)) an cs) a) dp + = L (EpAnn (EpaDelta ss dp []) an cs) a +setEntryDP (L (EpAnn (EpaSpan ss) an (EpaComments [])) a) dp + = L (EpAnn (EpaDelta ss dp []) an (EpaComments [])) a +setEntryDP (L (EpAnn (EpaDelta ss d csd) an cs) a) dp + = L (EpAnn (EpaDelta ss d' csd') an cs') a + where + -- I suspect we should assume the comments are already in the + -- right place, and just set the entry DP for this case. This + -- avoids surprises from the caller. + (d', csd', cs') = case cs of + EpaComments (h:t) -> + let + (dp0,c') = go h + in + (dp0, csd, EpaComments (c':t)) + EpaComments [] -> + (dp, csd, cs) + EpaCommentsBalanced (h:t) ts -> + let + (dp0,c') = go h + in + (dp0, c':t++csd, EpaCommentsBalanced [] ts) + EpaCommentsBalanced [] ts -> + case csd of + [] -> (d, csd, EpaCommentsBalanced [] ts) + (h:t) -> + let + (dp0,c') = go h + in + (dp0, c':t, EpaCommentsBalanced [] ts) + go :: GenLocated NoCommentsLocation e -> (DeltaPos, GenLocated NoCommentsLocation e) + go (L (EpaDelta ss0 _ c0) c) = (d, L (EpaDelta ss0 dp c0) c) + go (L (EpaSpan ss0) c) = (d, L (EpaDelta ss0 dp NoComments) c) +setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp + = case sortEpaComments (priorComments cs) of + [] -> + L (EpAnn (EpaDelta ss dp []) an cs) a + (L ca c:cs') -> + L (EpAnn (EpaDelta ss edp csd) an cs'') a + where + cs'' = setPriorComments cs [] + csd = L (EpaDelta ss dp NoComments) c:commentOrigDeltas cs' + lc = last $ (L ca c:cs') + delta = case getLoc lc of + EpaSpan (RealSrcSpan rr _) -> ss2delta (ss2pos rr) r + EpaSpan _ -> (SameLine 0) + EpaDelta _ _dp _ -> DifferentLine 1 0 + line = getDeltaLine delta + col = deltaColumn delta + edp' = if line == 0 then SameLine col + else DifferentLine line (col - 1) + -- At the top level the layout offset is 1, adjust for it + -- TODO: what about the layout offset for nested items? + edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ epaLocationRealSrcSpan $ getLoc lc), r)) + + +-- --------------------------------------------------------------------- + +getEntryDP :: LocatedAn t a -> DeltaPos +getEntryDP (L (EpAnn (EpaDelta _ dp _) _ _) _) = dp +getEntryDP _ = SameLine 1 + +-- --------------------------------------------------------------------- + +addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation +addEpaLocationDelta _off _anc (EpaDelta ss d cs) = EpaDelta ss d cs +addEpaLocationDelta _off _anc (EpaSpan ss@(UnhelpfulSpan _)) = EpaDelta ss (SameLine 0) [] +addEpaLocationDelta off anc (EpaSpan ss@(RealSrcSpan r _)) + = EpaDelta ss (adjustDeltaForOffset off (ss2deltaEnd anc r)) [] + +-- Set the entry DP for an element coming after an existing keyword annotation +setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t +setEntryDPFromAnchor _off (EpaDelta _ _ _) (L la a) = L la a +setEntryDPFromAnchor _off (EpaSpan (UnhelpfulSpan _)) (L la a) = L la a +setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP ll dp' + where + dp' = case la of + (EpAnn (EpaSpan (RealSrcSpan r' _)) _ _) -> adjustDeltaForOffset off (ss2deltaEnd anc r') + (EpAnn (EpaSpan _) _ _) -> adjustDeltaForOffset off (SameLine 0) + (EpAnn (EpaDelta _ dp _) _ _) -> adjustDeltaForOffset off dp + +-- --------------------------------------------------------------------- + +-- |Take the annEntryDelta associated with the first item and +-- associate it with the second. Also transfer any comments occurring +-- before it. +transferEntryDP :: (Typeable t1, Typeable t2) + => LocatedAn t1 a -> LocatedAn t2 b -> (LocatedAn t2 b) +transferEntryDP (L (EpAnn anc1 an1 cs1) _) (L (EpAnn anc2 an2 cs2) b) = + -- Note: the EpaDelta version of an EpaLocation contains the original + -- SrcSpan. We must preserve that. + let anc1' = case (anc1,anc2) of + (EpaDelta _ dp cs, EpaDelta ss2 _ _) -> EpaDelta ss2 dp cs + (_, _) -> anc1 + -- Problem: if the original had preceding comments, blindly + -- transferring the location is not correct + in case priorComments cs1 of + [] -> (L (EpAnn anc1' (combine an1 an2) cs2) b) + -- TODO: what happens if the receiving side already has comments? + (L _ _:_) -> (L (EpAnn anc1' (combine an1 an2) (cs1 <> cs2)) b) + + +-- |If a and b are the same type return first arg, else return second +combine :: (Typeable a, Typeable b) => a -> b -> b +combine x y = fromMaybe y (cast x) + +-- |Take the annEntryDelta associated with the first item and associate it with the second. +-- Also transfer any comments occurring before it. +-- TODO: call transferEntryDP, and use pushDeclDP +transferEntryDP' :: LHsDecl GhcPs -> LHsDecl GhcPs -> (LHsDecl GhcPs) +transferEntryDP' la lb = + let + (L l2 b) = transferEntryDP la lb + in (L l2 (pushDeclDP b (SameLine 0))) + + +pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs +pushDeclDP (ValD x (FunBind a b (MG c (L d ms )))) dp + = ValD x (FunBind a b (MG c (L d' ms'))) + where + L d' _ = setEntryDP (L d ms) dp + ms' :: [LMatch GhcPs (LHsExpr GhcPs)] + ms' = case ms of + [] -> [] + (m0':ms0) -> setEntryDP m0' dp : ms0 +pushDeclDP d _dp = d + +-- --------------------------------------------------------------------- + +-- | If we compile in haddock mode, the haddock processing inserts +-- DocDecls to carry the Haddock Documentation. We ignore these in +-- exact printing, as all the comments are also available in their +-- normal location, and the haddock processing is lossy, in that it +-- does not preserve all haddock-like comments. When we balance +-- comments in a list, we migrate some to preceding or following +-- declarations in the list. We must make sure we do not move any to +-- these DocDecls, which are not printed. +balanceCommentsList :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] +balanceCommentsList decls = balanceCommentsList' (filter notDocDecl decls) + +balanceCommentsList' :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] +balanceCommentsList' [] = [] +balanceCommentsList' [x] = [x] +balanceCommentsList' (a:b:ls) = (a':r) + where + (a',b') = balanceComments a b + r = balanceCommentsList' (b':ls) + +-- |The GHC parser puts all comments appearing between the end of one AST +-- item and the beginning of the next as 'annPriorComments' for the second one. +-- This function takes two adjacent AST items and moves any 'annPriorComments' +-- from the second one to the 'annFollowingComments' of the first if they belong +-- to it instead. This is typically required before deleting or duplicating +-- either of the AST elements. +balanceComments :: LHsDecl GhcPs -> LHsDecl GhcPs + -> (LHsDecl GhcPs, LHsDecl GhcPs) +balanceComments first second = + case first of + (L l (ValD x fb@(FunBind{}))) -> + let + (L l' fb',second') = balanceCommentsFB (L l fb) second + in (L l' (ValD x fb'), second') + _ -> balanceCommentsA first second + +-- |Once 'balanceCommentsA has been called to move trailing comments to a +-- 'FunBind', these need to be pushed down from the top level to the last +-- 'Match' if that 'Match' needs to be manipulated. +balanceCommentsFB :: LHsBind GhcPs -> LocatedA b -> (LHsBind GhcPs, LocatedA b) +balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second + = balanceCommentsA (packFunBind bind) second' + -- There are comments on lf. We need to + -- + Keep the prior ones here + -- + move the interior ones to the first match, + -- + move the trailing ones to the last match. + where + (before,middle,after) = case entry lf of + EpaSpan (RealSrcSpan ss _) -> + let + split = splitCommentsEnd ss (comments lf) + split2 = splitCommentsStart ss (EpaComments (sortEpaComments $ priorComments split)) + + before0 = sortEpaComments $ priorComments split2 + middle0 = sortEpaComments $ getFollowingComments split2 + after0 = sortEpaComments $ getFollowingComments split + in (before0,middle0,after0) + _ -> (priorComments $ comments lf, + [], + getFollowingComments $ comments lf) + + lf' = setCommentsEpAnn lf (EpaComments before) + matches' :: [LocatedA (Match GhcPs (LHsExpr GhcPs))] + matches' = case matches of + (L lm' m0:ms') -> + (L (addCommentsToEpAnn lm' (EpaComments middle )) m0:ms') + _ -> error "balanceCommentsFB" + matches'' = balanceCommentsListA matches' + (m,ms) = case reverse matches'' of + (L lm' m0:ms') -> + (L (addCommentsToEpAnn lm' (EpaCommentsBalanced [] after)) m0,ms') + _ -> error "balanceCommentsFB4" + (m',second') = balanceCommentsA m second + m'' = balanceCommentsMatch m' + (m''',lf'') = case ms of + [] -> moveLeadingComments m'' lf' + _ -> (m'',lf') + bind = L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms))))) +balanceCommentsFB f s = balanceCommentsA f s + +-- | Move comments on the same line as the end of the match into the +-- GRHS, prior to the binds +balanceCommentsMatch :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) +balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) + = (L l'' (Match am mctxt pats (GRHSs xg grhss' binds'))) + where + simpleBreak (r,_) = r /= 0 + an1 = l + anc1 = comments an1 + cs1f = getFollowingComments anc1 + (move',stay') = break simpleBreak (trailingCommentsDeltas (anchorFromLocatedA (L l ())) cs1f) + move = map snd move' + stay = map snd stay' + (l'', grhss', binds', _logInfo) + = case NE.reverse grhss of + L lg (GRHS ag grs rhs):|gs -> + let + anc1' = setFollowingComments anc1 stay + an1' = setCommentsEpAnn l anc1' + + -- --------------------------------- + (moved,bindsm) = pushTrailingComments WithWhere (EpaCommentsBalanced [] move) binds + -- --------------------------------- + + (EpAnn anc an lgc) = ag + lgc' = splitCommentsEnd (realSrcSpan $ locA lg) lgc + ag' = if moved + then EpAnn anc an lgc' + else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move)) + + in (an1', (NE.reverse $ L lg (GRHS ag' grs rhs):|gs), bindsm, (anc1',an1')) + +pushTrailingComments :: WithWhere -> EpAnnComments -> HsLocalBinds GhcPs -> (Bool, HsLocalBinds GhcPs) +pushTrailingComments _ _cs b@EmptyLocalBinds{} = (False, b) +pushTrailingComments _ _cs (HsIPBinds _ _) = error "TODO: pushTrailingComments:HsIPBinds" +pushTrailingComments w cs lb@(HsValBinds an _) = (True, HsValBinds an' vb) + where + decls = hsDeclsLocalBinds lb + (an', decls') = case reverse decls of + [] -> (addCommentsToEpAnn an cs, decls) + (L la d:ds) -> (an, L (addCommentsToEpAnn la cs) d:ds) + vb = case replaceDeclsValbinds w lb (reverse decls') of + (HsValBinds _ vb') -> vb' + _ -> ValBinds NoAnnSortKey [] [] + + +balanceCommentsListA :: [LocatedA a] -> [LocatedA a] +balanceCommentsListA [] = [] +balanceCommentsListA [x] = [x] +balanceCommentsListA (a:b:ls) = (a':r) + where + (a',b') = balanceCommentsA a b + r = balanceCommentsListA (b':ls) + +-- |Prior to moving an AST element, make sure any trailing comments belonging to +-- it are attached to it, and not the following element. Of necessity this is a +-- heuristic process, to be tuned later. Possibly a variant should be provided +-- with a passed-in decision function. +-- The initial situation is that all comments for a given anchor appear as prior comments +-- Many of these should in fact be following comments for the previous anchor +balanceCommentsA :: LocatedA a -> LocatedA b -> (LocatedA a, LocatedA b) +balanceCommentsA la1 la2 = (la1', la2') + where + simpleBreak n (r,_) = r > n + L an1 f = la1 + L an2 s = la2 + anc1 = comments an1 + anc2 = comments an2 + + (p1,m1,f1) = splitComments (anchorFromLocatedA la1) anc1 + cs1p = priorCommentsDeltas (anchorFromLocatedA la1) p1 + + -- Split cs1 following comments into those before any + -- TrailingAnn's on an1, and any after + cs1f = splitCommentsEnd (fullSpanFromLocatedA la1) $ EpaComments f1 + cs1fp = priorCommentsDeltas (anchorFromLocatedA la1) (priorComments cs1f) + cs1ff = trailingCommentsDeltas (anchorFromLocatedA la1) (getFollowingComments cs1f) + + -- Split cs1ff into those that belong on an1 and ones that must move to an2 + (cs1move,cs1stay) = break (simpleBreak 1) cs1ff + + (p2,m2,f2) = splitComments (anchorFromLocatedA la2) anc2 + cs2p = priorCommentsDeltas (anchorFromLocatedA la2) p2 + cs2f = trailingCommentsDeltas (anchorFromLocatedA la2) f2 + + (stay'',move') = break (simpleBreak 1) cs2p + -- Need to also check for comments more closely attached to la1, + -- ie trailing on the same line + (move'',stay') = break (simpleBreak 0) (trailingCommentsDeltas (anchorFromLocatedA la1) (map snd stay'')) + move = sortEpaComments $ map snd (cs1fp ++ cs1move ++ move'' ++ move') + stay = sortEpaComments $ m2 ++ map snd (cs1stay ++ stay') + + an1' = setCommentsEpAnn (getLoc la1) (epaCommentsBalanced (m1 ++ map snd cs1p) move) + an2' = setCommentsEpAnn (getLoc la2) (epaCommentsBalanced stay (map snd cs2f)) + la1' = L an1' f + la2' = L an2' s + +-- | Like commentsDeltas, but calculates the delta from the end of the anchor, not the start +trailingCommentsDeltas :: RealSrcSpan -> [LEpaComment] + -> [(Int, LEpaComment)] +trailingCommentsDeltas _ [] = [] +trailingCommentsDeltas r (la@(L (EpaDelta _ dp _) _):las) + = (getDeltaLine dp, la): trailingCommentsDeltas r las +trailingCommentsDeltas r (la@(L l _):las) + = deltaComment r la : trailingCommentsDeltas (epaLocationRealSrcSpan l) las + where + deltaComment rs' (L loc c) = (abs(ll - al), L loc c) + where + (al,_) = ss2posEnd rs' + (ll,_) = ss2pos (epaLocationRealSrcSpan loc) + +priorCommentsDeltas :: RealSrcSpan -> [LEpaComment] + -> [(Int, LEpaComment)] +priorCommentsDeltas r cs = go r (sortEpaComments cs) + where + go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] + go _ [] = [] + go _ (la@(L l@(EpaDelta _ dp _) _):las) = (getDeltaLine dp, la) : go (epaLocationRealSrcSpan l) las + go rs' (la@(L l _):las) = deltaComment rs' la : go (epaLocationRealSrcSpan l) las + + deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment) + deltaComment rs' (L loc c) = (abs(ll - al), L loc c) + where + (al,_) = ss2pos rs' + (ll,_) = ss2pos (epaLocationRealSrcSpan loc) + + +-- --------------------------------------------------------------------- + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) +splitComments p cs = (before, middle, after) + where + cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmpe (L _ _) = True + + cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p + cmpb (L _ _) = True + + (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) + (before, middle) = break cmpb beforeEnd + + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsEnd p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | Split comments into ones occurring before the start of the reference +-- span, and those after it. +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsStart p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u) + => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u) +moveLeadingComments (L la a) lb = (L la' a, lb') + `debug` ("moveLeadingComments: (before, after, la', lb'):" ++ showAst (before, after, la', lb')) + where + split = splitCommentsEnd (realSrcSpan $ locA la) (comments la) + before = sortEpaComments $ priorComments split + after = sortEpaComments $ getFollowingComments split + + -- TODO: need to set an entry delta on lb' to zero, and move the + -- original spacing to the first comment. + + la' = setCommentsEpAnn la (epaCommentsBalanced [] after) + lb' = addCommentsToEpAnn lb (epaCommentsBalanced before []) + +-- | A GHC comment includes the span of the preceding (non-comment) +-- token. Takes an original list of comments, and converts the +-- 'Anchor's to have a have a `MovedAnchor` operation based on the +-- original locations. +commentOrigDeltas :: [LEpaComment] -> [LEpaComment] +commentOrigDeltas [] = [] +commentOrigDeltas lcs = map commentOrigDelta lcs + +addCommentOrigDeltas :: EpAnnComments -> EpAnnComments +addCommentOrigDeltas (EpaComments cs) = EpaComments (commentOrigDeltas cs) +addCommentOrigDeltas (EpaCommentsBalanced pcs fcs) + = EpaCommentsBalanced (commentOrigDeltas pcs) (commentOrigDeltas fcs) + +addCommentOrigDeltasAnn :: (EpAnn a) -> (EpAnn a) +addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) + +-- TODO: this is replicating functionality in ExactPrint. Sort out the +-- import loop` +anchorFromLocatedA :: LocatedA a -> RealSrcSpan +anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc + +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan +fullSpanFromLocatedA (L (EpAnn anc (AnnListItem tas) _) _) = rr + where + r = epaLocationRealSrcSpan anc + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + rr = case reverse (concatMap trailing_loc tas) of + [] -> r + (s:_) -> combineRealSrcSpans r s + +-- --------------------------------------------------------------------- + +balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) +balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) + = (L la' (Match anm mctxt pats (GRHSs x grhss' lb))) + where + simpleBreak n (r,_) = r > n + (la',grhss', _logInfo) = case NE.reverse grhss of + L lg (GRHS ga gs rhs):|grs -> (la'',NE.reverse $ L lg (GRHS ga' gs rhs):|grs,[(gac,(csp,csf))]) + where + anc1 = comments la + (EpAnn anc an _) = ga :: EpAnn GrhsAnn + (csp,csf) = case anc1 of + EpaComments cs -> ([],cs) + EpaCommentsBalanced p f -> (p,f) + (move',stay') = break (simpleBreak 0) (trailingCommentsDeltas (epaLocationRealSrcSpan anc) csf) + move = map snd move' + stay = map snd stay' + cs1 = epaCommentsBalanced csp stay + + gac = epAnnComments ga + gfc = getFollowingComments gac + gac' = setFollowingComments gac (sortEpaComments $ gfc ++ move) + ga' = (EpAnn anc an gac') + + la'' = setCommentsEpAnn la cs1 + +-- --------------------------------------------------------------------- + +anchorEof :: ParsedSource -> ParsedSource +anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) + where + an' = addCommentOrigDeltasAnn an + +-- --------------------------------------------------------------------- + +-- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the +-- given @DeltaPos@. +noAnnSrcSpanDP :: (NoAnn ann) => DeltaPos -> EpAnn ann +noAnnSrcSpanDP dp = EpAnn (EpaDelta noSrcSpan dp []) noAnn emptyComments + +noAnnSrcSpanDP0 :: (NoAnn ann) => EpAnn ann +noAnnSrcSpanDP0 = noAnnSrcSpanDP (SameLine 0) + +noAnnSrcSpanDP1 :: (NoAnn ann) => EpAnn ann +noAnnSrcSpanDP1 = noAnnSrcSpanDP (SameLine 1) + +noAnnSrcSpanDPn :: (NoAnn ann) => Int -> EpAnn ann +noAnnSrcSpanDPn s = noAnnSrcSpanDP (SameLine s) + +d0 :: EpaLocation +d0 = EpaDelta noSrcSpan (SameLine 0) [] + +d1 :: EpaLocation +d1 = EpaDelta noSrcSpan (SameLine 1) [] + +dn :: Int -> EpaLocation +dn n = EpaDelta noSrcSpan (SameLine n) [] + +addComma :: SrcSpanAnnA -> SrcSpanAnnA +addComma (EpAnn anc (AnnListItem as) cs) + = EpAnn anc (AnnListItem (AddCommaAnn (EpTok d0):as)) cs + +-- --------------------------------------------------------------------- + +-- | Insert a declaration into an AST element having sub-declarations +-- (@HasDecls@) according to the given location function. +insertAt :: (HasDecls ast) + => (LHsDecl GhcPs + -> [LHsDecl GhcPs] + -> [LHsDecl GhcPs]) + -> ast + -> LHsDecl GhcPs + -> ast +insertAt f t decl = replaceDecls t (f decl oldDecls') + where + oldDecls = hsDecls t + oldDeclsb = balanceCommentsList oldDecls + oldDecls' = oldDeclsb + +-- |Insert a declaration at the beginning or end of the subdecls of the given +-- AST item +insertAtStart, insertAtEnd :: HasDecls ast => ast -> LHsDecl GhcPs -> ast + +insertAtEnd = insertAt (\x xs -> xs ++ [x]) + +insertAtStart = insertAt insertFirst + where + insertFirst x xs = + case xs of + [] -> [x] + (h:t) -> x:setEntryDP h (DifferentLine 2 0):t + `debug` ("insertAtStart:h=" ++ showAst h) + + +-- |Insert a declaration at a specific location in the subdecls of the given +-- AST item +insertAfter, insertBefore :: HasDecls (LocatedA ast) + => LocatedA old + -> LocatedA ast + -> LHsDecl GhcPs + -> LocatedA ast +insertAfter (getLocA -> k) = insertAt findAfter + where + findAfter x xs = + case span (\(L l _) -> locA l /= k) xs of + ([],[]) -> [x] + (fs,[]) -> fs++[x] + (fs, b:bs) -> fs ++ (b : x : bs) +insertBefore (getLocA -> k) = insertAt findBefore + where + findBefore x xs = + let (fs, bs) = span (\(L l _) -> locA l /= k) xs + in fs ++ (x : bs) + +-- ===================================================================== +-- start of HasDecls instances +-- ===================================================================== + +-- |Provide a means to get and process the immediate child declarations of a +-- given AST element. +class (Data t) => HasDecls t where +-- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent + + -- | Return the 'HsDecl's that are directly enclosed in the + -- given syntax phrase. They are always returned in the wrapped 'HsDecl' + -- form, even if orginating in local decls. This is safe, as annotations + -- never attach to the wrapper, only to the wrapped item. + hsDecls :: t -> [LHsDecl GhcPs] + + -- | Replace the directly enclosed decl list by the given + -- decl list. As part of replacing it will update list order + -- annotations, and rebalance comments and other layout changes as needed. + -- + -- For example, a call on replaceDecls for a wrapped 'FunBind' having no + -- where clause will convert + -- + -- @ + -- -- |This is a function + -- foo = x -- comment1 + -- @ + -- in to + -- + -- @ + -- -- |This is a function + -- foo = x -- comment1 + -- where + -- nn = 2 + -- @ + replaceDecls :: t -> [LHsDecl GhcPs] -> t + +-- --------------------------------------------------------------------- + +instance HasDecls ParsedSource where + hsDecls (L _ (HsModule (XModulePs _ _lo _ _) _mn _exps _imps decls)) = decls + + replaceDecls (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps _decls)) decls + = (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps decls)) + +-- --------------------------------------------------------------------- + +instance HasDecls (LocatedA (HsDecl GhcPs)) where + hsDecls (L _ (TyClD _ c@ClassDecl{})) = hsDeclsClassDecl c + hsDecls decl = error $ "hsDecls:decl=" ++ showAst decl + replaceDecls (L l (TyClD e dec@ClassDecl{})) decls = + let + decl' = replaceDeclsClassDecl dec decls + in (L l (TyClD e decl')) + replaceDecls decl _decls + = error $ "replaceDecls:decl=" ++ showAst decl + +-- --------------------------------------------------------------------- + +instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where + hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = hsDeclsLocalBinds lb + + replaceDecls (L l (Match xm c p (GRHSs xr rhs binds))) [] + = let + binds'' = replaceDeclsValbinds WithoutWhere binds [] + in (L l (Match xm c p (GRHSs xr rhs binds''))) + + replaceDecls m@(L l (Match xm c p (GRHSs xr rhs binds))) newBinds + = let + -- Need to throw in a fresh where clause if the binds were empty, + -- in the annotations. + (l', rhs') = case binds of + EmptyLocalBinds{} -> + let + L l0 m' = balanceSameLineComments m + in (l0, grhssGRHSs $ m_grhss m') + _ -> (l, rhs) + binds'' = replaceDeclsValbinds WithWhere binds newBinds + in (L l' (Match xm c p (GRHSs xr rhs' binds''))) + +-- --------------------------------------------------------------------- + +instance HasDecls (LocatedA (HsExpr GhcPs)) where + hsDecls (L _ (HsLet _ decls _ex)) = hsDeclsLocalBinds decls + hsDecls _ = [] + + replaceDecls (L ll (HsLet (tkLet, tkIn) binds ex)) newDecls + = let + lastAnc = realSrcSpan $ spanHsLocaLBinds binds + -- TODO: may be an intervening comment, take account for lastAnc + (tkLet', tkIn', ex',newDecls') = case (tkLet, tkIn) of + (EpTok l, EpTok i) -> + let + off = case l of + (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r + (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0 + (EpaDelta _ (SameLine _) _) -> LayoutStartCol 0 + (EpaDelta _ (DifferentLine _ c) _) -> LayoutStartCol c + ex'' = setEntryDPFromAnchor off i ex + newDecls'' = case newDecls of + [] -> newDecls + (d:ds) -> setEntryDPDecl d (SameLine 0) : ds + in ( EpTok l + , EpTok (addEpaLocationDelta off lastAnc i) + , ex'' + , newDecls'') + (_,_) -> (tkLet, tkIn, ex, newDecls) + binds' = replaceDeclsValbinds WithoutWhere binds newDecls' + in (L ll (HsLet (tkLet', tkIn') binds' ex')) + + -- TODO: does this make sense? Especially as no hsDecls for HsPar + replaceDecls (L l (HsPar x e)) newDecls + = let + e' = replaceDecls e newDecls + in (L l (HsPar x e')) + replaceDecls old _new = error $ "replaceDecls (LHsExpr GhcPs) undefined for:" ++ showGhc old + +-- --------------------------------------------------------------------- + +-- | Extract the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is +-- idempotent. +hsDeclsPatBindD :: LHsDecl GhcPs -> [LHsDecl GhcPs] +hsDeclsPatBindD (L l (ValD _ d)) = hsDeclsPatBind (L l d) +hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x + +-- | Extract the immediate declarations for a 'PatBind'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is +-- idempotent. +hsDeclsPatBind :: LHsBind GhcPs -> [LHsDecl GhcPs] +hsDeclsPatBind (L _ (PatBind _ _ _ (GRHSs _ _grhs lb))) = hsDeclsLocalBinds lb +hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x + +-- ------------------------------------- + +-- | Replace the immediate declarations for a 'PatBind' wrapped in a 'ValD'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is +-- idempotent. +replaceDeclsPatBindD :: LHsDecl GhcPs -> [LHsDecl GhcPs] -> (LHsDecl GhcPs) +replaceDeclsPatBindD (L l (ValD x d)) newDecls = + let + (L _ d') = replaceDeclsPatBind (L l d) newDecls + in (L l (ValD x d')) +replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x + +-- | Replace the immediate declarations for a 'PatBind'. This +-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent +-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is +-- idempotent. +replaceDeclsPatBind :: LHsBind GhcPs -> [LHsDecl GhcPs] -> (LHsBind GhcPs) +replaceDeclsPatBind (L l (PatBind x a p (GRHSs xr rhss binds))) newDecls + = (L l (PatBind x a p (GRHSs xr rhss binds''))) + where + binds'' = replaceDeclsValbinds WithWhere binds newDecls +replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where + hsDecls (L _ (LetStmt _ lb)) = hsDeclsLocalBinds lb + hsDecls (L _ (LastStmt _ e _ _)) = hsDecls e + hsDecls (L _ (BindStmt _ _pat e)) = hsDecls e + hsDecls (L _ (BodyStmt _ e _ _)) = hsDecls e + hsDecls _ = [] + + replaceDecls (L l (LetStmt x lb)) newDecls + = let + lb'' = replaceDeclsValbinds WithWhere lb newDecls + in (L l (LetStmt x lb'')) + replaceDecls (L l (LastStmt x e d se)) newDecls + = let + e' = replaceDecls e newDecls + in (L l (LastStmt x e' d se)) + replaceDecls (L l (BindStmt x pat e)) newDecls + = let + e' = replaceDecls e newDecls + in (L l (BindStmt x pat e')) + + replaceDecls (L l (BodyStmt x e a b)) newDecls + = let + e' = replaceDecls e newDecls + in (L l (BodyStmt x e' a b)) + replaceDecls x _newDecls = x + +-- ===================================================================== +-- end of HasDecls instances +-- ===================================================================== + +-- --------------------------------------------------------------------- +-- A @FunBind@ is a container for @[LMatch GhcPs]@ +-- +-- When being used as a Bind (or Decl), the surrounding context +-- annotations must appear at the FunBind level, so it can be +-- manipulated in the context of other Binds or Decls. +-- +-- Surrounding context annotations are specifically prior comments, +-- following comments and trailing annotations. +-- +-- But when we unpack the container, by calling @hsDecls@ on a +-- @FunBind@, we must make sure that the component parts fully +-- represent the relationship between them and the surrounding +-- declarations. +-- +-- This means pushing the prior context annotations into the first +-- match, and the following ones into the last match when returning +-- @hsDecls@, and undoing this for @replaceDecls@. + +-- |Push leading and trailing top level annotations into the @[LMatch GhcPs]@ +unpackFunBind :: LHsBind GhcPs -> LHsBind GhcPs +unpackFunBind (L loc (FunBind x1 fid (MG x2 (L lg (L lm m:matches))))) + = (L loc'' (FunBind x1 fid (MG x2 (L lg (reverse (L llm' lmtch:ms)))))) + -- `debug` ("unpackFunBind: =" + -- ++ showAst (("loc",loc), ("loc'",loc'), ("loc''",loc''), + -- ("lm'",lm'), ("llm",llm), ("llm'", llm'))) + where + (loc', lm') = transferPriorCommentsA loc lm + matches' = reverse $ L lm' m:matches + (L llm lmtch, ms) = case matches' of + mm:ms0 -> (mm,ms0) + _ -> error "unpackFunBind" + + (loc'', llm') = transferFollowingA loc' llm + +unpackFunBind d = d + +-- |Pull leading and trailing annotations from the @[LMatch GhcPs]@ to +-- the top level. +packFunBind :: LHsBind GhcPs -> LHsBind GhcPs +packFunBind (L loc (FunBind x1 fid (MG x2 (L lg (L lm m:matches))))) + = (L loc'' (FunBind x1 fid (MG x2 (L lg (reverse (L llm' lmtch:ms)))))) + -- `debug` ("packFunBind: =" + -- ++ showAst (("loc",loc), ("loc'",loc'), ("loc''",loc''), + -- ("lm'",lm'), ("llm",llm), ("llm'", llm'))) + where + (lm', loc') = transferPriorCommentsA lm loc + matches' = reverse $ L lm' m:matches + (L llm lmtch, ms) = case matches' of + mm:ms0 -> (mm,ms0) + _ -> error "packFunBind" + (llm', loc'') = transferFollowingA llm loc' +packFunBind d = d + +packFunDecl :: LHsDecl GhcPs -> LHsDecl GhcPs +packFunDecl (L l (ValD x b)) = L l' (ValD x b') + where + L l' b' = packFunBind (L l b) +packFunDecl x = x + +unpackFunDecl :: LHsDecl GhcPs -> LHsDecl GhcPs +unpackFunDecl (L l (ValD x b)) = L l' (ValD x b') + where + L l' b' = unpackFunBind (L l b) +unpackFunDecl x = x + +-- --------------------------------------------------------------------- + +data WithWhere = WithWhere + | WithoutWhere + deriving (Eq,Show) + +-- | Utility function for returning decls to 'HsLocalBinds'. Use with +-- care, as this does not manage the declaration order, the +-- ordering should be done by the calling function from the 'HsLocalBinds' +-- context in the AST. +replaceDeclsValbinds :: WithWhere + -> HsLocalBinds GhcPs -> [LHsDecl GhcPs] + -> HsLocalBinds GhcPs +replaceDeclsValbinds _ _ [] = EmptyLocalBinds NoExtField +replaceDeclsValbinds w b@(HsValBinds a _) new + = let + oldSpan = spanHsLocaLBinds b + an = oldWhereAnnotation a w (realSrcSpan oldSpan) + decs = concatMap decl2Bind new + sigs = concatMap decl2Sig new + sortKey = captureOrderBinds new + in (HsValBinds an (ValBinds sortKey decs sigs)) +replaceDeclsValbinds _ (HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds" +replaceDeclsValbinds w (EmptyLocalBinds _) new + = let + an = newWhereAnnotation w + decs = concatMap decl2Bind new + sigs = concatMap decl2Sig new + sortKey = captureOrderBinds new + in (HsValBinds an (ValBinds sortKey decs sigs)) + +oldWhereAnnotation :: EpAnn (AnnList (EpToken "where")) + -> WithWhere -> RealSrcSpan -> (EpAnn (AnnList (EpToken "where"))) +oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = an' + -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation, + -- change the AnnList anchor to have the correct DP too + where + (AnnList ancl p s _r t) = an + w = case ww of + WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) []) + WithoutWhere -> NoEpTok + (anc', ancl') = + case ww of + WithWhere -> (anc, ancl) + WithoutWhere -> (anc, ancl) + an' = EpAnn anc' + (AnnList ancl' p s w t) + cs + +newWhereAnnotation :: WithWhere -> (EpAnn (AnnList (EpToken "where"))) +newWhereAnnotation ww = an + where + anc = EpaDelta noSrcSpan (DifferentLine 1 2) [] + anc2 = EpaDelta noSrcSpan (DifferentLine 1 4) [] + w = case ww of + WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) []) + WithoutWhere -> NoEpTok + an = EpAnn anc + (AnnList (Just anc2) ListNone [] w []) + emptyComments + +-- --------------------------------------------------------------------- + +type Decl = LHsDecl GhcPs +type PMatch = LMatch GhcPs (LHsExpr GhcPs) + +-- |Modify a 'LHsBind' wrapped in a 'ValD'. For a 'PatBind' the +-- declarations are extracted and returned after modification. For a +-- 'FunBind' the supplied 'SrcSpan' is used to identify the specific +-- 'Match' to be transformed, for when there are multiple of them. +modifyValD :: forall t. + SrcSpan + -> Decl + -> (PMatch -> [Decl] -> ([Decl], Maybe t)) + -> (Decl,Maybe t) +modifyValD p pb@(L ss (ValD _ (PatBind {} ))) f = + if (locA ss) == p + then + let + ds = hsDeclsPatBindD pb + (ds',r) = f (error "modifyValD.PatBind should not touch Match") ds + pb' = replaceDeclsPatBindD pb ds' + in (pb',r) + else (pb,Nothing) +modifyValD p decl f = (packFunDecl decl', r) + where + (decl',r) = runState (everywhereM (mkM doModLocal) (unpackFunDecl decl)) Nothing + doModLocal :: PMatch -> State (Maybe t) PMatch + doModLocal (match@(L ss _) :: PMatch) = do + if (locA ss) == p + then do + let + ds = hsDecls match + (ds',r0) = f match ds + put r0 + let match' = replaceDecls match ds' + return match' + else return match + +-- --------------------------------------------------------------------- + +-- |Used to integrate a @Transform@ into other Monad stacks +class (Monad m) => (HasTransform m) where + liftT :: Transform a -> m a + +instance Monad m => HasTransform (TransformT m) where + liftT = hoistTransform (return . runIdentity) + +-- --------------------------------------------------------------------- + +-- | Apply a transformation to the decls contained in @t@ +modifyDeclsT :: (HasDecls t,HasTransform m) + => ([LHsDecl GhcPs] -> m [LHsDecl GhcPs]) + -> t -> m t +modifyDeclsT action t = do + let decls = hsDecls t + decls' <- action decls + return $ replaceDecls t decls' 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 @@ -21,19 +21,15 @@ -- --------------------------------------------------------------------- -data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) - --- --------------------------------------------------------------------- - -- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted -- from an @AnnKeywordId@ because the annotation must be interleaved into the -- stream and does not have a well-defined position data Comment = Comment { commentContents :: !String -- ^ The contents of the comment including separators - , commentAnchor :: !Anchor + , commentLoc :: !NoCommentsLocation , commentPriorTok :: !RealSrcSpan - , commentOrigin :: !(Maybe AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. + , commentOrigin :: !(Maybe String) -- ^ We sometimes turn syntax into comments in order to process them properly. } deriving (Data, Eq) @@ -45,7 +41,7 @@ -- When we have CPP injected comments with a fake filename, or LINE -- pragma, the file name changes, so we need to compare the -- locations only, with out the filename. - compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compare (ss2pos $ anchor ss1) (ss2pos $ anchor ss2) + compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compare (ss2pos $ epaLocationRealSrcSpan ss1) (ss2pos $ epaLocationRealSrcSpan ss2) where ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss) diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs --- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs @@ -1,35 +1,77 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} -module Language.Haskell.GHC.ExactPrint.Utils where +module Language.Haskell.GHC.ExactPrint.Utils + -- ( + -- showAst + -- , ss2pos, ss2posEnd + -- , ss2delta, ss2deltaEnd + -- , ss2range + -- , rs + -- , debug, debugM + -- , adjustDeltaForOffset + -- , sortEpaComments + -- , epaCommentsBalanced + -- , notDocDecl + -- , notIEDoc + -- , hsDeclsLocalBinds + -- , hsDeclsClassDecl + -- , hsDeclsValBinds + -- , captureOrderBinds + -- , wrapSig, wrapDecl + -- , decl2Sig + -- , mkLEpaComment + -- , mkEpaComments + -- , mkKWComment + -- , tokComment + -- , comment2LEpaComment + -- , commentOrigDelta + -- , replaceDeclsClassDecl + -- , decl2Bind + -- , badRealSrcSpan + -- , rs2range + -- , origDelta + -- , dedentDocChunk + -- , orderedDecls + -- , needsWhere + -- , undelta + -- , spanLength + -- , isGoodDelta + -- , dpFromString + -- , insertCppComments + -- ) + where import Control.Monad (when) +-- import Control.Monad.State.Lazy +import GHC.Utils.Monad.State.Strict +import Data.Data hiding ( Fixity ) import Data.Function +import Data.Generics.Aliases +import Data.Generics.Schemes import Data.List -import Data.Maybe -import Data.Ord (comparing) - -import Language.Haskell.GHC.ExactPrint.Lookup - -import qualified Language.Haskell.GHC.ExactPrint.Orphans() +import qualified Data.Map.Strict as Map -import GHC hiding (EpaComment) import qualified GHC +import GHC hiding (EpaComment) +import GHC.Base (NonEmpty(..)) +import GHC.Data.FastString +import GHC.Driver.Ppr +import GHC.Hs.Dump +import GHC.Parser.Lexer (allocateComments) import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.SrcLoc -import GHC.Driver.Ppr -import GHC.Data.FastString -import qualified GHC.Data.Strict as Strict -import GHC.Base (NonEmpty(..)) -import Debug.Trace import Language.Haskell.GHC.ExactPrint.Types -import Data.Default +import Debug.Trace + -- --------------------------------------------------------------------- -- |Global switch to enable debug tracing in ghc-exactprint Delta / Print @@ -46,12 +88,32 @@ debugM :: Monad m => String -> m () debugM s = when debugEnabledFlag $ traceM s --- --------------------------------------------------------------------- - warn :: c -> String -> c -- warn = flip trace warn c _ = c +-- --------------------------------------------------------------------- + +captureOrderBinds :: [LHsDecl GhcPs] -> AnnSortKey BindTag +captureOrderBinds ls = AnnSortKey $ map go ls + where + go (L _ (ValD _ _)) = BindTag + go (L _ (SigD _ _)) = SigDTag + go d = error $ "captureOrderBinds:" ++ showGhc d + +-- --------------------------------------------------------------------- + +notDocDecl :: LHsDecl GhcPs -> Bool +notDocDecl (L _ DocD{}) = False +notDocDecl _ = True + +notIEDoc :: LIE GhcPs -> Bool +notIEDoc (L _ IEGroup {}) = False +notIEDoc (L _ IEDoc {}) = False +notIEDoc (L _ IEDocNamed {}) = False +notIEDoc _ = True + +-- --------------------------------------------------------------------- -- | A good delta has no negative values. isGoodDelta :: DeltaPos -> Bool isGoodDelta (SameLine co) = co >= 0 @@ -105,17 +167,10 @@ fl = l + dl fc = co + dc -undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn -undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp Strict.Nothing) - where - (l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0) - len = length (keywordToString kw) - sp = range2rs ((l,c),(l,c+len)) - -- --------------------------------------------------------------------- adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos -adjustDeltaForOffset _colOffset dp@(SameLine _) = dp +adjustDeltaForOffset _colOffset dp@(SameLine _) = dp adjustDeltaForOffset (LayoutStartCol colOffset) (DifferentLine l c) = DifferentLine l (c - colOffset) @@ -150,6 +205,12 @@ spanLength :: RealSrcSpan -> Int spanLength = (-) <$> srcSpanEndCol <*> srcSpanStartCol + +-- | Useful for debug dumps +eloc2str :: EpaLocation -> String +eloc2str (EpaSpan r) = "EpaSpan " ++ show (ss2range r) +eloc2str epaLoc = show epaLoc + -- --------------------------------------------------------------------- -- | Checks whether a SrcSpan has zero length. isPointSrcSpan :: RealSrcSpan -> Bool @@ -158,39 +219,27 @@ -- --------------------------------------------------------------------- -origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos -origDelta pos pp = op +-- | A GHC comment includes the span of the preceding token. Take an +-- original comment, and convert the 'Anchor to have a have a +-- `MovedAnchor` operation based on the original location, only if it +-- does not already have one. +commentOrigDelta :: LEpaComment -> LEpaComment +commentOrigDelta (L (EpaSpan ss@(RealSrcSpan la _)) (GHC.EpaComment t pp)) + = (L (EpaDelta ss dp' NoComments) (GHC.EpaComment t pp)) + `debug` ("commentOrigDelta: (la, pp, r,c, dp, dp')=" ++ showAst (la, pp, r,c, dp, dp')) where - (r,c) = ss2posEnd pp - - op = if r == 0 - then ( ss2delta (r,c+1) pos) - else (tweakDelta $ ss2delta (r,c ) pos) - --- --------------------------------------------------------------------- - --- | For comment-related deltas starting on a new line we have an --- off-by-one problem. Adjust -tweakDelta :: DeltaPos -> DeltaPos -tweakDelta (SameLine d) = SameLine d -tweakDelta (DifferentLine l d) = DifferentLine l (d-1) - --- --------------------------------------------------------------------- - --- |Given a list of items and a list of keys, returns a list of items --- ordered by their position in the list of keys. -orderByKey :: [(RealSrcSpan,a)] -> [RealSrcSpan] -> [(RealSrcSpan,a)] -orderByKey keys order - -- AZ:TODO: if performance becomes a problem, consider a Map of the order - -- SrcSpan to an index, and do a lookup instead of elemIndex. - - -- Items not in the ordering are placed to the start - = sortBy (comparing (flip elemIndex order . fst)) keys + (r,c) = ss2posEnd pp --- --------------------------------------------------------------------- + dp = if r == 0 + then (ss2delta (r,c+1) la) + else (ss2delta (r,c) la) + dp' = case dp of + SameLine _ -> dp + DifferentLine l cc -> DifferentLine l (cc - 1) +commentOrigDelta c = c -isListComp :: HsDoFlavour -> Bool -isListComp = isDoComprehensionContext +origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos +origDelta pos pp = ss2delta (ss2posEnd pp) pos -- --------------------------------------------------------------------- @@ -202,16 +251,222 @@ -- --------------------------------------------------------------------- +-- | Insert the comments at the appropriate places in the AST insertCppComments :: ParsedSource -> [LEpaComment] -> ParsedSource -insertCppComments (L l p) cs = L l p' +-- insertCppComments p [] = p +insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining where - an' = case GHC.hsmodAnn $ GHC.hsmodExt p of - (EpAnn a an ocs) -> EpAnn a an (EpaComments cs') - where - cs' = sortEpaComments $ priorComments ocs ++ getFollowingComments ocs ++ cs - unused -> unused + (EpAnn anct ant cst) = hsmodAnn $ hsmodExt p + cs = sortEpaComments $ priorComments cst ++ getFollowingComments cst ++ cs0 + p0 = p { hsmodExt = (hsmodExt p) { hsmodAnn = EpAnn anct ant emptyComments }} + -- Comments embedded within spans + -- everywhereM is a bottom-up traversal + (p1, toplevel) = runState (everywhereM (mkM addCommentsListItem + `extM` addCommentsGrhs + `extM` addCommentsList) p0) cs + (p2, remaining) = insertTopLevelCppComments p1 toplevel + + addCommentsListItem :: EpAnn AnnListItem -> State [LEpaComment] (EpAnn AnnListItem) + addCommentsListItem = addComments + + addCommentsList :: EpAnn (AnnList ()) -> State [LEpaComment] (EpAnn (AnnList ())) + addCommentsList = addComments + + addCommentsGrhs :: EpAnn GrhsAnn -> State [LEpaComment] (EpAnn GrhsAnn) + addCommentsGrhs = addComments + + addComments :: forall ann. EpAnn ann -> State [LEpaComment] (EpAnn ann) + addComments (EpAnn anc an ocs) = do + case anc of + EpaSpan (RealSrcSpan s _) -> do + unAllocated <- get + let + (rest, these) = GHC.Parser.Lexer.allocateComments s unAllocated + cs' = workInComments ocs these + put rest + return $ EpAnn anc an cs' + + _ -> return $ EpAnn anc an ocs + +workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments +workInComments ocs [] = ocs +workInComments ocs new = cs' + where + pc = priorComments ocs + fc = getFollowingComments ocs + cs' = case fc of + [] -> EpaComments $ sortEpaComments $ pc ++ fc ++ new + (L ac _:_) -> epaCommentsBalanced (sortEpaComments $ pc ++ cs_before) + (sortEpaComments $ fc ++ cs_after) + where + (cs_before,cs_after) + = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) + new + +insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) +insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs + = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) + -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs)) + -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs)) + where + -- Comments at the top level. + (an0, cs0) = + case mmn of + Nothing -> (an, cs) + Just _ -> + -- We have a module name. Capture all comments up to the `where` + let + (these, remaining) = splitOnWhere Before (am_where $ anns an) cs + (EpAnn a anno ocs) = an :: EpAnn AnnsModule + anm = EpAnn a anno (workInComments ocs these) + in + (anm, remaining) + (an1,cs0a) = case lo of + EpExplicitBraces (EpTok (EpaSpan (RealSrcSpan s _))) _close -> + let + (stay,cs0a') = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ s)) cs0 + cs' = workInComments (comments an0) stay + in (an0 { comments = cs' }, cs0a') + _ -> (an0,cs0) + -- Deal with possible leading semis + (an2, cs0b) = case am_decls $ anns an1 of + (AddSemiAnn (EpTok (EpaSpan (RealSrcSpan s _))):_) -> (an1 {comments = cs'}, cs0b') + where + (stay,cs0b') = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ s)) cs0a + cs' = workInComments (comments an1) stay + _ -> (an1,cs0a) + + (mexports', an3, cs1) = + case mexports of + Nothing -> (Nothing, an2, cs0b) + Just (L l exports) -> (Just (L l exports'), an3', cse) + where + hc1' = workInComments (comments an2) csh' + an3' = an2 { comments = hc1' } + (csh', cs0b') = case annListBracketsLocs $ al_brackets $ anns l of + (EpaSpan (RealSrcSpan s _),_) ->(h, n) + where + (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) + cs0b + + _ -> ([], cs0b) + (exports', cse) = allocPreceding exports cs0b' + (imports0, cs2) = allocPreceding imports cs1 + (imports', hc0i) = balanceFirstLocatedAComments imports0 + + (decls0, cs3) = allocPreceding decls cs2 + (decls', hc0d) = balanceFirstLocatedAComments decls0 + + -- Either hc0i or hc0d should have comments. Combine them + hc0 = hc0i ++ hc0d + + (hc1,hc_cs) = if NoEpTok == (am_where $ anns an3) + then (hc0,[]) + else splitOnWhere After (am_where $ anns an3) hc0 + hc2 = workInComments (comments an3) hc1 + an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 } + + allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment]) + allocPreceding [] cs' = ([], cs') + allocPreceding (L (EpAnn anc4 an5 cs4) a:xs) cs' = ((L (EpAnn anc4 an5 cs4') a:xs'), rest') + where + (rest, these) = + case anc4 of + EpaSpan (RealSrcSpan s _) -> + allocatePriorComments (ss2pos s) cs' + _ -> (cs', []) + cs4' = workInComments cs4 these + (xs',rest') = allocPreceding xs rest + +annListBracketsLocs :: AnnListBrackets -> (EpaLocation,EpaLocation) +annListBracketsLocs (ListParens o c) = (getEpTokenLoc o, getEpTokenLoc c) +annListBracketsLocs (ListBraces o c) = (getEpTokenLoc o, getEpTokenLoc c) +annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) +annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) +annListBracketsLocs ListNone = (noAnn, noAnn) + + +data SplitWhere = Before | After + +splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) +splitOnWhere w (EpTok (EpaSpan (RealSrcSpan s _))) csIn = (hc, fc) + where + splitFunc Before anc_pos c_pos = c_pos < anc_pos + splitFunc After anc_pos c_pos = anc_pos < c_pos + (hc,fc) = break (\(L ll _) -> splitFunc w (ss2pos $ epaLocationRealSrcSpan ll) (ss2pos s)) csIn +splitOnWhere _ _ csIn = (csIn,[]) + +balanceFirstLocatedAComments :: [LocatedA a] -> ([LocatedA a], [LEpaComment]) +balanceFirstLocatedAComments [] = ([],[]) +balanceFirstLocatedAComments ((L (EpAnn anc an csd) a):ds) = (L (EpAnn anc an csd0) a:ds, hc') + where + (csd0, hc') = case anc of + EpaSpan (RealSrcSpan s _) -> (csd', hc) + `debug` ("balanceFirstLocatedAComments: (csd,csd',attached,header)=" ++ showAst (csd,csd',attached,header)) + where + (priors, inners) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) + (priorComments csd) + pcds = priorCommentsDeltas' s priors + (attached, header) = break (\(d,_c) -> d /= 1) pcds + csd' = setPriorComments csd (reverse (map snd attached) ++ inners) + hc = reverse (map snd header) + _ -> (csd, []) + + + +priorCommentsDeltas' :: RealSrcSpan -> [LEpaComment] + -> [(Int, LEpaComment)] +priorCommentsDeltas' r cs = go r (reverse cs) + where + go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] + go _ [] = [] + go _ (la@(L l@(EpaDelta _ dp _) _):las) = (getDeltaLine dp, la) : go (epaLocationRealSrcSpan l) las + go rs' (la@(L l _):las) = deltaComment rs' la : go (epaLocationRealSrcSpan l) las + + deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment) + deltaComment rs' (L loc c) = (abs(ll - al), L loc c) + where + (al,_) = ss2pos rs' + (ll,_) = ss2pos (epaLocationRealSrcSpan loc) + +allocatePriorComments + :: Pos + -> [LEpaComment] + -> ([LEpaComment], [LEpaComment]) +allocatePriorComments ss_loc comment_q = + let + cmp (L l _) = ss2pos (epaLocationRealSrcSpan l) <= ss_loc + (newAnns,after) = partition cmp comment_q + in + (after, newAnns) + +insertRemainingCppComments :: ParsedSource -> [LEpaComment] -> ParsedSource +insertRemainingCppComments (L l p) cs = L l p' + -- `debug` ("insertRemainingCppComments: (cs,an')=" ++ showAst (cs,an')) + where + (EpAnn a an ocs) = GHC.hsmodAnn $ GHC.hsmodExt p + an' = EpAnn a an (addTrailingComments end_loc ocs cs) p' = p { GHC.hsmodExt = (GHC.hsmodExt p) { GHC.hsmodAnn = an' } } + end_loc = case GHC.hsmodLayout $ GHC.hsmodExt p of + EpExplicitBraces _open close -> case close of + EpTok (EpaSpan (RealSrcSpan s _)) -> ss2pos s + _ -> (1,1) + _ -> (1,1) + (new_before, new_after) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > end_loc ) cs + addTrailingComments end_loc' cur new = epaCommentsBalanced pc' fc' + where + pc = priorComments cur + fc = getFollowingComments cur + (pc', fc') = case reverse pc of + [] -> (sortEpaComments $ pc ++ new_before, sortEpaComments $ fc ++ new_after) + (L ac _:_) -> (sortEpaComments $ pc ++ cs_before, sortEpaComments $ fc ++ cs_after) + where + (cs_before,cs_after) + = if (ss2pos $ epaLocationRealSrcSpan ac) > end_loc' + then break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new + else (new_before, new_after) + -- --------------------------------------------------------------------- ghcCommentText :: LEpaComment -> String @@ -219,15 +474,14 @@ ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _)) = s ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s -ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = "" tokComment :: LEpaComment -> [Comment] tokComment t@(L lt c) = case c of - (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments lt pt dc + (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments (noCommentsToEpaLocation lt) pt dc _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)] -hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment] +hsDocStringComments :: EpaLocation -> RealSrcSpan -> GHC.HsDocString -> [Comment] hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) = let decStr = printDecorator dec @@ -239,13 +493,12 @@ in (Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs)) hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk)) - = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ] + = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ] hsDocStringComments anc pt (NestedDocString dec (L _ chunk)) - = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ] + = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") (epaToNoCommentsLocation anc) pt Nothing ] hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code --- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/23459 is landed -- At the moment the locations of the 'HsDocStringChunk's are from the start of -- the string part, leaving aside the "--". So we need to subtract 2 columns from it dedentDocChunk :: LHsDocStringChunk -> LHsDocStringChunk @@ -264,38 +517,35 @@ dedentDocChunkBy _ x = x --- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/23459 is landed -printDecorator :: HsDocStringDecorator -> String -printDecorator HsDocStringNext = "|" -printDecorator HsDocStringPrevious = "^" -printDecorator (HsDocStringNamed n) = '$':n -printDecorator (HsDocStringGroup n) = replicate n '*' - +epaCommentsBalanced :: [LEpaComment] -> [LEpaComment] -> EpAnnComments +epaCommentsBalanced priorCs [] = EpaComments priorCs +epaCommentsBalanced priorCs postCs = EpaCommentsBalanced priorCs postCs mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments mkEpaComments priorCs [] = EpaComments (map comment2LEpaComment priorCs) mkEpaComments priorCs postCs - = EpaCommentsBalanced (map comment2LEpaComment priorCs) (map comment2LEpaComment postCs) + = epaCommentsBalanced (map comment2LEpaComment priorCs) (map comment2LEpaComment postCs) comment2LEpaComment :: Comment -> LEpaComment comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r -mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment -mkLEpaComment "" anc r = (L anc (GHC.EpaComment (EpaEofComment) r)) -mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r)) +mkLEpaComment :: String -> NoCommentsLocation -> RealSrcSpan -> LEpaComment +mkLEpaComment s loc r = (L loc (GHC.EpaComment (EpaLineComment s) r)) -mkComment :: String -> Anchor -> RealSrcSpan -> Comment -mkComment c anc r = Comment c anc r Nothing +mkComment :: String -> NoCommentsLocation -> RealSrcSpan -> Comment +mkComment c loc r = Comment c loc r Nothing -- Windows comments include \r in them from the lexer. normaliseCommentText :: String -> String -normaliseCommentText = filter (/= '\r') +normaliseCommentText [] = [] +normaliseCommentText ('\r':xs) = normaliseCommentText xs +normaliseCommentText (x:xs) = x:normaliseCommentText xs -- |Must compare without span filenames, for CPP injected comments with fake filename cmpComments :: Comment -> Comment -> Ordering -cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) +cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare (ss2pos $ epaLocationRealSrcSpan l1) (ss2pos $ epaLocationRealSrcSpan l2) -- |Sort, comparing without span filenames, for CPP injected comments with fake filename sortComments :: [Comment] -> [Comment] @@ -305,24 +555,16 @@ sortEpaComments :: [LEpaComment] -> [LEpaComment] sortEpaComments cs = sortBy cmp cs where - cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) + cmp (L l1 _) (L l2 _) = compare (ss2pos $ epaLocationRealSrcSpan l1) (ss2pos $ epaLocationRealSrcSpan l2) -- | Makes a comment which originates from a specific keyword. -mkKWComment :: AnnKeywordId -> EpaLocation -> Comment -mkKWComment kw (EpaSpan ss _) - = Comment (keywordToString kw) (Anchor ss UnchangedAnchor) ss (Just kw) -mkKWComment kw (EpaDelta dp _) - = Comment (keywordToString kw) (Anchor placeholderRealSpan (MovedAnchor dp)) placeholderRealSpan (Just kw) - --- | Detects a comment which originates from a specific keyword. -isKWComment :: Comment -> Bool -isKWComment c = isJust (commentOrigin c) - -noKWComments :: [Comment] -> [Comment] -noKWComments = filter (\c -> not (isKWComment c)) +mkKWComment :: String -> NoCommentsLocation -> Comment +mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) +mkKWComment kw (EpaSpan (UnhelpfulSpan _)) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw) +mkKWComment kw (EpaDelta ss dp cs) = Comment kw (EpaDelta ss dp cs) placeholderRealSpan (Just kw) -sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a] -sortAnchorLocated = sortBy (compare `on` (anchor . getLoc)) +sortAnchorLocated :: [GenLocated EpaLocation a] -> [GenLocated EpaLocation a] +sortAnchorLocated = sortBy (compare `on` (epaLocationRealSrcSpan . getLoc)) -- | Calculates the distance from the start of a string to the end of -- a string. @@ -356,113 +598,159 @@ name2String :: Name -> String name2String = showPprUnsafe - -- --------------------------------------------------------------------- - -locatedAnAnchor :: LocatedAn a t -> RealSrcSpan -locatedAnAnchor (L (SrcSpanAnn EpAnnNotUsed l) _) = realSrcSpan l -locatedAnAnchor (L (SrcSpanAnn (EpAnn a _ _) _) _) = anchor a - -- --------------------------------------------------------------------- --- Note: moved to Language.Haskell.GHC.ExactPrint.ExactPrint as a hack --- to avoid import loop problems while we have to use the local --- version of Dump --- showAst :: (Data a) => a -> String --- showAst ast --- = showSDocUnsafe --- $ showAstData NoBlankSrcSpan NoBlankEpAnnotations ast +type DeclsByTag a = Map.Map DeclTag [(RealSrcSpan, a)] --- --------------------------------------------------------------------- +orderedDecls + :: AnnSortKey DeclTag + -> DeclsByTag a + -> [(RealSrcSpan, a)] +orderedDecls sortKey declGroup = + case sortKey of + NoAnnSortKey -> + sortBy (\a b -> compare (fst a) (fst b)) (concat $ Map.elems declGroup) + AnnSortKey keys -> + let + go :: [DeclTag] -> DeclsByTag a -> [(RealSrcSpan, a)] + go [] _ = [] + go (tag:ks) dbt = d : go ks dbt' + where + dbt' = Map.adjust (\ds -> drop 1 ds) tag dbt + d = case Map.lookup tag dbt of + Just (d':_) -> d' + _ -> error $ "orderedDecls: could not look up " + ++ show tag ++ " in " ++ show (Map.keys dbt) + in + go keys declGroup -setAnchorAn :: (Default an) => LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a -setAnchorAn (L (SrcSpanAnn EpAnnNotUsed l) a) anc cs - = (L (SrcSpanAnn (EpAnn anc def cs) l) a) - -- `debug` ("setAnchorAn: anc=" ++ showAst anc) -setAnchorAn (L (SrcSpanAnn (EpAnn _ an _) l) a) anc cs - = (L (SrcSpanAnn (EpAnn anc an cs) l) a) - -- `debug` ("setAnchorAn: anc=" ++ showAst anc) +hsDeclsClassDecl :: TyClDecl GhcPs -> [LHsDecl GhcPs] +hsDeclsClassDecl dec = case dec of + ClassDecl { tcdCExt = (_an2, _layout, sortKey), + tcdSigs = sigs,tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs + } -> map snd decls + where + srs :: EpAnn a -> RealSrcSpan + srs a = realSrcSpan $ locA a + decls + = orderedDecls sortKey $ Map.fromList + [(ClsSigTag, map (\(L l s) -> (srs l, L l (SigD noExtField s))) sigs), + (ClsMethodTag, map (\(L l s) -> (srs l, L l (ValD noExtField s))) methods), + (ClsAtTag, map (\(L l s) -> (srs l, L l (TyClD noExtField $ FamDecl noExtField s))) ats), + (ClsAtdTag, map (\(L l s) -> (srs l, L l (InstD noExtField $ TyFamInstD noExtField s))) at_defs) + ] + _ -> error $ "hsDeclsClassDecl:dec=" ++ showAst dec -setAnchorEpa :: (Default an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an -setAnchorEpa EpAnnNotUsed anc cs = EpAnn anc def cs -setAnchorEpa (EpAnn _ an _) anc cs = EpAnn anc an cs +replaceDeclsClassDecl :: TyClDecl GhcPs -> [LHsDecl GhcPs] -> TyClDecl GhcPs +replaceDeclsClassDecl decl decls = case decl of + ClassDecl { tcdCExt = (an2, layout, _) } -> decl' + where + (tags, methods', sigs', ats', at_defs', _, _docs) = partitionWithSortKey decls + decl' = decl { tcdCExt = (an2, layout, AnnSortKey tags), + tcdSigs = sigs',tcdMeths = methods', + tcdATs = ats', tcdATDefs = at_defs' + } -setAnchorEpaL :: EpAnn AnnList -> Anchor -> EpAnnComments -> EpAnn AnnList -setAnchorEpaL EpAnnNotUsed anc cs = EpAnn anc mempty cs -setAnchorEpaL (EpAnn _ an _) anc cs = EpAnn anc (an {al_anchor = Nothing}) cs + _ -> error $ "replaceDeclsClassDecl:decl=" ++ showAst decl -setAnchorHsModule :: HsModule GhcPs -> Anchor -> EpAnnComments -> HsModule GhcPs -setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} } +partitionWithSortKey + :: [LHsDecl GhcPs] + -> ([DeclTag], LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], + [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) +partitionWithSortKey = go where - anc' = anc { anchor_op = UnchangedAnchor } - an' = setAnchorEpa (hsmodAnn $ hsmodExt hsmod) anc' cs + go [] = ([], [], [], [], [], [], []) + go ((L l decl) : ds) = + let (tags, bs, ss, ts, tfis, dfis, docs) = go ds in + case decl of + ValD _ b + -> (ClsMethodTag:tags, L l b : bs, ss, ts, tfis, dfis, docs) + SigD _ s + -> (ClsSigTag:tags, bs, L l s : ss, ts, tfis, dfis, docs) + TyClD _ (FamDecl _ t) + -> (ClsAtTag:tags, bs, ss, L l t : ts, tfis, dfis, docs) + InstD _ (TyFamInstD { tfid_inst = tfi }) + -> (ClsAtdTag:tags, bs, ss, ts, L l tfi : tfis, dfis, docs) + InstD _ (DataFamInstD { dfid_inst = dfi }) + -> (tags, bs, ss, ts, tfis, L l dfi : dfis, docs) + DocD _ d + -> (tags, bs, ss, ts, tfis, dfis, L l d : docs) + _ -> error $ "partitionBindsAndSigs" ++ (showAst decl) --- |Version of l2l that preserves the anchor, immportant if it has an --- updated AnchorOperation -moveAnchor :: Monoid b => SrcAnn a -> SrcAnn b -moveAnchor (SrcSpanAnn EpAnnNotUsed l) = noAnnSrcSpan l -moveAnchor (SrcSpanAnn (EpAnn anc _ cs) l) = SrcSpanAnn (EpAnn anc mempty cs) l -- --------------------------------------------------------------------- -trailingAnnLoc :: TrailingAnn -> EpaLocation -trailingAnnLoc (AddSemiAnn ss) = ss -trailingAnnLoc (AddCommaAnn ss) = ss -trailingAnnLoc (AddVbarAnn ss) = ss +orderedDeclsBinds + :: AnnSortKey BindTag + -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] + -> [LHsDecl GhcPs] +orderedDeclsBinds sortKey binds sigs = + case sortKey of + NoAnnSortKey -> + sortBy (\a b -> compare (realSrcSpan $ getLocA a) + (realSrcSpan $ getLocA b)) (binds ++ sigs) + AnnSortKey keys -> + let + go [] _ _ = [] + go (BindTag:ks) (b:bs) ss = b : go ks bs ss + go (SigDTag:ks) bs (s:ss) = s : go ks bs ss + go (_:ks) bs ss = go ks bs ss + in + go keys binds sigs -setTrailingAnnLoc :: TrailingAnn -> EpaLocation -> TrailingAnn -setTrailingAnnLoc (AddSemiAnn _) ss = (AddSemiAnn ss) -setTrailingAnnLoc (AddCommaAnn _) ss = (AddCommaAnn ss) -setTrailingAnnLoc (AddVbarAnn _) ss = (AddVbarAnn ss) +hsDeclsLocalBinds :: HsLocalBinds GhcPs -> [LHsDecl GhcPs] +hsDeclsLocalBinds lb = case lb of + HsValBinds _ (ValBinds sortKey bs sigs) -> + let + bds = map wrapDecl bs + sds = map wrapSig sigs + in + orderedDeclsBinds sortKey bds sds + HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid" + HsIPBinds {} -> [] + EmptyLocalBinds {} -> [] -addEpAnnLoc :: AddEpAnn -> EpaLocation -addEpAnnLoc (AddEpAnn _ l) = l +hsDeclsValBinds :: (HsValBindsLR GhcPs GhcPs) -> [LHsDecl GhcPs] +hsDeclsValBinds (ValBinds sortKey bs sigs) = + let + bds = map wrapDecl bs + sds = map wrapSig sigs + in + orderedDeclsBinds sortKey bds sds +hsDeclsValBinds XValBindsLR{} = error "hsDeclsValBinds" -- --------------------------------------------------------------------- --- TODO: move this to GHC -anchorToEpaLocation :: Anchor -> EpaLocation -anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r Strict.Nothing -anchorToEpaLocation (Anchor _ (MovedAnchor dp)) = EpaDelta dp [] - --- --------------------------------------------------------------------- --- Horrible hack for dealing with some things still having a SrcSpan, --- not an Anchor. - -{- -A SrcSpan is defined as - -data SrcSpan = - RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos] - | UnhelpfulSpan !UnhelpfulSpanReason - -data BufSpan = - BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } - deriving (Eq, Ord, Show) - -newtype BufPos = BufPos { bufPos :: Int } - +-- |Pure function to convert a 'LHsDecl' to a 'LHsBind'. This does +-- nothing to any annotations that may be attached to either of the elements. +-- It is used as a utility function in 'replaceDecls' +decl2Bind :: LHsDecl GhcPs -> [LHsBind GhcPs] +decl2Bind (L l (ValD _ s)) = [L l s] +decl2Bind _ = [] -We use the BufPos to encode a delta, using bufSpanStart for the line, -and bufSpanEnd for the col. +-- |Pure function to convert a 'LSig' to a 'LHsBind'. This does +-- nothing to any annotations that may be attached to either of the elements. +-- It is used as a utility function in 'replaceDecls' +decl2Sig :: LHsDecl GhcPs -> [LSig GhcPs] +decl2Sig (L l (SigD _ s)) = [L l s] +decl2Sig _ = [] -To be absolutely sure, we make the delta versions use -ve values. +-- --------------------------------------------------------------------- --} +-- |Convert a 'LSig' into a 'LHsDecl' +wrapSig :: LSig GhcPs -> LHsDecl GhcPs +wrapSig (L l s) = L l (SigD NoExtField s) -hackSrcSpanToAnchor :: SrcSpan -> Anchor -hackSrcSpanToAnchor (UnhelpfulSpan s) = error $ "hackSrcSpanToAnchor : UnhelpfulSpan:" ++ show s -hackSrcSpanToAnchor (RealSrcSpan r Strict.Nothing) = Anchor r UnchangedAnchor -hackSrcSpanToAnchor (RealSrcSpan r (Strict.Just (BufSpan (BufPos s) (BufPos e)))) - = if s <= 0 && e <= 0 - then Anchor r (MovedAnchor (deltaPos (-s) (-e))) - else Anchor r UnchangedAnchor +-- --------------------------------------------------------------------- -hackAnchorToSrcSpan :: Anchor -> SrcSpan -hackAnchorToSrcSpan (Anchor r UnchangedAnchor) = RealSrcSpan r Strict.Nothing -hackAnchorToSrcSpan (Anchor r (MovedAnchor dp)) - = RealSrcSpan r (Strict.Just (BufSpan (BufPos s) (BufPos e))) - where - s = - (getDeltaLine dp) - e = - (deltaColumn dp) +-- |Convert a 'LHsBind' into a 'LHsDecl' +wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs +wrapDecl (L l s) = L l (ValD NoExtField s) -- --------------------------------------------------------------------- + +showAst :: (Data a) => a -> String +showAst ast + = showSDocUnsafe + $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast diff --git a/tests/PrepareHackage.hs b/tests/PrepareHackage.hs deleted file mode 100644 --- a/tests/PrepareHackage.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -- - -import Data.Char --- import Data.Monoid -import System.Directory -import System.FilePath.Posix --- import System.IO -import Test.CommonUtils -import Turtle hiding (FilePath,(<.>)) -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.IO as T - --- import qualified GHC.IO.Handle.Text as GHC - -import Test.HUnit - -main :: IO () -main = do - packages <- allCabalPackages - -- packages <- allCabalPackagesTest - myecho (T.pack $ "number of packages:" ++ (show $ length packages)) - packageDirsFull <- drop 2 <$> getDirectoryContents hackageWorkDir - let cond c = c == '.' || c == '-' || isDigit c - let packageDirs = map (T.dropWhileEnd cond . T.pack) packageDirsFull - isBadPackages <- doesFileExist badpackagesFile - badPackages <- if isBadPackages - then T.lines <$> T.readFile badpackagesFile - else return [] - let alreadyUnpacked = Set.fromList $ packageDirs ++ badPackages - _ <- shell ("mkdir -p " <> (T.pack hackageWorkDir)) empty - mapM_ (preparePackage alreadyUnpacked) packages - --- --------------------------------------------------------------------- - -preparePackage :: Set.Set Text -> Text -> IO () -preparePackage alreadyUnpacked package = do - myecho $ "preparePackage:" <> package - if Set.member package alreadyUnpacked - then myecho $ "already unpacked:" <> package - else preparePackage' package - -preparePackage' :: Text -> IO () -preparePackage' package = do - (ec,dir) <- shellStrict ("cabal get --destdir=" <> T.pack hackageWorkDir <> " " <> package) empty - myecho (T.pack $ "cabal get:" ++ show dir) - -- cabal get:"Unpacking to\n./hackage-roundtrip-work/amazonka-kinesis-video-archived-media-2.0/\n" - myecho (T.pack $ show ec) - when (ec == ExitSuccess) $ do - let bits = T.splitOn " " (last $ T.lines dir) - myecho (T.pack $ "cabal get:dir=" ++ show (last bits)) - cleanPackage (last bits) - return () - --- --------------------------------------------------------------------- - --- |Clean up whitespace in a package - -cleanPackage :: Text -> IO () -cleanPackage dir = do - myecho ("cleaning:" <> dir) - fs <- findSrcFiles (T.unpack dir) - let - doOne :: FilePath -> IO () - doOne fn = do - myecho ("doOne:" <> T.pack fn) - let tmpFn = fn <.> "clean" - clean <- cleanupWhiteSpace fn - writeFile tmpFn clean - removeFile fn - renameFile tmpFn fn - return () - mapM_ doOne fs - myecho ("cleaned up:" <> dir) - --- --------------------------------------------------------------------- --- | The computation 'writeFile' @file str@ function writes the string @str@, --- to the file @file@. --- writeFileUtf8 :: FilePath -> String -> IO () --- writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> GHC.hPutStr hdl txt) - --- --------------------------------------------------------------------- - --- allCabalPackagesTest :: IO [Text] --- allCabalPackagesTest --- = return ["3d-graphics-examples","3dmodels","4Blocks","AAI","ABList"] --- -- = return ["airship"] - - -allCabalPackages :: IO [Text] -allCabalPackages = do - -- let cmd = "cabal list --simple-output | awk '{ print $1 }' | uniq" - let cmd = "cabal list --simple-output | awk '{ print $1 }' | sort | uniq" - (_ec,r) <- shellStrict cmd empty - let packages = T.lines r - myecho (T.pack $ show $ take 5 packages) - return packages - --- --------------------------------------------------------------------- - --- |strip trailing whitespace, and turn tabs into spaces -cleanupWhiteSpace :: FilePath -> IO String -cleanupWhiteSpace file = do - contents <- readFileGhc file - let cleaned = map cleanupOneLine (lines $ contents) - return (unlines cleaned) - -tabWidth :: Int -tabWidth = 8 - --- nonBreakingSpace :: Char --- nonBreakingSpace = '\xa0' - -cleanupOneLine :: String -> String -cleanupOneLine str = str' - where - numSpacesForTab n = tabWidth - (n `mod` tabWidth) - -- loop over the line, keeping current pos. Where a tab is found, insert - -- spaces until the next tab stop. Discard any trailing whitespace. - go col res cur = - case cur of - [] -> res - ('\t':cur') -> go (col + toAdd) ((replicate toAdd ' ') ++ res) cur' - where - toAdd = numSpacesForTab col - ('\xa0':cur') -> go (col + 1) (' ':res) cur' - - -- convert ISO 8859-16 euro symbol to the UTF8 equivalent - -- ('\xa4':cur') -> go (col + 1) ('\x20ac':res) cur' - (c:cur') ->go (col + 1) (c:res) cur' - str1 = go 0 [] str - str' = reverse $ dropWhile isSpace str1 - --- --------------------------------------------------------------------- - -tt :: IO Counts -tt = runTestTT $ TestList - [ testCleanupOneLine - , testTabs - ] - -testCleanupOneLine :: Test -testCleanupOneLine = do - let - makeCase n = (show n - ,(replicate n ' ') <> "\t|" <> replicate n ' ' <> "\t" - ,(replicate 8 ' ' <> "|")) - mkTest n = TestCase $ assertEqual name outp (cleanupOneLine inp) - where (name,inp,outp) = makeCase n - testList "cleanupOneLine" $ map mkTest [1..7] - -testTabs :: Test -testTabs = TestCase $ assertEqual "testTabs" t2tabsExpected (cleanupOneLine t2tabs) - where - t2tabs = "import Data.Foldable\t\t ( foldMap )" - t2tabsExpected ="import Data.Foldable ( foldMap )" - -testList :: String -> [Test] -> Test -testList str ts = TestLabel str (TestList ts) - --- --------------------------------------------------------------------- - -myecho :: T.Text -> IO () -myecho t = mapM_ echo (textToLines t) - --- --------------------------------------------------------------------- - -pwd :: IO FilePath -pwd = getCurrentDirectory - -mcd :: FilePath -> IO () -mcd = setCurrentDirectory diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -28,25 +28,26 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC96 - | GHC98 +data GHCVersion = GHC912 + | GHC914 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion -#if MIN_VERSION_ghc(9,8,0) -ghcVersion = GHC98 +#if MIN_VERSION_ghc(9,14,0) +ghcVersion = GHC914 #else -ghcVersion = GHC96 +ghcVersion = GHC912 #endif -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs = case ghcVersion of - GHC96 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94", "ghc96"] - GHC98 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94", "ghc96", "ghc98"] - -- GHC98 -> ["ghc98"] - -- GHC98 -> ["ghc98-copied"] + GHC912 -> ["pre-ghc910", "ghc910", "ghc912"] + GHC914 -> ["pre-ghc910", "ghc910", "ghc912", "ghc914"] + -- GHC914 -> ["ghc914"] + -- GHC914 -> ["ghc914-copied"] + -- GHC914 -> ["ghc914", "ghc914-copied"] -- --------------------------------------------------------------------- @@ -60,14 +61,10 @@ then exitFailure else return () -- exitSuccess -transform :: IO () -transform = hSilence [stderr] $ do +transform :: IO (Counts,Int) +transform = do let libdir = GHC.Paths.libdir - cnts <- fst <$> runTestText (putTextToHandle stdout True) (transformTestsTT libdir) - putStrLn $ show cnts - if errors cnts > 0 || failures cnts > 0 - then exitFailure - else return () -- exitSuccess + runTestText (putTextToHandle stdout True) (transformTestsTT libdir) -- --------------------------------------------------------------------- @@ -141,25 +138,19 @@ roundTripTests <- findTests libdir roundTripBalanceCommentsTests <- findTestsBC libdir roundTripMakeDeltaTests <- findTestsMD libdir - -- prettyRoundTripTests <- findPrettyTests libdir return $ TestList [ internalTests, roundTripTests , (transformTests libdir) - , (failingTests libdir) , + (failingTests libdir) + , roundTripBalanceCommentsTests , roundTripMakeDeltaTests ] --- Tests that are no longer needed - -- , noAnnotationTests - -- , - -- prettyRoundTripTests - -- , - failingTests :: LibDir -> Test failingTests libdir = testList "Failing tests" [ @@ -167,6 +158,8 @@ -- We do not capture EOF location very well any more mkTestModBad libdir "T10970a.hs" + -- Injecting CPP comments adjacent to existing ones is a problem + , mkTestModBad libdir "CppComment.hs" ] @@ -201,24 +194,34 @@ tt' = do let libdir = GHC.Paths.libdir runTestText (putTextToHandle stdout True) $ TestList [ - -- mkParserTest libdir "ghc92" "TopLevelSemis.hs" - -- mkParserTestBC libdir "ghc92" "TopLevelSemis.hs" - -- mkParserTestMD libdir "ghc92" "TopLevelSemis.hs" - -- mkParserTest libdir "ghc96" "T11671_run.hs" + -- mkParserTest libdir "ghc98" "ModuleComments1.hs" + -- mkParserTestBC libdir "ghc98" "MonoidsFD1.hs" + -- mkParserTestMD libdir "ghc98" "ModuleComments1.hs" - -- mkParserTest libdir "ghc96" "LexerM.hs" - -- mkParserTestBC libdir "ghc96" "LexerM.hs" + -- mkParserTest libdir "ghc910" "LinearLet.hs" + -- mkParserTest libdir "ghc910" "Generic.hs" + -- mkParserTest libdir "ghc910" "Expression.hs" + -- mkParserTest libdir "ghc910" "ConstructorArgs.hs" + -- mkParserTest libdir "ghc910" "CppComment.hs" + -- mkParserTest libdir "ghc910" "Class.hs" + -- mkParserTest libdir "ghc910" "Test138.hs" + -- mkParserTest libdir "vect" "DiophantineVect.hs" - -- mkParserTest libdir "ghc94" "Haddock.hs" - -- mkParserTest libdir "ghc94" "Haddock1.hs" - -- mkParserTest libdir "ghc94" "Haddock2.hs" - -- mkParserTestBC libdir "ghc94" "Haddock1.hs" + -- mkParserTest libdir "pre-ghc910" "RandomPGC.hs" - -- mkParserTest libdir "ghc98" "IndentedModule2.hs" - mkParserTest libdir "ghc98" "ModuleComments.hs" + -- mkParserTest libdir "ghc912" "Module.hs" + -- mkParserTest libdir "ghc912" "tests.hs" + -- mkParserTestMD libdir "ghc912" "Fff.hs" + -- mkParserTestMD libdir "transform" "AddLocalDecl5.hs" + -- mkParserTestBC libdir "transform" "AddLocalDecl5.hs" + -- mkParserTestMD libdir "ghc912" "Module.hs" + -- mkParserTestMD libdir "ghc912" "Operator.hs" + -- mkParserTest libdir "pre-ghc910" "AnnPackageName.hs" + mkParserTestMD libdir "pre-ghc910" "AnnPackageName.hs" -- Needs GHC changes + ] diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs --- a/tests/Test/Common.hs +++ b/tests/Test/Common.hs @@ -36,8 +36,12 @@ import Language.Haskell.GHC.ExactPrint.Preprocess import qualified Control.Monad.IO.Class as GHC -import qualified GHC hiding (parseModule) +import GHC hiding (moduleName) +import GHC.Driver.Errors.Types import qualified GHC.Driver.Session as GHC +import GHC.Types.Error +import GHC.Utils.Error +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, vcat) import qualified GHC.LanguageExtensions as LangExt @@ -105,12 +109,10 @@ changeBalanceComments :: Changer changeBalanceComments _libdir top = do - let (GHC.L l p) = makeDeltaAst top - -- let (GHC.L l p) = top + let (GHC.L l p) = top let decls0 = GHC.hsmodDecls p - (decls,_,w) = runTransform (balanceCommentsList decls0) + decls = balanceCommentsList decls0 let p2 = p { GHC.hsmodDecls = decls} - debugM $ "changeBalanceComments:\n" ++ unlines w return (GHC.L l p2) changeMakeDelta :: Changer @@ -127,7 +129,7 @@ case res of Left m -> return . Left $ ParseFailure (showErrorMessages m) - Right (injectedComments, dflags, pmod) -> do + Right (!injectedComments, !dflags, !pmod) -> do (printed', pmod') <- GHC.liftIO (runRoundTrip libdir f pmod injectedComments) let useCpp = GHC.xopt LangExt.Cpp dflags printed = trimPrinted printed' @@ -143,6 +145,14 @@ cppStatus = if useCpp then Just orig else Nothing return $ Right Report {..} +showErrorMessages :: Messages GhcMessage -> String +showErrorMessages msgs = + renderWithContext defaultSDocContext + $ vcat + $ pprMsgEnvelopeBagWithLocDefault + $ getMessages + $ msgs + -- showErrorMessages :: Messages GhcMessage -> String -- showErrorMessages msgs = -- renderWithContext defaultSDocContext @@ -151,6 +161,7 @@ -- $ getMessages -- $ msgs + mkDebugOutput :: FilePath -> String -> String -> GHC.ParsedSource -> String mkDebugOutput filename printed original parsed = @@ -172,8 +183,10 @@ -> [GHC.LEpaComment] -> IO (String, GHC.ParsedSource) runRoundTrip libdir f !parsedOrig cs = do + -- putStrLn $ "comments:" ++ showAst cs let !parsedOrigWithComments = insertCppComments parsedOrig cs - pmod <- f libdir parsedOrigWithComments + -- putStrLn $ "parsedOrigWithComments:" ++ showAst parsedOrigWithComments + !pmod <- f libdir parsedOrigWithComments let !printed = exactPrint pmod return (printed, pmod) diff --git a/tests/Test/CommonUtils.hs b/tests/Test/CommonUtils.hs --- a/tests/Test/CommonUtils.hs +++ b/tests/Test/CommonUtils.hs @@ -22,7 +22,7 @@ ) where import Control.Monad -import Control.Monad.Extra +import GHC.Utils.Monad import Data.List hiding (find) import qualified GHC.Data.StringBuffer as GHC import System.Directory diff --git a/tests/Test/NoAnnotations.hs b/tests/Test/NoAnnotations.hs --- a/tests/Test/NoAnnotations.hs +++ b/tests/Test/NoAnnotations.hs @@ -5,26 +5,19 @@ {-# LANGUAGE TupleSections #-} module Test.NoAnnotations where --- import Control.Monad.State import Data.Algorithm.Diff import Data.Algorithm.DiffOutput --- import Data.Data (Data, toConstr, showConstr, cast) --- import Data.Generics (extQ, ext1Q, ext2Q, gmapQ) import Data.List --- import Data.Ord (comparing) --- import qualified Data.ByteString as B import Language.Haskell.GHC.ExactPrint --- import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils -import qualified GHC.Utils.Outputable as GHC import qualified Control.Monad.IO.Class as GHC import qualified GHC as GHC hiding (parseModule) --- import qualified GHC.Driver.Ppr as GHC import qualified GHC.Hs.Dump as GHC +import qualified GHC.Utils.Outputable as GHC import System.Directory import System.FilePath diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -13,7 +13,6 @@ import Language.Haskell.GHC.ExactPrint.Utils import GHC as GHC -import GHC.Data.Bag as GHC import GHC.Data.FastString as GHC import GHC.Types.Name.Occurrence as GHC import GHC.Types.Name.Reader as GHC @@ -30,7 +29,7 @@ transformTestsTT :: LibDir -> Test transformTestsTT libdir = TestLabel "transformTestsTT" $ TestList [ - mkTestModChange libdir addLocaLDecl5 "AddLocalDecl5.hs" + mkTestModChange libdir addLocaLDecl5 "AddLocalDecl5.hs" ] transformTests :: LibDir -> Test @@ -62,6 +61,7 @@ , mkTestModChange libdir changeLocalDecls "LocalDecls.hs" , mkTestModChange libdir changeLocalDecls2 "LocalDecls2.hs" , mkTestModChange libdir changeWhereIn3a "WhereIn3a.hs" + , mkTestModChange libdir changeWhereIn3b "WhereIn3b.hs" -- , mkTestModChange changeCifToCase "C.hs" "C" ] @@ -94,9 +94,8 @@ changeWhereIn3a :: Changer changeWhereIn3a _libdir (L l p) = do let decls0 = hsmodDecls p - (decls,_,w) = runTransform (balanceCommentsList decls0) + decls = balanceCommentsList decls0 (_de0:_:de1:_d2:_) = decls - debugM $ unlines w debugM $ "changeWhereIn3a:de1:" ++ showAst de1 let p2 = p { hsmodDecls = decls} return (L l p2) @@ -106,13 +105,12 @@ changeWhereIn3b :: Changer changeWhereIn3b _libdir (L l p) = do let decls0 = hsmodDecls p - (decls,_,w) = runTransform (balanceCommentsList decls0) - (de0:_:de1:d2:_) = decls + decls = balanceCommentsList decls0 + (de0:tdecls@(_:de1:d2:_)) = decls de0' = setEntryDP de0 (DifferentLine 2 0) de1' = setEntryDP de1 (DifferentLine 2 0) d2' = setEntryDP d2 (DifferentLine 2 0) - decls' = d2':de1':de0':(tail decls) - debugM $ unlines w + decls' = d2':de1':de0':tdecls debugM $ "changeWhereIn3b:de1':" ++ showAst de1' let p2 = p { hsmodDecls = decls'} return (L l p2) @@ -122,66 +120,63 @@ -- | Add a local declaration with signature to LocalDecl, where there was no -- prior local decl. So it adds a "where" annotation. changeLocalDecls2 :: Changer -changeLocalDecls2 libdir top = do +changeLocalDecls2 libdir (L l p) = do Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") - let decl' = setEntryDP (makeDeltaAst (L ld decl)) (DifferentLine 1 0) - let sig' = setEntryDP (makeDeltaAst (L ls sig)) (SameLine 2) - let (top',_,_w) = runTransform doAddLocal - doAddLocal = everywhereM (mkM replaceLocalBinds) (makeDeltaAst top) + let decl' = setEntryDP (L ld decl) (DifferentLine 1 0) + let sig' = setEntryDP (L ls sig) (SameLine 2) + let (p',_,_w) = runTransform doAddLocal + doAddLocal = everywhereM (mkM replaceLocalBinds) p replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do - newSpan <- uniqueSrcSpanT - let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2))) - let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4))) + let anc = (EpaDelta noSrcSpan (DifferentLine 1 2) []) + let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 4) []) let an = EpAnn anc - (AnnList (Just anc2) Nothing Nothing - [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] []) + (AnnList (Just anc2) ListNone + [] + (EpTok (EpaDelta noSrcSpan (SameLine 0) [])) + []) emptyComments let decls = [s,d] - let sortKey = captureOrder decls - let binds = (HsValBinds an (ValBinds sortKey (listToBag $ [decl']) + let sortKey = captureOrderBinds decls + let binds = (HsValBinds an (ValBinds sortKey [decl'] [sig'])) return (L lm (Match ma mln pats (GRHSs emptyComments rhs binds))) replaceLocalBinds x = return x - -- return (L l p') - return top' + return (L l p') -- --------------------------------------------------------------------- -- | Add a local declaration with signature to LocalDecl changeLocalDecls :: Changer -changeLocalDecls libdir top = do +changeLocalDecls libdir (L l p) = do Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - let decl' = setEntryDP (makeDeltaAst (L ld decl)) (DifferentLine 1 0) - let sig' = setEntryDP (makeDeltaAst (L ls sig)) (SameLine 0) - -- let (p',_,_w) = runTransform doAddLocal - let (top',_,_w) = runTransform doAddLocal - doAddLocal = everywhereM (mkM replaceLocalBinds) (makeDeltaAst top) + let decl' = setEntryDP (L ld decl) (DifferentLine 1 0) + let sig' = setEntryDP (L ls sig) (SameLine 0) + let (p',_,_w) = runTransform doAddLocal + doAddLocal = everywhereM (mkM replaceLocalBinds) p replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds van (ValBinds _ binds sigs))))) = do - let oldDecls = sortLocatedA $ map wrapDecl (bagToList binds) ++ map wrapSig sigs + let oldDecls = sortLocatedA $ map wrapDecl binds ++ map wrapSig sigs let decls = s:d:oldDecls let oldDecls' = captureLineSpacing oldDecls let oldBinds = concatMap decl2Bind oldDecls' (os:oldSigs) = concatMap decl2Sig oldDecls' os' = setEntryDP os (DifferentLine 2 0) - let sortKey = captureOrder decls - -- let (EpAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van - -- let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 5)))) a b c dd) cs) - let (EpAnn anc (AnnList _ a b c dd) cs) = van - let van' = (EpAnn anc (AnnList (Just (Anchor (anchor anc) (MovedAnchor (DifferentLine 1 4)))) a b c dd) cs) + let sortKey = captureOrderBinds decls + let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van + let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b c dd) cs) let binds' = (HsValBinds van' - (ValBinds sortKey - (listToBag $ decl':oldBinds) - (sig':os':oldSigs))) + (ValBinds sortKey (decl':oldBinds) + (sig':os':oldSigs))) return (L lm (Match an mln pats (GRHSs emptyComments rhs binds'))) + `debug` ("oldDecls=" ++ showAst oldDecls) replaceLocalBinds x = return x - -- return (L l p') - return top' + debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + return (L l p') -- --------------------------------------------------------------------- @@ -189,14 +184,12 @@ changeAddDecl :: Changer changeAddDecl libdir top = do Right decl <- withDynFlags libdir (\df -> parseDecl df "" "nn = n2") - -- let decl' = setEntryDP decl (DifferentLine 2 0) - let decl' = setEntryDP (makeDeltaAst decl) (DifferentLine 2 0) + let decl' = setEntryDP decl (DifferentLine 2 0) - let (p',_,_) = runTransform doAddDecl - -- doAddDecl = everywhereM (mkM replaceTopLevelDecls) (makeDeltaAst top) + let (p',_,_w) = runTransform doAddDecl doAddDecl = everywhereM (mkM replaceTopLevelDecls) top replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource - replaceTopLevelDecls m = insertAtStart m decl' + replaceTopLevelDecls m = return $ insertAtStart m decl' return p' -- --------------------------------------------------------------------- @@ -235,9 +228,9 @@ changeLayoutLet5 _libdir parsed = return (rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed) -rename :: (ExactPrint a, Data a) => String -> [(Pos, Pos)] -> a -> a +rename :: (Data a) => String -> [(Pos, Pos)] -> a -> a rename newNameStr spans' a - = everywhere (mkT replaceRdr) (makeDeltaAst a) + = everywhere (mkT replaceRdr) a where newName = mkRdrUnqual (mkVarOcc newNameStr) @@ -253,7 +246,7 @@ changeWhereIn4 :: Changer changeWhereIn4 _libdir parsed - = return (everywhere (mkT replace) (makeDeltaAst parsed)) + = return (everywhere (mkT replace) parsed) where replace :: LocatedN RdrName -> LocatedN RdrName replace (L ln _n) @@ -264,20 +257,20 @@ changeLetIn1 :: Changer changeLetIn1 _libdir parsed - = return (everywhere (mkT replace) (makeDeltaAst parsed)) + = return (everywhere (mkT replace) parsed) where replace :: HsExpr GhcPs -> HsExpr GhcPs - replace (HsLet an tkLet localDecls _ expr) + replace (HsLet (tkLet, _) localDecls expr) = - let (HsValBinds x (ValBinds xv bagDecls sigs)) = localDecls - [l2,_l1] = map wrapDecl $ bagToList bagDecls - bagDecls' = listToBag $ concatMap decl2Bind [l2] - (L (SrcSpanAnn _ le) e) = expr - a = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan le) (MovedAnchor (SameLine 1))) mempty emptyComments) le) + let (HsValBinds x (ValBinds xv decls sigs)) = localDecls + [l2,_l1] = map wrapDecl decls + bagDecls' = concatMap decl2Bind [l2] + (L _ e) = expr + a = EpAnn (EpaDelta noSrcSpan (SameLine 1) []) noAnn emptyComments expr' = L a e - tkIn' = L (TokenLoc (EpaDelta (DifferentLine 1 0) [])) HsTok - in (HsLet an tkLet - (HsValBinds x (ValBinds xv bagDecls' sigs)) tkIn' expr') + tkIn' = EpTok (EpaDelta noSrcSpan (DifferentLine 1 0) []) + in (HsLet (tkLet, tkIn') + (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') replace x = x @@ -318,16 +311,15 @@ addLocaLDecl1 libdir top = do Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let decl' = setEntryDP (L ld decl) (DifferentLine 1 5) - doAddLocal = do - let lp = makeDeltaAst top - (de1:d2:d3:_) <- hsDecls lp - (de1'',d2') <- balanceComments de1 d2 - (de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do - return ((wrapDecl decl' : d),Nothing) - replaceDecls lp [de1', d2', d3] + doAddLocal :: ParsedSource + doAddLocal = replaceDecls lp [de1', d2', d3] + where + lp = top + (de1:d2:d3:_) = hsDecls lp + (de1'',d2') = balanceComments de1 d2 + (de1',_) = modifyValD (getLocA de1'') de1'' $ \_m d -> ((wrapDecl decl' : d),Nothing) - (lp',_,w) <- runTransformT doAddLocal - debugM $ "addLocaLDecl1:" ++ intercalate "\n" w + let lp' = doAddLocal return lp' -- --------------------------------------------------------------------- @@ -336,20 +328,19 @@ addLocaLDecl2 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let - doAddLocal = do - -- (de1:d2:_) <- hsDecls (makeDeltaAst lp) - (de1:d2:_) <- hsDecls lp - (de1'',d2') <- balanceComments de1 d2 + doAddLocal = replaceDecls lp [parent',d2'] + where + (de1:d2:_) = hsDecls lp + (de1'',d2') = balanceComments de1 d2 - (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do - newDecl' <- transferEntryDP' d (makeDeltaAst newDecl) - let d' = setEntryDP d (DifferentLine 1 0) - return ((newDecl':d':ds),Nothing) + (parent',_) = modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> + let + newDecl' = transferEntryDP' d (makeDeltaAst newDecl) + d' = setEntryDP d (DifferentLine 1 0) + in ((newDecl':d':ds),Nothing) - replaceDecls lp [parent',d2'] - (lp',_,_w) <- runTransformT doAddLocal - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doAddLocal return lp' -- --------------------------------------------------------------------- @@ -358,19 +349,18 @@ addLocaLDecl3 libdir top = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let - doAddLocal = do - let lp = makeDeltaAst top - (de1:d2:_) <- hsDecls lp - (de1'',d2') <- balanceComments de1 d2 - - (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do - let newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 0) - return (((d:ds) ++ [newDecl']),Nothing) + doAddLocal = replaceDecls (anchorEof lp) [parent',d2'] + where + lp = top + (de1:d2:_) = hsDecls lp + (de1'',d2') = balanceComments de1 d2 - replaceDecls (anchorEof lp) [parent',d2'] + (parent',_) = modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> + let + newDecl' = setEntryDP newDecl (DifferentLine 1 0) + in (((d:ds) ++ [newDecl']),Nothing) - (lp',_,_w) <- runTransformT doAddLocal - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doAddLocal return lp' -- --------------------------------------------------------------------- @@ -380,19 +370,18 @@ Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let - doAddLocal = do - (parent:ds) <- hsDecls (makeDeltaAst lp) + doAddLocal = replaceDecls (anchorEof lp) (parent':ds) + where + (parent:ds) = hsDecls (makeDeltaAst lp) - let newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 0) - let newSig' = setEntryDP (makeDeltaAst newSig) (DifferentLine 1 5) + newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 0) + newSig' = setEntryDP (makeDeltaAst newSig) (DifferentLine 1 5) - (parent',_) <- modifyValD (getLocA parent) parent $ \_m decls -> do - return ((decls++[newSig',newDecl']),Nothing) + (parent',_) = modifyValD (getLocA parent) parent $ \_m decls -> + ((decls++[newSig',newDecl']),Nothing) - replaceDecls (anchorEof lp) (parent':ds) - (lp',_,_w) <- runTransformT doAddLocal - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doAddLocal return lp' -- --------------------------------------------------------------------- @@ -400,19 +389,19 @@ addLocaLDecl5 :: Changer addLocaLDecl5 _libdir lp = do let - doAddLocal = do - decls <- hsDecls (makeDeltaAst lp) - [s1,de1,d2,d3] <- balanceCommentsList decls + doAddLocal = replaceDecls lp (s1:de1':d3':ds) + where + decls = hsDecls lp + (s1:de1:d2:d3:ds) = balanceCommentsList decls - let d3' = setEntryDP d3 (DifferentLine 2 0) + d3' = setEntryDP d3 (DifferentLine 2 0) - (de1',_) <- modifyValD (getLocA de1) de1 $ \_m _decls -> do - let d2' = setEntryDP d2 (DifferentLine 1 0) - return ([d2'],Nothing) - replaceDecls lp [s1,de1',d3'] + (de1',_) = modifyValD (getLocA de1) de1 $ \_m _decls -> + let + d2' = setEntryDP d2 (DifferentLine 1 0) + in ([d2'],Nothing) - (lp',_,_w) <- runTransformT doAddLocal - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doAddLocal return lp' -- --------------------------------------------------------------------- @@ -422,36 +411,35 @@ Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3") let newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 5) - doAddLocal = do - decls0 <- hsDecls lp - [de1'',d2] <- balanceCommentsList decls0 + doAddLocal = replaceDecls lp [de1', d2] + where + decls0 = hsDecls lp + [de1'',d2] = balanceCommentsList decls0 - let de1 = captureMatchLineSpacing de1'' - let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)))) = de1 - let [ma1,_ma2] = ms + de1 = captureMatchLineSpacing de1'' + L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)))) = de1 + [ma1,_ma2] = ms - (de1',_) <- modifyValD (getLocA ma1) de1 $ \_m decls -> do - return ((newDecl' : decls),Nothing) - replaceDecls lp [de1', d2] + (de1',_) = modifyValD (getLocA ma1) de1 $ \_m decls -> + ((newDecl' : decls),Nothing) - (lp',_,_w) <- runTransformT doAddLocal - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doAddLocal return lp' -- --------------------------------------------------------------------- rmDecl1 :: Changer rmDecl1 _libdir lp = do - let doRmDecl = do - tlDecs0 <- hsDecls lp - tlDecs <- balanceCommentsList tlDecs0 - let (de1:_s1:_d2:d3:ds) = tlDecs - let d3' = setEntryDP d3 (DifferentLine 2 0) + let + doRmDecl = replaceDecls lp (de1:d3':ds) + where + tlDecs0 = hsDecls lp + tlDecs = balanceCommentsList tlDecs0 + (de1:_s1:_d2:d3:ds) = tlDecs + d3' = setEntryDP d3 (DifferentLine 2 0) - replaceDecls lp (de1:d3':ds) - (lp',_,_w) <- runTransformT doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doRmDecl return lp' -- --------------------------------------------------------------------- @@ -463,9 +451,9 @@ let go :: GHC.LHsExpr GhcPs -> Transform (GHC.LHsExpr GhcPs) go e@(GHC.L _ (GHC.HsLet{})) = do - decs0 <- hsDecls e - decs <- balanceCommentsList $ captureLineSpacing decs0 - e' <- replaceDecls e (init decs) + let decs0 = hsDecls e + let decs = balanceCommentsList $ captureLineSpacing decs0 + let e' = replaceDecls e (init decs) return e' go x = return x @@ -474,43 +462,37 @@ let (lp',_,_w) = runTransform doRmDecl debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" return lp' + -- --------------------------------------------------------------------- rmDecl3 :: Changer rmDecl3 _libdir lp = do let - doRmDecl = do - -- [de1,d2] <- hsDecls (makeDeltaAst lp) - [de1,d2] <- hsDecls lp - - (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1] -> do - let sd1' = setEntryDP sd1 (DifferentLine 2 0) - return ([],Just sd1') - - replaceDecls lp [de1',sd1,d2] + doRmDecl = replaceDecls lp [de1',sd1,d2] + where + [de1,d2] = hsDecls lp + (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a] -> + let + sd1' = setEntryDP sd1a (DifferentLine 2 0) + in ([],Just sd1') - (lp',_,_w) <- runTransformT doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doRmDecl return lp' + -- --------------------------------------------------------------------- rmDecl4 :: Changer rmDecl4 _libdir lp = do let - doRmDecl = do - let lpd = (makeDeltaAst lp) - [de1] <- hsDecls lpd - - (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> do - sd2' <- transferEntryDP' sd1 sd2 - - let sd1' = setEntryDP sd1 (DifferentLine 2 0) - return ([sd2'],Just sd1') - - replaceDecls (anchorEof lpd) [de1',sd1] - - (lp',_,_w) <- runTransformT doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + doRmDecl = replaceDecls (anchorEof lp) [de1',sd1] + where + [de1] = hsDecls lp + (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a,sd2] -> + let + sd2' = transferEntryDP' sd1a sd2 + sd1' = setEntryDP sd1a (DifferentLine 2 0) + in ([sd2'],Just sd1') + lp' = doRmDecl return lp' -- --------------------------------------------------------------------- @@ -521,12 +503,11 @@ doRmDecl = do let go :: HsExpr GhcPs -> Transform (HsExpr GhcPs) - go (HsLet a tkLet lb tkIn expr) = do - decs <- hsDeclsValBinds lb + go (HsLet (tkLet, tkIn) lb expr) = do + let decs = hsDeclsLocalBinds lb let dec = last decs - -- _ <- transferEntryDPT (head decs) dec - lb' <- replaceDeclsValbinds WithoutWhere lb [dec] - return (HsLet a tkLet lb' tkIn expr) + let lb' = replaceDeclsValbinds WithoutWhere lb [dec] + return (HsLet (tkLet, tkIn) lb' expr) go x = return x everywhereM (mkM go) lp @@ -540,70 +521,61 @@ rmDecl6 :: Changer rmDecl6 _libdir lp = do let - doRmDecl = do - [de1] <- hsDecls (makeDeltaAst lp) - - (de1',_) <- modifyValD (getLocA de1) de1 $ \_m subDecs -> do - let (ss1:_sd1:sd2:sds) = subDecs - sd2' <- transferEntryDP' ss1 sd2 - - return (sd2':sds,Nothing) + doRmDecl = replaceDecls lp [de1'] + where + [de1] = hsDecls lp - replaceDecls lp [de1'] + (de1',_) = modifyValD (getLocA de1) de1 $ \_m subDecs -> + let + subDecs' = captureLineSpacing subDecs + (ss1:_sd1:sd2:sds) = subDecs' + sd2' = transferEntryDP' ss1 sd2 + in (sd2':sds,Nothing) - (lp',_,_w) <- runTransformT doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doRmDecl return lp' + -- --------------------------------------------------------------------- rmDecl7 :: Changer rmDecl7 _libdir lp = do let - doRmDecl = do - -- tlDecs <- hsDecls (makeDeltaAst lp) - tlDecs <- hsDecls lp - [s1,de1,d2,d3] <- balanceCommentsList tlDecs - - d3' <- transferEntryDP' d2 d3 - - replaceDecls lp [s1,de1,d3'] + doRmDecl = replaceDecls lp [s1,de1,d3'] + where + tlDecs = hsDecls lp + [s1,de1,d2,d3] = balanceCommentsList tlDecs + d3' = transferEntryDP' d2 d3 - (lp',_,_w) <- runTransformT doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doRmDecl return lp' + -- --------------------------------------------------------------------- rmTypeSig1 :: Changer rmTypeSig1 _libdir lp = do - let doRmDecl = do - -- tlDecs <- hsDecls (makeDeltaAst lp) - tlDecs <- hsDecls lp - let (s0:de1:d2) = tlDecs - s1 = captureTypeSigSpacing s0 - (L l (SigD x1 (TypeSig x2 [n1,n2] typ))) = s1 - n2' <- transferEntryDP n1 n2 - let s1' = (L l (SigD x1 (TypeSig x2 [n2'] typ))) - replaceDecls lp (s1':de1:d2) + let doRmDecl = replaceDecls lp (s1':de1:d2) + where + tlDecs = hsDecls lp + (s0:de1:d2) = tlDecs + s1 = captureTypeSigSpacing s0 + (L l (SigD x1 (TypeSig x2 [n1,n2] typ))) = s1 + L ln n2' = transferEntryDP n1 n2 + s1' = (L l (SigD x1 (TypeSig x2 [L (noTrailingN ln) n2'] typ))) - let (lp',_,_w) = runTransform doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doRmDecl return lp' -- --------------------------------------------------------------------- rmTypeSig2 :: Changer rmTypeSig2 _libdir lp = do - let doRmDecl = do - -- tlDecs <- hsDecls (makeDeltaAst lp) - tlDecs <- hsDecls lp - let [de1] = tlDecs - - (de1',_) <- modifyValD (getLocA de1) de1 $ \_m [_s,d] -> do - return ([d],Nothing) - replaceDecls lp [de1'] + let doRmDecl = replaceDecls lp [de1'] + where + tlDecs = hsDecls lp + [de1] = tlDecs + (de1',_) = modifyValD (getLocA de1) de1 $ \_m [_s,d] -> ([d],Nothing) - let (lp',_,_w) = runTransform doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + let lp' = doRmDecl return lp' -- --------------------------------------------------------------------- @@ -611,50 +583,48 @@ addHiding1 :: Changer addHiding1 _libdir (L l p) = do let doTransform = do - l0 <- uniqueSrcSpanT - l1 <- uniqueSrcSpanT - l2 <- uniqueSrcSpanT let [L li imp1,imp2] = hsmodImports p - n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) - n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2")) - v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar Nothing (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1))) - v2 = L ( noAnnSrcSpanDP0 l2) (IEVar Nothing (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2))) - impHiding = L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan l0) m0) - (AnnList Nothing - (Just (AddEpAnn AnnOpenP d1)) - (Just (AddEpAnn AnnCloseP d0)) - [(AddEpAnn AnnHiding d1)] - []) - emptyComments) l0) [v1,v2] + n1 = L noAnnSrcSpanDP0 (mkVarUnqual (mkFastString "n1")) + n2 = L noAnnSrcSpanDP0 (mkVarUnqual (mkFastString "n2")) + v1 = L (addComma $ noAnnSrcSpanDP0) (IEVar Nothing (L noAnnSrcSpanDP0 (IEName noExtField n1)) Nothing) + v2 = L ( noAnnSrcSpanDP0) (IEVar Nothing (L noAnnSrcSpanDP0 (IEName noExtField n2)) Nothing) + impHiding = L (EpAnn d0 + (AnnList Nothing + (ListParens (EpTok d1) (EpTok d0)) + [] + (EpTok d1, []) + []) + emptyComments) [v1,v2] imp1' = imp1 { ideclImportList = Just (EverythingBut,impHiding)} - p' = p { hsmodImports = [L li imp1',imp2]} + imp2' = setEntryDP imp2 (DifferentLine 2 0) + p' = p { hsmodImports = [L li imp1',imp2']} return (L l p') let (lp',_,_w) = runTransform doTransform debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" return lp' + -- --------------------------------------------------------------------- addHiding2 :: Changer -addHiding2 _libdir (L l p) = do +addHiding2 _libdir top = do let doTransform = do - l1 <- uniqueSrcSpanT - l2 <- uniqueSrcSpanT + let (L l p) = top let [L li imp1] = hsmodImports p - Just (_,L lh ns) = ideclImportList imp1 - lh' = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan (locA lh)) m1) - (AnnList Nothing - (Just (AddEpAnn AnnOpenP d1)) - (Just (AddEpAnn AnnCloseP d0)) - [(AddEpAnn AnnHiding d0)] - []) - emptyComments) (locA lh)) - n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) - n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2")) - v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar Nothing (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1))) - v2 = L ( noAnnSrcSpanDP0 l2) (IEVar Nothing (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2))) + Just (_,L _lh ns) = ideclImportList imp1 + lh' = (EpAnn d0 + (AnnList Nothing + (ListParens (EpTok d1) (EpTok d0)) + [] + (EpTok d1, []) + []) + emptyComments) + n1 = L (noAnnSrcSpanDP0) (mkVarUnqual (mkFastString "n1")) + n2 = L (noAnnSrcSpanDP0) (mkVarUnqual (mkFastString "n2")) + v1 = L (addComma $ noAnnSrcSpanDP0) (IEVar Nothing (L noAnnSrcSpanDP0 (IEName noExtField n1)) Nothing) + v2 = L ( noAnnSrcSpanDP0) (IEVar Nothing (L noAnnSrcSpanDP0 (IEName noExtField n2)) Nothing) L ln n = last ns n' = L (addComma ln) n imp1' = imp1 { ideclImportList = Just (EverythingBut, L lh' (init ns ++ [n',v1,v2]))} @@ -669,15 +639,14 @@ cloneDecl1 :: Changer cloneDecl1 _libdir lp = do - let doChange = do - tlDecs <- hsDecls (makeDeltaAst lp) - let (d1':d2:ds) = tlDecs - -- d2' <- fst <$> cloneT d2 - let d2' = d2 - let d2'' = setEntryDP d2' (DifferentLine 2 0) - replaceDecls lp (d1':d2:d2'':ds) + let doChange = replaceDecls lp (d1':d2:d2'':ds) + where + tlDecs = hsDecls (makeDeltaAst lp) + (d1':d2:ds) = tlDecs + d2' = d2 + d2'' = setEntryDP d2' (DifferentLine 2 0) - let (lp',_,_w) = runTransform doChange + let lp' = doChange return lp' -- --------------------------------------------------------------------- diff --git a/tests/examples/failing/CppComment.hs b/tests/examples/failing/CppComment.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/CppComment.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +module CppComment where + +trace_options = +-- c1 +#if 0 + x +#endif + y diff --git a/tests/examples/failing/CppComment.hs.bad b/tests/examples/failing/CppComment.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/CppComment.hs.bad @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +module CppComment where + +trace_options = + +#if 0 + x +#endif + y diff --git a/tests/examples/ghc710-only/DataDecl.hs b/tests/examples/ghc710-only/DataDecl.hs deleted file mode 100644 --- a/tests/examples/ghc710-only/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/ghc710-only/HashQQ.hs b/tests/examples/ghc710-only/HashQQ.hs deleted file mode 100644 --- a/tests/examples/ghc710-only/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/ghc710-only/QuasiQuote.hs b/tests/examples/ghc710-only/QuasiQuote.hs deleted file mode 100644 --- a/tests/examples/ghc710-only/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/ghc710-only/TypeFamilies.hs b/tests/examples/ghc710-only/TypeFamilies.hs deleted file mode 100644 --- a/tests/examples/ghc710-only/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/ghc710/AddAndOr3.hs b/tests/examples/ghc710/AddAndOr3.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/AltsSemis.hs b/tests/examples/ghc710/AltsSemis.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Ann01.hs b/tests/examples/ghc710/Ann01.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/AnnPackageName.hs b/tests/examples/ghc710/AnnPackageName.hs deleted file mode 100644 --- a/tests/examples/ghc710/AnnPackageName.hs +++ /dev/null @@ -1,4 +0,0 @@ - - -import "base" Prelude -import "base" Data.Data diff --git a/tests/examples/ghc710/Annotations.hs b/tests/examples/ghc710/Annotations.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Arrow.hs b/tests/examples/ghc710/Arrow.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Arrows.hs b/tests/examples/ghc710/Arrows.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Associated.hs b/tests/examples/ghc710/Associated.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/AssociatedType.hs b/tests/examples/ghc710/AssociatedType.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/B.hs b/tests/examples/ghc710/B.hs deleted file mode 100644 --- a/tests/examples/ghc710/B.hs +++ /dev/null @@ -1,4 +0,0 @@ - -foo x = case (odd x) of - True -> "Odd" - False -> "Even" diff --git a/tests/examples/ghc710/BCase.hs b/tests/examples/ghc710/BCase.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/BIf.hs b/tests/examples/ghc710/BIf.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Backquote.hs b/tests/examples/ghc710/Backquote.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/BangPatterns.hs b/tests/examples/ghc710/BangPatterns.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/BootImport.hs b/tests/examples/ghc710/BootImport.hs deleted file mode 100644 --- a/tests/examples/ghc710/BootImport.hs +++ /dev/null @@ -1,3 +0,0 @@ -module BootImport where - -data Foo = Foo Int diff --git a/tests/examples/ghc710/BootImport.hs-boot b/tests/examples/ghc710/BootImport.hs-boot deleted file mode 100644 --- a/tests/examples/ghc710/BootImport.hs-boot +++ /dev/null @@ -1,3 +0,0 @@ -module BootImport where - -data Foo diff --git a/tests/examples/ghc710/BracesSemiDataDecl.hs b/tests/examples/ghc710/BracesSemiDataDecl.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/CExpected.hs b/tests/examples/ghc710/CExpected.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Case.hs b/tests/examples/ghc710/Case.hs deleted file mode 100644 --- a/tests/examples/ghc710/Case.hs +++ /dev/null @@ -1,5 +0,0 @@ - -foo x = case x of - True -> "a" - False -> "b" - diff --git a/tests/examples/ghc710/Cg008.hs b/tests/examples/ghc710/Cg008.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Commands.hs b/tests/examples/ghc710/Commands.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Control.hs b/tests/examples/ghc710/Control.hs deleted file mode 100644 --- a/tests/examples/ghc710/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 !Foo - | 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/CoreIr.hs b/tests/examples/ghc710/CoreIr.hs deleted file mode 100644 --- a/tests/examples/ghc710/CoreIr.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Llvm.Data.CoreIr - ( module Llvm.Data.CoreIr - , module Llvm.Data.Shared - , module Llvm.Data.IrType - , module Data.Word - , Label - ) where -import Llvm.Data.Shared -import Llvm.Data.IrType -import Compiler.Hoopl (Label) -import Data.Int -import Data.Word (Word8, Word16, Word32, Word64) -import Data.DoubleWord - -data Conversion s v where { - AddrSpaceCast :: T (Type s P) v -> Type s P -> Conversion s v; - } deriving (Eq, Ord, Show) - diff --git a/tests/examples/ghc710/CorePragma.hs b/tests/examples/ghc710/CorePragma.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Cpp.hs b/tests/examples/ghc710/Cpp.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/DataDecl.hs b/tests/examples/ghc710/DataDecl.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/DataFamilies.hs b/tests/examples/ghc710/DataFamilies.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Dead1.hs b/tests/examples/ghc710/Dead1.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Default.hs b/tests/examples/ghc710/Default.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/DefaultTypeInstance.hs b/tests/examples/ghc710/DefaultTypeInstance.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Deriving.hs b/tests/examples/ghc710/Deriving.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/DerivingOC.hs b/tests/examples/ghc710/DerivingOC.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/DoParens.hs b/tests/examples/ghc710/DoParens.hs deleted file mode 100644 --- a/tests/examples/ghc710/DoParens.hs +++ /dev/null @@ -1,4 +0,0 @@ - -foo = do - (-) <- Just 5 - return () diff --git a/tests/examples/ghc710/DoPatBind.hs b/tests/examples/ghc710/DoPatBind.hs deleted file mode 100644 --- a/tests/examples/ghc710/DoPatBind.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -bar = do - foo :: String <- baz diff --git a/tests/examples/ghc710/DocDecls.hs b/tests/examples/ghc710/DocDecls.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/DoubleForall.hs b/tests/examples/ghc710/DoubleForall.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/DroppedComma.hs b/tests/examples/ghc710/DroppedComma.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/DroppedDoSpace.hs b/tests/examples/ghc710/DroppedDoSpace.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/DroppedDoSpace2.hs b/tests/examples/ghc710/DroppedDoSpace2.hs deleted file mode 100644 --- a/tests/examples/ghc710/DroppedDoSpace2.hs +++ /dev/null @@ -1,6 +0,0 @@ - - -save state = do \fileName -> - 4 - - diff --git a/tests/examples/ghc710/EmptyMostly.hs b/tests/examples/ghc710/EmptyMostly.hs deleted file mode 100644 --- a/tests/examples/ghc710/EmptyMostly.hs +++ /dev/null @@ -1,14 +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;;;;;;;;} --- ;; - } --- really trailing diff --git a/tests/examples/ghc710/EmptyMostly2.hs b/tests/examples/ghc710/EmptyMostly2.hs deleted file mode 100644 --- a/tests/examples/ghc710/EmptyMostly2.hs +++ /dev/null @@ -1,8 +0,0 @@ -module EmptyMostly2 where - { -;;;;;;;;;;;; -; -class Baz a where {;;;;;;;;; - ; baz :: a -> Int;;; -} - } diff --git a/tests/examples/ghc710/EmptyMostlyInst.hs b/tests/examples/ghc710/EmptyMostlyInst.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/EmptyMostlyNoSemis.hs b/tests/examples/ghc710/EmptyMostlyNoSemis.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Existential.hs b/tests/examples/ghc710/Existential.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ExplicitNamespaces.hs b/tests/examples/ghc710/ExplicitNamespaces.hs deleted file mode 100644 --- a/tests/examples/ghc710/ExplicitNamespaces.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# 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 deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ExprPragmas.hs b/tests/examples/ghc710/ExprPragmas.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ExtraConstraints1.hs b/tests/examples/ghc710/ExtraConstraints1.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Field1.hs b/tests/examples/ghc710/Field1.hs deleted file mode 100644 --- a/tests/examples/ghc710/Field1.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Field1 where - ---Rename field name 'pointx' to 'pointx1' - -data Point = Pt {pointx, pointy :: Float} deriving Show - -absPoint :: Point -> Float -absPoint p = sqrt (pointx p * pointx p + - pointy p * pointy p) - diff --git a/tests/examples/ghc710/FooExpected.hs b/tests/examples/ghc710/FooExpected.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ForAll.hs b/tests/examples/ghc710/ForAll.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ForeignDecl.hs b/tests/examples/ghc710/ForeignDecl.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/FromUtils.hs b/tests/examples/ghc710/FromUtils.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/FunDeps.hs b/tests/examples/ghc710/FunDeps.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/FunctionalDeps.hs b/tests/examples/ghc710/FunctionalDeps.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/GADTRecords.hs b/tests/examples/ghc710/GADTRecords.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/GADTRecords2.hs b/tests/examples/ghc710/GADTRecords2.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/GHCOrig.hs b/tests/examples/ghc710/GHCOrig.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/GenericDeriving.hs b/tests/examples/ghc710/GenericDeriving.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Guards.hs b/tests/examples/ghc710/Guards.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Hang.hs b/tests/examples/ghc710/Hang.hs deleted file mode 100644 --- a/tests/examples/ghc710/Hang.hs +++ /dev/null @@ -1,1 +0,0 @@ -(~>) = forall diff --git a/tests/examples/ghc710/HangingRecord.hs b/tests/examples/ghc710/HangingRecord.hs deleted file mode 100644 --- a/tests/examples/ghc710/HangingRecord.hs +++ /dev/null @@ -1,5 +0,0 @@ - -data Foo = Foo - { r1 :: Int - , r2 :: Int - } diff --git a/tests/examples/ghc710/HashQQ.hs b/tests/examples/ghc710/HashQQ.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/HsDo.hs b/tests/examples/ghc710/HsDo.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/IfThenElse1.hs b/tests/examples/ghc710/IfThenElse1.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/IfThenElse2.hs b/tests/examples/ghc710/IfThenElse2.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/IfThenElse3.hs b/tests/examples/ghc710/IfThenElse3.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ImplicitParams.hs b/tests/examples/ghc710/ImplicitParams.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ImplicitSemi.hs b/tests/examples/ghc710/ImplicitSemi.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ImplicitTypeSyn.hs b/tests/examples/ghc710/ImplicitTypeSyn.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Imports.hs b/tests/examples/ghc710/Imports.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ImportsSemi.hs b/tests/examples/ghc710/ImportsSemi.hs deleted file mode 100644 --- a/tests/examples/ghc710/ImportsSemi.hs +++ /dev/null @@ -1,6 +0,0 @@ -module ImportsSemi where -{ -; ; ; ; ; ; -import Data.List -;;; -} diff --git a/tests/examples/ghc710/IndentedDo.hs b/tests/examples/ghc710/IndentedDo.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Infix.hs b/tests/examples/ghc710/Infix.hs deleted file mode 100644 --- a/tests/examples/ghc710/Infix.hs +++ /dev/null @@ -1,8 +0,0 @@ - -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 deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/InlineSemi.hs b/tests/examples/ghc710/InlineSemi.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Internals.hs b/tests/examples/ghc710/Internals.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Jon.hs b/tests/examples/ghc710/Jon.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/LambdaCase.hs b/tests/examples/ghc710/LambdaCase.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/LayoutLet.hs b/tests/examples/ghc710/LayoutLet.hs deleted file mode 100644 --- a/tests/examples/ghc710/LayoutLet.hs +++ /dev/null @@ -1,7 +0,0 @@ - -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 deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/LetExpr.hs b/tests/examples/ghc710/LetExpr.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/LetExpr2.hs b/tests/examples/ghc710/LetExpr2.hs deleted file mode 100644 --- a/tests/examples/ghc710/LetExpr2.hs +++ /dev/null @@ -1,4 +0,0 @@ -l z = - let - ll = 34 - in ll + z diff --git a/tests/examples/ghc710/LetExprSemi.hs b/tests/examples/ghc710/LetExprSemi.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/LetStmt.hs b/tests/examples/ghc710/LetStmt.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/LiftedInfixConstructor.hs b/tests/examples/ghc710/LiftedInfixConstructor.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/LinePragma.hs b/tests/examples/ghc710/LinePragma.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ListComprehensions.hs b/tests/examples/ghc710/ListComprehensions.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/LocalDecls2Expected.hs b/tests/examples/ghc710/LocalDecls2Expected.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/MachineTypes.hs b/tests/examples/ghc710/MachineTypes.hs deleted file mode 100644 --- a/tests/examples/ghc710/MachineTypes.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -- Safe if eliminate GeneralizedNewtypeInstance -{-# LANGUAGE Arrows #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module - Control.Arrow.Machine.Types -where - -import qualified Control.Category as Cat -import Data.Profunctor (Profunctor, dimap, rmap) -import Control.Arrow -import Control.Monad -import Control.Monad.Trans -import Control.Monad.State -import Control.Monad.Reader -import Control.Monad.Writer hiding ((<>)) -import Control.Monad.Identity -import Control.Applicative -import Data.Foldable as Fd -import Data.Traversable as Tv -import Data.Semigroup (Semigroup, (<>)) -import Data.Maybe (fromMaybe, isNothing, isJust) -import qualified Control.Monad.Trans.Free as F -import qualified Control.Monad.Trans.Free.Church as F -import Control.Arrow.Machine.ArrowUtil -import GHC.Exts (build) - - --- | To get multiple outputs by one input, the `Phase` parameter is introduced. --- --- Once a value `Feed`ed, the machine is `Sweep`ed until it `Suspend`s. -data Phase = Feed | Sweep | Suspend deriving (Eq, Show) - -instance - Monoid Phase - where - mempty = Sweep - - mappend Feed _ = Feed - mappend _ Feed = Feed - mappend Suspend _ = Suspend - mappend _ Suspend = Suspend - mappend Sweep Sweep = Sweep - - -type ProcType a b c = ProcessA a b c - --- | The stream transducer arrow. --- --- To construct `ProcessA` instances, use `Control.Arrow.Machine.Plan.Plan`, --- `arr`, functions declared in `Control.Arrow.Machine.Utils`, --- or arrow combinations of them. --- --- See an introduction at "Control.Arrow.Machine" documentation. -data ProcessA a b c = ProcessA { - feed :: a b (c, ProcessA a b c), - sweep :: a b (Maybe c, ProcessA a b c), - suspend :: !(b -> c) - } - - --- For internal use -class - (Applicative f, Monad f) => ProcessHelper f - where - step :: ArrowApply a => ProcessA a b c -> a b (f c, ProcessA a b c) - helperToMaybe :: f a -> Maybe a - weakly :: a -> f a - - step' :: ArrowApply a => ProcessA a b c -> a (f b) (f c, ProcessA a b c) - step' pa = proc hx -> - do - let mx = helperToMaybe hx - maybe - (arr $ const (suspend pa <$> hx, pa)) - (\x -> proc _ -> step pa -< x) - mx - -<< () - diff --git a/tests/examples/ghc710/MagicHash.hs b/tests/examples/ghc710/MagicHash.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/MangledSemiLet.hs b/tests/examples/ghc710/MangledSemiLet.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Minimal.hs b/tests/examples/ghc710/Minimal.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Mixed.hs b/tests/examples/ghc710/Mixed.hs deleted file mode 100644 --- a/tests/examples/ghc710/Mixed.hs +++ /dev/null @@ -1,50 +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 - , Integer -> Integer #-} -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 - {-# Specialise instance Num (Int,Int) #-} - 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/ModuleOnly.hs b/tests/examples/ghc710/ModuleOnly.hs deleted file mode 100644 --- a/tests/examples/ghc710/ModuleOnly.hs +++ /dev/null @@ -1,1 +0,0 @@ -module ModuleOnly where diff --git a/tests/examples/ghc710/MonadComprehensions.hs b/tests/examples/ghc710/MonadComprehensions.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Move1.hs b/tests/examples/ghc710/Move1.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/MultiImplicitParams.hs b/tests/examples/ghc710/MultiImplicitParams.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/MultiLineCommentWithPragmas.hs b/tests/examples/ghc710/MultiLineCommentWithPragmas.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/MultiParamTypeClasses.hs b/tests/examples/ghc710/MultiParamTypeClasses.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/MultiWayIf.hs b/tests/examples/ghc710/MultiWayIf.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/NestedDoLambda.hs b/tests/examples/ghc710/NestedDoLambda.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/NestedLambda.hs b/tests/examples/ghc710/NestedLambda.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/NullaryTypeClasses.hs b/tests/examples/ghc710/NullaryTypeClasses.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Obscure.hs b/tests/examples/ghc710/Obscure.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/OptSig.hs b/tests/examples/ghc710/OptSig.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/OptSig2.hs b/tests/examples/ghc710/OptSig2.hs deleted file mode 100644 --- a/tests/examples/ghc710/OptSig2.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -errors= do - let ls :: Int = undefined - return () diff --git a/tests/examples/ghc710/OveridingPrimitives.hs b/tests/examples/ghc710/OveridingPrimitives.hs deleted file mode 100644 --- a/tests/examples/ghc710/OveridingPrimitives.hs +++ /dev/null @@ -1,7 +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/ghc710/OverloadedStrings.hs b/tests/examples/ghc710/OverloadedStrings.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/PArr.hs b/tests/examples/ghc710/PArr.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ParensAroundContext.hs b/tests/examples/ghc710/ParensAroundContext.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/PatBind.hs b/tests/examples/ghc710/PatBind.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/PatSigBind.hs b/tests/examples/ghc710/PatSigBind.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/PatSynBind.hs b/tests/examples/ghc710/PatSynBind.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/PatternGuards.hs b/tests/examples/ghc710/PatternGuards.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Ppr006a.hs b/tests/examples/ghc710/Ppr006a.hs deleted file mode 100644 --- a/tests/examples/ghc710/Ppr006a.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Ppr006a where - -commands :: [Command] -commands = [ - command "novisual" "cancel visual selection" $ - sendEventCurrent EvNoVisual - - -- 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 - - ] - diff --git a/tests/examples/ghc710/ProcNotation.hs b/tests/examples/ghc710/ProcNotation.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Process.hs b/tests/examples/ghc710/Process.hs deleted file mode 100644 --- a/tests/examples/ghc710/Process.hs +++ /dev/null @@ -1,717 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -module Synthesizer.MIDI.CausalIO.Process ( - Events, - - slice, - controllerLinear, - controllerExponential, - pitchBend, - channelPressure, - bendWheelPressure, - constant, - - Instrument, - Bank, - GateChunk, - noteEvents, - embedPrograms, - applyInstrument, - applyModulatedInstrument, - flattenControlSchedule, - applyModulation, - arrangeStorable, - sequenceCore, - sequenceModulated, - sequenceModulatedMultiProgram, - sequenceModulatedMultiProgramVelocityPitch, - sequenceStorable, - - -- auxiliary function - initWith, - mapMaybe, - ) where - -import qualified Synthesizer.CausalIO.Gate as Gate -import qualified Synthesizer.CausalIO.Process as PIO - -import qualified Synthesizer.MIDI.Value.BendModulation as BM -import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP -import qualified Synthesizer.MIDI.Value as MV - -import qualified Synthesizer.MIDI.EventList as MIDIEv -import Synthesizer.MIDI.EventList (StrictTime, ) - -import qualified Synthesizer.PiecewiseConstant.Signal as PC -import qualified Synthesizer.Storable.Cut as CutSt -import qualified Synthesizer.Generic.Cut as CutG -import qualified Synthesizer.Zip as Zip - -import qualified Sound.MIDI.Message.Class.Check as Check -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg - -import Control.DeepSeq (rnf, ) - -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.BodyTime as EventListBT -import qualified Data.EventList.Relative.TimeTime as EventListTT -import qualified Data.EventList.Relative.TimeMixed as EventListTM -import qualified Data.EventList.Relative.MixedTime as EventListMT -import qualified Data.EventList.Absolute.TimeBody as AbsEventList - -import qualified Numeric.NonNegative.Wrapper as NonNegW -import qualified Numeric.NonNegative.Class as NonNeg - -import qualified Algebra.Transcendental as Trans -import qualified Algebra.RealRing as RealRing -import qualified Algebra.Field as Field -import qualified Algebra.Additive as Additive -import qualified Algebra.ToInteger as ToInteger - -import qualified Data.StorableVector as SV -import qualified Data.StorableVector.ST.Strict as SVST -import Foreign.Storable (Storable, ) - -import qualified Control.Monad.Trans.Writer as MW -import qualified Control.Monad.Trans.State as MS -import qualified Control.Monad.Trans.Class as MT -import Control.Monad.IO.Class (liftIO, ) - -import qualified Data.Traversable as Trav -import Data.Traversable (Traversable, ) -import Data.Foldable (traverse_, ) - -import Control.Arrow (Arrow, arr, (^<<), (<<^), ) -import Control.Category ((.), ) - -import qualified Data.Map as Map - -import qualified Data.List.HT as ListHT -import qualified Data.Maybe as Maybe -import Data.Monoid (Monoid, mempty, mappend, ) -import Data.Maybe (maybeToList, ) -import Data.Tuple.HT (mapFst, mapPair, ) - -import NumericPrelude.Numeric -import NumericPrelude.Base hiding ((.), sequence, ) -import Prelude () - - -type Events event = EventListTT.T StrictTime [event] - - -initWith :: - (y -> c) -> - c -> - PIO.T - (Events y) - (EventListBT.T PC.ShortStrictTime c) -initWith f initial = - PIO.traverse initial $ - \evs0 -> do - y0 <- MS.get - fmap (PC.subdivideLongStrict . EventListMT.consBody y0) $ - Trav.traverse (\ys -> traverse_ (MS.put . f) ys >> MS.get) evs0 - -slice :: - (Check.C event) => - (event -> Maybe Int) -> - (Int -> y) -> y -> - PIO.T - (Events event) - (EventListBT.T PC.ShortStrictTime y) -slice select f initial = - initWith f initial . mapMaybe select - - - -mapMaybe :: - (Arrow arrow, Functor f) => - (a -> Maybe b) -> - arrow (f [a]) (f [b]) -mapMaybe f = - arr $ fmap $ Maybe.mapMaybe f - -catMaybes :: - (Arrow arrow, Functor f) => - arrow (f [Maybe a]) (f [a]) -catMaybes = - arr $ fmap Maybe.catMaybes - -traverse :: - (Traversable f) => - s -> (a -> MS.State s b) -> - PIO.T (f [a]) (f [b]) -traverse initial f = - PIO.traverse initial (Trav.traverse (Trav.traverse f)) - - -controllerLinear :: - (Check.C event, Field.C y) => - MIDIEv.Channel -> - MIDIEv.Controller -> - (y,y) -> y -> - PIO.T - (Events event) - (EventListBT.T PC.ShortStrictTime y) -controllerLinear chan ctrl bnd initial = - slice (Check.controller chan ctrl) - (MV.controllerLinear bnd) initial - -controllerExponential :: - (Check.C event, Trans.C y) => - MIDIEv.Channel -> - MIDIEv.Controller -> - (y,y) -> y -> - PIO.T - (Events event) - (EventListBT.T PC.ShortStrictTime y) -controllerExponential chan ctrl bnd initial = - slice (Check.controller chan ctrl) - (MV.controllerExponential bnd) initial - -pitchBend :: - (Check.C event, Trans.C y) => - MIDIEv.Channel -> - y -> y -> - PIO.T - (Events event) - (EventListBT.T PC.ShortStrictTime y) -pitchBend chan range center = - slice (Check.pitchBend chan) - (MV.pitchBend range center) center - -channelPressure :: - (Check.C event, Trans.C y) => - MIDIEv.Channel -> - y -> y -> - PIO.T - (Events event) - (EventListBT.T PC.ShortStrictTime y) -channelPressure chan maxVal initial = - slice (Check.channelPressure chan) - (MV.controllerLinear (zero,maxVal)) initial - -bendWheelPressure :: - (Check.C event, RealRing.C y, Trans.C y) => - MIDIEv.Channel -> - Int -> y -> y -> - PIO.T - (Events event) - (EventListBT.T PC.ShortStrictTime (BM.T y)) -bendWheelPressure chan - pitchRange wheelDepth pressDepth = - let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth - in initWith toBM (toBM BWP.deflt) - . - catMaybes - . - traverse BWP.deflt (BWP.check chan) - - --- might be moved to synthesizer-core -constant :: - (Arrow arrow) => - y -> arrow (Events event) (EventListBT.T PC.ShortStrictTime y) -constant y = arr $ - EventListBT.singleton y . - NonNegW.fromNumberMsg "MIDI.CausalIO.constant" . - fromIntegral . - EventListTT.duration - -_constant :: - (Arrow arrow, CutG.Read input) => - y -> arrow input (EventListBT.T PC.ShortStrictTime y) -_constant y = arr $ - EventListBT.singleton y . - NonNegW.fromNumberMsg "MIDI.CausalIO.constant" . - CutG.length - - - -noteEvents :: - (Check.C event, Arrow arrow) => - MIDIEv.Channel -> - arrow - (Events event) - (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool))) -noteEvents chan = - mapMaybe $ MIDIEv.checkNoteEvent chan - - -embedPrograms :: - MIDIEv.Program -> - PIO.T - (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool))) - (Events (MIDIEv.NoteBoundary (Maybe MIDIEv.Program))) -embedPrograms initPgm = - catMaybes . - traverse initPgm MIDIEv.embedProgramState - - -type GateChunk = Gate.Chunk MIDIEv.Velocity -type Instrument y chunk = y -> y -> PIO.T GateChunk chunk -type Bank y chunk = MIDIEv.Program -> Instrument y chunk - - - -{- -for distinction of notes with the same pitch - -We must use Integer instead of Int, in order to avoid an overflow -that would invalidate the check for unmatched NoteOffs -that is based on comparison of the NoteIds. -We cannot re-use NoteIds easily, -since the events at one time point are handled out of order. --} -newtype NoteId = NoteId Integer - deriving (Show, Eq, Ord) - -succNoteId :: NoteId -> NoteId -succNoteId (NoteId n) = NoteId (n+1) - -flattenNoteIdRange :: (NoteId,NoteId) -> [NoteId] -flattenNoteIdRange (start,afterEnd) = - takeWhile ( rnf (NonNegW.toNumber t)) . - unwrapNoteOffList - -instance Monoid NoteOffList where - mempty = NoteOffList (EventListTT.pause mempty) - mappend (NoteOffList xs) (NoteOffList ys) = - NoteOffList (mappend xs ys) - -{- | -The function defined here are based on the interpretation -of event lists as piecewise constant signals. -They do not fit to the interpretation of atomic events. -Because e.g. it makes no sense to split an atomic event into two instances by splitAt, -and it is also not clear, whether dropping the first chunk -shall leave a chunk of length zero -or remove that chunk completely. --} -instance CutG.Transform NoteOffList where - take n (NoteOffList xs) = - NoteOffList $ - EventListTT.takeTime - (NonNegW.fromNumberMsg "NoteOffList.take" $ fromIntegral n) xs - drop n (NoteOffList xs) = - NoteOffList $ - EventListTT.dropTime - (NonNegW.fromNumberMsg "NoteOffList.drop" $ fromIntegral n) xs - splitAt n (NoteOffList xs) = - mapPair (NoteOffList, NoteOffList) $ - EventListTT.splitAtTime - (NonNegW.fromNumberMsg "NoteOffList.splitAtTime" $ fromIntegral n) xs - - -- cf. ChunkySize.dropMarginRem - dropMarginRem = - CutG.dropMarginRemChunky - (fmap fromIntegral . EventListTT.getTimes . unwrapNoteOffList) - - reverse (NoteOffList xs) = - NoteOffList . EventListTT.reverse $ xs - - -findEvent :: - (a -> Bool) -> - Events a -> (Events a, Maybe a) -findEvent p = - EventListTT.foldr - (\t -> mapFst (EventListMT.consTime t)) - (\evs rest -> - case ListHT.break p evs of - (prefix, suffix) -> - mapFst (EventListMT.consBody prefix) $ - case suffix of - [] -> rest - ev:_ -> (EventListTT.pause mempty, Just ev)) - (EventListBT.empty, Nothing) - -gateFromNoteOffs :: - (MIDIEv.Pitch, NoteId) -> - NoteOffList -> - GateChunk -gateFromNoteOffs pitchNoteId (NoteOffList noteOffs) = - let dur = EventListTT.duration noteOffs - (sustain, mEnd) = - findEvent - (\bnd -> - case bnd of - -- AllNotesOff -> True - NoteBoundary endPitch _ noteId -> - pitchNoteId == (endPitch, noteId)) - noteOffs - in Gate.chunk dur $ - flip fmap mEnd $ \end -> - (EventListTT.duration sustain, - case end of - NoteBoundary _ endVel _ -> endVel - {- - AllNotesOff -> VoiceMsg.normalVelocity -} ) - - -data NoteBoundary a = - NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a --- | AllSoundOff - deriving (Eq, Show) - -{- | -We count NoteIds per pitch, -such that the pair (pitch,noteId) identifies a note. -We treat nested notes in a first-in-first-out order (FIFO). -E.g. - -> On, On, On, Off, Off, Off - -is interpreted as - -> On 0, On 1, On 2, Off 0, Off 1, Off 2 - -NoteOffs without previous NoteOns are thrown away. --} -assignNoteIds :: - (Traversable f) => - PIO.T - (f [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)]) - (f [NoteBoundary (NoteId, Maybe MIDIEv.Program)]) -assignNoteIds = - fmap concat - ^<< - traverse Map.empty (\bnd -> - case bnd of - MIDIEv.AllNotesOff -> do - notes <- MS.get - MS.put Map.empty - return $ - concatMap (\(pitch, range) -> - map - (\noteId -> - NoteBoundary pitch VoiceMsg.normalVelocity - (noteId, Nothing)) - (flattenNoteIdRange range)) $ - Map.toList notes - MIDIEv.NoteBoundary pitch vel mpgm -> - fmap (fmap (\noteId -> - NoteBoundary pitch vel (noteId,mpgm))) $ - case mpgm of - Nothing -> do - mNoteId <- MS.gets (Map.lookup pitch) - case mNoteId of - Nothing -> return [] - Just (nextNoteOffId, nextNoteOnId) -> - if nextNoteOffId >= nextNoteOnId - then return [] - else do - MS.modify (Map.insert pitch (succNoteId nextNoteOffId, nextNoteOnId)) - return [nextNoteOffId] - Just _ -> do - mNoteId <- MS.gets (Map.lookup pitch) - let (nextNoteOffId, nextNoteOnId) = - case mNoteId of - Nothing -> (NoteId 0, NoteId 0) - Just ids -> ids - - MS.modify (Map.insert pitch (nextNoteOffId, succNoteId nextNoteOnId)) - return [nextNoteOnId]) - -{-# INLINE velFreqBank #-} -velFreqBank :: - (Trans.C y) => - (MIDIEv.Program -> y -> y -> process) -> - (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> process) -velFreqBank bank pgm vel pitch = - bank pgm (MV.velocity vel) (MV.frequencyFromPitch pitch) - -applyInstrumentCore :: - (Arrow arrow) => - ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) -> - (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> - PIO.T gateCtrl chunk) -> - arrow - (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) - (Zip.T - NoteOffList - (Events (PIO.T noteOffListCtrl chunk))) -applyInstrumentCore makeGate bank = arr $ - uncurry Zip.Cons . - mapFst NoteOffList . - EventListTT.unzip . - fmap (ListHT.unzipEithers . fmap (\ev -> - case ev of --- MIDIEv.AllNotesOff -> Left MIDIEv.AllNotesOff - NoteBoundary pitch vel (noteId, mpgm) -> - case mpgm of - Nothing -> Left $ NoteBoundary pitch vel noteId - Just pgm -> - Right $ - bank pgm vel pitch - <<^ - makeGate (pitch, noteId))) - -applyInstrument :: - (Arrow arrow) => - (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> - PIO.T GateChunk chunk) -> - arrow - (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) - (Zip.T - NoteOffList - (Events (PIO.T NoteOffList chunk))) -applyInstrument bank = - applyInstrumentCore gateFromNoteOffs bank - - -type ModulatedBank y ctrl chunk = - MIDIEv.Program -> y -> y -> - PIO.T (Zip.T GateChunk ctrl) chunk - -applyModulatedInstrument :: - (Arrow arrow, CutG.Read ctrl) => - (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> - PIO.T (Zip.T GateChunk ctrl) chunk) -> - arrow - (Zip.T - (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) - ctrl) - (Zip.T - (Zip.T NoteOffList ctrl) - (Events (PIO.T (Zip.T NoteOffList ctrl) chunk))) -applyModulatedInstrument bank = - (\(Zip.Cons (Zip.Cons noteOffs events) ctrl) -> - Zip.Cons (Zip.Cons noteOffs ctrl) events) - ^<< - Zip.arrowFirst - (applyInstrumentCore - (Zip.arrowFirst . gateFromNoteOffs) bank) - - -{- | -Turn an event list with bundles of elements -into an event list with single events. -ToDo: Move to event-list package? --} -flatten :: - (NonNeg.C time) => - a -> - EventListTT.T time [a] -> - EventListTT.T time a -flatten empty = - EventListTT.foldr - EventListMT.consTime - (\bt xs -> - uncurry EventListMT.consBody $ - case bt of - [] -> (empty, xs) - b:bs -> (b, foldr (\c rest -> EventListTT.cons NonNeg.zero c rest) xs bs)) - EventListBT.empty - - -flattenControlSchedule :: - (Monoid chunk, Arrow arrow) => - arrow - (Zip.T ctrl - (EventListTT.T StrictTime [PIO.T ctrl chunk])) - (Zip.T ctrl - (EventListTT.T StrictTime (PIO.T ctrl chunk))) -flattenControlSchedule = arr $ - \(Zip.Cons ctrl evs) -> - -- Zip.consChecked "flattenControlSchedule" ctrl $ - Zip.Cons ctrl $ - flatten (arr (const mempty)) evs - - - -data CausalState a b = - forall state. - CausalState - (a -> state -> IO (b, state)) - (state -> IO ()) - state - -_applyChunkSimple :: CausalState a b -> a -> IO (b, CausalState a b) -_applyChunkSimple (CausalState next delete state0) input = do - (output, state1) <- next input state0 - return (output, CausalState next delete state1) - -applyChunk :: - (CutG.Read a, CutG.Read b) => - CausalState a b -> a -> IO (b, Maybe (CausalState a b)) -applyChunk (CausalState next delete state0) input = do - (output, state1) <- next input state0 - cs <- - if CutG.length output < CutG.length input - then do - delete state1 - return Nothing - else return $ Just $ CausalState next delete state1 - return (output, cs) - --- could be moved to synthesizer-core -applyModulation :: - (CutG.Transform ctrl, CutG.NormalForm ctrl, - CutG.Read chunk, - Monoid time, ToInteger.C time) => - PIO.T - (Zip.T ctrl (EventListTT.T time (PIO.T ctrl chunk))) - (EventListTT.T time chunk) -applyModulation = PIO.Cons - (\(Zip.Cons ctrl evs) acc0 -> do - acc1 <- mapM (flip applyChunk ctrl) acc0 - let (accChunks, acc2) = unzip acc1 - - (newChunks, newAcc) <- - MW.runWriterT $ - flip MS.evalStateT ctrl $ - EventListTT.mapM - (\time -> do - ctrl_ <- MS.gets (CutG.drop (fromIntegral time)) - MS.put ctrl_ - return (case CutG.evaluateHead ctrl_ of () -> time)) - (\(PIO.Cons next create delete) -> do - state0 <- liftIO create - (chunk, state1) <- - liftIO . applyChunk (CausalState next delete state0) - =<< MS.get - MT.lift $ MW.tell $ maybeToList state1 - return chunk) - evs - - return - (EventListTM.prependBodyEnd - (EventList.fromPairList $ - map ((,) mempty) accChunks) - newChunks, - Maybe.catMaybes acc2 ++ newAcc)) - - (return []) - (mapM_ (\(CausalState _ close state) -> close state)) - --- move synthesizer-core:CausalIO -arrangeStorable :: - (Arrow arrow, Storable a, Additive.C a) => - arrow - (EventListTT.T StrictTime (SV.Vector a)) - (SV.Vector a) -arrangeStorable = - arr $ \evs -> - SVST.runSTVector (do - v <- SVST.new (fromIntegral $ EventListTT.duration evs) zero - mapM_ (uncurry $ CutSt.addChunkToBuffer v) $ - AbsEventList.toPairList $ - AbsEventList.mapTime fromIntegral $ - EventList.toAbsoluteEventList 0 $ - EventListTM.switchTimeR const evs - return v) - - - -sequenceCore :: - (Check.C event, Monoid chunk, CutG.Read chunk, Trans.C y) => - MIDIEv.Channel -> - Bank y chunk -> - PIO.T (Events event) (EventListTT.T StrictTime chunk) -sequenceCore channel bank = - applyModulation - . - flattenControlSchedule - . - applyInstrument (velFreqBank bank) - . - assignNoteIds - . - embedPrograms (VoiceMsg.toProgram 0) - . - noteEvents channel - - -sequenceModulated :: - (Check.C event, Monoid chunk, CutG.Read chunk, - CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) => - MIDIEv.Channel -> - ModulatedBank y ctrl chunk -> - PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk) -sequenceModulated channel bank = - applyModulation - . - flattenControlSchedule - . - applyModulatedInstrument (velFreqBank bank) - . - Zip.arrowFirst - (assignNoteIds - . - embedPrograms (VoiceMsg.toProgram 0) - . - noteEvents channel) - - -sequenceModulatedMultiProgram :: - (Check.C event, Monoid chunk, CutG.Read chunk, - CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) => - MIDIEv.Channel -> - MIDIEv.Program -> - ModulatedBank y ctrl chunk -> - PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk) -sequenceModulatedMultiProgram channel initPgm bank = - applyModulation - . - flattenControlSchedule - . - applyModulatedInstrument (velFreqBank bank) - . - Zip.arrowFirst - (assignNoteIds - . - embedPrograms initPgm - . - noteEvents channel) - - --- | may replace the other functions -sequenceModulatedMultiProgramVelocityPitch :: - (Check.C event, Monoid chunk, CutG.Read chunk, - CutG.Transform ctrl, CutG.NormalForm ctrl) => - MIDIEv.Channel -> - MIDIEv.Program -> - (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> - PIO.T (Zip.T GateChunk ctrl) chunk) -> - PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk) -sequenceModulatedMultiProgramVelocityPitch channel initPgm bank = - applyModulation - . - flattenControlSchedule - . - applyModulatedInstrument bank - . - Zip.arrowFirst - (assignNoteIds - . - embedPrograms initPgm - . - noteEvents channel) - - -sequenceStorable :: - (Check.C event, Storable a, Additive.C a, Trans.C y) => - MIDIEv.Channel -> - Bank y (SV.Vector a) -> - PIO.T (Events event) (SV.Vector a) -sequenceStorable channel bank = - arrangeStorable - . - sequenceCore channel bank diff --git a/tests/examples/ghc710/Process1.hs b/tests/examples/ghc710/Process1.hs deleted file mode 100644 --- a/tests/examples/ghc710/Process1.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Synthesizer.MIDI.CausalIO.Process1 where - -gateFromNoteOffs= - let dur = 1 - in (d, 3 - {- - AllNotesOff -> VoiceMsg.normalVelocity -} ) diff --git a/tests/examples/ghc710/Pseudonym.hs b/tests/examples/ghc710/Pseudonym.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/PuncFunctions.hs b/tests/examples/ghc710/PuncFunctions.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/QuasiQuote.hs b/tests/examples/ghc710/QuasiQuote.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/QuasiQuote2.hs b/tests/examples/ghc710/QuasiQuote2.hs deleted file mode 100644 --- a/tests/examples/ghc710/QuasiQuote2.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Test where - -a = bar - where - bar = [q| - |] - -b = bar - where - bar = [q| - |] - -c = bar - where - bar = [q| - |] - -d = [q| - |] diff --git a/tests/examples/ghc710/RSA.hs b/tests/examples/ghc710/RSA.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/RankNTypes.hs b/tests/examples/ghc710/RankNTypes.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/RdrNames.hs b/tests/examples/ghc710/RdrNames.hs deleted file mode 100644 --- a/tests/examples/ghc710/RdrNames.hs +++ /dev/null @@ -1,149 +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 ( ~ ) 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] } - --- --------------------------------------------------------------------- - - -{- From #haskell-emacs -gracjan> did you know that this is legal haskell: - (+ 1) ` fmap {- -} ` [1,2,3] --} -xxx = (+ 1) ` fmap {- -} ` [1,2,3] diff --git a/tests/examples/ghc710/RebindableSyntax.hs b/tests/examples/ghc710/RebindableSyntax.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/RecordSemi.hs b/tests/examples/ghc710/RecordSemi.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/RecordUpdate.hs b/tests/examples/ghc710/RecordUpdate.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/RecordWildcard.hs b/tests/examples/ghc710/RecordWildcard.hs deleted file mode 100644 --- a/tests/examples/ghc710/RecordWildcard.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - - -parseArgs = - Args - { equalProb = E `elem` opts - , .. - } diff --git a/tests/examples/ghc710/RecursiveDo.hs b/tests/examples/ghc710/RecursiveDo.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/RedundantDo.hs b/tests/examples/ghc710/RedundantDo.hs deleted file mode 100644 --- a/tests/examples/ghc710/RedundantDo.hs +++ /dev/null @@ -1,4 +0,0 @@ -foo = - case x of - True -> foo - False -> foo diff --git a/tests/examples/ghc710/Remorse.hs b/tests/examples/ghc710/Remorse.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Roles.hs b/tests/examples/ghc710/Roles.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Rules.hs b/tests/examples/ghc710/Rules.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/RulesSemi.hs b/tests/examples/ghc710/RulesSemi.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ScopedTypeVariables.hs b/tests/examples/ghc710/ScopedTypeVariables.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/SemiInstance.hs b/tests/examples/ghc710/SemiInstance.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/SemiWorkout.hs b/tests/examples/ghc710/SemiWorkout.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Shebang.hs b/tests/examples/ghc710/Shebang.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ShiftingLambda.hs b/tests/examples/ghc710/ShiftingLambda.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Sigs.hs b/tests/examples/ghc710/Sigs.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Simple.hs b/tests/examples/ghc710/Simple.hs deleted file mode 100644 --- a/tests/examples/ghc710/Simple.hs +++ /dev/null @@ -1,12 +0,0 @@ - --- blah -x :: (Int) -x = 1 - -(y) = 1 - -z :: t -z = do - let - a = 1 - return a diff --git a/tests/examples/ghc710/SimpleComplexTuple.hs b/tests/examples/ghc710/SimpleComplexTuple.hs deleted file mode 100644 --- a/tests/examples/ghc710/SimpleComplexTuple.hs +++ /dev/null @@ -1,3 +0,0 @@ - - -foo ((-),(.))= (5,6) diff --git a/tests/examples/ghc710/SimpleDo.hs b/tests/examples/ghc710/SimpleDo.hs deleted file mode 100644 --- a/tests/examples/ghc710/SimpleDo.hs +++ /dev/null @@ -1,4 +0,0 @@ - -foo = do - let x = 1 -- a comment - return x diff --git a/tests/examples/ghc710/SlidingDataClassDecl.hs b/tests/examples/ghc710/SlidingDataClassDecl.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/SlidingDoClause.hs b/tests/examples/ghc710/SlidingDoClause.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/SlidingLambda.hs b/tests/examples/ghc710/SlidingLambda.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/SlidingListComp.hs b/tests/examples/ghc710/SlidingListComp.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/SlidingRecordSetter.hs b/tests/examples/ghc710/SlidingRecordSetter.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/SpacesSplice.hs b/tests/examples/ghc710/SpacesSplice.hs deleted file mode 100644 --- a/tests/examples/ghc710/SpacesSplice.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -makeLenses '' PostscriptFont diff --git a/tests/examples/ghc710/Splice.hs b/tests/examples/ghc710/Splice.hs deleted file mode 100644 --- a/tests/examples/ghc710/Splice.hs +++ /dev/null @@ -1,49 +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 - -makeLenses '' PostscriptFont - -$(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 deleted file mode 100644 --- a/tests/examples/ghc710/SpliceSemi.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - - -$(makePredicates ''TheType) ; $(makePredicatesNot ''TheType) diff --git a/tests/examples/ghc710/StaticPointers.hs b/tests/examples/ghc710/StaticPointers.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Stmts.hs b/tests/examples/ghc710/Stmts.hs deleted file mode 100644 --- a/tests/examples/ghc710/Stmts.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Stmts where - --- Make sure we get all the semicolons in statements -;;;; ;; -import Data.List -; ; ; -import Data.Maybe - ; ;; -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 deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Stream.hs b/tests/examples/ghc710/Stream.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/StrictLet.hs b/tests/examples/ghc710/StrictLet.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/StringGap.hs b/tests/examples/ghc710/StringGap.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/T10196.hs b/tests/examples/ghc710/T10196.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/T10942.hs b/tests/examples/ghc710/T10942.hs deleted file mode 100644 --- a/tests/examples/ghc710/T10942.hs +++ /dev/null @@ -1,6 +0,0 @@ --- 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 deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/T3132.hs b/tests/examples/ghc710/T3132.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/T5951.hs b/tests/examples/ghc710/T5951.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/T7918A.hs b/tests/examples/ghc710/T7918A.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/TH.hs b/tests/examples/ghc710/TH.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/THMonadInstance.hs b/tests/examples/ghc710/THMonadInstance.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/TemplateHaskell.hs b/tests/examples/ghc710/TemplateHaskell.hs deleted file mode 100644 --- a/tests/examples/ghc710/TemplateHaskell.hs +++ /dev/null @@ -1,43 +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]))||] - -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 deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Trit.hs b/tests/examples/ghc710/Trit.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Tuple.hs b/tests/examples/ghc710/Tuple.hs deleted file mode 100644 --- a/tests/examples/ghc710/Tuple.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TupleSections #-} - -baz = (1, "hello", 6.5,,) 'a' (Just ()) - diff --git a/tests/examples/ghc710/TupleSections.hs b/tests/examples/ghc710/TupleSections.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/TypeBrackets.hs b/tests/examples/ghc710/TypeBrackets.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/TypeBrackets2.hs b/tests/examples/ghc710/TypeBrackets2.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/TypeBrackets4.hs b/tests/examples/ghc710/TypeBrackets4.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/TypeFamilies2.hs b/tests/examples/ghc710/TypeFamilies2.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/TypeInstance.hs b/tests/examples/ghc710/TypeInstance.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/TypeOperators.hs b/tests/examples/ghc710/TypeOperators.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/TypeSignature.hs b/tests/examples/ghc710/TypeSignature.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/TypeSignatureParens.hs b/tests/examples/ghc710/TypeSignatureParens.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/TypeSynOperator.hs b/tests/examples/ghc710/TypeSynOperator.hs deleted file mode 100644 --- a/tests/examples/ghc710/TypeSynOperator.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - -type a :-> t = a diff --git a/tests/examples/ghc710/TypeSynParens.hs b/tests/examples/ghc710/TypeSynParens.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Unboxed.hs b/tests/examples/ghc710/Unboxed.hs deleted file mode 100644 --- a/tests/examples/ghc710/Unboxed.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Undefined11.hs b/tests/examples/ghc710/Undefined11.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Undefined13.hs b/tests/examples/ghc710/Undefined13.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Undefined2.hs b/tests/examples/ghc710/Undefined2.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Undefined3.hs b/tests/examples/ghc710/Undefined3.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Undefined4.hs b/tests/examples/ghc710/Undefined4.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Undefined5.hs b/tests/examples/ghc710/Undefined5.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Undefined6.hs b/tests/examples/ghc710/Undefined6.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Undefined7.hs b/tests/examples/ghc710/Undefined7.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Undefined8.hs b/tests/examples/ghc710/Undefined8.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Undefined9.hs b/tests/examples/ghc710/Undefined9.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Unicode.hs b/tests/examples/ghc710/Unicode.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/UnicodeSyntaxFailure.hs b/tests/examples/ghc710/UnicodeSyntaxFailure.hs deleted file mode 100644 --- a/tests/examples/ghc710/UnicodeSyntaxFailure.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE UnicodeSyntax #-} - -foo x = addToEnv (∀) diff --git a/tests/examples/ghc710/Utilities.hs b/tests/examples/ghc710/Utilities.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Utils2.hs b/tests/examples/ghc710/Utils2.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/ViewPatterns.hs b/tests/examples/ghc710/ViewPatterns.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Warning.hs b/tests/examples/ghc710/Warning.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Zipper.hs b/tests/examples/ghc710/Zipper.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/read018.hs b/tests/examples/ghc710/read018.hs deleted file mode 100644 --- a/tests/examples/ghc710/read018.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DatatypeContexts #-} --- !!! Checking that empty contexts are permitted. -module ShouldCompile where - -data () => Foo a = Foo a - -newtype () => Bar = Bar Int - -f :: () => Int -> Int -f = (+1) - - -class () => Fob a where - -instance () => Fob Int where -instance () => Fob Float - diff --git a/tests/examples/ghc80/A.hs b/tests/examples/ghc80/A.hs deleted file mode 100644 --- a/tests/examples/ghc80/A.hs +++ /dev/null @@ -1,4 +0,0 @@ -module A where - -class A a where - has :: a diff --git a/tests/examples/ghc80/AddParams2.hs b/tests/examples/ghc80/AddParams2.hs deleted file mode 100644 --- a/tests/examples/ghc80/AddParams2.hs +++ /dev/null @@ -1,9 +0,0 @@ -module AddParams2 where - -collapse rightInner rightOuter = right - where - right = (rightInner, rightOuter) - righ2 = (rightInner, (rightOuter baz bar)) - -baz = undefined -bar = undefined diff --git a/tests/examples/ghc80/Associated.hs b/tests/examples/ghc80/Associated.hs deleted file mode 100644 --- a/tests/examples/ghc80/Associated.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Associated(A(..)) where - -import AssociatedInternal (A(..)) - -foo = MkA 5 -baz = NoA - -qux (MkA x) = x -qux NoA = 0 diff --git a/tests/examples/ghc80/AssociatedInternal.hs b/tests/examples/ghc80/AssociatedInternal.hs deleted file mode 100644 --- a/tests/examples/ghc80/AssociatedInternal.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module AssociatedInternal (A(NewA,MkA, NoA)) where - -newtype A = NewA (Maybe Int) - -pattern MkA n = NewA (Just n) - -pattern NoA = NewA Nothing diff --git a/tests/examples/ghc80/B.hs b/tests/examples/ghc80/B.hs deleted file mode 100644 --- a/tests/examples/ghc80/B.hs +++ /dev/null @@ -1,4 +0,0 @@ -module B where - -class B a where - has :: a diff --git a/tests/examples/ghc80/Base.hs b/tests/examples/ghc80/Base.hs deleted file mode 100644 --- a/tests/examples/ghc80/Base.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Base (AClass(..), BClass()) where - -import Extends (BClass ()) - -class AClass a where - has :: a diff --git a/tests/examples/ghc80/Bundle.hs b/tests/examples/ghc80/Bundle.hs deleted file mode 100644 --- a/tests/examples/ghc80/Bundle.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Bundle(A(..)) where - -import BundleInternal (A(..)) - -foo = MkA 5 -baz = NoA - -qux (MkA x) = x -qux NoA = 0 diff --git a/tests/examples/ghc80/Bundle1.hs b/tests/examples/ghc80/Bundle1.hs deleted file mode 100644 --- a/tests/examples/ghc80/Bundle1.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Associated1(A(..)) where - -import BundleInternal1 (A(..)) - -foo = MkA 5 -baz = NoA - -qux (MkA x) = x -qux NoA = 0 diff --git a/tests/examples/ghc80/BundleExport.hs b/tests/examples/ghc80/BundleExport.hs deleted file mode 100644 --- a/tests/examples/ghc80/BundleExport.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module BundleExport(P(.., A), Q(B)) where - -data P = P - -data Q = Q - -pattern A = P -pattern B = Q diff --git a/tests/examples/ghc80/BundleInternal.hs b/tests/examples/ghc80/BundleInternal.hs deleted file mode 100644 --- a/tests/examples/ghc80/BundleInternal.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module BundleInternal (A(NewA,MkA, NoA)) where - -newtype A = NewA (Maybe Int) - -pattern MkA n = NewA (Just n) - -pattern NoA = NewA Nothing diff --git a/tests/examples/ghc80/BundleInternal1.hs b/tests/examples/ghc80/BundleInternal1.hs deleted file mode 100644 --- a/tests/examples/ghc80/BundleInternal1.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module BundleInternal1 (A(NewA,MkA, NoA)) where - -newtype A = NewA (Maybe Int) - -pattern MkA n = NewA (Just n) - -pattern NoA = NewA Nothing diff --git a/tests/examples/ghc80/C.hs b/tests/examples/ghc80/C.hs deleted file mode 100644 --- a/tests/examples/ghc80/C.hs +++ /dev/null @@ -1,3 +0,0 @@ -module C (oops) where - -import {-# SOURCE #-} B diff --git a/tests/examples/ghc80/CheckUtils.hs b/tests/examples/ghc80/CheckUtils.hs deleted file mode 100644 --- a/tests/examples/ghc80/CheckUtils.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - --- This program must be called with GHC's libdir and the file to be checked as --- the command line arguments. -module CheckUtils where - -import Data.Data -import Data.List -import System.IO -import GHC -import BasicTypes -import DynFlags -import MonadUtils -import Outputable -import ApiAnnotation -import Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Dynamic ( fromDynamic,Dynamic ) - -_main::IO() -_main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName - -testOneFile libdir fileName = do - ((anns,cs),p) <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - return (pm_annotations p,p) - - let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p) - - problems = filter (\(s,a) -> not (Set.member s spans)) - $ getAnnSrcSpans (anns,cs) - - exploded = [((kw,ss),[anchor]) - | ((anchor,kw),sss) <- Map.toList anns,ss <- sss] - - exploded' = Map.toList $ Map.fromListWith (++) exploded - - problems' = filter (\(_,anchors) - -> not (any (\a -> Set.member a spans) anchors)) - exploded' - - putStrLn "---Problems---------------------" - putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems]) - putStrLn "---Problems'--------------------" - putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems']) - putStrLn "--------------------------------" - putStrLn (intercalate "\n" [showAnns anns]) - - where - getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))] - getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns - - getAllSrcSpans :: (Data t) => t -> [SrcSpan] - getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast - where - getSrcSpan :: SrcSpan -> [SrcSpan] - getSrcSpan ss = [ss] - - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPpr unsafeGlobalDynFlags a - - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/tests/examples/ghc80/Class.hs b/tests/examples/ghc80/Class.hs deleted file mode 100644 --- a/tests/examples/ghc80/Class.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -module Servant.Auth.Server.Internal.Class where - -import Servant.Auth -import Data.Monoid -import Servant hiding (BasicAuth) - -import Servant.Auth.Server.Internal.Types -import Servant.Auth.Server.Internal.ConfigTypes -import Servant.Auth.Server.Internal.BasicAuth -import Servant.Auth.Server.Internal.Cookie -import Servant.Auth.Server.Internal.JWT - --- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all --- elements of @ctx@ to be the in the Context and whose authentication check --- returns an @AuthCheck v@. -class IsAuth a v where - type family AuthArgs a :: [*] - runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v) - diff --git a/tests/examples/ghc80/ClosedFam1a.hs b/tests/examples/ghc80/ClosedFam1a.hs deleted file mode 100644 --- a/tests/examples/ghc80/ClosedFam1a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module ClosedFam1a where - -import {-# SOURCE #-} ClosedFam1 diff --git a/tests/examples/ghc80/ClosedFam2a.hs b/tests/examples/ghc80/ClosedFam2a.hs deleted file mode 100644 --- a/tests/examples/ghc80/ClosedFam2a.hs +++ /dev/null @@ -1,2 +0,0 @@ -module ClosedFam2a where -import {-# SOURCE #-} ClosedFam2 diff --git a/tests/examples/ghc80/ClosedFam3a.hs b/tests/examples/ghc80/ClosedFam3a.hs deleted file mode 100644 --- a/tests/examples/ghc80/ClosedFam3a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module ClosedFam3a where - -import {-# SOURCE #-} ClosedFam3 diff --git a/tests/examples/ghc80/CmmSwitchTest.hs b/tests/examples/ghc80/CmmSwitchTest.hs deleted file mode 100644 --- a/tests/examples/ghc80/CmmSwitchTest.hs +++ /dev/null @@ -1,505 +0,0 @@ -{-# LANGUAGE MagicHash #-} -import Control.Monad (unless, forM_) -import GHC.Exts -{-# NOINLINE aa #-} -aa :: Int# -> Int# -aa 1# = 42# -aa 2# = 43# -aa 3# = 43# -aa 4# = 44# -aa 5# = 44# -aa 6# = 45# -aa 7# = 45# -aa 8# = 46# -aa 9# = 46# -aa 10# = 47# -aa _ = 1337# - -{-# NOINLINE ab #-} -ab :: Int# -> Int# -ab 0# = 42# -ab 1# = 42# -ab 2# = 43# -ab 3# = 43# -ab 4# = 44# -ab 5# = 44# -ab 6# = 45# -ab 7# = 45# -ab 8# = 46# -ab 9# = 46# -ab 10# = 47# -ab _ = 1337# - -{-# NOINLINE ac #-} -ac :: Int# -> Int# -ac 1# = 42# -ac 2# = 43# -ac 3# = 43# -ac _ = 1337# - -{-# NOINLINE ad #-} -ad :: Int# -> Int# -ad 1# = 42# -ad 2# = 43# -ad 3# = 43# -ad 4# = 44# -ad _ = 1337# - -{-# NOINLINE ae #-} -ae :: Int# -> Int# -ae 1# = 42# -ae 2# = 43# -ae 3# = 43# -ae 4# = 44# -ae 5# = 44# -ae _ = 1337# - -{-# NOINLINE af #-} -af :: Int# -> Int# -af -1# = 41# -af 0# = 42# -af 1# = 42# -af 2# = 43# -af 3# = 43# -af 4# = 44# -af 5# = 44# -af 6# = 45# -af 7# = 45# -af 8# = 46# -af 9# = 46# -af 10# = 47# -af _ = 1337# - -{-# NOINLINE ag #-} -ag :: Int# -> Int# -ag -10# = 37# -ag -9# = 37# -ag -8# = 38# -ag -7# = 38# -ag -6# = 39# -ag -5# = 39# -ag -4# = 40# -ag -3# = 40# -ag -2# = 41# -ag -1# = 41# -ag 0# = 42# -ag 1# = 42# -ag 2# = 43# -ag 3# = 43# -ag 4# = 44# -ag 5# = 44# -ag 6# = 45# -ag 7# = 45# -ag 8# = 46# -ag 9# = 46# -ag 10# = 47# -ag _ = 1337# - -{-# NOINLINE ah #-} -ah :: Int# -> Int# -ah -20# = 32# -ah -19# = 32# -ah -18# = 33# -ah -17# = 33# -ah -16# = 34# -ah -15# = 34# -ah -14# = 35# -ah -13# = 35# -ah -12# = 36# -ah -11# = 36# -ah -10# = 37# -ah 0# = 42# -ah 1# = 42# -ah 2# = 43# -ah 3# = 43# -ah 4# = 44# -ah 5# = 44# -ah 6# = 45# -ah 7# = 45# -ah 8# = 46# -ah 9# = 46# -ah 10# = 47# -ah _ = 1337# - -{-# NOINLINE ai #-} -ai :: Int# -> Int# -ai -20# = 32# -ai -19# = 32# -ai -18# = 33# -ai -17# = 33# -ai -16# = 34# -ai -15# = 34# -ai -14# = 35# -ai -13# = 35# -ai -12# = 36# -ai -11# = 36# -ai -10# = 37# -ai 1# = 42# -ai 2# = 43# -ai 3# = 43# -ai 4# = 44# -ai 5# = 44# -ai 6# = 45# -ai 7# = 45# -ai 8# = 46# -ai 9# = 46# -ai 10# = 47# -ai _ = 1337# - -{-# NOINLINE aj #-} -aj :: Int# -> Int# -aj -9223372036854775808# = -4611686018427387862# -aj 0# = 42# -aj 9223372036854775807# = 4611686018427387945# -aj _ = 1337# - -{-# NOINLINE ak #-} -ak :: Int# -> Int# -ak 9223372036854775797# = 4611686018427387940# -ak 9223372036854775798# = 4611686018427387941# -ak 9223372036854775799# = 4611686018427387941# -ak 9223372036854775800# = 4611686018427387942# -ak 9223372036854775801# = 4611686018427387942# -ak 9223372036854775802# = 4611686018427387943# -ak 9223372036854775803# = 4611686018427387943# -ak 9223372036854775804# = 4611686018427387944# -ak 9223372036854775805# = 4611686018427387944# -ak 9223372036854775806# = 4611686018427387945# -ak 9223372036854775807# = 4611686018427387945# -ak _ = 1337# - -{-# NOINLINE al #-} -al :: Int# -> Int# -al -9223372036854775808# = -4611686018427387862# -al -9223372036854775807# = -4611686018427387862# -al -9223372036854775806# = -4611686018427387861# -al -9223372036854775805# = -4611686018427387861# -al -9223372036854775804# = -4611686018427387860# -al -9223372036854775803# = -4611686018427387860# -al -9223372036854775802# = -4611686018427387859# -al -9223372036854775801# = -4611686018427387859# -al -9223372036854775800# = -4611686018427387858# -al -9223372036854775799# = -4611686018427387858# -al -9223372036854775798# = -4611686018427387857# -al 9223372036854775797# = 4611686018427387940# -al 9223372036854775798# = 4611686018427387941# -al 9223372036854775799# = 4611686018427387941# -al 9223372036854775800# = 4611686018427387942# -al 9223372036854775801# = 4611686018427387942# -al 9223372036854775802# = 4611686018427387943# -al 9223372036854775803# = 4611686018427387943# -al 9223372036854775804# = 4611686018427387944# -al 9223372036854775805# = 4611686018427387944# -al 9223372036854775806# = 4611686018427387945# -al 9223372036854775807# = 4611686018427387945# -al _ = 1337# - -{-# NOINLINE am #-} -am :: Word# -> Word# -am 0## = 42## -am 1## = 42## -am 2## = 43## -am 3## = 43## -am 4## = 44## -am 5## = 44## -am 6## = 45## -am 7## = 45## -am 8## = 46## -am 9## = 46## -am 10## = 47## -am _ = 1337## - -{-# NOINLINE an #-} -an :: Word# -> Word# -an 1## = 42## -an 2## = 43## -an 3## = 43## -an 4## = 44## -an 5## = 44## -an 6## = 45## -an 7## = 45## -an 8## = 46## -an 9## = 46## -an 10## = 47## -an _ = 1337## - -{-# NOINLINE ao #-} -ao :: Word# -> Word# -ao 0## = 42## -ao _ = 1337## - -{-# NOINLINE ap #-} -ap :: Word# -> Word# -ap 0## = 42## -ap 1## = 42## -ap _ = 1337## - -{-# NOINLINE aq #-} -aq :: Word# -> Word# -aq 0## = 42## -aq 1## = 42## -aq 2## = 43## -aq _ = 1337## - -{-# NOINLINE ar #-} -ar :: Word# -> Word# -ar 0## = 42## -ar 1## = 42## -ar 2## = 43## -ar 3## = 43## -ar _ = 1337## - -{-# NOINLINE as #-} -as :: Word# -> Word# -as 0## = 42## -as 1## = 42## -as 2## = 43## -as 3## = 43## -as 4## = 44## -as _ = 1337## - -{-# NOINLINE at #-} -at :: Word# -> Word# -at 1## = 42## -at _ = 1337## - -{-# NOINLINE au #-} -au :: Word# -> Word# -au 1## = 42## -au 2## = 43## -au _ = 1337## - -{-# NOINLINE av #-} -av :: Word# -> Word# -av 1## = 42## -av 2## = 43## -av 3## = 43## -av _ = 1337## - -{-# NOINLINE aw #-} -aw :: Word# -> Word# -aw 1## = 42## -aw 2## = 43## -aw 3## = 43## -aw 4## = 44## -aw _ = 1337## - -{-# NOINLINE ax #-} -ax :: Word# -> Word# -ax 1## = 42## -ax 2## = 43## -ax 3## = 43## -ax 4## = 44## -ax 5## = 44## -ax _ = 1337## - -{-# NOINLINE ay #-} -ay :: Word# -> Word# -ay 0## = 42## -ay 18446744073709551615## = 9223372036854775849## -ay _ = 1337## - -{-# NOINLINE az #-} -az :: Word# -> Word# -az 18446744073709551605## = 9223372036854775844## -az 18446744073709551606## = 9223372036854775845## -az 18446744073709551607## = 9223372036854775845## -az 18446744073709551608## = 9223372036854775846## -az 18446744073709551609## = 9223372036854775846## -az 18446744073709551610## = 9223372036854775847## -az 18446744073709551611## = 9223372036854775847## -az 18446744073709551612## = 9223372036854775848## -az 18446744073709551613## = 9223372036854775848## -az 18446744073709551614## = 9223372036854775849## -az 18446744073709551615## = 9223372036854775849## -az _ = 1337## - -{-# NOINLINE ba #-} -ba :: Word# -> Word# -ba 0## = 42## -ba 1## = 42## -ba 2## = 43## -ba 3## = 43## -ba 4## = 44## -ba 5## = 44## -ba 6## = 45## -ba 7## = 45## -ba 8## = 46## -ba 9## = 46## -ba 10## = 47## -ba 18446744073709551605## = 9223372036854775844## -ba 18446744073709551606## = 9223372036854775845## -ba 18446744073709551607## = 9223372036854775845## -ba 18446744073709551608## = 9223372036854775846## -ba 18446744073709551609## = 9223372036854775846## -ba 18446744073709551610## = 9223372036854775847## -ba 18446744073709551611## = 9223372036854775847## -ba 18446744073709551612## = 9223372036854775848## -ba 18446744073709551613## = 9223372036854775848## -ba 18446744073709551614## = 9223372036854775849## -ba 18446744073709551615## = 9223372036854775849## -ba _ = 1337## - -aa_check :: IO () -aa_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (aa i) - unless (r == o) $ putStrLn $ "ERR: aa (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ab_check :: IO () -ab_check = forM_ [(-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (ab i) - unless (r == o) $ putStrLn $ "ERR: ab (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ac_check :: IO () -ac_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(I# i,o) -> do - let r = I# (ac i) - unless (r == o) $ putStrLn $ "ERR: ac (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ad_check :: IO () -ad_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(I# i,o) -> do - let r = I# (ad i) - unless (r == o) $ putStrLn $ "ERR: ad (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ae_check :: IO () -ae_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(I# i,o) -> do - let r = I# (ae i) - unless (r == o) $ putStrLn $ "ERR: ae (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -af_check :: IO () -af_check = forM_ [(-2,1337), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (af i) - unless (r == o) $ putStrLn $ "ERR: af (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ag_check :: IO () -ag_check = forM_ [(-11,1337), (-10,37), (-9,37), (-8,38), (-7,38), (-6,39), (-5,39), (-4,40), (-3,40), (-2,41), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (ag i) - unless (r == o) $ putStrLn $ "ERR: ag (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ah_check :: IO () -ah_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (ah i) - unless (r == o) $ putStrLn $ "ERR: ah (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ai_check :: IO () -ai_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do - let r = I# (ai i) - unless (r == o) $ putStrLn $ "ERR: ai (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -aj_check :: IO () -aj_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,1337), (-1,1337), (0,42), (1,1337), (9223372036854775806,1337), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do - let r = I# (aj i) - unless (r == o) $ putStrLn $ "ERR: aj (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ak_check :: IO () -ak_check = forM_ [(9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do - let r = I# (ak i) - unless (r == o) $ putStrLn $ "ERR: ak (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -al_check :: IO () -al_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,-4611686018427387862), (-9223372036854775806,-4611686018427387861), (-9223372036854775805,-4611686018427387861), (-9223372036854775804,-4611686018427387860), (-9223372036854775803,-4611686018427387860), (-9223372036854775802,-4611686018427387859), (-9223372036854775801,-4611686018427387859), (-9223372036854775800,-4611686018427387858), (-9223372036854775799,-4611686018427387858), (-9223372036854775798,-4611686018427387857), (-9223372036854775797,1337), (9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do - let r = I# (al i) - unless (r == o) $ putStrLn $ "ERR: al (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -am_check :: IO () -am_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do - let r = W# (am i) - unless (r == o) $ putStrLn $ "ERR: am (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -an_check :: IO () -an_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do - let r = W# (an i) - unless (r == o) $ putStrLn $ "ERR: an (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ao_check :: IO () -ao_check = forM_ [(0,42), (1,1337)] $ \(W# i,o) -> do - let r = W# (ao i) - unless (r == o) $ putStrLn $ "ERR: ao (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ap_check :: IO () -ap_check = forM_ [(0,42), (1,42), (2,1337)] $ \(W# i,o) -> do - let r = W# (ap i) - unless (r == o) $ putStrLn $ "ERR: ap (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -aq_check :: IO () -aq_check = forM_ [(0,42), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do - let r = W# (aq i) - unless (r == o) $ putStrLn $ "ERR: aq (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ar_check :: IO () -ar_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do - let r = W# (ar i) - unless (r == o) $ putStrLn $ "ERR: ar (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -as_check :: IO () -as_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do - let r = W# (as i) - unless (r == o) $ putStrLn $ "ERR: as (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -at_check :: IO () -at_check = forM_ [(0,1337), (1,42), (2,1337)] $ \(W# i,o) -> do - let r = W# (at i) - unless (r == o) $ putStrLn $ "ERR: at (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -au_check :: IO () -au_check = forM_ [(0,1337), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do - let r = W# (au i) - unless (r == o) $ putStrLn $ "ERR: au (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -av_check :: IO () -av_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do - let r = W# (av i) - unless (r == o) $ putStrLn $ "ERR: av (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -aw_check :: IO () -aw_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do - let r = W# (aw i) - unless (r == o) $ putStrLn $ "ERR: aw (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ax_check :: IO () -ax_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(W# i,o) -> do - let r = W# (ax i) - unless (r == o) $ putStrLn $ "ERR: ax (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ay_check :: IO () -ay_check = forM_ [(0,42), (1,1337), (18446744073709551614,1337), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do - let r = W# (ay i) - unless (r == o) $ putStrLn $ "ERR: ay (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -az_check :: IO () -az_check = forM_ [(18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do - let r = W# (az i) - unless (r == o) $ putStrLn $ "ERR: az (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -ba_check :: IO () -ba_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337), (18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do - let r = W# (ba i) - unless (r == o) $ putStrLn $ "ERR: ba (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." - -main = do - aa_check - ab_check - ac_check - ad_check - ae_check - af_check - ag_check - ah_check - ai_check - aj_check - ak_check - al_check - am_check - an_check - ao_check - ap_check - aq_check - ar_check - as_check - at_check - au_check - av_check - aw_check - ax_check - ay_check - az_check - ba_check diff --git a/tests/examples/ghc80/CmmSwitchTestGen.hs b/tests/examples/ghc80/CmmSwitchTestGen.hs deleted file mode 100644 --- a/tests/examples/ghc80/CmmSwitchTestGen.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE TupleSections #-} - --- Generates CmmSwitch.hs - -import qualified Data.Set as S -import Data.Word -import Data.List - -output :: Integer -> Integer -output n = n`div`2 + 42 - -def :: Integer -def = 1337 - -type Spec = (String, Bool, [Integer]) - -primtyp True = "Int#" -primtyp False = "Word#" - -con True = "I#" -con False = "W#" - -hash True = "#" -hash False = "##" - -primLit s v = show v ++ hash s - -genSwitch :: Spec -> String -genSwitch (name, signed, values) = unlines $ - [ "{-# NOINLINE " ++ name ++ " #-}" ] ++ - [ name ++ " :: " ++ primtyp signed ++ " -> " ++ primtyp signed ] ++ - [ name ++ " " ++ primLit signed v ++ " = " ++ primLit signed (output v) - | v <- values] ++ - [ name ++ " _ = " ++ primLit signed def ] - -genCheck :: Spec -> String -genCheck (name, signed, values) = unlines $ - [ checkName name ++ " :: IO ()" - , checkName name ++ " = forM_ [" ++ pairs ++ "] $ \\(" ++ con signed ++ " i,o) -> do" - , " let r = " ++ con signed ++ " (" ++ name ++ " i)" - , " unless (r == o) $ putStrLn $ \"ERR: " ++ name ++ " (\" ++ show (" ++ con signed ++ " i)++ \") is \" ++ show r ++ \" and not \" ++ show o ++\".\"" - ] - where - f x | x `S.member` range = output x - | otherwise = def - range = S.fromList values - checkValues = S.toList $ S.fromList $ - [ v' | v <- values, v' <- [v-1,v,v+1], - if signed then v' >= minS && v' <= maxS else v' >= minU && v' <= maxU ] - pairs = intercalate ", " ["(" ++ show v ++ "," ++ show (f v) ++ ")" | v <- checkValues ] - -checkName :: String -> String -checkName f = f ++ "_check" - -genMain :: [Spec] -> String -genMain specs = unlines $ "main = do" : [ " " ++ checkName n | (n,_,_) <- specs ] - -genMod :: [Spec] -> String -genMod specs = unlines $ - "-- This file is generated from CmmSwitchGen!" : - "{-# LANGUAGE MagicHash, NegativeLiterals #-}" : - "import Control.Monad (unless, forM_)" : - "import GHC.Exts" : - map genSwitch specs ++ - map genCheck specs ++ - [ genMain specs ] - -main = putStrLn $ - genMod $ zipWith (\n (s,v) -> (n,s,v)) names $ signedChecks ++ unsignedChecks - - -signedChecks :: [(Bool, [Integer])] -signedChecks = map (True,) - [ [1..10] - , [0..10] - , [1..3] - , [1..4] - , [1..5] - , [-1..10] - , [-10..10] - , [-20.. -10]++[0..10] - , [-20.. -10]++[1..10] - , [minS,0,maxS] - , [maxS-10 .. maxS] - , [minS..minS+10]++[maxS-10 .. maxS] - ] - -minU, maxU, minS, maxS :: Integer -minU = 0 -maxU = fromIntegral (maxBound :: Word) -minS = fromIntegral (minBound :: Int) -maxS = fromIntegral (maxBound :: Int) - - -unsignedChecks :: [(Bool, [Integer])] -unsignedChecks = map (False,) - [ [0..10] - , [1..10] - , [0] - , [0..1] - , [0..2] - , [0..3] - , [0..4] - , [1] - , [1..2] - , [1..3] - , [1..4] - , [1..5] - , [minU,maxU] - , [maxU-10 .. maxU] - , [minU..minU+10]++[maxU-10 .. maxU] - ] - -names :: [String] -names = [ c1:c2:[] | c1 <- ['a'..'z'], c2 <- ['a'..'z']] diff --git a/tests/examples/ghc80/Collapse1.hs b/tests/examples/ghc80/Collapse1.hs deleted file mode 100644 --- a/tests/examples/ghc80/Collapse1.hs +++ /dev/null @@ -1,16 +0,0 @@ -module LiftToTop3evel.Collapse1 where - -collapse' _ _ [] = [] -collapse' left space (t:ts) = new : collapse' right space rest - where - (_, leftInner) = left - rightInner = leftInner + symbolSize t - right = (rightInner, (rightOuter rightInner rights)) - (rights, rest) = span space ts - new = (t, Bounds left right) - -rightOuter rightInner rights = rightInner + symbolSize rights - -data Bounds = Bounds (Int,Int) (Int,Int) -symbolSize t = 4 - diff --git a/tests/examples/ghc80/Compare.hs b/tests/examples/ghc80/Compare.hs deleted file mode 100644 --- a/tests/examples/ghc80/Compare.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE Trustworthy, - TypeOperators, - PolyKinds, DataKinds, - TypeFamilies, - UndecidableInstances #-} - - -module Type.Compare where - -import Data.Ord -import GHC.TypeLits - -type family (a :: Ordering) $$ (b :: Ordering) :: Ordering where - LT $$ b = LT - GT $$ b = GT - EQ $$ b = b -infixl 0 $$ - --- | Compare two types of any (possibly different) kinds. --- Since `Compare` itself is a closed type family, add instances to `CompareUser` if you want to compare other types. -type family Compare (a :: k) (b :: k') :: Ordering where - - Compare '() '() = EQ diff --git a/tests/examples/ghc80/CustomTypeErrors01.hs b/tests/examples/ghc80/CustomTypeErrors01.hs deleted file mode 100644 --- a/tests/examples/ghc80/CustomTypeErrors01.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DataKinds, UndecidableInstances #-} -module T1 where -import GHC.TypeLits - - -data MyType = MyType - -instance - TypeError (Text "Values of type 'MyType' cannot be compared for equality.") - => Eq MyType where (==) = undefined - -err x = x == MyType - - diff --git a/tests/examples/ghc80/CustomTypeErrors02.hs b/tests/examples/ghc80/CustomTypeErrors02.hs deleted file mode 100644 --- a/tests/examples/ghc80/CustomTypeErrors02.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DataKinds, UndecidableInstances #-} -{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts #-} -module T2 where - -import GHC.TypeLits - -type family IntRep a where - IntRep Int = Integer - IntRep Integer = Integer - IntRep Bool = Integer - IntRep a = TypeError (Text "The type '" :<>: ShowType a :<>: - Text "' cannot be represented as an integer.") - -convert :: Num (IntRep a) => a -> IntRep a -convert _ = 5 - -err = convert id - - diff --git a/tests/examples/ghc80/CustomTypeErrors03.hs b/tests/examples/ghc80/CustomTypeErrors03.hs deleted file mode 100644 --- a/tests/examples/ghc80/CustomTypeErrors03.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module T3 where - -import GHC.TypeLits - -f :: TypeError (Text "This is a type error") -f = undefined diff --git a/tests/examples/ghc80/D.hs b/tests/examples/ghc80/D.hs deleted file mode 100644 --- a/tests/examples/ghc80/D.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module D where - -import A -import C - -type instance F a b = a - -unsafeCoerce :: a -> b -unsafeCoerce x = oops x x diff --git a/tests/examples/ghc80/DataFamilyInstanceLHS.hs b/tests/examples/ghc80/DataFamilyInstanceLHS.hs deleted file mode 100644 --- a/tests/examples/ghc80/DataFamilyInstanceLHS.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds #-} -module DataFamilyInstanceLHS where --- Test case from #10586 -data MyKind = A | B - -data family Sing (a :: k) - -data instance Sing (_ :: MyKind) where - SingA :: Sing A - SingB :: Sing B - -foo :: Sing A -foo = SingA diff --git a/tests/examples/ghc80/DatatypeContexts.hs b/tests/examples/ghc80/DatatypeContexts.hs deleted file mode 100644 --- a/tests/examples/ghc80/DatatypeContexts.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DatatypeContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} --- I don't know how to silence the -XDatatypeContexts warnings otherwise... -{-# OPTIONS_GHC -w #-} - -{-| -Module: Derived.DatatypeContexts -Copyright: (C) 2014-2016 Ryan Scott -License: BSD-style (see the file LICENSE) -Maintainer: Ryan Scott -Stability: Provisional -Portability: GHC - -Defines data types with DatatypeContexts (which are gross, but still possible). --} -module Derived.DatatypeContexts where - - -data family TyFamily x y z :: * - -data instance Ord a => TyFamily a b c = TyFamily a b c - deriving Show - diff --git a/tests/examples/ghc80/Decision.hs b/tests/examples/ghc80/Decision.hs deleted file mode 100644 --- a/tests/examples/ghc80/Decision.hs +++ /dev/null @@ -1,726 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} - -module Airship.Internal.Decision - ( flow - , appendRequestPath - ) where - -import Airship.Internal.Date (parseRfc1123Date, utcTimeToRfc1123) -import Airship.Headers (addResponseHeader) -import Airship.Types ( Response(..) - , ResponseBody(..) - , Webmachine - , etagToByteString - , getResponseBody - , getResponseHeaders - , halt - , pathInfo - , putResponseBody - , request - , requestHeaders - , requestMethod - , requestTime ) - -import Airship.Resource(Resource(..), PostResponse(..)) -import Airship.Internal.Parsers (parseEtagList) -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>)) -#endif -import Control.Monad (when) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.State.Strict (StateT(..), evalStateT, - get, modify) -import Control.Monad.Writer.Class (tell) - -import Blaze.ByteString.Builder (toByteString) -import Data.Maybe (isJust) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import Data.ByteString (ByteString, intercalate) - -import Network.HTTP.Media -import qualified Network.HTTP.Types as HTTP - ------------------------------------------------------------------------------- --- HTTP Headers --- These are headers not defined for us already in --- Network.HTTP.Types ------------------------------------------------------------------------------- --- TODO this exist in http-types-0.9, see CHANGES.txt -hAcceptCharset :: HTTP.HeaderName -hAcceptCharset = "Accept-Charset" - -hAcceptEncoding :: HTTP.HeaderName -hAcceptEncoding = "Accept-Encoding" - -hIfMatch :: HTTP.HeaderName -hIfMatch = "If-Match" - -hIfUnmodifiedSince :: HTTP.HeaderName -hIfUnmodifiedSince = "If-Unmodified-Since" - -hIfNoneMatch :: HTTP.HeaderName -hIfNoneMatch = "If-None-Match" - ------------------------------------------------------------------------------- --- FlowState: StateT used for recording information as we walk the decision --- tree ------------------------------------------------------------------------------- - -data FlowState m = FlowState - { _contentType :: Maybe (MediaType, Webmachine m ResponseBody) } - -type FlowStateT m a = StateT (FlowState m) (Webmachine m) a - -type Flow m = Resource m -> FlowStateT m Response - -initFlowState :: FlowState m -initFlowState = FlowState Nothing - -flow :: Monad m => Resource m -> Webmachine m Response -flow r = evalStateT (b13 r) initFlowState - -trace :: Monad m => Text -> FlowStateT m () -trace t = lift $ tell [t] - ------------------------------------------------------------------------------ --- Header value data newtypes ------------------------------------------------------------------------------- - -newtype IfMatch = IfMatch ByteString -newtype IfNoneMatch = IfNoneMatch ByteString - ------------------------------------------------------------------------------- --- Decision Helpers ------------------------------------------------------------------------------- - -negotiateContentTypesAccepted :: Monad m => Resource m -> FlowStateT m () -negotiateContentTypesAccepted Resource{..} = do - req <- lift request - accepted <- lift contentTypesAccepted - let reqHeaders = requestHeaders req - result = do - cType <- lookup HTTP.hContentType reqHeaders - mapContentMedia accepted cType - case result of - (Just process) -> lift process - Nothing -> lift $ halt HTTP.status415 - -appendRequestPath :: Monad m => [Text] -> Webmachine m ByteString -appendRequestPath ts = do - currentPath <- pathInfo <$> request - return $ toByteString (HTTP.encodePathSegments (currentPath ++ ts)) - -requestHeaderDate :: Monad m => HTTP.HeaderName -> - Webmachine m (Maybe UTCTime) -requestHeaderDate headerName = do - req <- request - let reqHeaders = requestHeaders req - dateHeader = lookup headerName reqHeaders - parsedDate = dateHeader >>= parseRfc1123Date - return parsedDate - -writeCacheTags :: Monad m => Resource m -> FlowStateT m () -writeCacheTags Resource{..} = lift $ do - etag <- generateETag - case etag of - Nothing -> return () - Just t -> addResponseHeader ("ETag", etagToByteString t) - modified <- lastModified - case modified of - Nothing -> return () - Just d -> addResponseHeader ("Last-Modified", utcTimeToRfc1123 d) - ------------------------------------------------------------------------------- --- Type definitions for all decision nodes ------------------------------------------------------------------------------- - -b13, b12, b11, b10, b09, b08, b07, b06, b05, b04, b03 :: Monad m => Flow m -c04, c03 :: Monad m => Flow m -d05, d04 :: Monad m => Flow m -e06, e05 :: Monad m => Flow m -f07, f06 :: Monad m => Flow m -g11, g09 :: Monad m => IfMatch -> Flow m -g08, g07 :: Monad m => Flow m -h12, h11, h10, h07 :: Monad m => Flow m -i13 :: Monad m => IfNoneMatch -> Flow m -i12, i07, i04 :: Monad m => Flow m -j18 :: Monad m => Flow m -k13 :: Monad m => IfNoneMatch -> Flow m -k07, k05 :: Monad m => Flow m -l17, l15, l14, l13, l07, l05 :: Monad m => Flow m -m20, m16, m07, m05 :: Monad m => Flow m -n16, n11, n05 :: Monad m => Flow m -o20, o18, o16, o14 :: Monad m => Flow m -p11, p03 :: Monad m => Flow m - ------------------------------------------------------------------------------- --- B column ------------------------------------------------------------------------------- - -b13 r@Resource{..} = do - trace "b13" - available <- lift serviceAvailable - if available - then b12 r - else lift $ halt HTTP.status503 - -b12 r@Resource{..} = do - trace "b12" - -- known method - req <- lift request - let knownMethods = [ HTTP.methodGet - , HTTP.methodPost - , HTTP.methodHead - , HTTP.methodPut - , HTTP.methodDelete - , HTTP.methodTrace - , HTTP.methodConnect - , HTTP.methodOptions - , HTTP.methodPatch - ] - if requestMethod req `elem` knownMethods - then b11 r - else lift $ halt HTTP.status501 - -b11 r@Resource{..} = do - trace "b11" - long <- lift uriTooLong - if long - then lift $ halt HTTP.status414 - else b10 r - -b10 r@Resource{..} = do - trace "b10" - req <- lift request - allowed <- lift allowedMethods - if requestMethod req `elem` allowed - then b09 r - else do - lift $ addResponseHeader ("Allow", intercalate "," allowed) - lift $ halt HTTP.status405 - -b09 r@Resource{..} = do - trace "b09" - malformed <- lift malformedRequest - if malformed - then lift $ halt HTTP.status400 - else b08 r - -b08 r@Resource{..} = do - trace "b08" - authorized <- lift isAuthorized - if authorized - then b07 r - else lift $ halt HTTP.status401 - -b07 r@Resource{..} = do - trace "b07" - forbid <- lift forbidden - if forbid - then lift $ halt HTTP.status403 - else b06 r - -b06 r@Resource{..} = do - trace "b06" - validC <- lift validContentHeaders - if validC - then b05 r - else lift $ halt HTTP.status501 - -b05 r@Resource{..} = do - trace "b05" - known <- lift knownContentType - if known - then b04 r - else lift $ halt HTTP.status415 - -b04 r@Resource{..} = do - trace "b04" - large <- lift entityTooLarge - if large - then lift $ halt HTTP.status413 - else b03 r - -b03 r@Resource{..} = do - trace "b03" - req <- lift request - allowed <- lift allowedMethods - if requestMethod req == HTTP.methodOptions - then do - lift $ addResponseHeader ("Allow", intercalate "," allowed) - lift $ halt HTTP.status204 - else c03 r - ------------------------------------------------------------------------------- --- C column ------------------------------------------------------------------------------- - -c04 r@Resource{..} = do - trace "c04" - req <- lift request - provided <- lift contentTypesProvided - let reqHeaders = requestHeaders req - result = do - acceptStr <- lookup HTTP.hAccept reqHeaders - (acceptTyp, resource) <- mapAcceptMedia provided' acceptStr - Just (acceptTyp, resource) - where - -- this is so that in addition to getting back the resource - -- that we match, we also return the content-type provided - -- by that resource. - provided' = map dupContentType provided - dupContentType (a, b) = (a, (a, b)) - - case result of - Nothing -> lift $ halt HTTP.status406 - Just res -> do - modify (\fs -> fs { _contentType = Just res }) - d04 r - -c03 r@Resource{..} = do - trace "c03" - req <- lift request - let reqHeaders = requestHeaders req - case lookup HTTP.hAccept reqHeaders of - (Just _h) -> - c04 r - Nothing -> - d04 r - ------------------------------------------------------------------------------- --- D column ------------------------------------------------------------------------------- - -d05 r@Resource{..} = do - trace "d05" - langAvailable <- lift languageAvailable - if langAvailable - then e05 r - else lift $ halt HTTP.status406 - -d04 r@Resource{..} = do - trace "d04" - req <- lift request - let reqHeaders = requestHeaders req - case lookup HTTP.hAcceptLanguage reqHeaders of - (Just _h) -> - d05 r - Nothing -> - e05 r - ------------------------------------------------------------------------------- --- E column ------------------------------------------------------------------------------- - -e06 r@Resource{..} = do - trace "e06" - -- TODO: charset negotiation - f06 r - -e05 r@Resource{..} = do - trace "e05" - req <- lift request - let reqHeaders = requestHeaders req - case lookup hAcceptCharset reqHeaders of - (Just _h) -> - e06 r - Nothing -> - f06 r - ------------------------------------------------------------------------------- --- F column ------------------------------------------------------------------------------- - -f07 r@Resource{..} = do - trace "f07" - -- TODO: encoding negotiation - g07 r - -f06 r@Resource{..} = do - trace "f06" - req <- lift request - let reqHeaders = requestHeaders req - case lookup hAcceptEncoding reqHeaders of - (Just _h) -> - f07 r - Nothing -> - g07 r - ------------------------------------------------------------------------------- --- G column ------------------------------------------------------------------------------- - -g11 (IfMatch ifMatch) r@Resource{..} = do - trace "g11" - let etags = parseEtagList ifMatch - if null etags - then lift $ halt HTTP.status412 - else h10 r - -g09 ifMatch r@Resource{..} = do - trace "g09" - case ifMatch of - -- TODO: should we be stripping whitespace here? - (IfMatch "*") -> - h10 r - _ -> - g11 ifMatch r - -g08 r@Resource{..} = do - trace "g08" - req <- lift request - let reqHeaders = requestHeaders req - case IfMatch <$> lookup hIfMatch reqHeaders of - (Just h) -> - g09 h r - Nothing -> - h10 r - -g07 r@Resource{..} = do - trace "g07" - -- TODO: set Vary headers - exists <- lift resourceExists - if exists - then g08 r - else h07 r - ------------------------------------------------------------------------------- --- H column ------------------------------------------------------------------------------- - -h12 r@Resource{..} = do - trace "h12" - modified <- lift lastModified - parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince - let maybeGreater = do - lastM <- modified - headerDate <- parsedDate - return (lastM > headerDate) - if maybeGreater == Just True - then lift $ halt HTTP.status412 - else i12 r - -h11 r@Resource{..} = do - trace "h11" - parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince - if isJust parsedDate - then h12 r - else i12 r - -h10 r@Resource{..} = do - trace "h10" - req <- lift request - let reqHeaders = requestHeaders req - case lookup hIfUnmodifiedSince reqHeaders of - (Just _h) -> - h11 r - Nothing -> - i12 r - -h07 r@Resource {..} = do - trace "h07" - req <- lift request - let reqHeaders = requestHeaders req - case lookup hIfMatch reqHeaders of - -- TODO: should we be stripping whitespace here? - (Just "*") -> - lift $ halt HTTP.status412 - _ -> - i07 r - ------------------------------------------------------------------------------- --- I column ------------------------------------------------------------------------------- - -i13 ifNoneMatch r@Resource{..} = do - trace "i13" - case ifNoneMatch of - -- TODO: should we be stripping whitespace here? - (IfNoneMatch "*") -> - j18 r - _ -> - k13 ifNoneMatch r - -i12 r@Resource{..} = do - trace "i12" - req <- lift request - let reqHeaders = requestHeaders req - case IfNoneMatch <$> lookup hIfNoneMatch reqHeaders of - (Just h) -> - i13 h r - Nothing -> - l13 r - -i07 r = do - trace "i07" - req <- lift request - if requestMethod req == HTTP.methodPut - then i04 r - else k07 r - -i04 r@Resource{..} = do - trace "i04" - moved <- lift movedPermanently - case moved of - (Just loc) -> do - lift $ addResponseHeader ("Location", loc) - lift $ halt HTTP.status301 - Nothing -> - p03 r - ------------------------------------------------------------------------------- --- J column ------------------------------------------------------------------------------- - -j18 _ = do - trace "j18" - req <- lift request - let getOrHead = [ HTTP.methodGet - , HTTP.methodHead - ] - if requestMethod req `elem` getOrHead - then lift $ halt HTTP.status304 - else lift $ halt HTTP.status412 - ------------------------------------------------------------------------------- --- K column ------------------------------------------------------------------------------- - -k13 (IfNoneMatch ifNoneMatch) r@Resource{..} = do - trace "k13" - let etags = parseEtagList ifNoneMatch - if null etags - then l13 r - else j18 r - -k07 r@Resource{..} = do - trace "k07" - prevExisted <- lift previouslyExisted - if prevExisted - then k05 r - else l07 r - -k05 r@Resource{..} = do - trace "k05" - moved <- lift movedPermanently - case moved of - (Just loc) -> do - lift $ addResponseHeader ("Location", loc) - lift $ halt HTTP.status301 - Nothing -> - l05 r - ------------------------------------------------------------------------------- --- L column ------------------------------------------------------------------------------- - -l17 r@Resource{..} = do - trace "l17" - parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince - modified <- lift lastModified - let maybeGreater = do - lastM <- modified - ifModifiedSince <- parsedDate - return (lastM > ifModifiedSince) - if maybeGreater == Just True - then m16 r - else lift $ halt HTTP.status304 - -l15 r@Resource{..} = do - trace "l15" - parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince - now <- lift requestTime - let maybeGreater = (> now) <$> parsedDate - if maybeGreater == Just True - then m16 r - else l17 r - -l14 r@Resource{..} = do - trace "l14" - req <- lift request - let reqHeaders = requestHeaders req - dateHeader = lookup HTTP.hIfModifiedSince reqHeaders - validDate = isJust (dateHeader >>= parseRfc1123Date) - if validDate - then l15 r - else m16 r - -l13 r@Resource{..} = do - trace "l13" - req <- lift request - let reqHeaders = requestHeaders req - case lookup HTTP.hIfModifiedSince reqHeaders of - (Just _h) -> - l14 r - Nothing -> - m16 r - -l07 r = do - trace "l07" - req <- lift request - if requestMethod req == HTTP.methodPost - then m07 r - else lift $ halt HTTP.status404 - -l05 r@Resource{..} = do - trace "l05" - moved <- lift movedTemporarily - case moved of - (Just loc) -> do - lift $ addResponseHeader ("Location", loc) - lift $ halt HTTP.status307 - Nothing -> - m05 r - ------------------------------------------------------------------------------- --- M column ------------------------------------------------------------------------------- - -m20 r@Resource{..} = do - trace "m20" - deleteAccepted <- lift deleteResource - if deleteAccepted - then do - completed <- lift deleteCompleted - if completed - then o20 r - else lift $ halt HTTP.status202 - else lift $ halt HTTP.status500 - -m16 r = do - trace "m16" - req <- lift request - if requestMethod req == HTTP.methodDelete - then m20 r - else n16 r - -m07 r@Resource{..} = do - trace "m07" - allowMissing <- lift allowMissingPost - if allowMissing - then n11 r - else lift $ halt HTTP.status404 - -m05 r = do - trace "m05" - req <- lift request - if requestMethod req == HTTP.methodPost - then n05 r - else lift $ halt HTTP.status410 - ------------------------------------------------------------------------------- --- N column ------------------------------------------------------------------------------- - -n16 r = do - trace "n16" - req <- lift request - if requestMethod req == HTTP.methodPost - then n11 r - else o16 r - -n11 r@Resource{..} = trace "n11" >> lift processPost >>= flip processPostAction r - -create :: Monad m => [Text] -> Resource m -> FlowStateT m () -create ts r = do - loc <- lift (appendRequestPath ts) - lift (addResponseHeader ("Location", loc)) - negotiateContentTypesAccepted r - -processPostAction :: Monad m => PostResponse m -> Flow m -processPostAction (PostCreate ts) r = do - create ts r - p11 r -processPostAction (PostCreateRedirect ts) r = do - create ts r - lift $ halt HTTP.status303 -processPostAction (PostProcess p) r = - lift p >> p11 r -processPostAction (PostProcessRedirect ts) _r = do - locBs <- lift ts - lift $ addResponseHeader ("Location", locBs) - lift $ halt HTTP.status303 - -n05 r@Resource{..} = do - trace "n05" - allow <- lift allowMissingPost - if allow - then n11 r - else lift $ halt HTTP.status410 - ------------------------------------------------------------------------------- --- O column ------------------------------------------------------------------------------- - -o20 r = do - trace "o20" - body <- lift getResponseBody - -- ResponseBody is a little tough to make an instance of 'Eq', - -- so we just use a pattern match - case body of - Empty -> lift $ halt HTTP.status204 - _ -> o18 r - -o18 r@Resource{..} = do - trace "o18" - multiple <- lift multipleChoices - if multiple - then lift $ halt HTTP.status300 - else do - -- TODO: set etag, expiration, etc. headers - req <- lift request - let getOrHead = [ HTTP.methodGet - , HTTP.methodHead - ] - when (requestMethod req `elem` getOrHead) $ do - m <- _contentType <$> get - (cType, body) <- case m of - Nothing -> do - provided <- lift contentTypesProvided - return (head provided) - Just (cType, body) -> - return (cType, body) - b <- lift body - lift $ putResponseBody b - lift $ addResponseHeader ("Content-Type", renderHeader cType) - writeCacheTags r - lift $ halt HTTP.status200 - -o16 r = do - trace "o16" - req <- lift request - if requestMethod req == HTTP.methodPut - then o14 r - else o18 r - -o14 r@Resource{..} = do - trace "o14" - conflict <- lift isConflict - if conflict - then lift $ halt HTTP.status409 - else negotiateContentTypesAccepted r >> p11 r - ------------------------------------------------------------------------------- --- P column ------------------------------------------------------------------------------- - -p11 r = do - trace "p11" - headers <- lift getResponseHeaders - case lookup HTTP.hLocation headers of - (Just _) -> - lift $ halt HTTP.status201 - _ -> - o20 r - -p03 r@Resource{..} = do - trace "p03" - conflict <- lift isConflict - if conflict - then lift $ halt HTTP.status409 - else negotiateContentTypesAccepted r >> p11 r diff --git a/tests/examples/ghc80/Defer03.hs b/tests/examples/ghc80/Defer03.hs deleted file mode 100644 --- a/tests/examples/ghc80/Defer03.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -a :: Int -a = 'p' - -main :: IO () -main = print "No errors!" diff --git a/tests/examples/ghc80/Dep1.hs b/tests/examples/ghc80/Dep1.hs deleted file mode 100644 --- a/tests/examples/ghc80/Dep1.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module Dep1 where - -import Data.Kind - -data Proxy k (a :: k) = P - -x :: Proxy * Int -x = P - -y :: Proxy Bool True -y = P diff --git a/tests/examples/ghc80/Dep2.hs b/tests/examples/ghc80/Dep2.hs deleted file mode 100644 --- a/tests/examples/ghc80/Dep2.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PolyKinds, GADTs #-} - -module Dep2 where - -data G (a :: k) where - G1 :: G Int - G2 :: G Maybe diff --git a/tests/examples/ghc80/DepFail1.hs b/tests/examples/ghc80/DepFail1.hs deleted file mode 100644 --- a/tests/examples/ghc80/DepFail1.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module DepFail1 where - -data Proxy k (a :: k) = P - -z :: Proxy Bool -z = P - -a :: Proxy Int Bool -a = P diff --git a/tests/examples/ghc80/DeprM.hs b/tests/examples/ghc80/DeprM.hs deleted file mode 100644 --- a/tests/examples/ghc80/DeprM.hs +++ /dev/null @@ -1,4 +0,0 @@ -module DeprM {-# DEPRECATED "Here can be your menacing deprecation warning!" #-} where - -f :: Int -f = 42 diff --git a/tests/examples/ghc80/DeprU.hs b/tests/examples/ghc80/DeprU.hs deleted file mode 100644 --- a/tests/examples/ghc80/DeprU.hs +++ /dev/null @@ -1,6 +0,0 @@ -module A where - -import DeprM -- here should be emitted deprecation warning - -g :: Int -g = f diff --git a/tests/examples/ghc80/Deprecation.hs b/tests/examples/ghc80/Deprecation.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/DsStrict.hs b/tests/examples/ghc80/DsStrict.hs deleted file mode 100644 --- a/tests/examples/ghc80/DsStrict.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE Strict #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -module Main where - -import Debug.Trace - -f0 a = "fun" -f0' ~a = "fun2" - -f1 ~n = - case n of - a -> "case" -f1' ~n = - case n of - ~a -> "case2" - -f2 = \a -> "lamda" -f2' = \ ~a -> "lambda2" - -newtype Age = MkAge Int - -f4, f4' :: Age -> String -f4 (MkAge a) = "newtype" -f4' ~(MkAge a) = "newtype2" - -main :: IO () -main = mapM_ (\(what,f) -> putStrLn (f (v what))) fs - where fs = - [("fun",f0 ) - ,("fun lazy",f0') - ,("case",f1) - ,("case lazy",f1') - ,("lambda",f2) - ,("lambda lazy",f2') - ,("newtype",(\ ~i -> f4 (MkAge i))) - ,("newtype lazy",(\ ~i -> f4' (MkAge i)))] - v n = trace ("evaluated in " ++ n) 1 diff --git a/tests/examples/ghc80/DsStrictData.hs b/tests/examples/ghc80/DsStrictData.hs deleted file mode 100644 --- a/tests/examples/ghc80/DsStrictData.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, StrictData, GADTs #-} - --- | Tests the StrictData LANGUAGE pragma. -module Main where - -import qualified Control.Exception as E -import System.IO.Unsafe (unsafePerformIO) - -data Strict a = S a -data Strict2 b = S2 !b -data Strict3 c where - S3 :: c -> Strict3 c - -data UStrict = US {-# UNPACK #-} Int - -data Lazy d = L ~d -data Lazy2 e where - L2 :: ~e -> Lazy2 e - -main :: IO () -main = - do print (isBottom (S bottom)) - print (isBottom (S2 bottom)) - print (isBottom (US bottom)) - print (isBottom (S3 bottom)) - putStrLn "" - print (not (isBottom (L bottom))) - print (not (isBottom (L2 bottom))) - print (not (isBottom (Just bottom))) -- sanity check - ------------------------------------------------------------------------- --- Support for testing for bottom - -bottom :: a -bottom = error "_|_" - -isBottom :: a -> Bool -isBottom f = unsafePerformIO $ - (E.evaluate f >> return False) `E.catches` - [ E.Handler (\(_ :: E.ArrayException) -> return True) - , E.Handler (\(_ :: E.ErrorCall) -> return True) - , E.Handler (\(_ :: E.NoMethodError) -> return True) - , E.Handler (\(_ :: E.NonTermination) -> return True) - , E.Handler (\(_ :: E.PatternMatchFail) -> return True) - , E.Handler (\(_ :: E.RecConError) -> return True) - , E.Handler (\(_ :: E.RecSelError) -> return True) - , E.Handler (\(_ :: E.RecUpdError) -> return True) - ] diff --git a/tests/examples/ghc80/DsStrictFail.hs b/tests/examples/ghc80/DsStrictFail.hs deleted file mode 100644 --- a/tests/examples/ghc80/DsStrictFail.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE Strict #-} -module Main where - -main = let False = True - in return () diff --git a/tests/examples/ghc80/DsStrictLet.hs b/tests/examples/ghc80/DsStrictLet.hs deleted file mode 100644 --- a/tests/examples/ghc80/DsStrictLet.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE Strict #-} -module Main where - -import Debug.Trace - -main = let False = trace "no binders" False -- evaluated - - a :: a -> a - a = trace "polymorphic" id -- evaluated - - f :: Eq a => a -> a -> Bool - f = trace "overloaded" (==) -- not evaluated - - xs :: [Int] - xs = (trace "recursive" (:) 1 xs) -- evaluated - in return () diff --git a/tests/examples/ghc80/DsStrictWarn.hs b/tests/examples/ghc80/DsStrictWarn.hs deleted file mode 100644 --- a/tests/examples/ghc80/DsStrictWarn.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-} -{-# LANGUAGE Strict #-} -module DsStrictWarn where - --- should warn about non-exhaustive pattern match -w :: String -> String -w x = let (_:_) = x in "1" diff --git a/tests/examples/ghc80/Eq.hs b/tests/examples/ghc80/Eq.hs deleted file mode 100644 --- a/tests/examples/ghc80/Eq.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, - RankNTypes, FlexibleContexts, TemplateHaskell, - UndecidableInstances, GADTs, DefaultSignatures #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Singletons.Prelude.Eq --- Copyright : (C) 2013 Richard Eisenberg --- License : BSD-style (see LICENSE) --- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) --- Stability : experimental --- Portability : non-portable --- --- Defines the SEq singleton version of the Eq type class. --- ------------------------------------------------------------------------------ - -module Data.Singletons.Prelude.Eq ( - PEq(..), SEq(..), - (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$) - ) where - -import Data.Singletons.Prelude.Bool -import Data.Singletons -import Data.Singletons.Single -import Data.Singletons.Prelude.Instances -import Data.Singletons.Util -import Data.Singletons.Promote -import Data.Type.Equality - --- NB: These must be defined by hand because of the custom handling of the --- default for (:==) to use Data.Type.Equality.== - --- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)', --- then it defaults to a use of '(==)', from @Data.Type.Equality@. -class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where - type (:==) (x :: a) (y :: a) :: Bool - type (:/=) (x :: a) (y :: a) :: Bool - - type (x :: a) :== (y :: a) = x == y - type (x :: a) :/= (y :: a) = Not (x :== y) - -infix 4 :== -infix 4 :/= - -$(genDefunSymbols [''(:==), ''(:/=)]) - --- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required --- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'. -class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where - -- | Boolean equality on singletons - (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b) - infix 4 %:== - - -- | Boolean disequality on singletons - (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b) - default (%:/=) :: forall (a :: k) (b :: k). - ((a :/= b) ~ Not (a :== b)) - => Sing a -> Sing b -> Sing (a :/= b) - a %:/= b = sNot (a %:== b) - infix 4 %:/= - -$(singEqInstances basicTypes) diff --git a/tests/examples/ghc80/ExpandSynsFail1.hs b/tests/examples/ghc80/ExpandSynsFail1.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExpandSynsFail1.hs +++ /dev/null @@ -1,4 +0,0 @@ -type Foo = Int -type Bar = Bool - -main = print $ (1 :: Foo) == (False :: Bar) diff --git a/tests/examples/ghc80/ExpandSynsFail2.hs b/tests/examples/ghc80/ExpandSynsFail2.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExpandSynsFail2.hs +++ /dev/null @@ -1,19 +0,0 @@ --- In case of types with nested type synonyms, all synonyms should be expanded - -{-# LANGUAGE RankNTypes #-} - -import Control.Monad.ST - -type Foo = Int -type Bar = Bool - -type MyFooST s = ST s Foo -type MyBarST s = ST s Bar - -fooGen :: forall s . MyFooST s -fooGen = undefined - -barGen :: forall s . MyBarST s -barGen = undefined - -main = print (runST fooGen == runST barGen) diff --git a/tests/examples/ghc80/ExpandSynsFail3.hs b/tests/examples/ghc80/ExpandSynsFail3.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExpandSynsFail3.hs +++ /dev/null @@ -1,23 +0,0 @@ --- We test two things here: --- --- 1. We expand only as much as necessary. In this case, we shouldn't expand T. --- 2. When we find a difference(T3 and T5 in this case), we do minimal expansion --- e.g. we don't expand both of them to T1, instead we expand T5 to T3. - -module Main where - -type T5 = T4 -type T4 = T3 -type T3 = T2 -type T2 = T1 -type T1 = Int - -type T a = Int -> Bool -> a -> String - -f :: T (T3, T5, Int) -> Int -f = undefined - -a :: Int -a = f (undefined :: T (T5, T3, Bool)) - -main = print a diff --git a/tests/examples/ghc80/ExpandSynsFail4.hs b/tests/examples/ghc80/ExpandSynsFail4.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExpandSynsFail4.hs +++ /dev/null @@ -1,11 +0,0 @@ --- Synonyms shouldn't be expanded since type error is visible without --- expansions. Error message should not have `Type synonyms expanded: ...` part. - -module Main where - -type T a = [a] - -f :: T Int -> String -f = undefined - -main = putStrLn $ f (undefined :: T Bool) diff --git a/tests/examples/ghc80/ExportSyntax.hs b/tests/examples/ghc80/ExportSyntax.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExportSyntax.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module ExportSyntax ( A(.., NoA), Q(F,..), G(T,..,U)) where - -data A = A | B - -pattern NoA = B - -data Q a = Q a - -pattern F a = Q a - -data G = G | H - -pattern T = G - -pattern U = H diff --git a/tests/examples/ghc80/ExportSyntaxImport.hs b/tests/examples/ghc80/ExportSyntaxImport.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExportSyntaxImport.hs +++ /dev/null @@ -1,7 +0,0 @@ -module ExportSyntaxImport where - -import ExportSyntax - -foo = NoA - -baz = A diff --git a/tests/examples/ghc80/ExprSigLocal.hs b/tests/examples/ghc80/ExprSigLocal.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExprSigLocal.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures, RankNTypes #-} - -module ExprSigLocal where - --- We expect this to compile fine, --- reporting that '_' stands 'a' - -y :: forall b. b->b -y = ((\x -> x) :: forall a. a -> _) - -g :: forall a. a -> _ -g x = x diff --git a/tests/examples/ghc80/Extends.hs b/tests/examples/ghc80/Extends.hs deleted file mode 100644 --- a/tests/examples/ghc80/Extends.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Extends where - -class BClass b where - has :: b diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInExpressionSignature.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInExpressionSignature.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExtraConstraintsWildcardInExpressionSignature.hs +++ /dev/null @@ -1,3 +0,0 @@ -module ExtraConstraintsWildcardInExpressionSignature where - -foo x y = ((==) :: _ => _) x y diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSignature.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSignature.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSignature.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module ExtraConstraintsWildcardInPatternSignature where - -foo (x :: _ => _) y = x == y diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSplice.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSplice.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSplice.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ScopedTypeVariables #-} -module ExtraConstraintsWildcardInPatternSplice where - -foo $( [p| (x :: _) |] ) = x diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module ExtraConstraintsWildcardInTypeSplice where - -import Language.Haskell.TH - -metaType :: TypeQ -metaType = [t| _ => _ |] diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice2.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice2.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice2.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module ExtraConstraintsWildcardInTypeSplice2 where - -import Language.Haskell.TH.Lib (wildCardT) - -show' :: $(wildCardT) => a -> String -show' x = show x diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSpliceUsed.hs b/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSpliceUsed.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSpliceUsed.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module ExtraConstraintsWildcardInTypeSpliceUsed where - -import ExtraConstraintsWildcardInTypeSplice - --- An extra-constraints wild card is not supported in type splices -eq :: $(metaType) -eq x y = x == y diff --git a/tests/examples/ghc80/ExtraConstraintsWildcardTwice.hs b/tests/examples/ghc80/ExtraConstraintsWildcardTwice.hs deleted file mode 100644 --- a/tests/examples/ghc80/ExtraConstraintsWildcardTwice.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -module ExtraConstraintsWildcardTwice where - -foo :: ((_), _) => a -> a -foo = undefined diff --git a/tests/examples/ghc80/F.hs b/tests/examples/ghc80/F.hs deleted file mode 100644 --- a/tests/examples/ghc80/F.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | Thompson's group F. --- --- See eg. --- --- Based mainly on James Michael Belk's PhD thesis \"THOMPSON'S GROUP F\"; --- see --- - -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns, PatternSynonyms, DeriveFunctor #-} -module Math.Combinat.Groups.Thompson.F where - --- | Remove the carets with the given indices --- (throws an error if there is no caret at the given index) -removeCarets :: [Int] -> T -> T -removeCarets idxs tree = if null rem then final else error ("removeCarets: some stuff remained: " ++ show rem) where - - (_,rem,final) = go 0 idxs tree where - - go :: Int -> [Int] -> T -> (Int,[Int],T) - go !x [] t = (x + treeWidth t , [] , t) diff --git a/tests/examples/ghc80/FDsFromGivens2.hs b/tests/examples/ghc80/FDsFromGivens2.hs deleted file mode 100644 --- a/tests/examples/ghc80/FDsFromGivens2.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, GADTs #-} - -module FDsFromGivens2 where - -class C a b | a -> b where - cop :: a -> b -> () - -data KCC where - KCC :: C Char Char => () -> KCC - -f :: C Char [a] => a -> a -f = undefined - -bar (KCC _) = f diff --git a/tests/examples/ghc80/Families.hs b/tests/examples/ghc80/Families.hs deleted file mode 100644 --- a/tests/examples/ghc80/Families.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds, KindSignatures, - TypeOperators, UndecidableInstances #-} - -{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, EmptyDataDecls #-} - --- | A prelude for type-level programming with type families - -module Prelude.Type.Families where - --- >>> T :: T ((I 4) `Minus` (I 7)) --- -3 -type family (a :: k) `Minus` (b :: k) :: k -type instance a `Minus` b = a + Negate b - diff --git a/tests/examples/ghc80/FooBar.hs b/tests/examples/ghc80/FooBar.hs deleted file mode 100644 --- a/tests/examples/ghc80/FooBar.hs +++ /dev/null @@ -1,4 +0,0 @@ -module FooBar where - -import Foo -import Bar diff --git a/tests/examples/ghc80/ForFree.hs b/tests/examples/ghc80/ForFree.hs deleted file mode 100644 --- a/tests/examples/ghc80/ForFree.hs +++ /dev/null @@ -1,23 +0,0 @@ - -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} --- {-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module Control.ForFree where { - --- | Free monad from a functor -; - data Free f x = Pure x | Free (f (Free f x)); - - deriving instance (Eq (f (Free f a)), Eq a) => Eq (Free f a); - deriving instance (Ord (f (Free f a)), Ord a) => Ord (Free f a); - deriving instance (Read (f (Free f a)), Read a) => Read (Free f a); - deriving instance (Show (f (Free f a)), Show a) => Show (Free f a); -} diff --git a/tests/examples/ghc80/FromGrin2.hs b/tests/examples/ghc80/FromGrin2.hs deleted file mode 100644 --- a/tests/examples/ghc80/FromGrin2.hs +++ /dev/null @@ -1,6 +0,0 @@ - --- ./hackage-roundtrip-work/ajhc-0.8.0.10/src/C/FromGrin2.hs --- orig line 588 -convertExp :: Exp -> C (Statement,Expression) -convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do - return (mempty,e) diff --git a/tests/examples/ghc80/FrontendPlugin.hs b/tests/examples/ghc80/FrontendPlugin.hs deleted file mode 100644 --- a/tests/examples/ghc80/FrontendPlugin.hs +++ /dev/null @@ -1,52 +0,0 @@ -module FrontendPlugin where - -import GhcPlugins -import qualified GHC -import GHC ( Ghc, LoadHowMuch(..) ) - -import DriverPipeline hiding ( hsc_env ) -import DriverPhases -import System.Exit -import Control.Monad -import Data.List - -frontendPlugin :: FrontendPlugin -frontendPlugin = defaultFrontendPlugin { - frontend = doMake - } - --- Copypasted from ghc/Main.hs -doMake :: [String] -> [(String,Maybe Phase)] -> Ghc () -doMake opts srcs = do - liftIO $ print opts - let (hs_srcs, non_hs_srcs) = partition haskellish srcs - - haskellish (f,Nothing) = - looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f - haskellish (_,Just phase) = - phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm - , StopLn] - - hsc_env <- GHC.getSession - - -- if we have no haskell sources from which to do a dependency - -- analysis, then just do one-shot compilation and/or linking. - -- This means that "ghc Foo.o Bar.o -o baz" links the program as - -- we expect. - if (null hs_srcs) - then liftIO (oneShot hsc_env StopLn srcs) - else do - - o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) - non_hs_srcs - dflags <- GHC.getSessionDynFlags - let dflags' = dflags { ldInputs = map (FileOption "") o_files - ++ ldInputs dflags } - _ <- GHC.setSessionDynFlags dflags' - - targets <- mapM (uncurry GHC.guessTarget) hs_srcs - GHC.setTargets targets - ok_flag <- GHC.load LoadAllTargets - - when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) - return () diff --git a/tests/examples/ghc80/GA1r.hs b/tests/examples/ghc80/GA1r.hs deleted file mode 100644 --- a/tests/examples/ghc80/GA1r.hs +++ /dev/null @@ -1,5 +0,0 @@ -module GA1r where -import Text.ParserCombinators.Parsec - -parseStr :: CharParser () String -parseStr = char '"' *> (many1 (noneOf "\"")) <* char '"' diff --git a/tests/examples/ghc80/Generate.hs b/tests/examples/ghc80/Generate.hs deleted file mode 100644 --- a/tests/examples/ghc80/Generate.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Control.Monad (forM_) - -main :: IO () -main = forM_ [0..0xffff] $ \i -> do - putStrLn $ ".section s" ++ show i ++ ",\"\",@progbits" - putStrLn $ ".asciz \"Section " ++ show i ++ "\"" - putStrLn "" diff --git a/tests/examples/ghc80/Generic.hs b/tests/examples/ghc80/Generic.hs deleted file mode 100644 --- a/tests/examples/ghc80/Generic.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} -module Env.Generic - ( Record(..) - , type (?)(..) - ) where - -import Data.Promotion.Prelude (type (:+$), type (:*$), type (:^$), type (:-$)) -import Options.Generic (Generic, ParseRecord, type ()(..)) diff --git a/tests/examples/ghc80/IPLocation.hs b/tests/examples/ghc80/IPLocation.hs deleted file mode 100644 --- a/tests/examples/ghc80/IPLocation.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE ImplicitParams, RankNTypes #-} -{-# OPTIONS_GHC -dcore-lint #-} -module Main where - -import GHC.Exception -import GHC.Types - -f0 = putStrLn $ showCallStack ?loc - -- should just show the location of ?loc - -f1 :: (?loc :: CallStack) => IO () -f1 = putStrLn $ showCallStack ?loc - -- should show the location of ?loc *and* f1's call-site - -f2 :: (?loc :: CallStack) => IO () -f2 = do putStrLn $ showCallStack ?loc - putStrLn $ showCallStack ?loc - -- each ?loc should refer to a different location, but they should - -- share f2's call-site - -f3 :: ((?loc :: CallStack) => () -> IO ()) -> IO () -f3 x = x () - -- the call-site for the functional argument should be added to the - -- stack.. - -f4 :: (?loc :: CallStack) => ((?loc :: CallStack) => () -> IO ()) -> IO () -f4 x = x () - -- as should the call-site for f4 itself - -f5 :: (?loc1 :: CallStack) => ((?loc2 :: CallStack) => () -> IO ()) -> IO () -f5 x = x () - -- we only push new call-sites onto CallStacks with the name IP name - -f6 :: (?loc :: CallStack) => Int -> IO () -f6 0 = putStrLn $ showCallStack ?loc -f6 n = f6 (n-1) - -- recursive functions add a SrcLoc for each recursive call - -main = do f0 - f1 - f2 - f3 (\ () -> putStrLn $ showCallStack ?loc) - f4 (\ () -> putStrLn $ showCallStack ?loc) - f5 (\ () -> putStrLn $ showCallStack ?loc3) - f6 5 diff --git a/tests/examples/ghc80/Improvement.hs b/tests/examples/ghc80/Improvement.hs deleted file mode 100644 --- a/tests/examples/ghc80/Improvement.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module Foo where - -type family F a -type instance F Int = Bool - -class C a b where - -instance (b~Int) => C Bool b - -blug :: C (F a) a => a -> F a -blug = error "Urk" - -foo :: Bool -foo = blug undefined --- [W] C (F a0) a0, F a0 ~ Bool - diff --git a/tests/examples/ghc80/KindEqualities.hs b/tests/examples/ghc80/KindEqualities.hs deleted file mode 100644 --- a/tests/examples/ghc80/KindEqualities.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE PolyKinds, GADTs, ExplicitForAll #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - -module KindEqualities where - -data TyRep1 :: * -> * where - TyInt1 :: TyRep1 Int - TyBool1 :: TyRep1 Bool - -zero1 :: forall a. TyRep1 a -> a -zero1 TyInt1 = 0 -zero1 TyBool1 = False - -data Proxy (a :: k) = P - -data TyRep :: k -> * where - TyInt :: TyRep Int - TyBool :: TyRep Bool - TyMaybe :: TyRep Maybe - TyApp :: TyRep a -> TyRep b -> TyRep (a b) - -zero :: forall (a :: *). TyRep a -> a -zero TyInt = 0 -zero TyBool = False -zero (TyApp TyMaybe _) = Nothing diff --git a/tests/examples/ghc80/KindLevels.hs b/tests/examples/ghc80/KindLevels.hs deleted file mode 100644 --- a/tests/examples/ghc80/KindLevels.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DataKinds, PolyKinds #-} - -module KindLevels where - -data A -data B :: A -> * -data C :: B a -> * -data D :: C b -> * -data E :: D c -> * diff --git a/tests/examples/ghc80/ListComprehensions.hs b/tests/examples/ghc80/ListComprehensions.hs deleted file mode 100644 --- a/tests/examples/ghc80/ListComprehensions.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE ParallelListComp, - TransformListComp, - RecordWildCards #-} --- MonadComprehensions, - -module ListComprehensions where - - - -import GHC.Exts -import qualified Data.Map as M -import Data.Ord (comparing) -import Data.List (sortBy) - --- Let’s look at a simple, normal list comprehension to start: - -parallelListComp :: [Int] -parallelListComp = [ x + y * z - | x <- [0..10] - | y <- [10..20] - | z <- [20..30] - ] - -oldest :: [Int] -> [String] -oldest tbl = [ "str" - | n <- tbl - , then id - ] diff --git a/tests/examples/ghc80/LiteralsTest2.hs b/tests/examples/ghc80/LiteralsTest2.hs deleted file mode 100644 --- a/tests/examples/ghc80/LiteralsTest2.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module LiteralsTest2 where - -x,y :: Int -x = 0003 -y = 0x04 - -s :: String -s = "\x20" - -c :: Char -c = '\x20' - -d :: Double -d = 0.00 - -blah = x - where - charH = '\x41'# - intH = 0004# - wordH = 005## - floatH = 3.20# - doubleH = 04.16## - x = 1 diff --git a/tests/examples/ghc80/Main.hs b/tests/examples/ghc80/Main.hs deleted file mode 100644 --- a/tests/examples/ghc80/Main.hs +++ /dev/null @@ -1,14 +0,0 @@ --- Copyright (C) 2015, Luke Iannini - -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ForeignFunctionInterface #-} - -module Main where -import Printf ( pr ) - -foreign import ccall "talkToCxx" talkToCxx :: IO () - -main :: IO () -main = do - putStrLn ( $(pr "Hello From Template Haskell!") ) - talkToCxx diff --git a/tests/examples/ghc80/Manipulate.hs b/tests/examples/ghc80/Manipulate.hs deleted file mode 100644 --- a/tests/examples/ghc80/Manipulate.hs +++ /dev/null @@ -1,39 +0,0 @@ -{- | -Module : Control.Comonad.Sheet.Manipulate -Description : Generic functions for manipulating multi-dimensional comonadic spreadsheets. -Copyright : Copyright (c) 2014 Kenneth Foner - -Maintainer : kenneth.foner@gmail.com -Stability : experimental -Portability : non-portable - -This module defines the 'take', 'view', 'go', and 'insert' functions generically for any dimensionality of sheet. These -constitute the preferred way of manipulating sheets, providing an interface to: take finite slices ('take'), infinite -slices ('view'), move to locations ('go'), and insert finite or infinite structures ('insert'). --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Control.Comonad.Sheet.Manipulate where - - --- | In the case of a @Nested@ structure, @asDimensionalAs@ defaults to @asNestedAs@. -instance (NestedAs x (Nested ts y), AsDimensionalAs x (Nested ts y) ~ AsNestedAs x (Nested ts y)) => DimensionalAs x (Nested ts y) where - type x `AsDimensionalAs` (Nested ts a) = x `AsNestedAs` (Nested ts a) - asDimensionalAs = asNestedAs - --- | @DimensionalAs@ also knows the dimensionality of an 'Indexed' sheet as well as regular @Nested@ structures. -instance (NestedAs x (Nested ts y)) => DimensionalAs x (Indexed ts y) where - type x `AsDimensionalAs` (Indexed ts a) = x `AsNestedAs` (Nested ts a) - x `asDimensionalAs` (Indexed i t) = x `asNestedAs` t - - -instance DepIndex (a,b) TH_0 where - type (a,b) `DepIndexResult` TH_0 = a - (a,b) # TH_0 = a diff --git a/tests/examples/ghc80/Match.hs b/tests/examples/ghc80/Match.hs deleted file mode 100644 --- a/tests/examples/ghc80/Match.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_HADDOCK hide #-} - --- Discriminate binary functions that commute, and if so return the operands in --- a stable ordering such that matching recognises expressions modulo --- commutativity. --- -commutes - :: forall acc env aenv a r. - HashAcc acc - -> PrimFun (a -> r) - -> PreOpenExp acc env aenv a - -> Maybe (PreOpenExp acc env aenv a) -commutes h f x = case f of - PrimAdd _ -> Just (swizzle x) - PrimMul _ -> Just (swizzle x) - PrimBAnd _ -> Just (swizzle x) - PrimBOr _ -> Just (swizzle x) - PrimBXor _ -> Just (swizzle x) - PrimEq _ -> Just (swizzle x) - PrimNEq _ -> Just (swizzle x) - PrimMax _ -> Just (swizzle x) - PrimMin _ -> Just (swizzle x) - PrimLAnd -> Just (swizzle x) - PrimLOr -> Just (swizzle x) - _ -> Nothing - where - swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a') - swizzle exp - | Tuple (NilTup `SnocTup` a `SnocTup` b) <- exp - , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a) - -- - | otherwise = exp diff --git a/tests/examples/ghc80/MonadFailErrors.hs b/tests/examples/ghc80/MonadFailErrors.hs deleted file mode 100644 --- a/tests/examples/ghc80/MonadFailErrors.hs +++ /dev/null @@ -1,95 +0,0 @@ --- Test purpose: --- Break properly if MonadFail is live - -{- # LANGUAGE MonadFailDesugaring # -} - -module MonadFailWarnings where - -import Control.Monad.Fail -import Control.Monad.ST -import Data.Functor.Identity - - - -general :: Monad m => m a -general = do - Just x <- undefined - undefined - - - -general' :: MonadFail m => m a -general' = do - Just x <- undefined - undefined - - - -identity :: Identity a -identity = do - Just x <- undefined - undefined - - - -io :: IO a -io = do - Just x <- undefined - undefined - - - -st :: ST s a -st = do - Just x <- undefined - undefined - - - -reader :: r -> a -reader = do - Just x <- undefined - undefined - - - -newtype Newtype a = Newtype a -newtypeMatch :: Identity a -newtypeMatch = do - Newtype x <- undefined - undefined - - - -data Data a = Data a -singleConMatch :: Identity a -singleConMatch = do - Data x <- undefined - undefined - - - -data Maybe' a = Nothing' | Just' a -instance Functor Maybe' where fmap = undefined -instance Applicative Maybe' where pure = undefined; (<*>) = undefined -instance Monad Maybe' where (>>=) = undefined -instance MonadFail Maybe' where fail = undefined -customFailable :: Maybe' a -customFailable = do - Just x <- undefined - undefined - - -wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a -wildcardx = do - x <- undefined - undefined -explicitlyIrrefutable = do - ~(x:y) <- undefined - undefined -wildcard_ = do - _ <- undefined - undefined -tuple = do - (a,b) <- undefined - undefined diff --git a/tests/examples/ghc80/MonadFailWarnings.hs b/tests/examples/ghc80/MonadFailWarnings.hs deleted file mode 100644 --- a/tests/examples/ghc80/MonadFailWarnings.hs +++ /dev/null @@ -1,107 +0,0 @@ --- Test purpose: --- Ensure that MonadFail warnings are issued correctly if the warning flag --- is enabled - -{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-} - -module MonadFailWarnings where - -import Control.Monad.Fail -import Control.Monad.ST -import Data.Functor.Identity - - - --- should warn, because the do-block gets a general Monad constraint, --- but should have MonadFail -general :: Monad m => m a -general = do - Just x <- undefined - undefined - - - --- should NOT warn, because the constraint is correct -general' :: MonadFail m => m a -general' = do - Just x <- undefined - undefined - - - --- should warn, because Identity isn't MonadFail -identity :: Identity a -identity = do - Just x <- undefined - undefined - - - --- should NOT warn, because IO is MonadFail -io :: IO a -io = do - Just x <- undefined - undefined - - - --- should warn, because (ST s) is not MonadFail -st :: ST s a -st = do - Just x <- undefined - undefined - - - --- should warn, because (r ->) is not MonadFail -reader :: r -> a -reader = do - Just x <- undefined - undefined - - - --- should NOT warn, because matching against newtype -newtype Newtype a = Newtype a -newtypeMatch :: Identity a -newtypeMatch = do - Newtype x <- undefined - undefined - - - --- should NOT warn, because Data has only one constructor -data Data a = Data a -singleConMatch :: Identity a -singleConMatch = do - Data x <- undefined - undefined - - - --- should NOT warn, because Maybe' has a MonadFail instance -data Maybe' a = Nothing' | Just' a -instance Functor Maybe' where fmap = undefined -instance Applicative Maybe' where pure = undefined; (<*>) = undefined -instance Monad Maybe' where (>>=) = undefined -instance MonadFail Maybe' where fail = undefined -customFailable :: Maybe' a -customFailable = do - Just x <- undefined - undefined - - --- should NOT warn, because patterns always match -wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a -wildcardx = do - x <- undefined - undefined -explicitlyIrrefutable = do - ~(x:y) <- undefined - undefined -wildcard_ = do - _ <- undefined - undefined -tuple = do - (a,b) <- undefined - undefined diff --git a/tests/examples/ghc80/MonadFailWarningsDisabled.hs b/tests/examples/ghc80/MonadFailWarningsDisabled.hs deleted file mode 100644 --- a/tests/examples/ghc80/MonadFailWarningsDisabled.hs +++ /dev/null @@ -1,94 +0,0 @@ --- Test purpose: --- Make sure that not enabling MonadFail warnings makes code compile just --- as it did in < 8.0 - -module MonadFailWarnings where - -import Control.Monad.Fail -import Control.Monad.ST -import Data.Functor.Identity - - - -general :: Monad m => m a -general = do - Just x <- undefined - undefined - - - -general' :: MonadFail m => m a -general' = do - Just x <- undefined - undefined - - - -identity :: Identity a -identity = do - Just x <- undefined - undefined - - - -io :: IO a -io = do - Just x <- undefined - undefined - - - -st :: ST s a -st = do - Just x <- undefined - undefined - - - -reader :: r -> a -reader = do - Just x <- undefined - undefined - - - -newtype Newtype a = Newtype a -newtypeMatch :: Identity a -newtypeMatch = do - Newtype x <- undefined - undefined - - - -data Data a = Data a -singleConMatch :: Identity a -singleConMatch = do - Data x <- undefined - undefined - - - -data Maybe' a = Nothing' | Just' a -instance Functor Maybe' where fmap = undefined -instance Applicative Maybe' where pure = undefined; (<*>) = undefined -instance Monad Maybe' where (>>=) = undefined -instance MonadFail Maybe' where fail = undefined -customFailable :: Maybe' a -customFailable = do - Just x <- undefined - undefined - - -wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a -wildcardx = do - x <- undefined - undefined -explicitlyIrrefutable = do - ~(x:y) <- undefined - undefined -wildcard_ = do - _ <- undefined - undefined -tuple = do - (a,b) <- undefined - undefined diff --git a/tests/examples/ghc80/MonadFailWarningsWithRebindableSyntax.hs b/tests/examples/ghc80/MonadFailWarningsWithRebindableSyntax.hs deleted file mode 100644 --- a/tests/examples/ghc80/MonadFailWarningsWithRebindableSyntax.hs +++ /dev/null @@ -1,14 +0,0 @@ --- Test purpose: --- RebindableSyntax does not play that well with MonadFail, so here we ensure --- that when both settings are enabled we get the proper warning. - -{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-} -{-# LANGUAGE RebindableSyntax #-} - -module MonadFailWarningsWithRebindableSyntax where - -import Prelude - -test1 f g = do - Just x <- f - g diff --git a/tests/examples/ghc80/MonadT.hs b/tests/examples/ghc80/MonadT.hs deleted file mode 100644 --- a/tests/examples/ghc80/MonadT.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# OPTIONS -XRank2Types #-} - -module Control.Monatron.MonadT ( - MonadT(..), FMonadT(..), MMonadT(..), FComp(..), FunctorD(..), tmap, mtmap, - module Control.Monad -) where - -import Control.Monad - - ----------------------------------------------------------- --- Class of monad transformers with --- a lifting of first-order operations ----------------------------------------------------------- - -class MonadT t where - lift :: Monad m => m a -> t m a - treturn :: Monad m => a -> t m a - treturn = lift. return - tbind :: Monad m => t m a -> (a -> t m b) -> t m b - -newtype FunctorD f = FunctorD {fmapD :: forall a b . (a -> b) -> f a -> f b} - -functor :: Functor f => FunctorD f -functor = FunctorD fmap - -class MonadT t => FMonadT t where - tmap' :: FunctorD m -> FunctorD n -> (a -> b) -> (forall x. m x -> n x) -> t m a -> t n b - -tmap :: (FMonadT t, Functor m, Functor n) => (forall b. m b -> n b) -> t m a -> t n a -tmap = tmap' functor functor id - -mtmap :: FMonadT t => FunctorD f -> (a -> b) -> t f a -> t f b -mtmap fd f = tmap' fd fd f id - -class FMonadT t => MMonadT t where - flift :: Functor f => f a -> t f a --should coincide with lift! - monoidalT :: (Functor f, Functor g) => t f (t g a) -> t (FComp f g) a - ----------------------------------------- --- Functor Composition ----------------------------------------- - -newtype (FComp f g) a = Comp {deComp :: (f (g a)) } - -instance (Functor f, Functor g) => Functor (FComp f g) where - fmap f (Comp fga) = Comp (fmap (fmap f) fga) - diff --git a/tests/examples/ghc80/MultiLineWarningPragma.hs b/tests/examples/ghc80/MultiLineWarningPragma.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/MultiQuote.hs b/tests/examples/ghc80/MultiQuote.hs deleted file mode 100644 --- a/tests/examples/ghc80/MultiQuote.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes#-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE EmptyCase #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Internal API for the store package. The functions here which are --- not re-exported by "Data.Store" are less likely to have stable APIs. --- --- This module also defines most of the included 'Store' instances, for --- types from the base package and other commonly used packages --- (bytestring, containers, text, time, etc). -module Data.Store.Internal where - ------------------------------------------------------------------------- --- Instances generated by TH - -$($(derive [d| - -- TODO - -- instance Deriving (Store ()) - instance Deriving (Store All) - instance Deriving (Store Any) - instance Deriving (Store Void) - instance Deriving (Store Bool) - |])) - diff --git a/tests/examples/ghc80/MultiWayIf.hs b/tests/examples/ghc80/MultiWayIf.hs deleted file mode 100644 --- a/tests/examples/ghc80/MultiWayIf.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -module MultiWayIf where - -foo = if | test1 -> e1 - | test2 witharg -> e2 - | otherwise -> def - -bar = if { | test1 -> if { | test2 -> e1 - | test3 -> e2 } - | test4 -> e3 - } - --- taken from GHC's test suite -x = 10 -x1 = if | x < 10 -> "< 10" | otherwise -> "" -x2 = if | x < 10 -> "< 10" - | otherwise -> "" -x3 = if | x < 10 -> "< 10" - | otherwise -> "" -x4 = if | True -> "yes" -x5 = if | True -> if | False -> 1 | True -> 2 - -x6 = if | x < 10 -> if | True -> "yes" - | False -> "no" - | otherwise -> "maybe" - -x7 = (if | True -> 0) - --- issue #98 -spam = if | () <- () -> () diff --git a/tests/examples/ghc80/NamedWildcardInDataFamilyInstanceLHS.hs b/tests/examples/ghc80/NamedWildcardInDataFamilyInstanceLHS.hs deleted file mode 100644 --- a/tests/examples/ghc80/NamedWildcardInDataFamilyInstanceLHS.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds, NamedWildCards #-} -module NamedWildcardInDataFamilyInstanceLHS where - -data MyKind = A | B - -data family Sing (a :: k) - -data instance Sing (_a :: MyKind) where - SingA :: Sing A - SingB :: Sing B diff --git a/tests/examples/ghc80/NamedWildcardInTypeFamilyInstanceLHS.hs b/tests/examples/ghc80/NamedWildcardInTypeFamilyInstanceLHS.hs deleted file mode 100644 --- a/tests/examples/ghc80/NamedWildcardInTypeFamilyInstanceLHS.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE NamedWildCards #-} -module NamedWildcardInTypeFamilyInstanceLHS where - -type family F a where - F _t = Int diff --git a/tests/examples/ghc80/NamedWildcardInTypeSplice.hs b/tests/examples/ghc80/NamedWildcardInTypeSplice.hs deleted file mode 100644 --- a/tests/examples/ghc80/NamedWildcardInTypeSplice.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NamedWildCards #-} -module NamedWildcardInTypeSplice where - -import Language.Haskell.TH - -metaType :: TypeQ -metaType = [t| _a -> _a |] diff --git a/tests/examples/ghc80/OutOfHeap.hs b/tests/examples/ghc80/OutOfHeap.hs deleted file mode 100644 --- a/tests/examples/ghc80/OutOfHeap.hs +++ /dev/null @@ -1,10 +0,0 @@ -import qualified Data.Array.Unboxed as UA -import Data.Word - -main :: IO () -main = print (UA.listArray (1, 2^(20::Int)) (repeat 0) - :: UA.UArray Int Word64) - -- this unboxed array should at least take: - -- 2^20 * 64 bits - -- = 8 * (2^20 bytes) - -- = 8 MiB (in heap) diff --git a/tests/examples/ghc80/OverloadedRecFldsFail04_A.hs b/tests/examples/ghc80/OverloadedRecFldsFail04_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/OverloadedRecFldsFail04_A.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - -module OverloadedRecFldsFail04_A (U(..), V(MkV, x), Unused(..), u) where - -data U = MkU { x :: Bool, y :: Bool } -data V = MkV { x :: Int } -data Unused = MkUnused { unused :: Bool } - -u = MkU False True diff --git a/tests/examples/ghc80/OverloadedRecFldsFail06_A.hs b/tests/examples/ghc80/OverloadedRecFldsFail06_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/OverloadedRecFldsFail06_A.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -fwarn-unused-binds #-} - -module OverloadedRecFldsFail06_A (U(..), V(..), Unused(unused), u, getX, getY, z) where - -data U = MkU { x :: Bool, y :: Bool } | MkU2 { used_locally :: Bool } - deriving Show -data V = MkV { x :: Int } | MkV2 { y :: Bool } -data Unused = MkUnused { unused :: Bool, unused2 :: Bool, used_locally :: Bool } - -u = MkU False True - -z MkU2{used_locally=used_locally} = used_locally - -getX MkU{x=x} = x -getY MkV2{y=y} = y diff --git a/tests/examples/ghc80/OverloadedRecFldsFail10_A.hs b/tests/examples/ghc80/OverloadedRecFldsFail10_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/OverloadedRecFldsFail10_A.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module OverloadedRecFldsFail10_A where - -data family F a -data instance F Int = MkFInt { foo :: Int } diff --git a/tests/examples/ghc80/OverloadedRecFldsFail10_B.hs b/tests/examples/ghc80/OverloadedRecFldsFail10_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/OverloadedRecFldsFail10_B.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module OverloadedRecFldsFail10_B (F(..)) where - -import OverloadedRecFldsFail10_A hiding (foo) - -data instance F Bool = MkFBool { foo :: Int } diff --git a/tests/examples/ghc80/OverloadedRecFldsFail10_C.hs b/tests/examples/ghc80/OverloadedRecFldsFail10_C.hs deleted file mode 100644 --- a/tests/examples/ghc80/OverloadedRecFldsFail10_C.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} -module OverloadedRecFldsFail10_C (F(..)) where - -import OverloadedRecFldsFail10_A - -data instance F Char = MkFChar { foo :: Char } diff --git a/tests/examples/ghc80/OverloadedRecFldsFail11_A.hs b/tests/examples/ghc80/OverloadedRecFldsFail11_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/OverloadedRecFldsFail11_A.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module OverloadedRecFldsFail11_A where - -{-# WARNING foo "Warning on a record field" #-} -data S = MkS { foo :: Bool } -data T = MkT { foo :: Int } diff --git a/tests/examples/ghc80/OverloadedRecFldsFail12_A.hs b/tests/examples/ghc80/OverloadedRecFldsFail12_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/OverloadedRecFldsFail12_A.hs +++ /dev/null @@ -1,5 +0,0 @@ -module OverloadedRecFldsFail12_A where - -{-# WARNING foo "Deprecated foo" #-} -{-# WARNING bar "Deprecated bar" #-} -data T = MkT { foo :: Int, bar :: Int } diff --git a/tests/examples/ghc80/OverloadedRecFldsRun02_A.hs b/tests/examples/ghc80/OverloadedRecFldsRun02_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/OverloadedRecFldsRun02_A.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - -module OverloadedRecFldsRun02_A (U(..), V(MkV, x), Unused(..), u) where - -data U = MkU { x :: Bool, y :: Bool } -data V = MkV { x :: Int } -data Unused = MkUnused { unused :: Bool } - -u = MkU False True diff --git a/tests/examples/ghc80/P.hs b/tests/examples/ghc80/P.hs deleted file mode 100644 --- a/tests/examples/ghc80/P.hs +++ /dev/null @@ -1,12 +0,0 @@ -module P where - -import qualified Map -import qualified Set - -foo = do - let x = Map.insert 0 "foo" - . Map.insert (6 :: Int) "foo" - $ Map.empty - print (Map.lookup 1 x) - print (Set.size (Map.keysSet x)) - return x diff --git a/tests/examples/ghc80/PSQ.hs b/tests/examples/ghc80/PSQ.hs deleted file mode 100644 --- a/tests/examples/ghc80/PSQ.hs +++ /dev/null @@ -1,4 +0,0 @@ - -data TourView a = Null - | Single {-# UNPACK #-} !(Elem a) - | (PSQ a) `Play` (PSQ a) diff --git a/tests/examples/ghc80/ParenFunBind.hs b/tests/examples/ghc80/ParenFunBind.hs deleted file mode 100644 --- a/tests/examples/ghc80/ParenFunBind.hs +++ /dev/null @@ -1,5 +0,0 @@ -module ParenFunBind where - -(foo x) y = x + y -((bar x)) y = x + y -((baz x)) (y) = x + y diff --git a/tests/examples/ghc80/ParenTypeSynonym.hs b/tests/examples/ghc80/ParenTypeSynonym.hs deleted file mode 100644 --- a/tests/examples/ghc80/ParenTypeSynonym.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -module ParenTypeSynonym where - -type Is = (~) diff --git a/tests/examples/ghc80/PartialClassMethodSignature2.hs b/tests/examples/ghc80/PartialClassMethodSignature2.hs deleted file mode 100644 --- a/tests/examples/ghc80/PartialClassMethodSignature2.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -module PartialClassMethodSignature2 where - -class Foo a where - foo :: (Eq a, _) => a -> a diff --git a/tests/examples/ghc80/PluralS.hs b/tests/examples/ghc80/PluralS.hs deleted file mode 100644 --- a/tests/examples/ghc80/PluralS.hs +++ /dev/null @@ -1,27 +0,0 @@ --- Test purpose: --- --- Ensure the plural "s" in warnings is only shown if there are more than --- one entries - -{-# OPTIONS_GHC -Wredundant-constraints #-} -{-# OPTIONS_GHC -Wtype-defaults #-} - -module PluralS () where - - - --- Defaulting type classes - -defaultingNum = 123 `seq` () - -defaultingNumAndShow = show 123 - - - --- Redundant constraints - -redundantNum :: (Num a, Num a) => a -redundantNum = 123 - -redundantMultiple :: (Num a, Show a, Num a, Eq a, Eq a) => a -redundantMultiple = 123 diff --git a/tests/examples/ghc80/PolyInstances.hs b/tests/examples/ghc80/PolyInstances.hs deleted file mode 100644 --- a/tests/examples/ghc80/PolyInstances.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE PolyKinds, FlexibleInstances, ScopedTypeVariables, - UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module PolyInstances where - -import GHC.Exts -import Data.Proxy - -class C (a :: k) - -instance (C a, C b) => C (a b) - -data Dict :: Constraint -> * - -instance C Dict - -foo :: C p => proxy p -> () -foo = undefined - -bar :: forall (p :: Constraint) proxy. C p => proxy p -> () -bar _ = foo (Proxy :: Proxy (Dict p)) diff --git a/tests/examples/ghc80/PopCnt.hs b/tests/examples/ghc80/PopCnt.hs deleted file mode 100644 --- a/tests/examples/ghc80/PopCnt.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-} -module Main where - -import GHC.Exts - -foreign import prim "do_popcnt32" popcnt32 :: Int# -> Int# - -main = print (I# (popcnt32 0xffff#)) - diff --git a/tests/examples/ghc80/Ppr017.hs b/tests/examples/ghc80/Ppr017.hs deleted file mode 100644 --- a/tests/examples/ghc80/Ppr017.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ExplicitNamespaces #-} -module Imports( f, type (+), pattern Single ) where - -import GHC.TypeLits - -pattern Single x = [x] - -f = undefined diff --git a/tests/examples/ghc80/Primop.hs b/tests/examples/ghc80/Primop.hs deleted file mode 100644 --- a/tests/examples/ghc80/Primop.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE GHCForeignImportPrim, MagicHash, - UnliftedFFITypes, UnboxedTuples #-} - -import GHC.Exts - -foreign import prim "dummy" - dummy :: Word# -> Word# - -foreign import prim "dummy2" - dummy2 :: Any -> State# RealWorld -> (# State# RealWorld, Word# #) diff --git a/tests/examples/ghc80/Printf.hs b/tests/examples/ghc80/Printf.hs deleted file mode 100644 --- a/tests/examples/ghc80/Printf.hs +++ /dev/null @@ -1,34 +0,0 @@ --- Copyright (C) 2015, Luke Iannini - -{-# LANGUAGE TemplateHaskell #-} -module Printf where - --- Skeletal printf from the paper: --- http://research.microsoft.com/pubs/67015/meta-haskell.pdf --- It needs to be in a separate module to the one where --- you intend to use it. - --- Import some Template Haskell syntax -import Language.Haskell.TH - --- Describe a format string -data Format = D | S | L String - --- Parse a format string. This is left largely to you --- as we are here interested in building our first ever --- Template Haskell program and not in building printf. -parse :: String -> [Format] -parse s = [ L s ] - --- Generate Haskell source code from a parsed representation --- of the format string. This code will be spliced into --- the module which calls "pr", at compile time. -gen :: [Format] -> Q Exp -gen [D] = [| \n -> show n |] -gen [S] = [| \s -> s |] -gen [L s] = stringE s - --- Here we generate the Haskell code for the splice --- from an input format string. -pr :: String -> Q Exp -pr s = gen (parse s) diff --git a/tests/examples/ghc80/PromotedClass.hs b/tests/examples/ghc80/PromotedClass.hs deleted file mode 100644 --- a/tests/examples/ghc80/PromotedClass.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeInType, GADTs #-} - -module PromotedClass where - -import Data.Proxy - -data X a where - MkX :: Show a => a -> X a - -foo :: Proxy ('MkX 'True) -foo = Proxy diff --git a/tests/examples/ghc80/Q.hs b/tests/examples/ghc80/Q.hs deleted file mode 100644 --- a/tests/examples/ghc80/Q.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Q where - -import qualified Map -import Map(Map) - -mymember :: Int -> Map Int a -> Bool -mymember k m = Map.member k m || Map.member (k + 1) m diff --git a/tests/examples/ghc80/QQ.hs b/tests/examples/ghc80/QQ.hs deleted file mode 100644 --- a/tests/examples/ghc80/QQ.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module QQ where - -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import Language.Haskell.TH - -pq = QuasiQuoter { quoteDec = \_ -> return [sig], - quoteType = \_ -> undefined, - quoteExp = \_ -> undefined, - quotePat = \_ -> undefined } - -sig = SigD (mkName "f") (ArrowT `AppT` int `AppT` int) -int = ConT (mkName "Int") diff --git a/tests/examples/ghc80/Query.hs b/tests/examples/ghc80/Query.hs deleted file mode 100644 --- a/tests/examples/ghc80/Query.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE CPP #-} - -module AWS.Lib.Query where - -requestQuery = do - if st < 400 -#ifdef DEBUG - do e -#else - then return body - else fail "not reached" -#endif - diff --git a/tests/examples/ghc80/RandomPGC.hs b/tests/examples/ghc80/RandomPGC.hs deleted file mode 100644 --- a/tests/examples/ghc80/RandomPGC.hs +++ /dev/null @@ -1,597 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif - ------------------------------------------------------------------------------ --- | --- Module : System.Random --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE in the 'random' repository) --- --- Maintainer : libraries@haskell.org --- Stability : stable --- Portability : portable --- --- This library deals with the common task of pseudo-random number --- generation. The library makes it possible to generate repeatable --- results, by starting with a specified initial random number generator, --- or to get different results on each run by using the system-initialised --- generator or by supplying a seed from some other source. --- --- The library is split into two layers: --- --- * A core /random number generator/ provides a supply of bits. --- The class 'RandomGen' provides a common interface to such generators. --- The library provides one instance of 'RandomGen', the abstract --- data type 'StdGen'. Programmers may, of course, supply their own --- instances of 'RandomGen'. --- --- * The class 'Random' provides a way to extract values of a particular --- type from a random number generator. For example, the 'Float' --- instance of 'Random' allows one to generate random values of type --- 'Float'. --- --- This implementation uses the Portable Combined Generator of L'Ecuyer --- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by --- Lennart Augustsson. It has a period of roughly 2.30584e18. --- ------------------------------------------------------------------------------ - -#include "MachDeps.h" - -module RandomPGC - ( - - -- $intro - - -- * Random number generators - -#ifdef ENABLE_SPLITTABLEGEN - RandomGen(next, genRange) - , SplittableGen(split) -#else - RandomGen(next, genRange, split) -#endif - -- ** Standard random number generators - , StdGen - , mkStdGen - - -- ** The global random number generator - - -- $globalrng - - , getStdRandom - , getStdGen - , setStdGen - , newStdGen - - -- * Random values of various types - , Random ( random, randomR, - randoms, randomRs, - randomIO, randomRIO ) - - -- * References - -- $references - - ) where - -import Prelude - -import Data.Bits -import Data.Int -import Data.Word -import Foreign.C.Types - -#ifdef __NHC__ -import CPUTime ( getCPUTime ) -import Foreign.Ptr ( Ptr, nullPtr ) -import Foreign.C ( CTime, CUInt ) -#else -import System.CPUTime ( getCPUTime ) -import Data.Time ( getCurrentTime, UTCTime(..) ) -import Data.Ratio ( numerator, denominator ) -#endif -import Data.Char ( isSpace, chr, ord ) -import System.IO.Unsafe ( unsafePerformIO ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) -import Data.IORef ( atomicModifyIORef' ) -import Numeric ( readDec ) - -#ifdef __GLASGOW_HASKELL__ -import GHC.Exts ( build ) -#else --- | A dummy variant of build without fusion. -{-# INLINE build #-} -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build g = g (:) [] -#endif - --- The standard nhc98 implementation of Time.ClockTime does not match --- the extended one expected in this module, so we lash-up a quick --- replacement here. -#ifdef __NHC__ -foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime -getTime :: IO (Integer, Integer) -getTime = do CTime t <- readtime nullPtr; return (toInteger t, 0) -#else -getTime :: IO (Integer, Integer) -getTime = do - utc <- getCurrentTime - let daytime = toRational $ utctDayTime utc - return $ quotRem (numerator daytime) (denominator daytime) -#endif - --- | The class 'RandomGen' provides a common interface to random number --- generators. --- -#ifdef ENABLE_SPLITTABLEGEN --- Minimal complete definition: 'next'. -#else --- Minimal complete definition: 'next' and 'split'. -#endif - -class RandomGen g where - - -- |The 'next' operation returns an 'Int' that is uniformly distributed - -- in the range returned by 'genRange' (including both end points), - -- and a new generator. - next :: g -> (Int, g) - - -- |The 'genRange' operation yields the range of values returned by - -- the generator. - -- - -- It is required that: - -- - -- * If @(a,b) = 'genRange' g@, then @a < b@. - -- - -- * 'genRange' always returns a pair of defined 'Int's. - -- - -- The second condition ensures that 'genRange' cannot examine its - -- argument, and hence the value it returns can be determined only by the - -- instance of 'RandomGen'. That in turn allows an implementation to make - -- a single call to 'genRange' to establish a generator's range, without - -- being concerned that the generator returned by (say) 'next' might have - -- a different range to the generator passed to 'next'. - -- - -- The default definition spans the full range of 'Int'. - genRange :: g -> (Int,Int) - - -- default method - genRange _ = (minBound, maxBound) - -#ifdef ENABLE_SPLITTABLEGEN --- | The class 'SplittableGen' proivides a way to specify a random number --- generator that can be split into two new generators. -class SplittableGen g where -#endif - -- |The 'split' operation allows one to obtain two distinct random number - -- generators. This is very useful in functional programs (for example, when - -- passing a random number generator down to recursive calls), but very - -- little work has been done on statistically robust implementations of - -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"] - -- are the only examples we know of). - split :: g -> (g, g) - -{- | -The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits. - -The result of repeatedly using 'next' should be at least as statistically -robust as the /Minimal Standard Random Number Generator/ described by -["System.Random\#Park", "System.Random\#Carta"]. -Until more is known about implementations of 'split', all we require is -that 'split' deliver generators that are (a) not identical and -(b) independently robust in the sense just given. - -The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the -state of a random number generator. -It is required that @'read' ('show' g) == g@. - -In addition, 'reads' may be used to map an arbitrary string (not necessarily one -produced by 'show') onto a value of type 'StdGen'. In general, the 'Read' -instance of 'StdGen' has the following properties: - -* It guarantees to succeed on any string. - -* It guarantees to consume only a finite portion of the string. - -* Different argument strings are likely to result in different results. - --} - -data StdGen - = StdGen !Int32 !Int32 - -instance RandomGen StdGen where - next = stdNext - genRange _ = stdRange - -#ifdef ENABLE_SPLITTABLEGEN -instance SplittableGen StdGen where -#endif - split = stdSplit - -instance Show StdGen where - showsPrec p (StdGen s1 s2) = - showsPrec p s1 . - showChar ' ' . - showsPrec p s2 - -instance Read StdGen where - readsPrec _p = \ r -> - case try_read r of - r'@[_] -> r' - _ -> [stdFromString r] -- because it shouldn't ever fail. - where - try_read r = do - (s1, r1) <- readDec (dropWhile isSpace r) - (s2, r2) <- readDec (dropWhile isSpace r1) - return (StdGen s1 s2, r2) - -{- - If we cannot unravel the StdGen from a string, create - one based on the string given. --} -stdFromString :: String -> (StdGen, String) -stdFromString s = (mkStdGen num, rest) - where (cs, rest) = splitAt 6 s - num = foldl (\a x -> x + 3 * a) 1 (map ord cs) - - -{- | -The function 'mkStdGen' provides an alternative way of producing an initial -generator, by mapping an 'Int' into a generator. Again, distinct arguments -should be likely to produce distinct generators. --} -mkStdGen :: Int -> StdGen -- why not Integer ? -mkStdGen s = mkStdGen32 $ fromIntegral s - -{- -From ["System.Random\#LEcuyer"]: "The integer variables s1 and s2 ... must be -initialized to values in the range [1, 2147483562] and [1, 2147483398] -respectively." --} -mkStdGen32 :: Int32 -> StdGen -mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1) - where - -- We want a non-negative number, but we can't just take the abs - -- of sMaybeNegative as -minBound == minBound. - s = sMaybeNegative .&. maxBound - (q, s1) = s `divMod` 2147483562 - s2 = q `mod` 2147483398 - -createStdGen :: Integer -> StdGen -createStdGen s = mkStdGen32 $ fromIntegral s - -{- | -With a source of random number supply in hand, the 'Random' class allows the -programmer to extract random values of a variety of types. - -Minimal complete definition: 'randomR' and 'random'. - --} - -class Random a where - -- | Takes a range /(lo,hi)/ and a random number generator - -- /g/, and returns a random value uniformly distributed in the closed - -- interval /[lo,hi]/, together with a new generator. It is unspecified - -- what happens if /lo>hi/. For continuous types there is no requirement - -- that the values /lo/ and /hi/ are ever produced, but they may be, - -- depending on the implementation and the interval. - randomR :: RandomGen g => (a,a) -> g -> (a,g) - - -- | The same as 'randomR', but using a default range determined by the type: - -- - -- * For bounded types (instances of 'Bounded', such as 'Char'), - -- the range is normally the whole type. - -- - -- * For fractional types, the range is normally the semi-closed interval - -- @[0,1)@. - -- - -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. - random :: RandomGen g => g -> (a, g) - - -- | Plural variant of 'randomR', producing an infinite list of - -- random values instead of returning a new generator. - {-# INLINE randomRs #-} - randomRs :: RandomGen g => (a,a) -> g -> [a] - randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g) - - -- | Plural variant of 'random', producing an infinite list of - -- random values instead of returning a new generator. - {-# INLINE randoms #-} - randoms :: RandomGen g => g -> [a] - randoms g = build (\cons _nil -> buildRandoms cons random g) - - -- | A variant of 'randomR' that uses the global random number generator - -- (see "System.Random#globalrng"). - randomRIO :: (a,a) -> IO a - randomRIO range = getStdRandom (randomR range) - - -- | A variant of 'random' that uses the global random number generator - -- (see "System.Random#globalrng"). - randomIO :: IO a - randomIO = getStdRandom random - --- | Produce an infinite list-equivalent of random values. -{-# INLINE buildRandoms #-} -buildRandoms :: RandomGen g - => (a -> as -> as) -- ^ E.g. '(:)' but subject to fusion - -> (g -> (a,g)) -- ^ E.g. 'random' - -> g -- ^ A 'RandomGen' instance - -> as -buildRandoms cons rand = go - where - -- The seq fixes part of #4218 and also makes fused Core simpler. - go g = x `seq` (x `cons` go g') where (x,g') = rand g - - -instance Random Integer where - randomR ival g = randomIvalInteger ival g - random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g - -instance Random Int where randomR = randomIvalIntegral; random = randomBounded -instance Random Int8 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int16 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int32 where randomR = randomIvalIntegral; random = randomBounded -instance Random Int64 where randomR = randomIvalIntegral; random = randomBounded - -#ifndef __NHC__ --- Word is a type synonym in nhc98. -instance Random Word where randomR = randomIvalIntegral; random = randomBounded -#endif -instance Random Word8 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word16 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word32 where randomR = randomIvalIntegral; random = randomBounded -instance Random Word64 where randomR = randomIvalIntegral; random = randomBounded - -instance Random CChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CSChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CUChar where randomR = randomIvalIntegral; random = randomBounded -instance Random CShort where randomR = randomIvalIntegral; random = randomBounded -instance Random CUShort where randomR = randomIvalIntegral; random = randomBounded -instance Random CInt where randomR = randomIvalIntegral; random = randomBounded -instance Random CUInt where randomR = randomIvalIntegral; random = randomBounded -instance Random CLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CULong where randomR = randomIvalIntegral; random = randomBounded -instance Random CPtrdiff where randomR = randomIvalIntegral; random = randomBounded -instance Random CSize where randomR = randomIvalIntegral; random = randomBounded -instance Random CWchar where randomR = randomIvalIntegral; random = randomBounded -instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded -instance Random CLLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CULLong where randomR = randomIvalIntegral; random = randomBounded -instance Random CIntPtr where randomR = randomIvalIntegral; random = randomBounded -instance Random CUIntPtr where randomR = randomIvalIntegral; random = randomBounded -instance Random CIntMax where randomR = randomIvalIntegral; random = randomBounded -instance Random CUIntMax where randomR = randomIvalIntegral; random = randomBounded - -instance Random Char where - randomR (a,b) g = - case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of - (x,g') -> (chr x, g') - random g = randomR (minBound,maxBound) g - -instance Random Bool where - randomR (a,b) g = - case (randomIvalInteger (bool2Int a, bool2Int b) g) of - (x, g') -> (int2Bool x, g') - where - bool2Int :: Bool -> Integer - bool2Int False = 0 - bool2Int True = 1 - - int2Bool :: Int -> Bool - int2Bool 0 = False - int2Bool _ = True - - random g = randomR (minBound,maxBound) g - -{-# INLINE randomRFloating #-} -randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g) -randomRFloating (l,h) g - | l>h = randomRFloating (h,l) g - | otherwise = let (coef,g') = random g in - (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g') -- avoid overflow - -instance Random Double where - randomR = randomRFloating - random rng = - case random rng of - (x,rng') -> - -- We use 53 bits of randomness corresponding to the 53 bit significand: - ((fromIntegral (mask53 .&. (x::Int64)) :: Double) - / fromIntegral twoto53, rng') - where - twoto53 = (2::Int64) ^ (53::Int64) - mask53 = twoto53 - 1 - -instance Random Float where - randomR = randomRFloating - random rng = - -- TODO: Faster to just use 'next' IF it generates enough bits of randomness. - case random rng of - (x,rng') -> - -- We use 24 bits of randomness corresponding to the 24 bit significand: - ((fromIntegral (mask24 .&. (x::Int32)) :: Float) - / fromIntegral twoto24, rng') - -- Note, encodeFloat is another option, but I'm not seeing slightly - -- worse performance with the following [2011.06.25]: --- (encodeFloat rand (-24), rng') - where - mask24 = twoto24 - 1 - twoto24 = (2::Int32) ^ (24::Int32) - --- CFloat/CDouble are basically the same as a Float/Double: -instance Random CFloat where - randomR = randomRFloating - random rng = case random rng of - (x,rng') -> (realToFrac (x::Float), rng') - -instance Random CDouble where - randomR = randomRFloating - -- A MYSTERY: - -- Presently, this is showing better performance than the Double instance: - -- (And yet, if the Double instance uses randomFrac then its performance is much worse!) - random = randomFrac - -- random rng = case random rng of - -- (x,rng') -> (realToFrac (x::Double), rng') - -mkStdRNG :: Integer -> IO StdGen -mkStdRNG o = do - ct <- getCPUTime - (sec, psec) <- getTime - return (createStdGen (sec * 12345 + psec + ct + o)) - -randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g) -randomBounded = randomR (minBound, maxBound) - --- The two integer functions below take an [inclusive,inclusive] range. -randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g) -randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h) - -{-# SPECIALIZE randomIvalInteger :: (Num a) => - (Integer, Integer) -> StdGen -> (a, StdGen) #-} - -randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) -randomIvalInteger (l,h) rng - | l > h = randomIvalInteger (h,l) rng - | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') - where - (genlo, genhi) = genRange rng - b = fromIntegral genhi - fromIntegral genlo + 1 - - -- Probabilities of the most likely and least likely result - -- will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen - -- is uniform, of course - - -- On average, log q / log b more random values will be generated - -- than the minimum - q = 1000 - k = h - l + 1 - magtgt = k * q - - -- generate random values until we exceed the target magnitude - f mag v g | mag >= magtgt = (v, g) - | otherwise = v' `seq`f (mag*b) v' g' where - (x,g') = next g - v' = (v * b + (fromIntegral x - fromIntegral genlo)) - - --- The continuous functions on the other hand take an [inclusive,exclusive) range. -randomFrac :: (RandomGen g, Fractional a) => g -> (a, g) -randomFrac = randomIvalDouble (0::Double,1) realToFrac - -randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g) -randomIvalDouble (l,h) fromDouble rng - | l > h = randomIvalDouble (h,l) fromDouble rng - | otherwise = - case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of - (x, rng') -> - let - scaled_x = - fromDouble (0.5*l + 0.5*h) + -- previously (l+h)/2, overflowed - fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) * -- avoid overflow - fromIntegral (x::Int32) - in - (scaled_x, rng') - -int32Count :: Integer -int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1 -- GHC ticket #3982 - -stdRange :: (Int,Int) -stdRange = (1, 2147483562) - -stdNext :: StdGen -> (Int, StdGen) --- Returns values in the range stdRange -stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'') - where z' = if z < 1 then z + 2147483562 else z - z = s1'' - s2'' - - k = s1 `quot` 53668 - s1' = 40014 * (s1 - k * 53668) - k * 12211 - s1'' = if s1' < 0 then s1' + 2147483563 else s1' - - k' = s2 `quot` 52774 - s2' = 40692 * (s2 - k' * 52774) - k' * 3791 - s2'' = if s2' < 0 then s2' + 2147483399 else s2' - -stdSplit :: StdGen -> (StdGen, StdGen) -stdSplit std@(StdGen s1 s2) - = (left, right) - where - -- no statistical foundation for this! - left = StdGen new_s1 t2 - right = StdGen t1 new_s2 - - new_s1 | s1 == 2147483562 = 1 - | otherwise = s1 + 1 - - new_s2 | s2 == 1 = 2147483398 - | otherwise = s2 - 1 - - StdGen t1 t2 = snd (next std) - --- The global random number generator - -{- $globalrng #globalrng# - -There is a single, implicit, global random number generator of type -'StdGen', held in some global variable maintained by the 'IO' monad. It is -initialised automatically in some system-dependent fashion, for example, by -using the time of day, or Linux's kernel random number generator. To get -deterministic behaviour, use 'setStdGen'. --} - --- |Sets the global random number generator. -setStdGen :: StdGen -> IO () -setStdGen sgen = writeIORef theStdGen sgen - --- |Gets the global random number generator. -getStdGen :: IO StdGen -getStdGen = readIORef theStdGen - -theStdGen :: IORef StdGen -theStdGen = unsafePerformIO $ do - rng <- mkStdRNG 0 - newIORef rng - --- |Applies 'split' to the current global random generator, --- updates it with one of the results, and returns the other. -newStdGen :: IO StdGen -newStdGen = atomicModifyIORef' theStdGen split - -{- |Uses the supplied function to get a value from the current global -random generator, and updates the global generator with the new generator -returned by the function. For example, @rollDice@ gets a random integer -between 1 and 6: - -> rollDice :: IO Int -> rollDice = getStdRandom (randomR (1,6)) - --} - -getStdRandom :: (StdGen -> (a,StdGen)) -> IO a -getStdRandom f = atomicModifyIORef' theStdGen (swap . f) - where swap (v,g) = (g,v) - -{- $references - -1. FW #Burton# Burton and RL Page, /Distributed random number generation/, -Journal of Functional Programming, 2(2):203-212, April 1992. - -2. SK #Park# Park, and KW Miller, /Random number generators - -good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201. - -3. DG #Carta# Carta, /Two fast implementations of the minimal standard -random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88. - -4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/, -Department of Mathematics, University of Salzburg, -, 1998. - -5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random -number generators/, Comm ACM, 31(6), Jun 1988, pp742-749. - -The Web site is a great source of information. - --} diff --git a/tests/examples/ghc80/RepArrow.hs b/tests/examples/ghc80/RepArrow.hs deleted file mode 100644 --- a/tests/examples/ghc80/RepArrow.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module RepArrow where - -import Data.Ord ( Down ) -- convenient "Id" newtype, without its constructor -import Data.Coerce - -foo :: Coercible (Down (Int -> Int)) (Int -> Int) => Down (Int -> Int) -> Int -> Int -foo = coerce diff --git a/tests/examples/ghc80/Roles12a.hs b/tests/examples/ghc80/Roles12a.hs deleted file mode 100644 --- a/tests/examples/ghc80/Roles12a.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Roles12a where -import {-# SOURCE #-} Roles12 diff --git a/tests/examples/ghc80/RuleDefiningPlugin.hs b/tests/examples/ghc80/RuleDefiningPlugin.hs deleted file mode 100644 --- a/tests/examples/ghc80/RuleDefiningPlugin.hs +++ /dev/null @@ -1,8 +0,0 @@ -module RuleDefiningPlugin where - -import GhcPlugins - -{-# RULES "unsound" forall x. show x = "SHOWED" #-} - -plugin :: Plugin -plugin = defaultPlugin diff --git a/tests/examples/ghc80/RulePragma.hs b/tests/examples/ghc80/RulePragma.hs deleted file mode 100644 --- a/tests/examples/ghc80/RulePragma.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Data.Text.Internal.Fusion.Common where - -{-# - RULES "STREAM map/map fusion" forall f g s. - map f (map g s) = map (\x -> f (g x)) s - #-} - diff --git a/tests/examples/ghc80/SH_Overlap1.hs b/tests/examples/ghc80/SH_Overlap1.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap1.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Compilation should fail as we have overlapping instances that don't obey --- our heuristics. -module SH_Overlap1 where - -import safe SH_Overlap1_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc80/SH_Overlap10.hs b/tests/examples/ghc80/SH_Overlap10.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap10.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as `SH_Overlap6`, but now we are inferring safety. Safe since --- overlapped instance declares itself overlappable. -module SH_Overlap10 where - -import SH_Overlap10_A - -instance - {-# OVERLAPS #-} - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc80/SH_Overlap10_A.hs b/tests/examples/ghc80/SH_Overlap10_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap10_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap10_A ( - C(..) - ) where - -import SH_Overlap10_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc80/SH_Overlap10_B.hs b/tests/examples/ghc80/SH_Overlap10_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap10_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -module SH_Overlap10_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc80/SH_Overlap11.hs b/tests/examples/ghc80/SH_Overlap11.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap11.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred --- unsafe due to overlapping instances at call site `f`. --- --- Testing that we are given correct reason. -module SH_Overlap11 where - -import SH_Overlap11_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc80/SH_Overlap11_A.hs b/tests/examples/ghc80/SH_Overlap11_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap11_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap11_A ( - C(..) - ) where - -import SH_Overlap11_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc80/SH_Overlap11_B.hs b/tests/examples/ghc80/SH_Overlap11_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap11_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -module SH_Overlap11_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc80/SH_Overlap1_A.hs b/tests/examples/ghc80/SH_Overlap1_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap1_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap1_A ( - C(..) - ) where - -import SH_Overlap1_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc80/SH_Overlap1_B.hs b/tests/examples/ghc80/SH_Overlap1_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap1_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Safe #-} -module SH_Overlap1_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc80/SH_Overlap2.hs b/tests/examples/ghc80/SH_Overlap2.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap2.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as SH_Overlap1, but SH_Overlap2_A is not imported as 'safe'. --- --- Question: Should the OI-check be enforced? Y, see reasoning in --- `SH_Overlap4.hs` for why the Safe Haskell overlapping instance check should --- be tied to Safe Haskell mode only, and not to safe imports. -module SH_Overlap2 where - -import SH_Overlap2_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc80/SH_Overlap2_A.hs b/tests/examples/ghc80/SH_Overlap2_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap2_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap2_A ( - C(..) - ) where - -import SH_Overlap2_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc80/SH_Overlap2_B.hs b/tests/examples/ghc80/SH_Overlap2_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap2_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Safe #-} -module SH_Overlap2_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc80/SH_Overlap3.hs b/tests/examples/ghc80/SH_Overlap3.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap3.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE Unsafe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as SH_Overlap1, but module where overlap occurs (SH_Overlap3) is --- marked `Unsafe`. Compilation should succeed (symetry with inferring safety). -module SH_Overlap3 where - -import SH_Overlap3_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc80/SH_Overlap3_A.hs b/tests/examples/ghc80/SH_Overlap3_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap3_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap3_A ( - C(..) - ) where - -import SH_Overlap3_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc80/SH_Overlap3_B.hs b/tests/examples/ghc80/SH_Overlap3_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap3_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Safe #-} -module SH_Overlap3_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc80/SH_Overlap4.hs b/tests/examples/ghc80/SH_Overlap4.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap4.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE Unsafe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as SH_Overlap3, however, SH_Overlap4_A is imported as `safe`. --- --- Question: Should compilation now fail? N. At first it seems a nice idea to --- tie the overlap check to safe imports. However, instances are a global --- entity and can be imported by multiple import paths. How should safe imports --- interact with this? Especially when considering transitive situations... --- --- Simplest is to just enforce the overlap check in Safe and Trustworthy --- modules, but not in Unsafe ones. -module SH_Overlap4 where - -import safe SH_Overlap4_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc80/SH_Overlap4_A.hs b/tests/examples/ghc80/SH_Overlap4_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap4_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap4_A ( - C(..) - ) where - -import SH_Overlap4_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc80/SH_Overlap4_B.hs b/tests/examples/ghc80/SH_Overlap4_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap4_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Safe #-} -module SH_Overlap4_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc80/SH_Overlap5.hs b/tests/examples/ghc80/SH_Overlap5.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap5.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Compilation should fail as we have overlapping instances that don't obey --- our heuristics. -module SH_Overlap5 where - -import safe SH_Overlap5_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc80/SH_Overlap5_A.hs b/tests/examples/ghc80/SH_Overlap5_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap5_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap5_A ( - C(..) - ) where - -import SH_Overlap5_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc80/SH_Overlap5_B.hs b/tests/examples/ghc80/SH_Overlap5_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap5_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Safe #-} -module SH_Overlap5_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc80/SH_Overlap6.hs b/tests/examples/ghc80/SH_Overlap6.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap6.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as `SH_Overlap5` but dependencies are now inferred-safe, not --- explicitly marked. Compilation should still fail. -module SH_Overlap6 where - -import safe SH_Overlap6_A - -instance C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc80/SH_Overlap6_A.hs b/tests/examples/ghc80/SH_Overlap6_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap6_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap6_A ( - C(..) - ) where - -import SH_Overlap6_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc80/SH_Overlap6_B.hs b/tests/examples/ghc80/SH_Overlap6_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap6_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -module SH_Overlap6_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc80/SH_Overlap7.hs b/tests/examples/ghc80/SH_Overlap7.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap7.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred --- unsafe due to overlapping instances at call site `f`. -module SH_Overlap7 where - -import SH_Overlap7_A - -instance C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc80/SH_Overlap7_A.hs b/tests/examples/ghc80/SH_Overlap7_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap7_A.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Safe #-} -module SH_Overlap7_A ( - C(..) - ) where - -import SH_Overlap7_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc80/SH_Overlap7_B.hs b/tests/examples/ghc80/SH_Overlap7_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap7_B.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE Safe #-} -module SH_Overlap7_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc80/SH_Overlap8.hs b/tests/examples/ghc80/SH_Overlap8.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap8.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Overlapping instances, but with a single parameter type-class and no --- orphans. So `SH_Overlap8` decided to explictly depend on `SH_Overlap8_A` --- since that's where the type-class `C` with function `f` is defined. --- --- Question: Safe or Unsafe? Safe -module SH_Overlap8 where - -import safe SH_Overlap8_A - -instance C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc80/SH_Overlap8_A.hs b/tests/examples/ghc80/SH_Overlap8_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap8_A.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap8_A ( - C(..) - ) where - -class C a where - f :: a -> String - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc80/SH_Overlap9.hs b/tests/examples/ghc80/SH_Overlap9.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap9.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# OPTIONS_GHC -fwarn-safe #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred --- unsafe due to overlapping instances at call site `f`. -module SH_Overlap9 where - -import SH_Overlap9_A - -instance - C [a] where - f _ = "[a]" - -test :: String -test = f ([1,2,3,4] :: [Int]) - diff --git a/tests/examples/ghc80/SH_Overlap9_A.hs b/tests/examples/ghc80/SH_Overlap9_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap9_A.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -{-# LANGUAGE FlexibleInstances #-} -module SH_Overlap9_A ( - C(..) - ) where - -import SH_Overlap9_B - -instance - {-# OVERLAPS #-} - C [Int] where - f _ = "[Int]" - diff --git a/tests/examples/ghc80/SH_Overlap9_B.hs b/tests/examples/ghc80/SH_Overlap9_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/SH_Overlap9_B.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unsafe #-} -module SH_Overlap9_B ( - C(..) - ) where - -class C a where - f :: a -> String - diff --git a/tests/examples/ghc80/SayAnnNames.hs b/tests/examples/ghc80/SayAnnNames.hs deleted file mode 100644 --- a/tests/examples/ghc80/SayAnnNames.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module SayAnnNames (plugin, SomeAnn(..)) where -import GhcPlugins -import Control.Monad (unless) -import Data.Data - -data SomeAnn = SomeAnn deriving (Data, Typeable) - -plugin :: Plugin -plugin = defaultPlugin { - installCoreToDos = install - } - -install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] -install _ todo = do - reinitializeGlobals - return (CoreDoPluginPass "Say name" pass : todo) - -pass :: ModGuts -> CoreM ModGuts -pass g = do - dflags <- getDynFlags - mapM_ (printAnn dflags g) (mg_binds g) >> return g - where printAnn :: DynFlags -> ModGuts -> CoreBind -> CoreM CoreBind - printAnn dflags guts bndr@(NonRec b _) = do - anns <- annotationsOn guts b :: CoreM [SomeAnn] - unless (null anns) $ putMsgS $ - "Annotated binding found: " ++ showSDoc dflags (ppr b) - return bndr - printAnn _ _ bndr = return bndr - -annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] -annotationsOn guts bndr = do - anns <- getAnnotations deserializeWithData guts - return $ lookupWithDefaultUFM anns [] (varUnique bndr) diff --git a/tests/examples/ghc80/SelfDep.hs b/tests/examples/ghc80/SelfDep.hs deleted file mode 100644 --- a/tests/examples/ghc80/SelfDep.hs +++ /dev/null @@ -1,3 +0,0 @@ -module SelfDep where - -data T :: T -> * diff --git a/tests/examples/ghc80/SemicolonIf.hs b/tests/examples/ghc80/SemicolonIf.hs deleted file mode 100644 --- a/tests/examples/ghc80/SemicolonIf.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Bar where - -import Data.Text as Text - -replace :: Text -> Text -replace = Text.map (\c -> if c == '_' then '.'; else c) - -replace1 :: Text -> Text -replace1 = Text.map (\c -> if c == '_' ; then '.' else c) - -replace2 :: Text -> Text -replace2 = Text.map (\c -> if c == '_'; then '.'; else c) - -replace4 :: Text -> Text -replace4 = Text.map (\c -> if c == '_' then '.' else c) diff --git a/tests/examples/ghc80/SemigroupWarnings.hs b/tests/examples/ghc80/SemigroupWarnings.hs deleted file mode 100644 --- a/tests/examples/ghc80/SemigroupWarnings.hs +++ /dev/null @@ -1,34 +0,0 @@ --- Test purpose: --- Ensure that missing semigroup warnings are issued --- correctly if the warning flag is enabled - -{-# OPTIONS_GHC -fwarn-semigroup #-} - -module SemigroupWarnings where - - - -import Data.Semigroup - - - --- Bad instance, should complain about missing Semigroup parent -data LacksSemigroup -instance Monoid LacksSemigroup where - mempty = undefined - mappend = undefined - - - --- Correct instance, should not warn -data HasSemigroup -instance Semigroup HasSemigroup where - (<>) = undefined -instance Monoid HasSemigroup where - mempty = undefined - mappend = undefined - - - --- Should issue a Prelude clash warning -(<>) = undefined diff --git a/tests/examples/ghc80/Setup.hs b/tests/examples/ghc80/Setup.hs deleted file mode 100644 --- a/tests/examples/ghc80/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/tests/examples/ghc80/ShouldFail.hs b/tests/examples/ghc80/ShouldFail.hs deleted file mode 100644 --- a/tests/examples/ghc80/ShouldFail.hs +++ /dev/null @@ -1,1 +0,0 @@ -import Set diff --git a/tests/examples/ghc80/SigTvKinds.hs b/tests/examples/ghc80/SigTvKinds.hs deleted file mode 100644 --- a/tests/examples/ghc80/SigTvKinds.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PolyKinds #-} - -module SigTvKinds where - -data T (a :: k1) x = MkT (S a ()) -data S (b :: k2) y = MkS (T b ()) - -- tests TcTyClsDecls.no_sig_tv diff --git a/tests/examples/ghc80/SigTvKinds2.hs b/tests/examples/ghc80/SigTvKinds2.hs deleted file mode 100644 --- a/tests/examples/ghc80/SigTvKinds2.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PolyKinds #-} - -module SigTvKinds2 where - -data SameKind :: k -> k -> * - -data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) diff --git a/tests/examples/ghc80/SpecializePhaseControl.hs b/tests/examples/ghc80/SpecializePhaseControl.hs deleted file mode 100644 --- a/tests/examples/ghc80/SpecializePhaseControl.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# SPECIALISE [1] x :: - Integer -> Integer -> Integer, - Integer -> Int -> Integer, - Int -> Int -> Int #-} -{-# INLINABLE [1] x #-} -x :: (Num a, Integral b) => a -> b -> a -x = undefined - -{-# SPECIALISE INLINE [999] y :: - Integer -> Integer -> Integer, - Integer -> Int -> Integer, - Int -> Int -> Int #-} -{-# INLINABLE [1] y #-} -y :: (Num a, Integral b) => a -> b -> a -y = undefined diff --git a/tests/examples/ghc80/Splices.hs b/tests/examples/ghc80/Splices.hs deleted file mode 100644 --- a/tests/examples/ghc80/Splices.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NamedWildCards #-} -module Splices where - -import Language.Haskell.TH -import Language.Haskell.TH.Lib (wildCardT) - -metaType1 :: TypeQ -metaType1 = wildCardT - -metaType2 :: TypeQ -metaType2 = [t| _ |] - -metaType3 :: TypeQ -metaType3 = [t| _ -> _ -> _ |] - -metaDec1 :: Q [Dec] -metaDec1 = [d| foo :: _ => _ - foo x y = x == y |] - -metaDec2 :: Q [Dec] -metaDec2 = [d| bar :: _a -> _b -> (_a, _b) - bar x y = (not x, y) |] - --- An expression with a partial type annotation -metaExp1 :: ExpQ -metaExp1 = [| Just True :: Maybe _ |] - -metaExp2 :: ExpQ -metaExp2 = [| id :: _a -> _a |] diff --git a/tests/examples/ghc80/SplicesUsed.hs b/tests/examples/ghc80/SplicesUsed.hs deleted file mode 100644 --- a/tests/examples/ghc80/SplicesUsed.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE PartialTypeSignatures #-} -module SplicesUsed where - -import Splices - -maybeBool :: $(metaType1) -maybeBool = $(metaExp2) $(metaExp1) - -charA :: a -> $(metaType2) -charA x = ('x', x) - -filter' :: $(metaType3) -filter' = filter - -$(metaDec1) - -$(metaDec2) diff --git a/tests/examples/ghc80/StackOverflow.hs b/tests/examples/ghc80/StackOverflow.hs deleted file mode 100644 --- a/tests/examples/ghc80/StackOverflow.hs +++ /dev/null @@ -1,4 +0,0 @@ -main :: IO () -main = main' () - where - main' _ = main >> main' () diff --git a/tests/examples/ghc80/Structure8.hs b/tests/examples/ghc80/Structure8.hs deleted file mode 100644 --- a/tests/examples/ghc80/Structure8.hs +++ /dev/null @@ -1,1 +0,0 @@ -foo x | otherwise = y diff --git a/tests/examples/ghc80/Structure8a.hs b/tests/examples/ghc80/Structure8a.hs deleted file mode 100644 --- a/tests/examples/ghc80/Structure8a.hs +++ /dev/null @@ -1,1 +0,0 @@ -foo x = y diff --git a/tests/examples/ghc80/T10009.hs b/tests/examples/ghc80/T10009.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10009.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module T10009 where - - -type family F a -type family UnF a - -f :: (UnF (F b) ~ b) => F b -> () -f = error "urk" - -g :: forall a. (UnF (F a) ~ a) => a -> () -g _ = f (undefined :: F a) - - -{- --------------- -[G] UnF (F b) ~ b - -[W] UnF (F beta) ~ beta -[W] F a ~ F beta - -------------------- -[G] g1: F a ~ fsk1 fsk1 := F a -[G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1 -[G] g3: fsk2 ~ a - -[W] w1: F beta ~ fmv1 -[W] w2: UnF fmv1 ~ fmv2 -[W] w3: fmv2 ~ beta -[W] w5: fsk1 ~ fmv1 -- From F a ~ F beta - -- using flat-cache - ----- No progress in solving ----- --- Unflatten: - -[W] w3: UnF (F beta) ~ beta -[W] w5: fsk1 ~ F beta - ---- Improvement - -[D] F beta ~ fmv1 -[D] UnF fmv1 ~ fmv2 -- (A) -[D] fmv2 ~ beta -[D] fmv1 ~ fsk1 -- (B) From F a ~ F beta - -- NB: put fmv on left - ---> rewrite (A) with (B), and match with g2 - -[D] F beta ~ fmv1 -[D] fmv2 ~ fsk2 -- (C) -[D] fmv2 ~ beta -- (D) -[D] fmv1 ~ fsk1 - ---> rewrite (D) with (C) and re-orient - -[D] F beta ~ fmv1 -[D] fmv2 ~ fsk2 -[D] beta ~ fsk2 -- (E) -[D] fmv1 ~ fsk1 - --- Now we can unify beta! --} - - - -{- - ------ -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - -wl: [W] F b_amr ~ F b_amt - -work item: [W] UnF (F b_amt) ~ b_amt - b_amt is the unification variable - -===> b_amt := s_amF - -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - -wl: [W] F b_amr ~ F b_amt - [W] UnF s_amD ~ s_amF - -work item: [W] F b_amt ~ s_amD - - -===> -wl: [W] F b_amr ~ F b_amt - [W] UnF s_amD ~ s_amF - -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - [W] F s_amF ~ s_amD - -===> -wl: [W] F b_amr ~ F b_amt - -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - [W] F s_amF ~ s_amD - [W] UnF s_amD ~ s_amF - -===> -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - [W] UnF s_amD ~ s_amF - [W] F s_amF ~ s_amD - -wl: - -work-item: [W] F b_amr ~ F b_amt ---> fsk_amy ~ s_amD ---> s_amD ~ fsk_amy - -===> -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - [W] UnF s_amD ~ s_amF - [W] F s_amF ~ s_amD - [W] s_amD ~ fsk_amy - -wl: - -work item: [D] UnF s_amD ~ s_amF - ---> [D] UnF fsk_amy ~ s_amF ---> [D] s_amF ~ fsk_amA - -===> -Inert: [G] fsk_amA ~ b_amr - [G] UnF fsk_amy ~ fsk_amA - [G} F b_amr ~ fsk_amy - [W] UnF s_amD ~ s_amF - [W] F s_amF ~ s_amD - [W] s_amD ~ fsk_amy - [D] s_amF ~ fsk_amA - -wl: - -work item: [D] F s_amF ~ s_amD ---> F fsk_amA ~ s_amD ---> s_amd ~ b_amr --} diff --git a/tests/examples/ghc80/T10030.hs b/tests/examples/ghc80/T10030.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10030.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import GHC.Generics - -main = do - putStrLn $ packageName $ from $ Just True - putStrLn $ packageName $ from $ True diff --git a/tests/examples/ghc80/T10041.hs b/tests/examples/ghc80/T10041.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10041.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds #-} -{-# LANGUAGE TypeOperators, GADTs, InstanceSigs #-} - -module T10041 where - -data family Sing (a :: k) -data instance Sing (xs :: [k]) where - SNil :: Sing '[] - -class SingI (a :: ĸ) where diff --git a/tests/examples/ghc80/T10045.hs b/tests/examples/ghc80/T10045.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10045.hs +++ /dev/null @@ -1,8 +0,0 @@ -module T10045 where - -newtype Meta = Meta () - -foo (Meta ws1) = - let copy :: _ - copy w from = copy w True - in copy ws1 False diff --git a/tests/examples/ghc80/T10047.hs b/tests/examples/ghc80/T10047.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10047.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-fields #-} -module T10047 where - -import Language.Haskell.TH -import Language.Haskell.TH.Quote - -n = QuasiQuoter { quoteExp = dyn } diff --git a/tests/examples/ghc80/T10052-input.hs b/tests/examples/ghc80/T10052-input.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10052-input.hs +++ /dev/null @@ -1,1 +0,0 @@ -main = let (x :: String) = "hello" in putStrLn x diff --git a/tests/examples/ghc80/T10052.hs b/tests/examples/ghc80/T10052.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10052.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wall #-} -module Main where - -import System.Environment -import GHC - -main :: IO () -main = do - flags <- getArgs - runGhc' flags $ do - setTargets [Target (TargetFile "T10052-input.hs" Nothing) True Nothing] - _success <- load LoadAllTargets - return () - -runGhc' :: [String] -> Ghc a -> IO a -runGhc' args act = do - let libdir = head args - flags = tail args - (dynFlags, _warns) <- parseStaticFlags (map noLoc flags) - runGhc (Just libdir) $ do - dflags0 <- getSessionDynFlags - (dflags1, _leftover, _warns) <- parseDynamicFlags dflags0 dynFlags - let dflags2 = dflags1 { - hscTarget = HscInterpreted - , ghcLink = LinkInMemory - , verbosity = 1 - } - _newPkgs <- setSessionDynFlags dflags2 - act diff --git a/tests/examples/ghc80/T10083.hs b/tests/examples/ghc80/T10083.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10083.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T10083 where - import T10083a - data RSR = MkRSR SR - eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) - foo x y = not (eqRSR x y) diff --git a/tests/examples/ghc80/T10083a.hs b/tests/examples/ghc80/T10083a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10083a.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10083a where - import {-# SOURCE #-} T10083 - data SR = MkSR RSR - eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 diff --git a/tests/examples/ghc80/T10100.hs b/tests/examples/ghc80/T10100.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10100.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -module T10100 where - -data Zero -data Succ a - -class Add a b ab | a b -> ab, a ab -> b -instance Add Zero b b -instance (Add a b ab) => Add (Succ a) b (Succ ab) diff --git a/tests/examples/ghc80/T10104.hs b/tests/examples/ghc80/T10104.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10104.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module Main where - -import GHC.Prim - -data P = Positives Int# Float# Double# Char# Word# deriving Show -data N = Negatives Int# Float# Double# deriving Show - -main = do - print $ Positives 42# 4.23# 4.23## '4'# 4## - print $ Negatives -4# -4.0# -4.0## diff --git a/tests/examples/ghc80/T10109.hs b/tests/examples/ghc80/T10109.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10109.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PolyKinds, MultiParamTypeClasses, FunctionalDependencies, - UndecidableInstances, FlexibleInstances #-} - -module T10109 where - -data Succ a - -class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab -instance (Add a b ab) => Add (Succ a) b (Succ ab) - diff --git a/tests/examples/ghc80/T10110A.hs b/tests/examples/ghc80/T10110A.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10110A.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10110A (a) where -{-# NOINLINE a #-} -a :: Int -a = 3 diff --git a/tests/examples/ghc80/T10110B.hs b/tests/examples/ghc80/T10110B.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10110B.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10110B (b) where -b :: Int -b = 5 diff --git a/tests/examples/ghc80/T10110C.hs b/tests/examples/ghc80/T10110C.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10110C.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T10110C (c) where -import T10110A (a) -import T10110B (b) -c :: Int -c = a+b diff --git a/tests/examples/ghc80/T10112.hs b/tests/examples/ghc80/T10112.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10112.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE RankNTypes, RebindableSyntax #-} -module T10112 where - -import qualified Prelude as P - -(>>=) :: a -> ((forall b . b) -> c) -> c -a >>= f = f P.undefined -return a = a -fail s = P.undefined - -t1 = 'd' >>= (\_ -> 'k') - -t2 = do { _ <- 'd' - ; 'k' } - -foo = P.putStrLn [t1, t2] diff --git a/tests/examples/ghc80/T10134.hs b/tests/examples/ghc80/T10134.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10134.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DataKinds, TypeOperators, ConstraintKinds, TypeFamilies, NoMonoLocalBinds, NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module T10134 where - -import GHC.TypeLits -import T10134a -import Prelude - -type Positive n = ((n-1)+1)~n - -data Dummy n d = Dummy { vec :: Vec n (Vec d Bool) } - -nextDummy :: Positive (2*(n+d)) => Dummy n d -> Dummy n d -nextDummy d = Dummy { vec = vec dFst } - where (dFst,dSnd) = nextDummy' d - -nextDummy' :: Positive (2*(n+d)) => Dummy n d -> ( Dummy n d, Bool ) -nextDummy' _ = undefined diff --git a/tests/examples/ghc80/T10139.hs b/tests/examples/ghc80/T10139.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10139.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances, - MultiParamTypeClasses, FunctionalDependencies #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module T10139 where - -import GHC.Exts -import Data.Monoid - -class Monoid v => Measured v a | a -> v where - _measure :: v -> a -data FingerTree v a = Dummy v a -singleton :: Measured v a => a -> FingerTree v a -singleton = undefined - -class DOps a where - plus :: a -> D a -> a - -type family D a :: * -type instance D (FingerTree (Size Int, v) (Sized a)) = [Diff (Normal a)] - -type family Normal a :: * - -data Diff a = Add Int a - -newtype Sized a = Sized a -newtype Size a = Size a - --- This works: -{- -instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where - plus = foldr (\(Add index val) seq -> singleton ((coerce) val)) --} - --- This hangs: -instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where - plus = foldr (flip f) - where f _seq x = case x of - Add _index val -> singleton ((coerce) val) diff --git a/tests/examples/ghc80/T10141.hs b/tests/examples/ghc80/T10141.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10141.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies, PolyKinds #-} - -module T10141 where - -type family G (a :: k) where - G Int = Bool - G Bool = Int - G a = a diff --git a/tests/examples/ghc80/T10148.hs b/tests/examples/ghc80/T10148.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10148.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Main where - -import Debug.Trace - -data Machine = Machine (Int -> Machine) Int - -main :: IO () -main = (go 7 $ Machine (gstep (Array 99)) 8) `seq` return () - where - go :: Int -> Machine -> Int - go 0 (Machine _ done) = done - go nq (Machine step _) = go (nq-1) $ step 0 - -gstep :: Array Int -> Int -> Machine -gstep m x = Machine (gstep m') (mindexA m) - where - !m' = adjustA x m - -data Array a = Array a - -adjustA :: (Show a) => Int -> Array a -> Array a -adjustA i (Array t) - | i < 0 = undefined i -- not just undefined! - | otherwise = Array $ trace ("adj " ++ show t) $ t - -mindexA :: Array a -> a -mindexA (Array v) = v diff --git a/tests/examples/ghc80/T10156.hs b/tests/examples/ghc80/T10156.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10156.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE FlexibleContexts, TypeFamilies #-} - -module T10156 where - -import Data.Coerce - -data Iso a b = Iso (a -> b) (b -> a) - -coerceIso :: Coercible a b => Iso a b -coerceIso = Iso coerce coerce - -type family F x - -f :: (Coercible a (F b), Coercible c (F b)) => a -> b -> c -f x _ = coerce x diff --git a/tests/examples/ghc80/T10180.hs b/tests/examples/ghc80/T10180.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10180.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE TypeOperators, TypeFamilies, GADTs, EmptyCase #-} -module T10180 where - -newtype Foo = Foo Int - -type family Bar a -type instance Bar Int = Int - -type family Baz a where - Baz Int = Int - Baz Char = Int - -data a :~: b where - Refl :: a :~: a - -absurd0 :: Int :~: Bool -> a -absurd0 x = case x of {} - -absurd1 :: Foo :~: Bool -> a -absurd1 x = case x of {} - -absurd2 :: Bar Int :~: Bool -> a -absurd2 x = case x of {} - -absurd3 :: Baz a :~: Bool -> a -absurd3 x = case x of {} - diff --git a/tests/examples/ghc80/T10181.hs b/tests/examples/ghc80/T10181.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10181.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10181 where - -t a = t a diff --git a/tests/examples/ghc80/T10182.hs b/tests/examples/ghc80/T10182.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10182.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10182 where -import T10182a -instance Show (a -> b) where - show _ = "" diff --git a/tests/examples/ghc80/T10182a.hs b/tests/examples/ghc80/T10182a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10182a.hs +++ /dev/null @@ -1,2 +0,0 @@ -module T10182a where -import {-# SOURCE #-} T10182 diff --git a/tests/examples/ghc80/T10184.hs b/tests/examples/ghc80/T10184.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10184.hs +++ /dev/null @@ -1,9 +0,0 @@ -module T10184 where - -import Data.Coerce - -newtype Bar a = Bar (Either a (Bar a)) -newtype Age = MkAge Int - -x :: Bar Age -x = coerce (Bar (Left (5 :: Int))) diff --git a/tests/examples/ghc80/T10185.hs b/tests/examples/ghc80/T10185.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10185.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T10185 where - -import Data.Coerce -import Data.Proxy - -foo :: (Coercible (a b) (c d), Coercible (c d) (e f)) => Proxy (c d) -> a b -> e f -foo _ = coerce diff --git a/tests/examples/ghc80/T10188.hs b/tests/examples/ghc80/T10188.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10188.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} - -module T10188 where - -data Peano = Zero | Succ Peano - -type family Length (as :: [k]) :: Peano where - Length (a : as) = Succ (Length as) - Length '[] = Zero - -type family Length' (as :: [k]) :: Peano where - Length' ((:) a as) = Succ (Length' as) - Length' '[] = Zero diff --git a/tests/examples/ghc80/T10194.hs b/tests/examples/ghc80/T10194.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10194.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module T10194 where - -type X = forall a . a - -comp :: (X -> c) -> (a -> X) -> (a -> c) -comp = (.) diff --git a/tests/examples/ghc80/T10195.hs b/tests/examples/ghc80/T10195.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10195.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, GADTs, - ConstraintKinds, DataKinds, KindSignatures, - FlexibleInstances #-} -{-# OPTIONS -fno-warn-redundant-constraints #-} - -module T10195 where - -import GHC.Exts - -data Foo m zp r'q = Foo zp -data Dict :: Constraint -> * where - Dict :: a => Dict a - -type family BarFamily a b :: Bool -class Bar m m' -instance (BarFamily m m' ~ 'True) => Bar m m' - -magic :: (Bar m m') => c m zp -> Foo m zp (c m' zq) -magic = undefined - -getDict :: a -> Dict (Num a) -getDict _ = undefined -fromScalar :: r -> c m r -fromScalar = undefined - -foo :: (Bar m m') - => c m zp -> Foo m zp (c m' zq) -> Foo m zp (c m' zq) -foo b (Foo sc) = - let scinv = fromScalar sc - in case getDict scinv of - Dict -> magic $ scinv * b diff --git a/tests/examples/ghc80/T10196.hs b/tests/examples/ghc80/T10196.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/T10215.hs b/tests/examples/ghc80/T10215.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10215.hs +++ /dev/null @@ -1,9 +0,0 @@ -testF :: Float -> Bool -testF x = x == 0 && not (isNegativeZero x) - -testD :: Double -> Bool -testD x = x == 0 && not (isNegativeZero x) - -main :: IO () -main = do print $ testF (-0.0) - print $ testD (-0.0) diff --git a/tests/examples/ghc80/T10218.hs b/tests/examples/ghc80/T10218.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10218.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -feager-blackholing #-} - -module Main where - -{-# NOINLINE foo #-} -foo :: Bool -> Int -> Int -> Int -foo True _ x = 1 -foo False _ x = x+1 - -{-# NOINLINE bar #-} -bar :: Int -> (Int,Int) -bar x = let y1 = x * 2 - y2 = x * 2 - in (foo False y1 y2,foo False y2 y1) - -main = print (fst p + snd p) - where - p = bar 3 diff --git a/tests/examples/ghc80/T10220B.hs b/tests/examples/ghc80/T10220B.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10220B.hs +++ /dev/null @@ -1,1 +0,0 @@ -module T10220B where diff --git a/tests/examples/ghc80/T10226.hs b/tests/examples/ghc80/T10226.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10226.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -- only necessary in 7.10 -{-# LANGUAGE FlexibleContexts #-} -- necessary for showFromF' example -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module T10226 where - -type family F a -type family FInv a - --- This definition is accepted in 7.8 without anything extra, but requires --- AllowAmbiguousTypes in 7.10 (this, by itself, is not a problem): -showFromF :: (Show a, FInv (F a) ~ a) => F a -> String -showFromF fa = undefined - --- Consider what happens when we attempt to call `showFromF` at some type b. --- In order to check that this is valid, we have to find an a such that --- --- > b ~ F a /\ Show a /\ FInv (F a) ~ a --- --- Introducing an intermediate variable `x` for the result of `F a` gives us --- --- > b ~ F a /\ Show a /\ FInv x ~ a /\ F a ~ x --- --- Simplifying --- --- > b ~ x /\ Show a /\ FInv x ~ a /\ F a ~ x --- --- Set x := b --- --- > Show a /\ FInv b ~ a /\ F a ~ b --- --- Set a := FInv b --- --- > Show (FInv b) /\ FInv b ~ FInv b /\ F (FInv b) ~ b --- --- Simplifying --- --- > Show (FInv b) /\ F (FInv b) ~ b --- --- Indeed, we can give this definition in 7.8, but not in 7.10: -showFromF' :: (Show (FInv b), F (FInv b) ~ b) => b -> String -showFromF' = showFromF - -{------------------------------------------------------------------------------- - In 7.10 the definition of showFromF' is not accepted, but it gets stranger. - In 7.10 we cannot _call_ showFromF at all, even at a concrete type. Below - we try to call it at type b ~ Int. It would need to show - - > Show (FInv Int) /\ F (FInt Int) ~ Int - - all of which should easily get resolved, but somehow don't. --------------------------------------------------------------------------------} - -type instance F Int = Int -type instance FInv Int = Int - -test :: String -test = showFromF (0 :: Int) diff --git a/tests/examples/ghc80/T10233.hs b/tests/examples/ghc80/T10233.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10233.hs +++ /dev/null @@ -1,2 +0,0 @@ -module T10233 where -import T10233a( Constraint, Int ) diff --git a/tests/examples/ghc80/T10233a.hs b/tests/examples/ghc80/T10233a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10233a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10233a ( module GHC.Exts ) where -import GHC.Exts ( Constraint, Int ) - diff --git a/tests/examples/ghc80/T10245.hs b/tests/examples/ghc80/T10245.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10245.hs +++ /dev/null @@ -1,13 +0,0 @@ -f :: Int -> String -f n = case n of - 0x8000000000000000 -> "yes" - _ -> "no" -{-# NOINLINE f #-} - -main = do - let string = "0x8000000000000000" - let i = read string :: Integer - let i' = fromIntegral i :: Int - print i - print i' - print (f i') diff --git a/tests/examples/ghc80/T10246.hs b/tests/examples/ghc80/T10246.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10246.hs +++ /dev/null @@ -1,32 +0,0 @@ -f1 :: Int -> String -f1 n = case n of - 0 -> "bar" - 0x10000000000000000 -> "foo" - _ -> "c" -{-# NOINLINE f1 #-} - -g1 :: Int -> String -g1 n = if n == 0 then "bar" else - if n == 0x10000000000000000 then "foo" else - "c" -{-# NOINLINE g1 #-} - -f2 :: Int -> String -f2 n = case n of - 0x10000000000000000 -> "foo" - 0 -> "bar" - _ -> "c" -{-# NOINLINE f2 #-} - -g2 :: Int -> String -g2 n = if n == 0x10000000000000000 then "foo" else - if n == 0 then "bar" else - "c" -{-# NOINLINE g2 #-} - -main = do - let i = read "0" :: Int - print (f1 i) - print (g1 i) - print (f2 i) - print (g2 i) diff --git a/tests/examples/ghc80/T10251.hs b/tests/examples/ghc80/T10251.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10251.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -O #-} -module T10251 where - -data D = D -data E = E - -class Storable a where - poke2 :: a -> E -instance Storable D where - poke2 = poke2 -- undefined - -class Foo a where -instance Foo D where - -class (Foo t, Storable t) => FooStorable t where - -instance FooStorable D where - {-# SPECIALIZE instance FooStorable D #-} - -{-# SPECIALIZE bug :: D -> E #-} - -bug - :: FooStorable t - => t - -> E -bug = poke2 -{- -sf 9160 # ghc -c -fforce-recomp -Wall B.hs - -ghc: panic! (the 'impossible' happened) - (GHC version 7.10.1 for x86_64-unknown-linux): - Template variable unbound in rewrite rule - $fFooStorableD_XU - [$fFooStorableD_XU] - [$fFooStorableD_XU] - [] - [] - -Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug --} diff --git a/tests/examples/ghc80/T10263.hs b/tests/examples/ghc80/T10263.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10263.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} -module T10263 where - -data Maybe a = AF -type role Maybe representational diff --git a/tests/examples/ghc80/T10267.hs b/tests/examples/ghc80/T10267.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10267.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module T10267 where - -import Language.Haskell.TH -import T10267a - -[d| i :: a -> a - i = _foo - - j :: a -> a - j x = _ |] - -$(return [ - SigD (mkName "k") - (ForallT [PlainTV (mkName "a")] - [] - (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) - , FunD (mkName "k") - [Clause [] (NormalB (UnboundVarE (mkName "_foo"))) []] - ]) - -$(return [ - SigD (mkName "l") - (ForallT [PlainTV (mkName "a")] - [] - (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) - , FunD (mkName "l") - [Clause [VarP (mkName "x")] (NormalB (UnboundVarE (mkName "_"))) []] - ]) - -foo :: a -> a -foo x = $varX diff --git a/tests/examples/ghc80/T10267a.hs b/tests/examples/ghc80/T10267a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10267a.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module T10267a where - -import Language.Haskell.TH - -varX :: Q Exp -varX = [| x |] diff --git a/tests/examples/ghc80/T10279.hs b/tests/examples/ghc80/T10279.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10279.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module T10279 where -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - --- NB: rts-1.0 is used here because it doesn't change. --- You do need to pick the right version number, otherwise the --- error message doesn't recognize it as a source package ID, --- (This is OK, since it will look obviously wrong when they --- try to find the package in their package database.) -blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A")))) diff --git a/tests/examples/ghc80/T10283.hs b/tests/examples/ghc80/T10283.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10283.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-} -{-# LANGUAGE ImpredicativeTypes #-} - -module T9834 where -import Control.Applicative -import Data.Functor.Identity - -type Nat f g = forall a. f a -> g a - -newtype Comp p q a = Comp (p (q a)) - -liftOuter :: (Functor p, Applicative q) => p a -> (Comp p q) a -liftOuter pa = Comp (pure <$> pa) - -runIdComp :: Functor p => Comp p Identity a -> p a -runIdComp (Comp p) = runIdentity <$> p - -wrapIdComp :: Applicative p => (forall q. Applicative q => Nat (Comp p q) (Comp p q)) -> p a -> p a -wrapIdComp f = runIdComp . f . liftOuter - -class Applicative p => ApplicativeFix p where - afix :: (forall q. Applicative q => (Comp p q) a -> (Comp p q) a) -> p a - afix = wrapIdComp diff --git a/tests/examples/ghc80/T10284.hs b/tests/examples/ghc80/T10284.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10284.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-} - -import Control.Exception - -a :: Int -a = 'a' - -main :: IO () -main = do - catch (evaluate a) - (\e -> do let err = show (e :: TypeError) - putStrLn ("As expected, TypeError: " ++ err) - return "") - catch (evaluate a) - (\e -> do let err = show (e :: ErrorCall) - putStrLn ("Something went horribly wrong: " ++ err) - return "") diff --git a/tests/examples/ghc80/T10285.hs b/tests/examples/ghc80/T10285.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10285.hs +++ /dev/null @@ -1,11 +0,0 @@ -module T10285 where - -import T10285a -import Data.Type.Coercion -import Data.Coerce - -oops :: Coercion (N a) (N b) -> a -> b -oops Coercion = coerce - -unsafeCoerce :: a -> b -unsafeCoerce = oops coercion diff --git a/tests/examples/ghc80/T10285a.hs b/tests/examples/ghc80/T10285a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10285a.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} - -module T10285a (N, coercion) where - -import Data.Type.Coercion - -newtype N a = MkN Int -type role N representational - -coercion :: Coercion (N a) (N b) -coercion = Coercion diff --git a/tests/examples/ghc80/T10294.hs b/tests/examples/ghc80/T10294.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10294.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T10294 where - -import SayAnnNames - -{-# ANN foo SomeAnn #-} -foo :: () -foo = () diff --git a/tests/examples/ghc80/T10294a.hs b/tests/examples/ghc80/T10294a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10294a.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T10294a where - -import SayAnnNames -import Data.Data - -baz :: Constr -baz = toConstr SomeAnn diff --git a/tests/examples/ghc80/T10306.hs b/tests/examples/ghc80/T10306.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10306.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeFamilies #-} - -module T10306 where - -import Language.Haskell.TH -import GHC.TypeLits - --- Attempting to reify a built-in type family like (+) previously --- caused a crash, because it has no equations -$(do x <- reify ''(+) - case x of - FamilyI (ClosedTypeFamilyD _ _ _ _ []) _ -> return [] - _ -> error $ show x - ) diff --git a/tests/examples/ghc80/T10318.hs b/tests/examples/ghc80/T10318.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10318.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, - FlexibleInstances, TypeFamilies, - UndecidableSuperClasses #-} - -module T10318 where - --- | Product of non-zero elements always non-zero. --- Every integral domain has a field of fractions. --- The field of fractions of any field is itself. -class (Frac (Frac a) ~ Frac a, Fractional (Frac a), IntegralDomain (Frac a)) - => IntegralDomain a where - type Frac a :: * - embed :: a -> Frac a - -instance IntegralDomain Integer where - type Frac Integer = Rational - embed = fromInteger - -instance IntegralDomain Rational where - type Frac Rational = Rational - embed = id - -g :: IntegralDomain a => a -> a -g x = g x - -h :: a -> Frac a -h x = h x - --- This is the test function - -f :: IntegralDomain a => a -> Frac a -f x = g (h (h x)) - -- Given: IntegralDomain (Frac a) - -- Wanted: IntegralDomain (Frac (Frac a)) - diff --git a/tests/examples/ghc80/T10322A.hs b/tests/examples/ghc80/T10322A.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10322A.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10322A (a) where -{-# NOINLINE a #-} -a :: Int -a = 3 diff --git a/tests/examples/ghc80/T10322B.hs b/tests/examples/ghc80/T10322B.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10322B.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10322B (b) where -import T10322A (a) -b :: Int -b = a+1 diff --git a/tests/examples/ghc80/T10322C.hs b/tests/examples/ghc80/T10322C.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10322C.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T10322C (c) where -import T10322A (a) -import T10322B (b) -c :: Int -c = a+b diff --git a/tests/examples/ghc80/T10335.hs b/tests/examples/ghc80/T10335.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10335.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-} - -module Foo where - -type X a = (Eq a, Show a) - -class Eq a => C a b - --- HEAD was unable to find the (Eq a) superclass --- for a while in March/April 2015 -instance X a => C a [b] - - - - - diff --git a/tests/examples/ghc80/T10340.hs b/tests/examples/ghc80/T10340.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10340.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -module T10340 where - -import GHC.Exts (Any) - -class MonadState s m where - get :: m s - -newtype State s a = State (s -> (s, a)) - -instance MonadState s (State s) where - get = State $ \s -> (s, s) - -foo :: State Any Any -foo = get diff --git a/tests/examples/ghc80/T10348.hs b/tests/examples/ghc80/T10348.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10348.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE AutoDeriveTypeable, GADTs, DataKinds, KindSignatures, StandaloneDeriving, TypeOperators #-} - -module T10348 where - -import GHC.TypeLits -import Data.Typeable -import Data.Proxy - -data Foo (n :: Nat) where - Hey :: KnownNat n => Foo n - -deriving instance Show (Foo n) - -data T t where - T :: (Show t, Typeable t) => t -> T t - -deriving instance Show (T n) - -hey :: KnownNat n => T (Foo n) -hey = T Hey - -ho :: T (Foo 42) -ho = T Hey - -f1 :: KnownNat a => Proxy a -> TypeRep -f1 = typeRep - -g2 :: KnownSymbol a => Proxy a -> TypeRep -g2 = typeRep - -pEqT :: (KnownSymbol a, KnownSymbol b) => Proxy a -> Proxy b -> Maybe (a :~: b) -pEqT Proxy Proxy = eqT diff --git a/tests/examples/ghc80/T10351.hs b/tests/examples/ghc80/T10351.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10351.hs +++ /dev/null @@ -1,6 +0,0 @@ -module T10351 where - -class C a where - op :: a -> () - -f x = op [x] diff --git a/tests/examples/ghc80/T10359.hs b/tests/examples/ghc80/T10359.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10359.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ConstraintKinds #-} - -module Main( main, boo ) where - -import Prelude hiding (repeat) - -boo xs f = (\x -> f x, xs) - -repeat :: Int -> (a -> a) -> a -> a -repeat 1 f x = f x -repeat n f x = n `seq` x `seq` repeat (n-1) f $ f x - ----- Buggy version ------------------- - -type Numerical a = (Fractional a, Real a) - -data Box a = Box - { func :: forall dum. (Numerical dum) => dum -> a -> a - , obj :: !a } - -do_step :: (Numerical num) => num -> Box a -> Box a -do_step number Box{..} = Box{ obj = func number obj, .. } - -start :: Box Double -start = Box { func = \x y -> realToFrac x + y - , obj = 0 } - -test :: Int -> IO () -test steps = putStrLn $ show $ obj $ repeat steps (do_step 1) start - ----- Driver ------------ - -main :: IO () -main = test 2000 -- compare test2 10000000 or test3 10000000, but test4 20000 - - -{- ----- No tuple constraint synonym is better ------------------------------------------- - -data Box2 a = Box2 - { func2 :: forall num. (Fractional num, Real num) => num -> a -> a - , obj2 :: !a } - -do_step2 :: (Fractional num, Real num) => num -> Box2 a -> Box2 a -do_step2 number Box2{..} = Box2{ obj2 = func2 number obj2, ..} - -start2 :: Box2 Double -start2 = Box2 { func2 = \x y -> realToFrac x + y - , obj2 = 0 } - -test2 :: Int -> IO () -test2 steps = putStrLn $ show $ obj2 $ repeat steps (do_step2 1) start2 - ----- Not copying the function field works too ---------------------------------------------- - -do_step3 :: (Numerical num) => num -> Box a -> Box a -do_step3 number b@Box{..} = b{ obj = func number obj } - -test3 :: Int -> IO () -test3 steps = putStrLn $ show $ obj $ repeat steps (do_step3 1) start - ----- But record wildcards are not at fault ------------------------------------------- - -do_step4 :: (Numerical num) => num -> Box a -> Box a -do_step4 number Box{func = f, obj = x} = Box{ obj = f number x, func = f } - -test4 :: Int -> IO () -test4 steps = putStrLn $ show $ obj $ repeat steps (do_step4 1) start --} - - -{- -First of all, very nice example. Thank you for making it so small and easy to work with. - -I can see what's happening. The key part is what happens here: -{{{ -do_step4 :: (Numerical num) => num -> Box a -> Box a -do_step4 number Box{ func = f, obj = x} - = Box{ func = f, obj = f number x } -}}} -After elaboration (ie making dictionaries explicit) we get this: -{{{ -do_step4 dn1 number (Box {func = f, obj = x }) - = Box { func = \dn2 -> f ( case dn2 of (f,r) -> f - , case dn2 of (f,r) -> r) - , obj = f dn1 number x } -}}} -That's odd! We expected this: -{{{ -do_step4 dn1 number (Box {func = f, obj = x }) - = Box { func = f - , obj = f dn1 number x } -}}} -And indeed, the allocation of all those `\dn2` closures is what is causing the problem. -So we are missing this optimisation: -{{{ - (case dn2 of (f,r) -> f, case dn2 of (f,r) -> r) -===> - dn2 -}}} -If we did this, then the lambda would look like `\dn2 -> f dn2` which could eta-reduce to `f`. -But there are at least three problems: - * The tuple transformation above is hard to spot - * The tuple transformation is not quite semantically right; if `dn2` was bottom, the LHS and RHS are different - * The eta-reduction isn't quite semantically right: if `f` ws bottom, the LHS and RHS are different. - -You might argue that the latter two can be ignored because dictionary arguments are special; -indeed we often toy with making them strict. - -But perhaps a better way to avoid the tuple-transformation issue would be not to construct that strange expression in the first place. Where is it coming from? It comes from the call to `f` (admittedly applied to no arguments) in `Box { ..., func = f }`. GHC needs a dictionary for `(Numerical dum)` (I changed the name of the type variable in `func`'s type in the definition of `Box`). Since it's just a pair GHC says "fine, I'll build a pair, out of `Fractional dum` and `Real dum`. How does it get those dictionaries? By selecting the components of the `Franctional dum` passed to `f`. - -If GHC said instead "I need `Numerical dum` and behold I have one in hand, it'd be much better. It doesn't because tuple constraints are treated specially. But if we adopted the idea in #10362, we would (automatically) get to re-use the `Numerical dum` constraint. That would leave us with eta reduction, which is easier. - -As to what will get you rolling, a good solution is `test3`, which saves instantiating and re-generalising `f`. The key thing is to update all the fields ''except'' the polymorphic `func` field. I'm surprised you say that it doesn't work. Can you give a (presumably more complicated) example to demonstrate? Maybe there's a separate bug! - --} - - diff --git a/tests/examples/ghc80/T10361a.hs b/tests/examples/ghc80/T10361a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10361a.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -module T10361a where - -class C1 a where - type T1 a - type instance T1 a = Char - -class C2 a where -- equivalent to C1 - type T2 a - type instance T2 a = Char - -class C3 a where -- equivalent to C1, C2 - type T3 a - type instance T3 a = Char - -data A = B - deriving C1 - -deriving instance C2 A - -instance C3 A - -test1 :: T1 A -test1 = 'x' - -test2 :: T2 A -test2 = 'x' - -test3 :: T3 A -test3 = 'x' diff --git a/tests/examples/ghc80/T10361b.hs b/tests/examples/ghc80/T10361b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10361b.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module T10361b where - -import GHC.Generics - ---------------------------------------------------------------------- -class Convert a where - type Result a - type instance Result a = GResult (Rep a) - - convert :: a -> Result a - default convert :: (Generic a, GConvert (Rep a)) => a -> GResult (Rep a) - convert x = gconvert (from x) - -instance Convert Float where - type Result Float = Float - convert = id - -instance Convert Int where - type Result Int = Int - convert = id - ---------------------------------------------------------------------- -class GConvert f where - type GResult f - gconvert :: f p -> GResult f - -instance (Convert c) => GConvert (K1 i c) where - type GResult (K1 i c) = Result c - gconvert (K1 x) = convert x - -instance (GConvert f) => GConvert (M1 i t f) where - type GResult (M1 i t f) = GResult f - gconvert (M1 x) = gconvert x - -instance (GConvert f, GConvert g) => GConvert (f :*: g) where - type GResult (f :*: g) = (GResult f, GResult g) - gconvert (x :*: y) = (gconvert x, gconvert y) - ---------------------------------------------------------------------- - -data Data1 = Data1 Int Float - deriving (Generic) - -instance Convert Data1 - -val :: (Int, Float) -val = convert $ Data1 0 0.0 - -data Data2 = Data2 Int Float - deriving (Generic, Convert) diff --git a/tests/examples/ghc80/T10370.hs b/tests/examples/ghc80/T10370.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10370.hs +++ /dev/null @@ -1,1002 +0,0 @@ -module Out where -import Control.Monad (forever) -a1 :: IO (); a1 = forever $ putStrLn "a1" -a2 :: IO (); a2 = forever $ putStrLn "a2" -a3 :: IO (); a3 = forever $ putStrLn "a3" -a4 :: IO (); a4 = forever $ putStrLn "a4" -a5 :: IO (); a5 = forever $ putStrLn "a5" -a6 :: IO (); a6 = forever $ putStrLn "a6" -a7 :: IO (); a7 = forever $ putStrLn "a7" -a8 :: IO (); a8 = forever $ putStrLn "a8" -a9 :: IO (); a9 = forever $ putStrLn "a9" -a10 :: IO (); a10 = forever $ putStrLn "a10" -a11 :: IO (); a11 = forever $ putStrLn "a11" -a12 :: IO (); a12 = forever $ putStrLn "a12" -a13 :: IO (); a13 = forever $ putStrLn "a13" -a14 :: IO (); a14 = forever $ putStrLn "a14" -a15 :: IO (); a15 = forever $ putStrLn "a15" -a16 :: IO (); a16 = forever $ putStrLn "a16" -a17 :: IO (); a17 = forever $ putStrLn "a17" -a18 :: IO (); a18 = forever $ putStrLn "a18" -a19 :: IO (); a19 = forever $ putStrLn "a19" -a20 :: IO (); a20 = forever $ putStrLn "a20" -a21 :: IO (); a21 = forever $ putStrLn "a21" -a22 :: IO (); a22 = forever $ putStrLn "a22" -a23 :: IO (); a23 = forever $ putStrLn "a23" -a24 :: IO (); a24 = forever $ putStrLn "a24" -a25 :: IO (); a25 = forever $ putStrLn "a25" -a26 :: IO (); a26 = forever $ putStrLn "a26" -a27 :: IO (); a27 = forever $ putStrLn "a27" -a28 :: IO (); a28 = forever $ putStrLn "a28" -a29 :: IO (); a29 = forever $ putStrLn "a29" -a30 :: IO (); a30 = forever $ putStrLn "a30" -a31 :: IO (); a31 = forever $ putStrLn "a31" -a32 :: IO (); a32 = forever $ putStrLn "a32" -a33 :: IO (); a33 = forever $ putStrLn "a33" -a34 :: IO (); a34 = forever $ putStrLn "a34" -a35 :: IO (); a35 = forever $ putStrLn "a35" -a36 :: IO (); a36 = forever $ putStrLn "a36" -a37 :: IO (); a37 = forever $ putStrLn "a37" -a38 :: IO (); a38 = forever $ putStrLn "a38" -a39 :: IO (); a39 = forever $ putStrLn "a39" -a40 :: IO (); a40 = forever $ putStrLn "a40" -a41 :: IO (); a41 = forever $ putStrLn "a41" -a42 :: IO (); a42 = forever $ putStrLn "a42" -a43 :: IO (); a43 = forever $ putStrLn "a43" -a44 :: IO (); a44 = forever $ putStrLn "a44" -a45 :: IO (); a45 = forever $ putStrLn "a45" -a46 :: IO (); a46 = forever $ putStrLn "a46" -a47 :: IO (); a47 = forever $ putStrLn "a47" -a48 :: IO (); a48 = forever $ putStrLn "a48" -a49 :: IO (); a49 = forever $ putStrLn "a49" -a50 :: IO (); a50 = forever $ putStrLn "a50" -a51 :: IO (); a51 = forever $ putStrLn "a51" -a52 :: IO (); a52 = forever $ putStrLn "a52" -a53 :: IO (); a53 = forever $ putStrLn "a53" -a54 :: IO (); a54 = forever $ putStrLn "a54" -a55 :: IO (); a55 = forever $ putStrLn "a55" -a56 :: IO (); a56 = forever $ putStrLn "a56" -a57 :: IO (); a57 = forever $ putStrLn "a57" -a58 :: IO (); a58 = forever $ putStrLn "a58" -a59 :: IO (); a59 = forever $ putStrLn "a59" -a60 :: IO (); a60 = forever $ putStrLn "a60" -a61 :: IO (); a61 = forever $ putStrLn "a61" -a62 :: IO (); a62 = forever $ putStrLn "a62" -a63 :: IO (); a63 = forever $ putStrLn "a63" -a64 :: IO (); a64 = forever $ putStrLn "a64" -a65 :: IO (); a65 = forever $ putStrLn "a65" -a66 :: IO (); a66 = forever $ putStrLn "a66" -a67 :: IO (); a67 = forever $ putStrLn "a67" -a68 :: IO (); a68 = forever $ putStrLn "a68" -a69 :: IO (); a69 = forever $ putStrLn "a69" -a70 :: IO (); a70 = forever $ putStrLn "a70" -a71 :: IO (); a71 = forever $ putStrLn "a71" -a72 :: IO (); a72 = forever $ putStrLn "a72" -a73 :: IO (); a73 = forever $ putStrLn "a73" -a74 :: IO (); a74 = forever $ putStrLn "a74" -a75 :: IO (); a75 = forever $ putStrLn "a75" -a76 :: IO (); a76 = forever $ putStrLn "a76" -a77 :: IO (); a77 = forever $ putStrLn "a77" -a78 :: IO (); a78 = forever $ putStrLn "a78" -a79 :: IO (); a79 = forever $ putStrLn "a79" -a80 :: IO (); a80 = forever $ putStrLn "a80" -a81 :: IO (); a81 = forever $ putStrLn "a81" -a82 :: IO (); a82 = forever $ putStrLn "a82" -a83 :: IO (); a83 = forever $ putStrLn "a83" -a84 :: IO (); a84 = forever $ putStrLn "a84" -a85 :: IO (); a85 = forever $ putStrLn "a85" -a86 :: IO (); a86 = forever $ putStrLn "a86" -a87 :: IO (); a87 = forever $ putStrLn "a87" -a88 :: IO (); a88 = forever $ putStrLn "a88" -a89 :: IO (); a89 = forever $ putStrLn "a89" -a90 :: IO (); a90 = forever $ putStrLn "a90" -a91 :: IO (); a91 = forever $ putStrLn "a91" -a92 :: IO (); a92 = forever $ putStrLn "a92" -a93 :: IO (); a93 = forever $ putStrLn "a93" -a94 :: IO (); a94 = forever $ putStrLn "a94" -a95 :: IO (); a95 = forever $ putStrLn "a95" -a96 :: IO (); a96 = forever $ putStrLn "a96" -a97 :: IO (); a97 = forever $ putStrLn "a97" -a98 :: IO (); a98 = forever $ putStrLn "a98" -a99 :: IO (); a99 = forever $ putStrLn "a99" -a100 :: IO (); a100 = forever $ putStrLn "a100" -a101 :: IO (); a101 = forever $ putStrLn "a101" -a102 :: IO (); a102 = forever $ putStrLn "a102" -a103 :: IO (); a103 = forever $ putStrLn "a103" -a104 :: IO (); a104 = forever $ putStrLn "a104" -a105 :: IO (); a105 = forever $ putStrLn "a105" -a106 :: IO (); a106 = forever $ putStrLn "a106" -a107 :: IO (); a107 = forever $ putStrLn "a107" -a108 :: IO (); a108 = forever $ putStrLn "a108" -a109 :: IO (); a109 = forever $ putStrLn "a109" -a110 :: IO (); a110 = forever $ putStrLn "a110" -a111 :: IO (); a111 = forever $ putStrLn "a111" -a112 :: IO (); a112 = forever $ putStrLn "a112" -a113 :: IO (); a113 = forever $ putStrLn "a113" -a114 :: IO (); a114 = forever $ putStrLn "a114" -a115 :: IO (); a115 = forever $ putStrLn "a115" -a116 :: IO (); a116 = forever $ putStrLn "a116" -a117 :: IO (); a117 = forever $ putStrLn "a117" -a118 :: IO (); a118 = forever $ putStrLn "a118" -a119 :: IO (); a119 = forever $ putStrLn "a119" -a120 :: IO (); a120 = forever $ putStrLn "a120" -a121 :: IO (); a121 = forever $ putStrLn "a121" -a122 :: IO (); a122 = forever $ putStrLn "a122" -a123 :: IO (); a123 = forever $ putStrLn "a123" -a124 :: IO (); a124 = forever $ putStrLn "a124" -a125 :: IO (); a125 = forever $ putStrLn "a125" -a126 :: IO (); a126 = forever $ putStrLn "a126" -a127 :: IO (); a127 = forever $ putStrLn "a127" -a128 :: IO (); a128 = forever $ putStrLn "a128" -a129 :: IO (); a129 = forever $ putStrLn "a129" -a130 :: IO (); a130 = forever $ putStrLn "a130" -a131 :: IO (); a131 = forever $ putStrLn "a131" -a132 :: IO (); a132 = forever $ putStrLn "a132" -a133 :: IO (); a133 = forever $ putStrLn "a133" -a134 :: IO (); a134 = forever $ putStrLn "a134" -a135 :: IO (); a135 = forever $ putStrLn "a135" -a136 :: IO (); a136 = forever $ putStrLn "a136" -a137 :: IO (); a137 = forever $ putStrLn "a137" -a138 :: IO (); a138 = forever $ putStrLn "a138" -a139 :: IO (); a139 = forever $ putStrLn "a139" -a140 :: IO (); a140 = forever $ putStrLn "a140" -a141 :: IO (); a141 = forever $ putStrLn "a141" -a142 :: IO (); a142 = forever $ putStrLn "a142" -a143 :: IO (); a143 = forever $ putStrLn "a143" -a144 :: IO (); a144 = forever $ putStrLn "a144" -a145 :: IO (); a145 = forever $ putStrLn "a145" -a146 :: IO (); a146 = forever $ putStrLn "a146" -a147 :: IO (); a147 = forever $ putStrLn "a147" -a148 :: IO (); a148 = forever $ putStrLn "a148" -a149 :: IO (); a149 = forever $ putStrLn "a149" -a150 :: IO (); a150 = forever $ putStrLn "a150" -a151 :: IO (); a151 = forever $ putStrLn "a151" -a152 :: IO (); a152 = forever $ putStrLn "a152" -a153 :: IO (); a153 = forever $ putStrLn "a153" -a154 :: IO (); a154 = forever $ putStrLn "a154" -a155 :: IO (); a155 = forever $ putStrLn "a155" -a156 :: IO (); a156 = forever $ putStrLn "a156" -a157 :: IO (); a157 = forever $ putStrLn "a157" -a158 :: IO (); a158 = forever $ putStrLn "a158" -a159 :: IO (); a159 = forever $ putStrLn "a159" -a160 :: IO (); a160 = forever $ putStrLn "a160" -a161 :: IO (); a161 = forever $ putStrLn "a161" -a162 :: IO (); a162 = forever $ putStrLn "a162" -a163 :: IO (); a163 = forever $ putStrLn "a163" -a164 :: IO (); a164 = forever $ putStrLn "a164" -a165 :: IO (); a165 = forever $ putStrLn "a165" -a166 :: IO (); a166 = forever $ putStrLn "a166" -a167 :: IO (); a167 = forever $ putStrLn "a167" -a168 :: IO (); a168 = forever $ putStrLn "a168" -a169 :: IO (); a169 = forever $ putStrLn "a169" -a170 :: IO (); a170 = forever $ putStrLn "a170" -a171 :: IO (); a171 = forever $ putStrLn "a171" -a172 :: IO (); a172 = forever $ putStrLn "a172" -a173 :: IO (); a173 = forever $ putStrLn "a173" -a174 :: IO (); a174 = forever $ putStrLn "a174" -a175 :: IO (); a175 = forever $ putStrLn "a175" -a176 :: IO (); a176 = forever $ putStrLn "a176" -a177 :: IO (); a177 = forever $ putStrLn "a177" -a178 :: IO (); a178 = forever $ putStrLn "a178" -a179 :: IO (); a179 = forever $ putStrLn "a179" -a180 :: IO (); a180 = forever $ putStrLn "a180" -a181 :: IO (); a181 = forever $ putStrLn "a181" -a182 :: IO (); a182 = forever $ putStrLn "a182" -a183 :: IO (); a183 = forever $ putStrLn "a183" -a184 :: IO (); a184 = forever $ putStrLn "a184" -a185 :: IO (); a185 = forever $ putStrLn "a185" -a186 :: IO (); a186 = forever $ putStrLn "a186" -a187 :: IO (); a187 = forever $ putStrLn "a187" -a188 :: IO (); a188 = forever $ putStrLn "a188" -a189 :: IO (); a189 = forever $ putStrLn "a189" -a190 :: IO (); a190 = forever $ putStrLn "a190" -a191 :: IO (); a191 = forever $ putStrLn "a191" -a192 :: IO (); a192 = forever $ putStrLn "a192" -a193 :: IO (); a193 = forever $ putStrLn "a193" -a194 :: IO (); a194 = forever $ putStrLn "a194" -a195 :: IO (); a195 = forever $ putStrLn "a195" -a196 :: IO (); a196 = forever $ putStrLn "a196" -a197 :: IO (); a197 = forever $ putStrLn "a197" -a198 :: IO (); a198 = forever $ putStrLn "a198" -a199 :: IO (); a199 = forever $ putStrLn "a199" -a200 :: IO (); a200 = forever $ putStrLn "a200" -a201 :: IO (); a201 = forever $ putStrLn "a201" -a202 :: IO (); a202 = forever $ putStrLn "a202" -a203 :: IO (); a203 = forever $ putStrLn "a203" -a204 :: IO (); a204 = forever $ putStrLn "a204" -a205 :: IO (); a205 = forever $ putStrLn "a205" -a206 :: IO (); a206 = forever $ putStrLn "a206" -a207 :: IO (); a207 = forever $ putStrLn "a207" -a208 :: IO (); a208 = forever $ putStrLn "a208" -a209 :: IO (); a209 = forever $ putStrLn "a209" -a210 :: IO (); a210 = forever $ putStrLn "a210" -a211 :: IO (); a211 = forever $ putStrLn "a211" -a212 :: IO (); a212 = forever $ putStrLn "a212" -a213 :: IO (); a213 = forever $ putStrLn "a213" -a214 :: IO (); a214 = forever $ putStrLn "a214" -a215 :: IO (); a215 = forever $ putStrLn "a215" -a216 :: IO (); a216 = forever $ putStrLn "a216" -a217 :: IO (); a217 = forever $ putStrLn "a217" -a218 :: IO (); a218 = forever $ putStrLn "a218" -a219 :: IO (); a219 = forever $ putStrLn "a219" -a220 :: IO (); a220 = forever $ putStrLn "a220" -a221 :: IO (); a221 = forever $ putStrLn "a221" -a222 :: IO (); a222 = forever $ putStrLn "a222" -a223 :: IO (); a223 = forever $ putStrLn "a223" -a224 :: IO (); a224 = forever $ putStrLn "a224" -a225 :: IO (); a225 = forever $ putStrLn "a225" -a226 :: IO (); a226 = forever $ putStrLn "a226" -a227 :: IO (); a227 = forever $ putStrLn "a227" -a228 :: IO (); a228 = forever $ putStrLn "a228" -a229 :: IO (); a229 = forever $ putStrLn "a229" -a230 :: IO (); a230 = forever $ putStrLn "a230" -a231 :: IO (); a231 = forever $ putStrLn "a231" -a232 :: IO (); a232 = forever $ putStrLn "a232" -a233 :: IO (); a233 = forever $ putStrLn "a233" -a234 :: IO (); a234 = forever $ putStrLn "a234" -a235 :: IO (); a235 = forever $ putStrLn "a235" -a236 :: IO (); a236 = forever $ putStrLn "a236" -a237 :: IO (); a237 = forever $ putStrLn "a237" -a238 :: IO (); a238 = forever $ putStrLn "a238" -a239 :: IO (); a239 = forever $ putStrLn "a239" -a240 :: IO (); a240 = forever $ putStrLn "a240" -a241 :: IO (); a241 = forever $ putStrLn "a241" -a242 :: IO (); a242 = forever $ putStrLn "a242" -a243 :: IO (); a243 = forever $ putStrLn "a243" -a244 :: IO (); a244 = forever $ putStrLn "a244" -a245 :: IO (); a245 = forever $ putStrLn "a245" -a246 :: IO (); a246 = forever $ putStrLn "a246" -a247 :: IO (); a247 = forever $ putStrLn "a247" -a248 :: IO (); a248 = forever $ putStrLn "a248" -a249 :: IO (); a249 = forever $ putStrLn "a249" -a250 :: IO (); a250 = forever $ putStrLn "a250" -a251 :: IO (); a251 = forever $ putStrLn "a251" -a252 :: IO (); a252 = forever $ putStrLn "a252" -a253 :: IO (); a253 = forever $ putStrLn "a253" -a254 :: IO (); a254 = forever $ putStrLn "a254" -a255 :: IO (); a255 = forever $ putStrLn "a255" -a256 :: IO (); a256 = forever $ putStrLn "a256" -a257 :: IO (); a257 = forever $ putStrLn "a257" -a258 :: IO (); a258 = forever $ putStrLn "a258" -a259 :: IO (); a259 = forever $ putStrLn "a259" -a260 :: IO (); a260 = forever $ putStrLn "a260" -a261 :: IO (); a261 = forever $ putStrLn "a261" -a262 :: IO (); a262 = forever $ putStrLn "a262" -a263 :: IO (); a263 = forever $ putStrLn "a263" -a264 :: IO (); a264 = forever $ putStrLn "a264" -a265 :: IO (); a265 = forever $ putStrLn "a265" -a266 :: IO (); a266 = forever $ putStrLn "a266" -a267 :: IO (); a267 = forever $ putStrLn "a267" -a268 :: IO (); a268 = forever $ putStrLn "a268" -a269 :: IO (); a269 = forever $ putStrLn "a269" -a270 :: IO (); a270 = forever $ putStrLn "a270" -a271 :: IO (); a271 = forever $ putStrLn "a271" -a272 :: IO (); a272 = forever $ putStrLn "a272" -a273 :: IO (); a273 = forever $ putStrLn "a273" -a274 :: IO (); a274 = forever $ putStrLn "a274" -a275 :: IO (); a275 = forever $ putStrLn "a275" -a276 :: IO (); a276 = forever $ putStrLn "a276" -a277 :: IO (); a277 = forever $ putStrLn "a277" -a278 :: IO (); a278 = forever $ putStrLn "a278" -a279 :: IO (); a279 = forever $ putStrLn "a279" -a280 :: IO (); a280 = forever $ putStrLn "a280" -a281 :: IO (); a281 = forever $ putStrLn "a281" -a282 :: IO (); a282 = forever $ putStrLn "a282" -a283 :: IO (); a283 = forever $ putStrLn "a283" -a284 :: IO (); a284 = forever $ putStrLn "a284" -a285 :: IO (); a285 = forever $ putStrLn "a285" -a286 :: IO (); a286 = forever $ putStrLn "a286" -a287 :: IO (); a287 = forever $ putStrLn "a287" -a288 :: IO (); a288 = forever $ putStrLn "a288" -a289 :: IO (); a289 = forever $ putStrLn "a289" -a290 :: IO (); a290 = forever $ putStrLn "a290" -a291 :: IO (); a291 = forever $ putStrLn "a291" -a292 :: IO (); a292 = forever $ putStrLn "a292" -a293 :: IO (); a293 = forever $ putStrLn "a293" -a294 :: IO (); a294 = forever $ putStrLn "a294" -a295 :: IO (); a295 = forever $ putStrLn "a295" -a296 :: IO (); a296 = forever $ putStrLn "a296" -a297 :: IO (); a297 = forever $ putStrLn "a297" -a298 :: IO (); a298 = forever $ putStrLn "a298" -a299 :: IO (); a299 = forever $ putStrLn "a299" -a300 :: IO (); a300 = forever $ putStrLn "a300" -a301 :: IO (); a301 = forever $ putStrLn "a301" -a302 :: IO (); a302 = forever $ putStrLn "a302" -a303 :: IO (); a303 = forever $ putStrLn "a303" -a304 :: IO (); a304 = forever $ putStrLn "a304" -a305 :: IO (); a305 = forever $ putStrLn "a305" -a306 :: IO (); a306 = forever $ putStrLn "a306" -a307 :: IO (); a307 = forever $ putStrLn "a307" -a308 :: IO (); a308 = forever $ putStrLn "a308" -a309 :: IO (); a309 = forever $ putStrLn "a309" -a310 :: IO (); a310 = forever $ putStrLn "a310" -a311 :: IO (); a311 = forever $ putStrLn "a311" -a312 :: IO (); a312 = forever $ putStrLn "a312" -a313 :: IO (); a313 = forever $ putStrLn "a313" -a314 :: IO (); a314 = forever $ putStrLn "a314" -a315 :: IO (); a315 = forever $ putStrLn "a315" -a316 :: IO (); a316 = forever $ putStrLn "a316" -a317 :: IO (); a317 = forever $ putStrLn "a317" -a318 :: IO (); a318 = forever $ putStrLn "a318" -a319 :: IO (); a319 = forever $ putStrLn "a319" -a320 :: IO (); a320 = forever $ putStrLn "a320" -a321 :: IO (); a321 = forever $ putStrLn "a321" -a322 :: IO (); a322 = forever $ putStrLn "a322" -a323 :: IO (); a323 = forever $ putStrLn "a323" -a324 :: IO (); a324 = forever $ putStrLn "a324" -a325 :: IO (); a325 = forever $ putStrLn "a325" -a326 :: IO (); a326 = forever $ putStrLn "a326" -a327 :: IO (); a327 = forever $ putStrLn "a327" -a328 :: IO (); a328 = forever $ putStrLn "a328" -a329 :: IO (); a329 = forever $ putStrLn "a329" -a330 :: IO (); a330 = forever $ putStrLn "a330" -a331 :: IO (); a331 = forever $ putStrLn "a331" -a332 :: IO (); a332 = forever $ putStrLn "a332" -a333 :: IO (); a333 = forever $ putStrLn "a333" -a334 :: IO (); a334 = forever $ putStrLn "a334" -a335 :: IO (); a335 = forever $ putStrLn "a335" -a336 :: IO (); a336 = forever $ putStrLn "a336" -a337 :: IO (); a337 = forever $ putStrLn "a337" -a338 :: IO (); a338 = forever $ putStrLn "a338" -a339 :: IO (); a339 = forever $ putStrLn "a339" -a340 :: IO (); a340 = forever $ putStrLn "a340" -a341 :: IO (); a341 = forever $ putStrLn "a341" -a342 :: IO (); a342 = forever $ putStrLn "a342" -a343 :: IO (); a343 = forever $ putStrLn "a343" -a344 :: IO (); a344 = forever $ putStrLn "a344" -a345 :: IO (); a345 = forever $ putStrLn "a345" -a346 :: IO (); a346 = forever $ putStrLn "a346" -a347 :: IO (); a347 = forever $ putStrLn "a347" -a348 :: IO (); a348 = forever $ putStrLn "a348" -a349 :: IO (); a349 = forever $ putStrLn "a349" -a350 :: IO (); a350 = forever $ putStrLn "a350" -a351 :: IO (); a351 = forever $ putStrLn "a351" -a352 :: IO (); a352 = forever $ putStrLn "a352" -a353 :: IO (); a353 = forever $ putStrLn "a353" -a354 :: IO (); a354 = forever $ putStrLn "a354" -a355 :: IO (); a355 = forever $ putStrLn "a355" -a356 :: IO (); a356 = forever $ putStrLn "a356" -a357 :: IO (); a357 = forever $ putStrLn "a357" -a358 :: IO (); a358 = forever $ putStrLn "a358" -a359 :: IO (); a359 = forever $ putStrLn "a359" -a360 :: IO (); a360 = forever $ putStrLn "a360" -a361 :: IO (); a361 = forever $ putStrLn "a361" -a362 :: IO (); a362 = forever $ putStrLn "a362" -a363 :: IO (); a363 = forever $ putStrLn "a363" -a364 :: IO (); a364 = forever $ putStrLn "a364" -a365 :: IO (); a365 = forever $ putStrLn "a365" -a366 :: IO (); a366 = forever $ putStrLn "a366" -a367 :: IO (); a367 = forever $ putStrLn "a367" -a368 :: IO (); a368 = forever $ putStrLn "a368" -a369 :: IO (); a369 = forever $ putStrLn "a369" -a370 :: IO (); a370 = forever $ putStrLn "a370" -a371 :: IO (); a371 = forever $ putStrLn "a371" -a372 :: IO (); a372 = forever $ putStrLn "a372" -a373 :: IO (); a373 = forever $ putStrLn "a373" -a374 :: IO (); a374 = forever $ putStrLn "a374" -a375 :: IO (); a375 = forever $ putStrLn "a375" -a376 :: IO (); a376 = forever $ putStrLn "a376" -a377 :: IO (); a377 = forever $ putStrLn "a377" -a378 :: IO (); a378 = forever $ putStrLn "a378" -a379 :: IO (); a379 = forever $ putStrLn "a379" -a380 :: IO (); a380 = forever $ putStrLn "a380" -a381 :: IO (); a381 = forever $ putStrLn "a381" -a382 :: IO (); a382 = forever $ putStrLn "a382" -a383 :: IO (); a383 = forever $ putStrLn "a383" -a384 :: IO (); a384 = forever $ putStrLn "a384" -a385 :: IO (); a385 = forever $ putStrLn "a385" -a386 :: IO (); a386 = forever $ putStrLn "a386" -a387 :: IO (); a387 = forever $ putStrLn "a387" -a388 :: IO (); a388 = forever $ putStrLn "a388" -a389 :: IO (); a389 = forever $ putStrLn "a389" -a390 :: IO (); a390 = forever $ putStrLn "a390" -a391 :: IO (); a391 = forever $ putStrLn "a391" -a392 :: IO (); a392 = forever $ putStrLn "a392" -a393 :: IO (); a393 = forever $ putStrLn "a393" -a394 :: IO (); a394 = forever $ putStrLn "a394" -a395 :: IO (); a395 = forever $ putStrLn "a395" -a396 :: IO (); a396 = forever $ putStrLn "a396" -a397 :: IO (); a397 = forever $ putStrLn "a397" -a398 :: IO (); a398 = forever $ putStrLn "a398" -a399 :: IO (); a399 = forever $ putStrLn "a399" -a400 :: IO (); a400 = forever $ putStrLn "a400" -a401 :: IO (); a401 = forever $ putStrLn "a401" -a402 :: IO (); a402 = forever $ putStrLn "a402" -a403 :: IO (); a403 = forever $ putStrLn "a403" -a404 :: IO (); a404 = forever $ putStrLn "a404" -a405 :: IO (); a405 = forever $ putStrLn "a405" -a406 :: IO (); a406 = forever $ putStrLn "a406" -a407 :: IO (); a407 = forever $ putStrLn "a407" -a408 :: IO (); a408 = forever $ putStrLn "a408" -a409 :: IO (); a409 = forever $ putStrLn "a409" -a410 :: IO (); a410 = forever $ putStrLn "a410" -a411 :: IO (); a411 = forever $ putStrLn "a411" -a412 :: IO (); a412 = forever $ putStrLn "a412" -a413 :: IO (); a413 = forever $ putStrLn "a413" -a414 :: IO (); a414 = forever $ putStrLn "a414" -a415 :: IO (); a415 = forever $ putStrLn "a415" -a416 :: IO (); a416 = forever $ putStrLn "a416" -a417 :: IO (); a417 = forever $ putStrLn "a417" -a418 :: IO (); a418 = forever $ putStrLn "a418" -a419 :: IO (); a419 = forever $ putStrLn "a419" -a420 :: IO (); a420 = forever $ putStrLn "a420" -a421 :: IO (); a421 = forever $ putStrLn "a421" -a422 :: IO (); a422 = forever $ putStrLn "a422" -a423 :: IO (); a423 = forever $ putStrLn "a423" -a424 :: IO (); a424 = forever $ putStrLn "a424" -a425 :: IO (); a425 = forever $ putStrLn "a425" -a426 :: IO (); a426 = forever $ putStrLn "a426" -a427 :: IO (); a427 = forever $ putStrLn "a427" -a428 :: IO (); a428 = forever $ putStrLn "a428" -a429 :: IO (); a429 = forever $ putStrLn "a429" -a430 :: IO (); a430 = forever $ putStrLn "a430" -a431 :: IO (); a431 = forever $ putStrLn "a431" -a432 :: IO (); a432 = forever $ putStrLn "a432" -a433 :: IO (); a433 = forever $ putStrLn "a433" -a434 :: IO (); a434 = forever $ putStrLn "a434" -a435 :: IO (); a435 = forever $ putStrLn "a435" -a436 :: IO (); a436 = forever $ putStrLn "a436" -a437 :: IO (); a437 = forever $ putStrLn "a437" -a438 :: IO (); a438 = forever $ putStrLn "a438" -a439 :: IO (); a439 = forever $ putStrLn "a439" -a440 :: IO (); a440 = forever $ putStrLn "a440" -a441 :: IO (); a441 = forever $ putStrLn "a441" -a442 :: IO (); a442 = forever $ putStrLn "a442" -a443 :: IO (); a443 = forever $ putStrLn "a443" -a444 :: IO (); a444 = forever $ putStrLn "a444" -a445 :: IO (); a445 = forever $ putStrLn "a445" -a446 :: IO (); a446 = forever $ putStrLn "a446" -a447 :: IO (); a447 = forever $ putStrLn "a447" -a448 :: IO (); a448 = forever $ putStrLn "a448" -a449 :: IO (); a449 = forever $ putStrLn "a449" -a450 :: IO (); a450 = forever $ putStrLn "a450" -a451 :: IO (); a451 = forever $ putStrLn "a451" -a452 :: IO (); a452 = forever $ putStrLn "a452" -a453 :: IO (); a453 = forever $ putStrLn "a453" -a454 :: IO (); a454 = forever $ putStrLn "a454" -a455 :: IO (); a455 = forever $ putStrLn "a455" -a456 :: IO (); a456 = forever $ putStrLn "a456" -a457 :: IO (); a457 = forever $ putStrLn "a457" -a458 :: IO (); a458 = forever $ putStrLn "a458" -a459 :: IO (); a459 = forever $ putStrLn "a459" -a460 :: IO (); a460 = forever $ putStrLn "a460" -a461 :: IO (); a461 = forever $ putStrLn "a461" -a462 :: IO (); a462 = forever $ putStrLn "a462" -a463 :: IO (); a463 = forever $ putStrLn "a463" -a464 :: IO (); a464 = forever $ putStrLn "a464" -a465 :: IO (); a465 = forever $ putStrLn "a465" -a466 :: IO (); a466 = forever $ putStrLn "a466" -a467 :: IO (); a467 = forever $ putStrLn "a467" -a468 :: IO (); a468 = forever $ putStrLn "a468" -a469 :: IO (); a469 = forever $ putStrLn "a469" -a470 :: IO (); a470 = forever $ putStrLn "a470" -a471 :: IO (); a471 = forever $ putStrLn "a471" -a472 :: IO (); a472 = forever $ putStrLn "a472" -a473 :: IO (); a473 = forever $ putStrLn "a473" -a474 :: IO (); a474 = forever $ putStrLn "a474" -a475 :: IO (); a475 = forever $ putStrLn "a475" -a476 :: IO (); a476 = forever $ putStrLn "a476" -a477 :: IO (); a477 = forever $ putStrLn "a477" -a478 :: IO (); a478 = forever $ putStrLn "a478" -a479 :: IO (); a479 = forever $ putStrLn "a479" -a480 :: IO (); a480 = forever $ putStrLn "a480" -a481 :: IO (); a481 = forever $ putStrLn "a481" -a482 :: IO (); a482 = forever $ putStrLn "a482" -a483 :: IO (); a483 = forever $ putStrLn "a483" -a484 :: IO (); a484 = forever $ putStrLn "a484" -a485 :: IO (); a485 = forever $ putStrLn "a485" -a486 :: IO (); a486 = forever $ putStrLn "a486" -a487 :: IO (); a487 = forever $ putStrLn "a487" -a488 :: IO (); a488 = forever $ putStrLn "a488" -a489 :: IO (); a489 = forever $ putStrLn "a489" -a490 :: IO (); a490 = forever $ putStrLn "a490" -a491 :: IO (); a491 = forever $ putStrLn "a491" -a492 :: IO (); a492 = forever $ putStrLn "a492" -a493 :: IO (); a493 = forever $ putStrLn "a493" -a494 :: IO (); a494 = forever $ putStrLn "a494" -a495 :: IO (); a495 = forever $ putStrLn "a495" -a496 :: IO (); a496 = forever $ putStrLn "a496" -a497 :: IO (); a497 = forever $ putStrLn "a497" -a498 :: IO (); a498 = forever $ putStrLn "a498" -a499 :: IO (); a499 = forever $ putStrLn "a499" -a500 :: IO (); a500 = forever $ putStrLn "a500" -a501 :: IO (); a501 = forever $ putStrLn "a501" -a502 :: IO (); a502 = forever $ putStrLn "a502" -a503 :: IO (); a503 = forever $ putStrLn "a503" -a504 :: IO (); a504 = forever $ putStrLn "a504" -a505 :: IO (); a505 = forever $ putStrLn "a505" -a506 :: IO (); a506 = forever $ putStrLn "a506" -a507 :: IO (); a507 = forever $ putStrLn "a507" -a508 :: IO (); a508 = forever $ putStrLn "a508" -a509 :: IO (); a509 = forever $ putStrLn "a509" -a510 :: IO (); a510 = forever $ putStrLn "a510" -a511 :: IO (); a511 = forever $ putStrLn "a511" -a512 :: IO (); a512 = forever $ putStrLn "a512" -a513 :: IO (); a513 = forever $ putStrLn "a513" -a514 :: IO (); a514 = forever $ putStrLn "a514" -a515 :: IO (); a515 = forever $ putStrLn "a515" -a516 :: IO (); a516 = forever $ putStrLn "a516" -a517 :: IO (); a517 = forever $ putStrLn "a517" -a518 :: IO (); a518 = forever $ putStrLn "a518" -a519 :: IO (); a519 = forever $ putStrLn "a519" -a520 :: IO (); a520 = forever $ putStrLn "a520" -a521 :: IO (); a521 = forever $ putStrLn "a521" -a522 :: IO (); a522 = forever $ putStrLn "a522" -a523 :: IO (); a523 = forever $ putStrLn "a523" -a524 :: IO (); a524 = forever $ putStrLn "a524" -a525 :: IO (); a525 = forever $ putStrLn "a525" -a526 :: IO (); a526 = forever $ putStrLn "a526" -a527 :: IO (); a527 = forever $ putStrLn "a527" -a528 :: IO (); a528 = forever $ putStrLn "a528" -a529 :: IO (); a529 = forever $ putStrLn "a529" -a530 :: IO (); a530 = forever $ putStrLn "a530" -a531 :: IO (); a531 = forever $ putStrLn "a531" -a532 :: IO (); a532 = forever $ putStrLn "a532" -a533 :: IO (); a533 = forever $ putStrLn "a533" -a534 :: IO (); a534 = forever $ putStrLn "a534" -a535 :: IO (); a535 = forever $ putStrLn "a535" -a536 :: IO (); a536 = forever $ putStrLn "a536" -a537 :: IO (); a537 = forever $ putStrLn "a537" -a538 :: IO (); a538 = forever $ putStrLn "a538" -a539 :: IO (); a539 = forever $ putStrLn "a539" -a540 :: IO (); a540 = forever $ putStrLn "a540" -a541 :: IO (); a541 = forever $ putStrLn "a541" -a542 :: IO (); a542 = forever $ putStrLn "a542" -a543 :: IO (); a543 = forever $ putStrLn "a543" -a544 :: IO (); a544 = forever $ putStrLn "a544" -a545 :: IO (); a545 = forever $ putStrLn "a545" -a546 :: IO (); a546 = forever $ putStrLn "a546" -a547 :: IO (); a547 = forever $ putStrLn "a547" -a548 :: IO (); a548 = forever $ putStrLn "a548" -a549 :: IO (); a549 = forever $ putStrLn "a549" -a550 :: IO (); a550 = forever $ putStrLn "a550" -a551 :: IO (); a551 = forever $ putStrLn "a551" -a552 :: IO (); a552 = forever $ putStrLn "a552" -a553 :: IO (); a553 = forever $ putStrLn "a553" -a554 :: IO (); a554 = forever $ putStrLn "a554" -a555 :: IO (); a555 = forever $ putStrLn "a555" -a556 :: IO (); a556 = forever $ putStrLn "a556" -a557 :: IO (); a557 = forever $ putStrLn "a557" -a558 :: IO (); a558 = forever $ putStrLn "a558" -a559 :: IO (); a559 = forever $ putStrLn "a559" -a560 :: IO (); a560 = forever $ putStrLn "a560" -a561 :: IO (); a561 = forever $ putStrLn "a561" -a562 :: IO (); a562 = forever $ putStrLn "a562" -a563 :: IO (); a563 = forever $ putStrLn "a563" -a564 :: IO (); a564 = forever $ putStrLn "a564" -a565 :: IO (); a565 = forever $ putStrLn "a565" -a566 :: IO (); a566 = forever $ putStrLn "a566" -a567 :: IO (); a567 = forever $ putStrLn "a567" -a568 :: IO (); a568 = forever $ putStrLn "a568" -a569 :: IO (); a569 = forever $ putStrLn "a569" -a570 :: IO (); a570 = forever $ putStrLn "a570" -a571 :: IO (); a571 = forever $ putStrLn "a571" -a572 :: IO (); a572 = forever $ putStrLn "a572" -a573 :: IO (); a573 = forever $ putStrLn "a573" -a574 :: IO (); a574 = forever $ putStrLn "a574" -a575 :: IO (); a575 = forever $ putStrLn "a575" -a576 :: IO (); a576 = forever $ putStrLn "a576" -a577 :: IO (); a577 = forever $ putStrLn "a577" -a578 :: IO (); a578 = forever $ putStrLn "a578" -a579 :: IO (); a579 = forever $ putStrLn "a579" -a580 :: IO (); a580 = forever $ putStrLn "a580" -a581 :: IO (); a581 = forever $ putStrLn "a581" -a582 :: IO (); a582 = forever $ putStrLn "a582" -a583 :: IO (); a583 = forever $ putStrLn "a583" -a584 :: IO (); a584 = forever $ putStrLn "a584" -a585 :: IO (); a585 = forever $ putStrLn "a585" -a586 :: IO (); a586 = forever $ putStrLn "a586" -a587 :: IO (); a587 = forever $ putStrLn "a587" -a588 :: IO (); a588 = forever $ putStrLn "a588" -a589 :: IO (); a589 = forever $ putStrLn "a589" -a590 :: IO (); a590 = forever $ putStrLn "a590" -a591 :: IO (); a591 = forever $ putStrLn "a591" -a592 :: IO (); a592 = forever $ putStrLn "a592" -a593 :: IO (); a593 = forever $ putStrLn "a593" -a594 :: IO (); a594 = forever $ putStrLn "a594" -a595 :: IO (); a595 = forever $ putStrLn "a595" -a596 :: IO (); a596 = forever $ putStrLn "a596" -a597 :: IO (); a597 = forever $ putStrLn "a597" -a598 :: IO (); a598 = forever $ putStrLn "a598" -a599 :: IO (); a599 = forever $ putStrLn "a599" -a600 :: IO (); a600 = forever $ putStrLn "a600" -a601 :: IO (); a601 = forever $ putStrLn "a601" -a602 :: IO (); a602 = forever $ putStrLn "a602" -a603 :: IO (); a603 = forever $ putStrLn "a603" -a604 :: IO (); a604 = forever $ putStrLn "a604" -a605 :: IO (); a605 = forever $ putStrLn "a605" -a606 :: IO (); a606 = forever $ putStrLn "a606" -a607 :: IO (); a607 = forever $ putStrLn "a607" -a608 :: IO (); a608 = forever $ putStrLn "a608" -a609 :: IO (); a609 = forever $ putStrLn "a609" -a610 :: IO (); a610 = forever $ putStrLn "a610" -a611 :: IO (); a611 = forever $ putStrLn "a611" -a612 :: IO (); a612 = forever $ putStrLn "a612" -a613 :: IO (); a613 = forever $ putStrLn "a613" -a614 :: IO (); a614 = forever $ putStrLn "a614" -a615 :: IO (); a615 = forever $ putStrLn "a615" -a616 :: IO (); a616 = forever $ putStrLn "a616" -a617 :: IO (); a617 = forever $ putStrLn "a617" -a618 :: IO (); a618 = forever $ putStrLn "a618" -a619 :: IO (); a619 = forever $ putStrLn "a619" -a620 :: IO (); a620 = forever $ putStrLn "a620" -a621 :: IO (); a621 = forever $ putStrLn "a621" -a622 :: IO (); a622 = forever $ putStrLn "a622" -a623 :: IO (); a623 = forever $ putStrLn "a623" -a624 :: IO (); a624 = forever $ putStrLn "a624" -a625 :: IO (); a625 = forever $ putStrLn "a625" -a626 :: IO (); a626 = forever $ putStrLn "a626" -a627 :: IO (); a627 = forever $ putStrLn "a627" -a628 :: IO (); a628 = forever $ putStrLn "a628" -a629 :: IO (); a629 = forever $ putStrLn "a629" -a630 :: IO (); a630 = forever $ putStrLn "a630" -a631 :: IO (); a631 = forever $ putStrLn "a631" -a632 :: IO (); a632 = forever $ putStrLn "a632" -a633 :: IO (); a633 = forever $ putStrLn "a633" -a634 :: IO (); a634 = forever $ putStrLn "a634" -a635 :: IO (); a635 = forever $ putStrLn "a635" -a636 :: IO (); a636 = forever $ putStrLn "a636" -a637 :: IO (); a637 = forever $ putStrLn "a637" -a638 :: IO (); a638 = forever $ putStrLn "a638" -a639 :: IO (); a639 = forever $ putStrLn "a639" -a640 :: IO (); a640 = forever $ putStrLn "a640" -a641 :: IO (); a641 = forever $ putStrLn "a641" -a642 :: IO (); a642 = forever $ putStrLn "a642" -a643 :: IO (); a643 = forever $ putStrLn "a643" -a644 :: IO (); a644 = forever $ putStrLn "a644" -a645 :: IO (); a645 = forever $ putStrLn "a645" -a646 :: IO (); a646 = forever $ putStrLn "a646" -a647 :: IO (); a647 = forever $ putStrLn "a647" -a648 :: IO (); a648 = forever $ putStrLn "a648" -a649 :: IO (); a649 = forever $ putStrLn "a649" -a650 :: IO (); a650 = forever $ putStrLn "a650" -a651 :: IO (); a651 = forever $ putStrLn "a651" -a652 :: IO (); a652 = forever $ putStrLn "a652" -a653 :: IO (); a653 = forever $ putStrLn "a653" -a654 :: IO (); a654 = forever $ putStrLn "a654" -a655 :: IO (); a655 = forever $ putStrLn "a655" -a656 :: IO (); a656 = forever $ putStrLn "a656" -a657 :: IO (); a657 = forever $ putStrLn "a657" -a658 :: IO (); a658 = forever $ putStrLn "a658" -a659 :: IO (); a659 = forever $ putStrLn "a659" -a660 :: IO (); a660 = forever $ putStrLn "a660" -a661 :: IO (); a661 = forever $ putStrLn "a661" -a662 :: IO (); a662 = forever $ putStrLn "a662" -a663 :: IO (); a663 = forever $ putStrLn "a663" -a664 :: IO (); a664 = forever $ putStrLn "a664" -a665 :: IO (); a665 = forever $ putStrLn "a665" -a666 :: IO (); a666 = forever $ putStrLn "a666" -a667 :: IO (); a667 = forever $ putStrLn "a667" -a668 :: IO (); a668 = forever $ putStrLn "a668" -a669 :: IO (); a669 = forever $ putStrLn "a669" -a670 :: IO (); a670 = forever $ putStrLn "a670" -a671 :: IO (); a671 = forever $ putStrLn "a671" -a672 :: IO (); a672 = forever $ putStrLn "a672" -a673 :: IO (); a673 = forever $ putStrLn "a673" -a674 :: IO (); a674 = forever $ putStrLn "a674" -a675 :: IO (); a675 = forever $ putStrLn "a675" -a676 :: IO (); a676 = forever $ putStrLn "a676" -a677 :: IO (); a677 = forever $ putStrLn "a677" -a678 :: IO (); a678 = forever $ putStrLn "a678" -a679 :: IO (); a679 = forever $ putStrLn "a679" -a680 :: IO (); a680 = forever $ putStrLn "a680" -a681 :: IO (); a681 = forever $ putStrLn "a681" -a682 :: IO (); a682 = forever $ putStrLn "a682" -a683 :: IO (); a683 = forever $ putStrLn "a683" -a684 :: IO (); a684 = forever $ putStrLn "a684" -a685 :: IO (); a685 = forever $ putStrLn "a685" -a686 :: IO (); a686 = forever $ putStrLn "a686" -a687 :: IO (); a687 = forever $ putStrLn "a687" -a688 :: IO (); a688 = forever $ putStrLn "a688" -a689 :: IO (); a689 = forever $ putStrLn "a689" -a690 :: IO (); a690 = forever $ putStrLn "a690" -a691 :: IO (); a691 = forever $ putStrLn "a691" -a692 :: IO (); a692 = forever $ putStrLn "a692" -a693 :: IO (); a693 = forever $ putStrLn "a693" -a694 :: IO (); a694 = forever $ putStrLn "a694" -a695 :: IO (); a695 = forever $ putStrLn "a695" -a696 :: IO (); a696 = forever $ putStrLn "a696" -a697 :: IO (); a697 = forever $ putStrLn "a697" -a698 :: IO (); a698 = forever $ putStrLn "a698" -a699 :: IO (); a699 = forever $ putStrLn "a699" -a700 :: IO (); a700 = forever $ putStrLn "a700" -a701 :: IO (); a701 = forever $ putStrLn "a701" -a702 :: IO (); a702 = forever $ putStrLn "a702" -a703 :: IO (); a703 = forever $ putStrLn "a703" -a704 :: IO (); a704 = forever $ putStrLn "a704" -a705 :: IO (); a705 = forever $ putStrLn "a705" -a706 :: IO (); a706 = forever $ putStrLn "a706" -a707 :: IO (); a707 = forever $ putStrLn "a707" -a708 :: IO (); a708 = forever $ putStrLn "a708" -a709 :: IO (); a709 = forever $ putStrLn "a709" -a710 :: IO (); a710 = forever $ putStrLn "a710" -a711 :: IO (); a711 = forever $ putStrLn "a711" -a712 :: IO (); a712 = forever $ putStrLn "a712" -a713 :: IO (); a713 = forever $ putStrLn "a713" -a714 :: IO (); a714 = forever $ putStrLn "a714" -a715 :: IO (); a715 = forever $ putStrLn "a715" -a716 :: IO (); a716 = forever $ putStrLn "a716" -a717 :: IO (); a717 = forever $ putStrLn "a717" -a718 :: IO (); a718 = forever $ putStrLn "a718" -a719 :: IO (); a719 = forever $ putStrLn "a719" -a720 :: IO (); a720 = forever $ putStrLn "a720" -a721 :: IO (); a721 = forever $ putStrLn "a721" -a722 :: IO (); a722 = forever $ putStrLn "a722" -a723 :: IO (); a723 = forever $ putStrLn "a723" -a724 :: IO (); a724 = forever $ putStrLn "a724" -a725 :: IO (); a725 = forever $ putStrLn "a725" -a726 :: IO (); a726 = forever $ putStrLn "a726" -a727 :: IO (); a727 = forever $ putStrLn "a727" -a728 :: IO (); a728 = forever $ putStrLn "a728" -a729 :: IO (); a729 = forever $ putStrLn "a729" -a730 :: IO (); a730 = forever $ putStrLn "a730" -a731 :: IO (); a731 = forever $ putStrLn "a731" -a732 :: IO (); a732 = forever $ putStrLn "a732" -a733 :: IO (); a733 = forever $ putStrLn "a733" -a734 :: IO (); a734 = forever $ putStrLn "a734" -a735 :: IO (); a735 = forever $ putStrLn "a735" -a736 :: IO (); a736 = forever $ putStrLn "a736" -a737 :: IO (); a737 = forever $ putStrLn "a737" -a738 :: IO (); a738 = forever $ putStrLn "a738" -a739 :: IO (); a739 = forever $ putStrLn "a739" -a740 :: IO (); a740 = forever $ putStrLn "a740" -a741 :: IO (); a741 = forever $ putStrLn "a741" -a742 :: IO (); a742 = forever $ putStrLn "a742" -a743 :: IO (); a743 = forever $ putStrLn "a743" -a744 :: IO (); a744 = forever $ putStrLn "a744" -a745 :: IO (); a745 = forever $ putStrLn "a745" -a746 :: IO (); a746 = forever $ putStrLn "a746" -a747 :: IO (); a747 = forever $ putStrLn "a747" -a748 :: IO (); a748 = forever $ putStrLn "a748" -a749 :: IO (); a749 = forever $ putStrLn "a749" -a750 :: IO (); a750 = forever $ putStrLn "a750" -a751 :: IO (); a751 = forever $ putStrLn "a751" -a752 :: IO (); a752 = forever $ putStrLn "a752" -a753 :: IO (); a753 = forever $ putStrLn "a753" -a754 :: IO (); a754 = forever $ putStrLn "a754" -a755 :: IO (); a755 = forever $ putStrLn "a755" -a756 :: IO (); a756 = forever $ putStrLn "a756" -a757 :: IO (); a757 = forever $ putStrLn "a757" -a758 :: IO (); a758 = forever $ putStrLn "a758" -a759 :: IO (); a759 = forever $ putStrLn "a759" -a760 :: IO (); a760 = forever $ putStrLn "a760" -a761 :: IO (); a761 = forever $ putStrLn "a761" -a762 :: IO (); a762 = forever $ putStrLn "a762" -a763 :: IO (); a763 = forever $ putStrLn "a763" -a764 :: IO (); a764 = forever $ putStrLn "a764" -a765 :: IO (); a765 = forever $ putStrLn "a765" -a766 :: IO (); a766 = forever $ putStrLn "a766" -a767 :: IO (); a767 = forever $ putStrLn "a767" -a768 :: IO (); a768 = forever $ putStrLn "a768" -a769 :: IO (); a769 = forever $ putStrLn "a769" -a770 :: IO (); a770 = forever $ putStrLn "a770" -a771 :: IO (); a771 = forever $ putStrLn "a771" -a772 :: IO (); a772 = forever $ putStrLn "a772" -a773 :: IO (); a773 = forever $ putStrLn "a773" -a774 :: IO (); a774 = forever $ putStrLn "a774" -a775 :: IO (); a775 = forever $ putStrLn "a775" -a776 :: IO (); a776 = forever $ putStrLn "a776" -a777 :: IO (); a777 = forever $ putStrLn "a777" -a778 :: IO (); a778 = forever $ putStrLn "a778" -a779 :: IO (); a779 = forever $ putStrLn "a779" -a780 :: IO (); a780 = forever $ putStrLn "a780" -a781 :: IO (); a781 = forever $ putStrLn "a781" -a782 :: IO (); a782 = forever $ putStrLn "a782" -a783 :: IO (); a783 = forever $ putStrLn "a783" -a784 :: IO (); a784 = forever $ putStrLn "a784" -a785 :: IO (); a785 = forever $ putStrLn "a785" -a786 :: IO (); a786 = forever $ putStrLn "a786" -a787 :: IO (); a787 = forever $ putStrLn "a787" -a788 :: IO (); a788 = forever $ putStrLn "a788" -a789 :: IO (); a789 = forever $ putStrLn "a789" -a790 :: IO (); a790 = forever $ putStrLn "a790" -a791 :: IO (); a791 = forever $ putStrLn "a791" -a792 :: IO (); a792 = forever $ putStrLn "a792" -a793 :: IO (); a793 = forever $ putStrLn "a793" -a794 :: IO (); a794 = forever $ putStrLn "a794" -a795 :: IO (); a795 = forever $ putStrLn "a795" -a796 :: IO (); a796 = forever $ putStrLn "a796" -a797 :: IO (); a797 = forever $ putStrLn "a797" -a798 :: IO (); a798 = forever $ putStrLn "a798" -a799 :: IO (); a799 = forever $ putStrLn "a799" -a800 :: IO (); a800 = forever $ putStrLn "a800" -a801 :: IO (); a801 = forever $ putStrLn "a801" -a802 :: IO (); a802 = forever $ putStrLn "a802" -a803 :: IO (); a803 = forever $ putStrLn "a803" -a804 :: IO (); a804 = forever $ putStrLn "a804" -a805 :: IO (); a805 = forever $ putStrLn "a805" -a806 :: IO (); a806 = forever $ putStrLn "a806" -a807 :: IO (); a807 = forever $ putStrLn "a807" -a808 :: IO (); a808 = forever $ putStrLn "a808" -a809 :: IO (); a809 = forever $ putStrLn "a809" -a810 :: IO (); a810 = forever $ putStrLn "a810" -a811 :: IO (); a811 = forever $ putStrLn "a811" -a812 :: IO (); a812 = forever $ putStrLn "a812" -a813 :: IO (); a813 = forever $ putStrLn "a813" -a814 :: IO (); a814 = forever $ putStrLn "a814" -a815 :: IO (); a815 = forever $ putStrLn "a815" -a816 :: IO (); a816 = forever $ putStrLn "a816" -a817 :: IO (); a817 = forever $ putStrLn "a817" -a818 :: IO (); a818 = forever $ putStrLn "a818" -a819 :: IO (); a819 = forever $ putStrLn "a819" -a820 :: IO (); a820 = forever $ putStrLn "a820" -a821 :: IO (); a821 = forever $ putStrLn "a821" -a822 :: IO (); a822 = forever $ putStrLn "a822" -a823 :: IO (); a823 = forever $ putStrLn "a823" -a824 :: IO (); a824 = forever $ putStrLn "a824" -a825 :: IO (); a825 = forever $ putStrLn "a825" -a826 :: IO (); a826 = forever $ putStrLn "a826" -a827 :: IO (); a827 = forever $ putStrLn "a827" -a828 :: IO (); a828 = forever $ putStrLn "a828" -a829 :: IO (); a829 = forever $ putStrLn "a829" -a830 :: IO (); a830 = forever $ putStrLn "a830" -a831 :: IO (); a831 = forever $ putStrLn "a831" -a832 :: IO (); a832 = forever $ putStrLn "a832" -a833 :: IO (); a833 = forever $ putStrLn "a833" -a834 :: IO (); a834 = forever $ putStrLn "a834" -a835 :: IO (); a835 = forever $ putStrLn "a835" -a836 :: IO (); a836 = forever $ putStrLn "a836" -a837 :: IO (); a837 = forever $ putStrLn "a837" -a838 :: IO (); a838 = forever $ putStrLn "a838" -a839 :: IO (); a839 = forever $ putStrLn "a839" -a840 :: IO (); a840 = forever $ putStrLn "a840" -a841 :: IO (); a841 = forever $ putStrLn "a841" -a842 :: IO (); a842 = forever $ putStrLn "a842" -a843 :: IO (); a843 = forever $ putStrLn "a843" -a844 :: IO (); a844 = forever $ putStrLn "a844" -a845 :: IO (); a845 = forever $ putStrLn "a845" -a846 :: IO (); a846 = forever $ putStrLn "a846" -a847 :: IO (); a847 = forever $ putStrLn "a847" -a848 :: IO (); a848 = forever $ putStrLn "a848" -a849 :: IO (); a849 = forever $ putStrLn "a849" -a850 :: IO (); a850 = forever $ putStrLn "a850" -a851 :: IO (); a851 = forever $ putStrLn "a851" -a852 :: IO (); a852 = forever $ putStrLn "a852" -a853 :: IO (); a853 = forever $ putStrLn "a853" -a854 :: IO (); a854 = forever $ putStrLn "a854" -a855 :: IO (); a855 = forever $ putStrLn "a855" -a856 :: IO (); a856 = forever $ putStrLn "a856" -a857 :: IO (); a857 = forever $ putStrLn "a857" -a858 :: IO (); a858 = forever $ putStrLn "a858" -a859 :: IO (); a859 = forever $ putStrLn "a859" -a860 :: IO (); a860 = forever $ putStrLn "a860" -a861 :: IO (); a861 = forever $ putStrLn "a861" -a862 :: IO (); a862 = forever $ putStrLn "a862" -a863 :: IO (); a863 = forever $ putStrLn "a863" -a864 :: IO (); a864 = forever $ putStrLn "a864" -a865 :: IO (); a865 = forever $ putStrLn "a865" -a866 :: IO (); a866 = forever $ putStrLn "a866" -a867 :: IO (); a867 = forever $ putStrLn "a867" -a868 :: IO (); a868 = forever $ putStrLn "a868" -a869 :: IO (); a869 = forever $ putStrLn "a869" -a870 :: IO (); a870 = forever $ putStrLn "a870" -a871 :: IO (); a871 = forever $ putStrLn "a871" -a872 :: IO (); a872 = forever $ putStrLn "a872" -a873 :: IO (); a873 = forever $ putStrLn "a873" -a874 :: IO (); a874 = forever $ putStrLn "a874" -a875 :: IO (); a875 = forever $ putStrLn "a875" -a876 :: IO (); a876 = forever $ putStrLn "a876" -a877 :: IO (); a877 = forever $ putStrLn "a877" -a878 :: IO (); a878 = forever $ putStrLn "a878" -a879 :: IO (); a879 = forever $ putStrLn "a879" -a880 :: IO (); a880 = forever $ putStrLn "a880" -a881 :: IO (); a881 = forever $ putStrLn "a881" -a882 :: IO (); a882 = forever $ putStrLn "a882" -a883 :: IO (); a883 = forever $ putStrLn "a883" -a884 :: IO (); a884 = forever $ putStrLn "a884" -a885 :: IO (); a885 = forever $ putStrLn "a885" -a886 :: IO (); a886 = forever $ putStrLn "a886" -a887 :: IO (); a887 = forever $ putStrLn "a887" -a888 :: IO (); a888 = forever $ putStrLn "a888" -a889 :: IO (); a889 = forever $ putStrLn "a889" -a890 :: IO (); a890 = forever $ putStrLn "a890" -a891 :: IO (); a891 = forever $ putStrLn "a891" -a892 :: IO (); a892 = forever $ putStrLn "a892" -a893 :: IO (); a893 = forever $ putStrLn "a893" -a894 :: IO (); a894 = forever $ putStrLn "a894" -a895 :: IO (); a895 = forever $ putStrLn "a895" -a896 :: IO (); a896 = forever $ putStrLn "a896" -a897 :: IO (); a897 = forever $ putStrLn "a897" -a898 :: IO (); a898 = forever $ putStrLn "a898" -a899 :: IO (); a899 = forever $ putStrLn "a899" -a900 :: IO (); a900 = forever $ putStrLn "a900" -a901 :: IO (); a901 = forever $ putStrLn "a901" -a902 :: IO (); a902 = forever $ putStrLn "a902" -a903 :: IO (); a903 = forever $ putStrLn "a903" -a904 :: IO (); a904 = forever $ putStrLn "a904" -a905 :: IO (); a905 = forever $ putStrLn "a905" -a906 :: IO (); a906 = forever $ putStrLn "a906" -a907 :: IO (); a907 = forever $ putStrLn "a907" -a908 :: IO (); a908 = forever $ putStrLn "a908" -a909 :: IO (); a909 = forever $ putStrLn "a909" -a910 :: IO (); a910 = forever $ putStrLn "a910" -a911 :: IO (); a911 = forever $ putStrLn "a911" -a912 :: IO (); a912 = forever $ putStrLn "a912" -a913 :: IO (); a913 = forever $ putStrLn "a913" -a914 :: IO (); a914 = forever $ putStrLn "a914" -a915 :: IO (); a915 = forever $ putStrLn "a915" -a916 :: IO (); a916 = forever $ putStrLn "a916" -a917 :: IO (); a917 = forever $ putStrLn "a917" -a918 :: IO (); a918 = forever $ putStrLn "a918" -a919 :: IO (); a919 = forever $ putStrLn "a919" -a920 :: IO (); a920 = forever $ putStrLn "a920" -a921 :: IO (); a921 = forever $ putStrLn "a921" -a922 :: IO (); a922 = forever $ putStrLn "a922" -a923 :: IO (); a923 = forever $ putStrLn "a923" -a924 :: IO (); a924 = forever $ putStrLn "a924" -a925 :: IO (); a925 = forever $ putStrLn "a925" -a926 :: IO (); a926 = forever $ putStrLn "a926" -a927 :: IO (); a927 = forever $ putStrLn "a927" -a928 :: IO (); a928 = forever $ putStrLn "a928" -a929 :: IO (); a929 = forever $ putStrLn "a929" -a930 :: IO (); a930 = forever $ putStrLn "a930" -a931 :: IO (); a931 = forever $ putStrLn "a931" -a932 :: IO (); a932 = forever $ putStrLn "a932" -a933 :: IO (); a933 = forever $ putStrLn "a933" -a934 :: IO (); a934 = forever $ putStrLn "a934" -a935 :: IO (); a935 = forever $ putStrLn "a935" -a936 :: IO (); a936 = forever $ putStrLn "a936" -a937 :: IO (); a937 = forever $ putStrLn "a937" -a938 :: IO (); a938 = forever $ putStrLn "a938" -a939 :: IO (); a939 = forever $ putStrLn "a939" -a940 :: IO (); a940 = forever $ putStrLn "a940" -a941 :: IO (); a941 = forever $ putStrLn "a941" -a942 :: IO (); a942 = forever $ putStrLn "a942" -a943 :: IO (); a943 = forever $ putStrLn "a943" -a944 :: IO (); a944 = forever $ putStrLn "a944" -a945 :: IO (); a945 = forever $ putStrLn "a945" -a946 :: IO (); a946 = forever $ putStrLn "a946" -a947 :: IO (); a947 = forever $ putStrLn "a947" -a948 :: IO (); a948 = forever $ putStrLn "a948" -a949 :: IO (); a949 = forever $ putStrLn "a949" -a950 :: IO (); a950 = forever $ putStrLn "a950" -a951 :: IO (); a951 = forever $ putStrLn "a951" -a952 :: IO (); a952 = forever $ putStrLn "a952" -a953 :: IO (); a953 = forever $ putStrLn "a953" -a954 :: IO (); a954 = forever $ putStrLn "a954" -a955 :: IO (); a955 = forever $ putStrLn "a955" -a956 :: IO (); a956 = forever $ putStrLn "a956" -a957 :: IO (); a957 = forever $ putStrLn "a957" -a958 :: IO (); a958 = forever $ putStrLn "a958" -a959 :: IO (); a959 = forever $ putStrLn "a959" -a960 :: IO (); a960 = forever $ putStrLn "a960" -a961 :: IO (); a961 = forever $ putStrLn "a961" -a962 :: IO (); a962 = forever $ putStrLn "a962" -a963 :: IO (); a963 = forever $ putStrLn "a963" -a964 :: IO (); a964 = forever $ putStrLn "a964" -a965 :: IO (); a965 = forever $ putStrLn "a965" -a966 :: IO (); a966 = forever $ putStrLn "a966" -a967 :: IO (); a967 = forever $ putStrLn "a967" -a968 :: IO (); a968 = forever $ putStrLn "a968" -a969 :: IO (); a969 = forever $ putStrLn "a969" -a970 :: IO (); a970 = forever $ putStrLn "a970" -a971 :: IO (); a971 = forever $ putStrLn "a971" -a972 :: IO (); a972 = forever $ putStrLn "a972" -a973 :: IO (); a973 = forever $ putStrLn "a973" -a974 :: IO (); a974 = forever $ putStrLn "a974" -a975 :: IO (); a975 = forever $ putStrLn "a975" -a976 :: IO (); a976 = forever $ putStrLn "a976" -a977 :: IO (); a977 = forever $ putStrLn "a977" -a978 :: IO (); a978 = forever $ putStrLn "a978" -a979 :: IO (); a979 = forever $ putStrLn "a979" -a980 :: IO (); a980 = forever $ putStrLn "a980" -a981 :: IO (); a981 = forever $ putStrLn "a981" -a982 :: IO (); a982 = forever $ putStrLn "a982" -a983 :: IO (); a983 = forever $ putStrLn "a983" -a984 :: IO (); a984 = forever $ putStrLn "a984" -a985 :: IO (); a985 = forever $ putStrLn "a985" -a986 :: IO (); a986 = forever $ putStrLn "a986" -a987 :: IO (); a987 = forever $ putStrLn "a987" -a988 :: IO (); a988 = forever $ putStrLn "a988" -a989 :: IO (); a989 = forever $ putStrLn "a989" -a990 :: IO (); a990 = forever $ putStrLn "a990" -a991 :: IO (); a991 = forever $ putStrLn "a991" -a992 :: IO (); a992 = forever $ putStrLn "a992" -a993 :: IO (); a993 = forever $ putStrLn "a993" -a994 :: IO (); a994 = forever $ putStrLn "a994" -a995 :: IO (); a995 = forever $ putStrLn "a995" -a996 :: IO (); a996 = forever $ putStrLn "a996" -a997 :: IO (); a997 = forever $ putStrLn "a997" -a998 :: IO (); a998 = forever $ putStrLn "a998" -a999 :: IO (); a999 = forever $ putStrLn "a999" -a1000 :: IO (); a1000 = forever $ putStrLn "a1000" diff --git a/tests/examples/ghc80/T10384.hs b/tests/examples/ghc80/T10384.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10384.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE TemplateHaskell, RankNTypes, ScopedTypeVariables #-} -module A where -x = \(y :: forall a. a -> a) -> [|| y ||] diff --git a/tests/examples/ghc80/T10390.hs b/tests/examples/ghc80/T10390.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10390.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module T10390 where - -class ApPair r where - apPair :: (forall a . (ApPair a, Num a) => Maybe a) -> Maybe r - -instance (ApPair a, ApPair b) => ApPair (a,b) where - apPair = apPair' - -apPair' :: (ApPair b, ApPair c) - => (forall a . (Num a, ApPair a) => Maybe a) -> Maybe (b,c) - -- NB constraints in a different order to apPair -apPair' f = let (Just a) = apPair f - (Just b) = apPair f - in Just $ (a, b) diff --git a/tests/examples/ghc80/T10398.hs b/tests/examples/ghc80/T10398.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10398.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Foo -( - -- The reference to chunk2 should show up in the -ddump-parsed output. - -- $chunk1 - -- $chunk2 - foo, - -- $chunk3 - bar -) -where - -{- $chunk1 -This is chunk 1. --} - -{- $chunk2 -This is chunk 2. --} - -{- $chunk3 -This is chunk 3. --} - -foo = 3 -bar = 7 diff --git a/tests/examples/ghc80/T10403.hs b/tests/examples/ghc80/T10403.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10403.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -fdefer-type-errors #-} -module T10403 where - -data I a = I a -instance Functor I where - fmap f (I a) = I (f a) - -newtype B t a = B a -instance Functor (B t) where - fmap f (B a) = B (f a) - -newtype H f = H (f ()) - -h1 :: _ => _ --- h :: Functor m => (a -> b) -> m a -> H m -h1 f b = (H . fmap (const ())) (fmap f b) - -h2 :: _ --- h2 :: Functor m => (a -> b) -> m a -> H m -h2 f b = (H . fmap (const ())) (fmap f b) - -app1 :: H (B t) -app1 = h1 (H . I) (B ()) - -app2 :: H (B t) -app2 = h2 (H . I) (B ()) diff --git a/tests/examples/ghc80/T10414.hs b/tests/examples/ghc80/T10414.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10414.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples #-} -import GHC.Exts -newtype Eval a = Eval {runEval :: State# RealWorld -> (# State# RealWorld, a #)} - --- inline sequence :: [Eval a] -> Eval [a] -well_sequenced :: [Eval a] -> Eval [a] -well_sequenced = foldr cons nil where - cons e es = Eval $ \s -> case runEval e s of - (# s', a #) -> case runEval es s' of - (# s'', as #) -> (# s'', a : as #) - nil = Eval $ \s -> (# s, [] #) - --- seemingly demonic use of spark# -ill_sequenced :: [Eval a] -> Eval [a] -ill_sequenced as = Eval $ spark# (case well_sequenced as of - Eval f -> case f realWorld# of (# _, a' #) -> a') - --- 'parallelized' version of (show >=> show >=> show >=> show >=> show) -main :: IO () -main = putStrLn ((layer . layer . layer . layer . layer) (:[]) 'y') - where - layer :: (Char -> String) -> (Char -> String) - layer f = (\(Eval x) -> case x realWorld# of (# _, as #) -> concat as) - . well_sequenced -- [Eval String] -> Eval [String] - . map ill_sequenced -- [[Eval Char]] -> [Eval String]; - -- 'map well_sequenced' is fine - . map (map (\x -> Eval $ \s -> (# s, x #))) -- wrap each Char in Eval - . chunk' -- String -> [String] - . concatMap f - . show -- add single quotes - - chunk' :: String -> [String] - chunk' [] = [] - chunk' xs = as : chunk' bs where (as,bs) = splitAt 3 xs - - -- this doesn't work: - -- chunk (a:b:c:xs) = [a,b,c]:chunk xs - -- chunk xs = [xs] diff --git a/tests/examples/ghc80/T10420.hs b/tests/examples/ghc80/T10420.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10420.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Main where - -import T10420a - -import RuleDefiningPlugin - -{-# NOINLINE x #-} -x = "foo" - -main = putStrLn (show x) diff --git a/tests/examples/ghc80/T10420a.hs b/tests/examples/ghc80/T10420a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10420a.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# OPTIONS_GHC -fplugin RuleDefiningPlugin #-} -module T10420a where diff --git a/tests/examples/ghc80/T10423.hs b/tests/examples/ghc80/T10423.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10423.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeFamilies, MultiParamTypeClasses #-} - -module T10423 where - -class Monad m => Testable m a - -newtype Prop m = MkProp (m Int) - -instance (Monad m, m ~ n) => Testable n (Prop m) diff --git a/tests/examples/ghc80/T10428.hs b/tests/examples/ghc80/T10428.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10428.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T10428 where - -import Data.Coerce -coerceNewtype :: (Coercible (o r) (n m' r)) => [o r] -> [n m' r] -coerceNewtype = coerce diff --git a/tests/examples/ghc80/T10438.hs b/tests/examples/ghc80/T10438.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10438.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TypeFamilies #-} -module T10438 where - -foo f = g - where g r = x - where x :: _ - x = r diff --git a/tests/examples/ghc80/T10447.hs b/tests/examples/ghc80/T10447.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10447.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DeriveFoldable, GADTs, StandaloneDeriving #-} -module Main where - -class (a ~ Int) => Foo a -instance Foo Int - -data A a where - A1 :: Ord a => a -> A a - A2 :: Int -> A Int - A3 :: b ~ Int => b -> A Int - A4 :: a ~ Int => Int -> A a - A5 :: a ~ Int => a -> A a - A6 :: (a ~ b, b ~ Int) => Int -> b -> A a - A7 :: Foo a => Int -> a -> A a - -deriving instance Foldable A - -data HK f a where - HK1 :: f a -> HK f (f a) - HK2 :: f a -> HK f a - -deriving instance Foldable f => Foldable (HK f) - -one :: Int -one = 1 - -main :: IO () -main = do - mapM_ (print . foldr (+) one) - [ A1 one - , A2 one - , A3 one - , A4 one - , A5 one - , A6 one one - , A7 one one - ] - mapM_ (print . foldr mappend Nothing) - [ HK1 (Just "Hello") - , HK2 (Just (Just "World")) - ] diff --git a/tests/examples/ghc80/T10451.hs b/tests/examples/ghc80/T10451.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10451.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} - -module T10451 where - -type S a = ( Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a ) - -type T a = ( Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a - , Eq a, Eq a, Eq a, Eq a) - diff --git a/tests/examples/ghc80/T10460.hs b/tests/examples/ghc80/T10460.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10460.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE GHCForeignImportPrim #-} -module T10460 where -import GHC.Exts --- don't link me! -foreign import prim "f" f :: Any -> Any diff --git a/tests/examples/ghc80/T10461.hs b/tests/examples/ghc80/T10461.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10461.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE MagicHash, GHCForeignImportPrim #-} - -module T10461 where -import GHC.Exts - -foreign import prim cheneycopy :: Any -> Word# diff --git a/tests/examples/ghc80/T10463.hs b/tests/examples/ghc80/T10463.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10463.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, PartialTypeSignatures #-} - -module T10463 where - -f (x :: _) = x ++ "" diff --git a/tests/examples/ghc80/T10481.hs b/tests/examples/ghc80/T10481.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10481.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE MagicHash #-} - -import GHC.Exts -import Control.Exception - -f :: ArithException -> Int# -f x = raise# (toException x) - -main = print (I# (f Overflow)) diff --git a/tests/examples/ghc80/T10482.hs b/tests/examples/ghc80/T10482.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10482.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} -module T10482 where - -data family Foo a -data instance Foo (a, b) = FooPair !(Foo a) !(Foo b) -newtype instance Foo Int = Foo Int - -foo :: Foo ((Int, Int), Int) -> Int -> Int -foo !f k = - if k == 0 then 0 - else if even k then foo f (k-1) - else case f of - FooPair (FooPair (Foo n) _) _ -> n diff --git a/tests/examples/ghc80/T10482a.hs b/tests/examples/ghc80/T10482a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10482a.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} - -- Makes f2 a bit more challenging - --- Tests inspired by Note [CPR examples] in DmdAnal, and Trac #10482 - -module Foo where - - -h :: Int -> Int -> Bool -h 0 y = y>0 -h n y = h (n-1) y - --- The main point: all of these functions can have the CPR property - -------- f1 ----------- --- x is used strictly by h, so it'll be available --- unboxed before it is returned in the True branch - -f1 :: Int -> Int -f1 x = case h x x of - True -> x - False -> f1 (x-1) - - -------- f2 ----------- --- x is a strict field of MkT2, so we'll pass it unboxed --- to $wf2, so it's available unboxed. This depends on --- the case expression analysing (a subcomponent of) one --- of the original arguments to the function, so it's --- a bit more delicate. - -data T2 = MkT2 !Int Int - -f2 :: T2 -> Int -f2 (MkT2 x y) | y>0 = f2 (MkT2 x (y-1)) - | y>1 = 1 - | otherwise = x - - -------- f3 ----------- --- h is strict in x, so x will be unboxed before it --- is rerturned in the otherwise case. - -data T3 = MkT3 Int Int - -f3 :: T3 -> Int -f3 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) - | otherwise = x - - -------- f4 ----------- --- Just like f2, but MkT4 can't unbox its strict --- argument automatically, as f2 can - -data family Foo a -newtype instance Foo Int = Foo Int - -data T4 a = MkT4 !(Foo a) Int - -f4 :: T4 Int -> Int -f4 (MkT4 x@(Foo v) y) | y>0 = f4 (MkT4 x (y-1)) - | otherwise = v diff --git a/tests/examples/ghc80/T10487.hs b/tests/examples/ghc80/T10487.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10487.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-} - -module T10487 where - -import GHC.Generics - -import qualified T10487_M as M - -data Name = Name - -deriving instance Generic Name -deriving instance Generic M.Name diff --git a/tests/examples/ghc80/T10487_M.hs b/tests/examples/ghc80/T10487_M.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10487_M.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10487_M where - -data Name = Name diff --git a/tests/examples/ghc80/T10489.hs b/tests/examples/ghc80/T10489.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10489.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10489 where - --- Triggered an ASSERT in a debug build at some point. -convert d = let d' = case d of '0' -> '!' in d' diff --git a/tests/examples/ghc80/T10493.hs b/tests/examples/ghc80/T10493.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10493.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module T10493 where - -import Data.Coerce -import Data.Ord (Down) -- no constructor - -foo :: Coercible (Down Int) Int => Down Int -> Int -foo = coerce diff --git a/tests/examples/ghc80/T10494.hs b/tests/examples/ghc80/T10494.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10494.hs +++ /dev/null @@ -1,6 +0,0 @@ -module App where - -import Data.Coerce - -foo :: Coercible (a b) (c d) => a b -> c d -foo = coerce diff --git a/tests/examples/ghc80/T10495.hs b/tests/examples/ghc80/T10495.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10495.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T10495 where - -import Data.Coerce - -foo = coerce diff --git a/tests/examples/ghc80/T10503.hs b/tests/examples/ghc80/T10503.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10503.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE RankNTypes, PolyKinds, DataKinds, TypeFamilies #-} -module GHCBug where - -data Proxy p = Proxy - -data KProxy (a :: *) = KProxy - -h :: forall r . (Proxy ('KProxy :: KProxy k) ~ Proxy ('KProxy :: KProxy *) => r) -> r -h = undefined diff --git a/tests/examples/ghc80/T10507.hs b/tests/examples/ghc80/T10507.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10507.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module T10507 where - -import Data.Type.Equality ( (:~:)(Refl) ) -import Prelude (Maybe(..), undefined) -import GHC.TypeLits ( Nat, type (<=)) - -data V (n::Nat) - -testEq :: (m <= n) => V m -> V n -> Maybe (m :~: n) -testEq = undefined - - -uext :: (1 <= m, m <= n) => V m -> V n -> V n -uext e w = - case testEq e w of - Just Refl -> e diff --git a/tests/examples/ghc80/T10508_api.hs b/tests/examples/ghc80/T10508_api.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10508_api.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Main where - -import DynFlags -import GHC - -import Control.Monad (forM_) -import Control.Monad.IO.Class (liftIO) -import System.Environment (getArgs) - -main :: IO () -main = do - [libdir] <- getArgs - runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags $ dflags - `gopt_unset` Opt_ImplicitImportQualified - `xopt_unset` Opt_ImplicitPrelude - - forM_ exprs $ \expr -> - handleSourceError printException $ do - dyn <- dynCompileExpr expr - liftIO $ print dyn - where - exprs = - [ "" - , "(),()" - , "()" - , "\"test\"" - , unlines [ "[()]" - , " :: [()]" - ] - ] diff --git a/tests/examples/ghc80/T10516.hs b/tests/examples/ghc80/T10516.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10516.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -module T10516 where - -type App f a = f a - -newtype X f a = X (f a) - -f :: f a -> X (App f) a -f = X diff --git a/tests/examples/ghc80/T10519.hs b/tests/examples/ghc80/T10519.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10519.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE PartialTypeSignatures #-} -module T10519 where - -foo :: forall a. _ => a -> a -> Bool -foo x y = x == y diff --git a/tests/examples/ghc80/T10521.hs b/tests/examples/ghc80/T10521.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10521.hs +++ /dev/null @@ -1,11 +0,0 @@ -import Data.Word( Word8 ) - -toV :: Float -> Word8 -toV d = let coeff = significand d * 255.9999 / d - a = truncate $ d * coeff - b = exponent d - in a `seq` (b `seq` a) - -main :: IO () -main = - print $ map toV [ 3.56158e-2, 0.7415215, 0.5383201, 0.1289829, 0.45520145 ] diff --git a/tests/examples/ghc80/T10521b.hs b/tests/examples/ghc80/T10521b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10521b.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE MagicHash #-} - -import GHC.Exts - -f :: Float# -> Float# -f x = x -{-# NOINLINE f #-} - -g :: Double# -> Double# -g x = x -{-# NOINLINE g #-} - -h :: Float -> Float -h (F# x) = let a = F# (f x) - b = D# (g (2.0##)) - in a `seq` (b `seq` a) - -main = print (h 1.0) diff --git a/tests/examples/ghc80/T10524.hs b/tests/examples/ghc80/T10524.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10524.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PolyKinds #-} -module T10524 where - -import Data.Data - -newtype WrappedFunctor f a = WrapFunctor (f a) deriving (Data, Typeable) - --- WrappedFunctor :: forall k. (k -> *) -> k -> * diff --git a/tests/examples/ghc80/T10534.hs b/tests/examples/ghc80/T10534.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10534.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T10534 where - -import T10534a - -newtype instance DF a = MkDF () - -unsafeCoerce :: a -> b -unsafeCoerce = silly diff --git a/tests/examples/ghc80/T10534a.hs b/tests/examples/ghc80/T10534a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10534a.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts #-} - -module T10534a where - -import Data.Coerce - -data family DF a - -silly :: Coercible (DF a) (DF b) => a -> b -silly = coerce diff --git a/tests/examples/ghc80/T10549.hs b/tests/examples/ghc80/T10549.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10549.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS_GHC -O2 #-} - --- Verify that -O2 is rejected when this module is loaded by GHCi -module T10549 where - -import qualified Data.ByteString.Internal as Internal -import System.IO.Unsafe (unsafePerformIO) -import Data.Word (Word8) -import Foreign.Ptr (Ptr) -import Foreign.Storable (peek) - -type S = Ptr Word8 - -chr :: S -> Char -chr x = Internal.w2c $ unsafePerformIO $ peek x diff --git a/tests/examples/ghc80/T10549a.hs b/tests/examples/ghc80/T10549a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10549a.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# OPTIONS_GHC -O #-} -module Main(main) where -import GHC.Exts -main = print 1 -go (Ptr a) = a diff --git a/tests/examples/ghc80/T10561.hs b/tests/examples/ghc80/T10561.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10561.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE PolyKinds, DeriveFunctor, RankNTypes #-} - -module T10561 where - --- Ultimately this should "Just Work", --- but in GHC 7.10 it gave a Lint failure --- For now (HEAD, Jun 2015) it gives a kind error message, --- which is better than a crash - -newtype Compose f g a = Compose (f (g a)) deriving Functor - -{- -instance forall (f_ant :: k_ans -> *) - (g_anu :: * -> k_ans). - (Functor f_ant, Functor g_anu) => - Functor (Compose f_ant g_anu) where - fmap f_anv (T10561.Compose a1_anw) - = Compose (fmap (fmap f_anv) a1_anw) --} diff --git a/tests/examples/ghc80/T10562.hs b/tests/examples/ghc80/T10562.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10562.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE GADTs, TypeFamilies #-} -module T10562 where - -type family Flip a - -data QueryRep qtyp a where - QAtom :: a -> QueryRep () a - QOp :: QueryRep (Flip qtyp) a -> QueryRep qtyp a - -instance Eq (QueryRep qtyp a) where - (==) = error "urk" - -instance (Ord a) => Ord (QueryRep qtyp a) where - compare (QOp a) (QOp b) = a `compare` b diff --git a/tests/examples/ghc80/T10564.hs b/tests/examples/ghc80/T10564.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10564.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances, - DataKinds, TypeFamilies, KindSignatures, PolyKinds, FunctionalDependencies #-} - -module T10564 where - -class HasFieldM (l :: k) r (v :: Maybe *) - | l r -> v - -class HasFieldM1 (b :: Maybe [*]) (l :: k) r v - | b l r -> v - -class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) - | e1 l -> r - -data Label a -type family LabelsOf (a :: [*]) :: [*] - -instance (HMemberM (Label (l::k)) (LabelsOf xs) b, - HasFieldM1 b l (r xs) v) - => HasFieldM l (r xs) v where diff --git a/tests/examples/ghc80/T10570.hs b/tests/examples/ghc80/T10570.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10570.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE FunctionalDependencies, PolyKinds, FlexibleInstances #-} - -module T10570 where - -import Data.Proxy - -class ConsByIdx2 x a m cls | x -> m where - consByIdx2 :: x -> a -> m cls - -instance ConsByIdx2 Int a Proxy cls where - consByIdx2 _ _ = Proxy diff --git a/tests/examples/ghc80/T10590.hs b/tests/examples/ghc80/T10590.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10590.hs +++ /dev/null @@ -1,37 +0,0 @@ -import Foreign.C -import Foreign.Marshal.Array -import Foreign.Storable -import Control.Concurrent - --- The test works only on UNIX like. --- unportable bits: -import qualified System.Posix.Internals as SPI -import qualified System.Posix.Types as SPT - -pipe :: IO (CInt, CInt) -pipe = allocaArray 2 $ \fds -> do - throwErrnoIfMinus1_ "pipe" $ SPI.c_pipe fds - rd <- peekElemOff fds 0 - wr <- peekElemOff fds 1 - return (rd, wr) - -main :: IO () -main = do - (r1, w1) <- pipe - (r2, _w2) <- pipe - _ <- forkIO $ do -- thread A - threadWaitRead (SPT.Fd r1) - _ <- forkIO $ do -- thread B - threadWaitRead (SPT.Fd r2) - yield -- switch to A, then B - -- now both are blocked - _ <- SPI.c_close w1 -- unblocking thread A fd - _ <- SPI.c_close r2 -- breaking thread B fd - yield -- kick RTS IO manager - -{- - Trac #10590 exposed a bug as: - T10590: internal error: removeThreadFromDeQueue: not found - (GHC version 7.11.20150702 for x86_64_unknown_linux) - Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug - -} diff --git a/tests/examples/ghc80/T10596.hs b/tests/examples/ghc80/T10596.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10596.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module T10596 where -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import System.IO - -do - putQ (100 :: Int) - x <- (getQ :: Q (Maybe Int)) - - -- It should print "Just 100" - runIO $ print x - runIO $ hFlush stdout - return [] diff --git a/tests/examples/ghc80/T10602.hs b/tests/examples/ghc80/T10602.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10602.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# OPTIONS_GHC -O2 #-} -{-# OPTIONS_GHC -fno-warn-missing-methods #-} -{-# LANGUAGE NoImplicitPrelude #-} --- {-# OPTIONS_GHC -fno-spec-constr #-} -- Makes the problem go away. --- {-# OPTIONS_GHC -fspec-constr-count=1 #-} -- Makes the problem go away. - -module T10602 where - --- Copy-pasting T10602b.hs into the current module makes the problem go away. -import T10602b - -data PairS a = PairS a a - --- Removing the '~' makes the problem go away. -(PairS _ _) >> ~(PairS b g) = PairS b g - -class Binary t where - put :: t -> PairS () - --- Not using a newtype makes the problem go away. -newtype A a = A [a] - -instance Binary a => Binary (A a) where - put (A xs) = case splitAt 254 xs of - (_, []) -> foldr (>>) (PairS () ()) (map put xs) - (_, b) -> put (A b) diff --git a/tests/examples/ghc80/T10602b.hs b/tests/examples/ghc80/T10602b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10602b.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -O2 #-} -{-# LANGUAGE NoImplicitPrelude #-} -module T10602b (splitAt, map, foldr) where - -import GHC.Classes -import GHC.Types -import GHC.Num -import GHC.Base - -splitAt :: Int -> [a] -> ([a],[a]) -splitAt n ls - | n <= 0 = ([], ls) - | otherwise = splitAt' n ls - where - splitAt' :: Int -> [a] -> ([a], [a]) - splitAt' _ [] = ([], []) - splitAt' 1 (x:xs) = ([x], xs) - splitAt' m (x:xs) = (x:xs', xs'') - where - (xs', xs'') = splitAt' (m - 1) xs diff --git a/tests/examples/ghc80/T10615.hs b/tests/examples/ghc80/T10615.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10615.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module T10615 where - -f1 :: _ -> f -f1 = const - -f2 :: _ -> _f -f2 = const diff --git a/tests/examples/ghc80/T10618.hs b/tests/examples/ghc80/T10618.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10618.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10618 where - -foo = Just $ Nothing <> Nothing diff --git a/tests/examples/ghc80/T10620.hs b/tests/examples/ghc80/T10620.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10620.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE MagicHash, TemplateHaskell #-} -module Main where - -import Language.Haskell.TH - -main :: IO () -main = do - putStrLn $([| 'a'# |] >>= stringE . show) - putStrLn $([| "abc"# |] >>= stringE . show) diff --git a/tests/examples/ghc80/T10627.hs b/tests/examples/ghc80/T10627.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10627.hs +++ /dev/null @@ -1,17 +0,0 @@ --- Made GHC 6.10.2 go into a loop in substRecBndrs -{-# OPTIONS_GHC -w #-} - -module T10627 where - -import Data.Word - -class C a where - splitFraction :: a -> (b,a) - -roundSimple :: (C a) => a -> b -roundSimple x = error "rik" - -{-# RULES - "rs" roundSimple = (fromIntegral :: Int -> Word) . roundSimple; - #-} - diff --git a/tests/examples/ghc80/T10632.hs b/tests/examples/ghc80/T10632.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10632.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} - -f :: (?file1 :: String) => IO () -f = putStrLn $ "f2: " - -main :: IO () -main = let ?file1 = "A" in f diff --git a/tests/examples/ghc80/T10634.hs b/tests/examples/ghc80/T10634.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10634.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T10634 where - -import Data.Int (Int8, Int16, Int32) - -type family Up a -type instance Up Int8 = Int16 -type instance Up Int16 = Int32 - -class (Up (Down a) ~ a) => Convert a where - type Down a - down :: a -> Down a - -instance Convert Int16 where - type Down Int16 = Int8 - down = fromIntegral - -instance Convert Int32 where - type Down Int32 = Int16 - down = fromIntegral - -x :: Int8 -x = down 8 diff --git a/tests/examples/ghc80/T10637.hs b/tests/examples/ghc80/T10637.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10637.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10637 where - -import {-# SOURCE #-} A () -data B = B diff --git a/tests/examples/ghc80/T10638.hs b/tests/examples/ghc80/T10638.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10638.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-} - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -import GHC.Exts - -{- - the prim and javascript calling conventions do not support - headers and the static keyword. --} - --- check that quasiquoting roundtrips succesfully and that the declaration --- does not include the static keyword -test1 :: String -test1 = $(do (ds@[ForeignD (ImportF _ _ p _ _)]) <- - [d| foreign import prim "test1" cmm_test1 :: Int# -> Int# |] - addTopDecls ds - case p of - "test1" -> return (LitE . stringL $ p) - _ -> error $ "unexpected value: " ++ show p - ) - --- check that constructed prim imports with the static keyword are rejected -test2 :: String -test2 = $(do t <- [t| Int# -> Int# |] - cmm_test2 <- newName "cmm_test2" - addTopDecls - [ForeignD (ImportF Prim Safe "static test2" cmm_test2 t)] - [| test1 |] - ) diff --git a/tests/examples/ghc80/T10642.hs b/tests/examples/ghc80/T10642.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10642.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T10642 where - -import Data.Coerce - -type family F a - -newtype D a = D (F a) - --- | This works on 7.10.1, but fails on HEAD (20150711) -coerceD :: F a -> D a -coerceD = coerce diff --git a/tests/examples/ghc80/T10662.hs b/tests/examples/ghc80/T10662.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10662.hs +++ /dev/null @@ -1,4 +0,0 @@ -main :: IO () -main = do - return $ let a = "hello" in a - return () diff --git a/tests/examples/ghc80/T10667.hs b/tests/examples/ghc80/T10667.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10667.hs +++ /dev/null @@ -1,6 +0,0 @@ -module A where - --- when used with '-g' debug generation option --- '*/*' leaked into a /* comment */ and broke --- GNU as. -x */* y = 42 diff --git a/tests/examples/ghc80/T10668.hs b/tests/examples/ghc80/T10668.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10668.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T10668 where - -import Data.Type.Equality(Refl) diff --git a/tests/examples/ghc80/T10670.hs b/tests/examples/ghc80/T10670.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10670.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, RankNTypes, GADTs, PolyKinds #-} - -module T10670 where - -import Unsafe.Coerce - -data TypeRepT (a::k) where - TRCon :: TypeRepT a - -data G2 c a where - G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b) - -getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a) -{-# NOINLINE getT2 #-} -getT2 c t = Nothing - -tyRepTArr :: TypeRepT (->) -{-# NOINLINE tyRepTArr #-} -tyRepTArr = TRCon - -s :: forall a x. TypeRepT (a :: *) -> Maybe x -s tf = case getT2 tyRepTArr tf :: Maybe (G2 (->) a) of - Just (G2 _ _) -> Nothing - _ -> Nothing diff --git a/tests/examples/ghc80/T10670a.hs b/tests/examples/ghc80/T10670a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10670a.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE GADTs , PolyKinds #-} - -module Bug2 where - -import Unsafe.Coerce - -data TyConT (a::k) = TyConT String - -eqTyConT :: TyConT a -> TyConT b -> Bool -eqTyConT (TyConT a) (TyConT b) = a == b - - - -tyConTArr :: TyConT (->) -tyConTArr = TyConT "(->)" - - -data TypeRepT (a::k) where - TRCon :: TyConT a -> TypeRepT a - TRApp :: TypeRepT a -> TypeRepT b -> TypeRepT (a b) - - -data GetAppT a where - GA :: TypeRepT a -> TypeRepT b -> GetAppT (a b) - -getAppT :: TypeRepT a -> Maybe (GetAppT a) -getAppT (TRApp a b) = Just $ GA a b -getAppT _ = Nothing - - - -eqTT :: TypeRepT (a::k1) -> TypeRepT (b::k2) -> Bool -eqTT (TRCon a) (TRCon b) = eqTyConT a b -eqTT (TRApp c a) (TRApp d b) = eqTT c d && eqTT a b -eqTT _ _ = False - - -data G2 c a where - G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b) - - -getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a) -getT2 c t = do GA t' b <- getAppT t - GA c' a <- getAppT t' - if eqTT c c' - then Just (unsafeCoerce $ G2 a b :: G2 c a) - else Nothing - -tyRepTArr :: TypeRepT (->) -tyRepTArr = TRCon tyConTArr - -s tf = case getT2 tyRepTArr tf - of Just (G2 _ _) -> Nothing - _ -> Nothing diff --git a/tests/examples/ghc80/T10678.hs b/tests/examples/ghc80/T10678.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10678.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE MagicHash #-} - -import GHC.Prim - -main :: IO () -main = go 1000000# 10 (2^100) - -go :: Int# -> Integer -> Integer -> IO () -go 0# _ _ = return () -go n# a b = (a + b) `seq` go (n# -# 1#) a b -{-# NOINLINE go #-} - -{- -This test is based on a strategy from rwbarton relying on the inefficiency -of `Integer` addition as defined by `integer-gmp` without `runRW#`. - - When I was testing the patch interactively, I measured allocations for, - say, a million (large Integer) + (small Integer) additions. If that - addition allocates, say, 6 words, then one can fairly reliably write the - program so that it will allocate between 6 million and 7 million words, - total. --} diff --git a/tests/examples/ghc80/T10689.hs b/tests/examples/ghc80/T10689.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10689.hs +++ /dev/null @@ -1,11 +0,0 @@ -module T10694 where - -f :: Eq a => a -> Bool -{-# NOINLINE f #-} -f x = x==x - -type Foo a b = b - -{-# RULES "foo" forall (x :: Foo a Char). f x = True #-} - -finkle = f 'c' diff --git a/tests/examples/ghc80/T10694.hs b/tests/examples/ghc80/T10694.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10694.hs +++ /dev/null @@ -1,16 +0,0 @@ -module T10694 where - --- The point here is that 'm' should NOT have the CPR property --- Checked by grepping in the -ddump-simpl - - --- Some nonsense so that the simplifier can't see through --- to the I# constructor -pm :: Int -> Int -> (Int, Int) -pm x y = (l !! 0, l !! 1) - where l = [x+y, x-y] -{-# NOINLINE pm #-} - -m :: Int -> Int -> Int -m x y = case pm x y of - (pr, mr) -> mr diff --git a/tests/examples/ghc80/T10698.hs b/tests/examples/ghc80/T10698.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10698.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} - -module T10698 where -import Data.Coerce - -data Map k a = Map k a -type role Map nominal representational - -map1 :: (k1->k2) -> Map k1 a -> Map k2 a -map1 f (Map a b) = Map (f a) b -{-# NOINLINE [1] map1 #-} -{-# RULES -"map1/coerce" map1 coerce = coerce - #-} - - -map2 :: (a -> b) -> Map k a -> Map k b -map2 f (Map a b) = Map a (f b) -{-# NOINLINE [1] map2 #-} - -{-# RULES -"map2/coerce" map2 coerce = coerce - #-} diff --git a/tests/examples/ghc80/T10704.hs b/tests/examples/ghc80/T10704.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10704.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE MagicHash, TemplateHaskell #-} -module Main where - -import GHC.Exts -import T10704a - -main :: IO () -main = do - putStrLn $(fixityExp ''(->)) - putStrLn $(fixityExp ''Show) - putStrLn $(fixityExp 'show) - putStrLn $(fixityExp '(+)) - putStrLn $(fixityExp ''Int) - putStrLn $(fixityExp ''Item) - putStrLn $(fixityExp ''Char#) - putStrLn $(fixityExp 'Just) - putStrLn $(fixityExp 'seq) - putStrLn $(fixityExp '($)) - putStrLn $(fixityExp ''(:=>)) - putStrLn $(fixityExp ''(:+:)) - putStrLn $(fixityExp ''(:*:)) - putStrLn $(fixityExp ''(:%:)) - putStrLn $(fixityExp ''(:?:)) - putStrLn $(fixityExp ''(:@:)) diff --git a/tests/examples/ghc80/T10704a.hs b/tests/examples/ghc80/T10704a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10704a.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, TypeOperators #-} -module T10704a where - -import Language.Haskell.TH - -infixl 1 :=> -infixl 2 :+: -infix 3 :*: -infix 4 :%: -infixr 5 :?: -infixr 6 :@: - -class a :=> b -type a :+: b = Either a b -data a :*: b = a :*: b -newtype a :%: b = Percent (a, b) -data family a :?: b -type family a :@: b where a :@: b = Int - -fixityExp :: Name -> Q Exp -fixityExp n = reifyFixity n >>= stringE . show diff --git a/tests/examples/ghc80/T10713.hs b/tests/examples/ghc80/T10713.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10713.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeFamilies, PolyKinds, DataKinds #-} - -module T10713 where - -import Data.Proxy - -type family TEq t s where - TEq t t = 'True - TEq t s = 'False -data family T a - -foo :: Proxy (TEq (T Int) (T Bool)) -> Proxy 'False -foo = id diff --git a/tests/examples/ghc80/T10734.hs b/tests/examples/ghc80/T10734.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10734.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Language.Haskell.TH - -main :: IO () -main = do - pprint <$> runQ [| do { let { }; return (); } |] >>= putStrLn - pprint <$> runQ [| do { let { x = 5 }; return x; } |] >>= putStrLn - pprint <$> runQ [| do { let { x = 5; y = 3 }; return x; } |] >>= putStrLn diff --git a/tests/examples/ghc80/T10742.hs b/tests/examples/ghc80/T10742.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10742.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module T10742 where - -import GHC.TypeLits - -data T a where MkT :: T Int - -test :: ((x <=? y) ~ 'True, (y <=? z) ~ 'True) - => proxy x y z -> () -test _ = case MkT of MkT -> () diff --git a/tests/examples/ghc80/T10744.hs b/tests/examples/ghc80/T10744.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10744.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module T10744 where - -import GHC.Exts -import GHC.Magic - --- Checks if oneShot is open-kinded - -f0 :: Int -> Int -f0 = oneShot $ \n -> n - -f1 :: Int# -> Int -f1 = oneShot $ \n# -> I# n# - -f2 :: Int -> Int# -f2 = oneShot $ \(I# n#) -> n# - diff --git a/tests/examples/ghc80/T10747.hs b/tests/examples/ghc80/T10747.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10747.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module T10747 where - -pattern head `Cons` tail = head : tail diff --git a/tests/examples/ghc80/T10753.hs b/tests/examples/ghc80/T10753.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10753.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-missing-methods #-} -module T10753 where - - -class MonadState s m | m -> s where - get :: m s - -newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } -instance (Monad m) => Monad (StateT s m) where -instance (Functor m, Monad m) => Applicative (StateT s m) where -instance (Functor m) => Functor (StateT s m) where - -instance (Monad m) => MonadState s (StateT s m) where - -class HasConns (m :: * -> *) where - type Conn m - -foo :: (Monad m) => StateT (Conn m) m () -foo = - do _ <- get - return () diff --git a/tests/examples/ghc80/T10767.hs b/tests/examples/ghc80/T10767.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10767.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} - -module Main where - -{- ghc-7.8.4 and ghc-7.10.2 showed a confusing warning: - -T10767.hs:43:1: Warning: - RULE left-hand side too complicated to desugar - Optimised lhs: case cobox_aWY - of _ [Occ=Dead] { GHC.Types.Eq# cobox -> - genLength @ Int $dSpecList_aWX - } - Orig lhs: case cobox_aWY of cobox_aWY { GHC.Types.Eq# cobox -> - genLength @ Int $dSpecList_aWX - } --} - -import Data.Proxy - -class SpecList a where - type List a :: * - - slCase :: List a -> b -> (a -> List a -> b) -> b - -data IntList - = ILNil - | ILCons {-# UNPACK #-} !Int IntList - deriving (Show) - -instance SpecList Int where - type List Int = IntList - - slCase ILNil n _ = n - slCase (ILCons i t) _ c = c i t - -fromList :: [Int] -> IntList -fromList [] = ILNil -fromList (h : t) = ILCons h (fromList t) - -lst1 :: IntList -lst1 = fromList [1..10] - -{-# SPECIALIZE genLength :: Proxy Int -> List Int -> Int #-} -genLength :: forall a . SpecList a => Proxy a -> List a -> Int -genLength p lst = slCase lst 0 (\(_ :: a) tail -> 1 + genLength p tail) - -main :: IO () -main = print (genLength (Proxy :: Proxy Int) lst1) diff --git a/tests/examples/ghc80/T10781.hs b/tests/examples/ghc80/T10781.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10781.hs +++ /dev/null @@ -1,12 +0,0 @@ -module T10781 where -{- ghc-7.10.2 reported: - -T10781.hs:6:5: - Found hole ‘_name’ with type: t - Where: ‘t’ is a rigid type variable bound by - the inferred type of f :: t at T10781.hs:6:1 - Relevant bindings include f :: t (bound at T10781.hs:6:1) - In the expression: Foo._name - In an equation for ‘f’: f = Foo._name --} -f = Foo._name diff --git a/tests/examples/ghc80/T10796a.hs b/tests/examples/ghc80/T10796a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10796a.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module T10796a where - -import Data.Ratio -import Data.Set (Set, fromList) -import Language.Haskell.TH.Syntax (liftData) - --- Data instance with toConstr implemented using a variable, --- not a data constructor -splicedSet :: Set Char -splicedSet = $(liftData (fromList "test")) - --- Infix data constructor -splicedRatio :: Ratio Int -splicedRatio = $(liftData (1 % 2 :: Ratio Int)) diff --git a/tests/examples/ghc80/T10796b.hs b/tests/examples/ghc80/T10796b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10796b.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module T10796b where - -import Data.Set (Set, fromList) -import Language.Haskell.TH.Quote (dataToPatQ) - -badPattern :: Set Char -> Set Char -badPattern s@($(dataToPatQ (const Nothing) (fromList "test"))) = s diff --git a/tests/examples/ghc80/T10806.hs b/tests/examples/ghc80/T10806.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10806.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE GADTs, ExplicitNamespaces, TypeOperators, DataKinds #-} - -module T10806 where - -import GHC.TypeLits (Nat, type (<=)) - -data Q a where - Q :: (a <= b, b <= c) => proxy a -> proxy b -> Q c - -triggersLoop :: Q b -> Q b -> Bool -triggersLoop (Q _ _) (Q _ _) = print 'x' 'y' diff --git a/tests/examples/ghc80/T10815.hs b/tests/examples/ghc80/T10815.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10815.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies #-} - -module T10815 where - -import Data.Proxy - -type family Any :: k - -class kproxy ~ 'KProxy => C (kproxy :: KProxy k) where - type F (a :: k) - type G a :: k - -instance C ('KProxy :: KProxy Bool) where - type F a = Int - type G a = Any diff --git a/tests/examples/ghc80/T10819.hs b/tests/examples/ghc80/T10819.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10819.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module T10819 where - -import T10819_Lib - -import Language.Haskell.TH.Syntax - -class C a b | b -> a where - f :: b -> a - -data D = X - -instance C Int D where - f X = 2 - -$(doSomeTH "N" (mkName "D") [ConT (mkName "C") `AppT` ConT (mkName "Int")]) - -thing :: N -thing = N X - -thing1 :: Int -thing1 = f thing diff --git a/tests/examples/ghc80/T10819_Lib.hs b/tests/examples/ghc80/T10819_Lib.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10819_Lib.hs +++ /dev/null @@ -1,7 +0,0 @@ -module T10819_Lib where - -import Language.Haskell.TH.Syntax - -doSomeTH s tp drv = return [NewtypeD [] n [] Nothing (NormalC n - [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) drv] - where n = mkName s diff --git a/tests/examples/ghc80/T10820.hs b/tests/examples/ghc80/T10820.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10820.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE LiberalTypeSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MagicHash #-} - -module Main where - -import Language.Haskell.TH.Syntax -import GHC.LanguageExtensions - -main = do - print $(isExtEnabled Cpp >>= lift) - print $(isExtEnabled LiberalTypeSynonyms >>= lift) - print $(isExtEnabled RankNTypes >>= lift) - print $(isExtEnabled TypeSynonymInstances >>= lift) - print $(isExtEnabled MagicHash >>= lift) diff --git a/tests/examples/ghc80/T10826.hs b/tests/examples/ghc80/T10826.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10826.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE Safe #-} -module Test (hook) where - -import System.IO.Unsafe - -{-# ANN hook (unsafePerformIO (putStrLn "Woops.")) #-} -hook = undefined diff --git a/tests/examples/ghc80/T10830.hs b/tests/examples/ghc80/T10830.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10830.hs +++ /dev/null @@ -1,3 +0,0 @@ -import GHC.OldList -main :: IO () -main = maximumBy compare [1..10000] `seq` return () diff --git a/tests/examples/ghc80/T10836.hs b/tests/examples/ghc80/T10836.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10836.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T10836 where - -type family Foo a = r | r -> a where - Foo Int = Int - Foo Bool = Int - -type family Bar a = r | r -> a where - Bar Int = Int - Bar Bool = Int diff --git a/tests/examples/ghc80/T10845.hs b/tests/examples/ghc80/T10845.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10845.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -{-# OPTIONS_GHC -dcore-lint #-} - -import GHC.Stack - -f1 :: (?loc :: CallStack) => CallStack --- we can infer a CallStack for let-binders -f1 = let y x = (?loc :: CallStack) - in y 0 - -f2 :: (?loc :: CallStack) => CallStack --- but only when we would infer an IP. --- i.e. the monomorphism restriction prevents us --- from inferring a CallStack. -f2 = let y = (?loc :: CallStack) - in y - -main :: IO () -main = do putStrLn $ prettyCallStack f1 - putStrLn $ prettyCallStack f2 diff --git a/tests/examples/ghc80/T10846.hs b/tests/examples/ghc80/T10846.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10846.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-} - -module Main where - -import GHC.Stack - -f1 :: (?loc :: CallStack) => String -f1 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc - -f2 :: (?loc :: CallStack) => _ -f2 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc - -f3 :: (?loc :: CallStack, _) => String -f3 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc - -main :: IO () -main = do - putStrLn f1 - putStrLn f2 - putStrLn f3 diff --git a/tests/examples/ghc80/T10870.hs b/tests/examples/ghc80/T10870.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10870.hs +++ /dev/null @@ -1,12 +0,0 @@ -import Data.Bits -import Data.Int -import Data.Word - -unsafeShift32R :: (Bits a, Num a) => a -> a -unsafeShift32R x = unsafeShiftR x 32 - -main :: IO () -main = do - print $ map unsafeShift32R [ 123456, 0x7fffffff :: Int ] - print $ map unsafeShift32R [ -123456, -0x80000000 :: Int ] - print $ map unsafeShift32R [ 123456, 0xffffffff :: Word ] diff --git a/tests/examples/ghc80/T10890.hs b/tests/examples/ghc80/T10890.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10890.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Main where - --- Previously GHC was printing this warning: --- --- Main.hs:5:1: Warning: --- The import of ‘A.has’ from module ‘A’ is redundant --- --- Main.hs:6:1: Warning: --- The import of ‘B.has’ from module ‘B’ is redundant - -import A (A (has)) -import B (B (has)) - -data Blah = Blah - -instance A Blah where - has = Blah - -instance B Blah where - has = Blah - -main :: IO () -main = return () diff --git a/tests/examples/ghc80/T10890_1.hs b/tests/examples/ghc80/T10890_1.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10890_1.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Main where - -import Base -import Extends - --- Previously GHC was giving this false positive: --- --- T10890_1.hs:4:1: Warning: --- The import of ‘Extends’ is redundant --- except perhaps to import instances from ‘Extends’ --- To import instances alone, use: import Extends() - -data Bar = Bar - -instance AClass Bar where - has = Bar - -instance BClass Bar where - has = Bar - -main :: IO () -main = return () diff --git a/tests/examples/ghc80/T10890_2.hs b/tests/examples/ghc80/T10890_2.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10890_2.hs +++ /dev/null @@ -1,17 +0,0 @@ -module T10890_2 where - --- Previously GHC was printing this warning: --- --- Main.hs:5:1: Warning: --- The import of ‘A.has’ from module ‘A’ is redundant --- --- Main.hs:6:1: Warning: --- The import of ‘B.has’ from module ‘B’ is redundant - -import T10890_2A (A (has)) -import T10890_2B (B (has)) - -data Blah = Blah - -instance A Blah where - has = Blah diff --git a/tests/examples/ghc80/T10890_2A.hs b/tests/examples/ghc80/T10890_2A.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10890_2A.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10890_2A where - -class A a where - has :: a diff --git a/tests/examples/ghc80/T10890_2B.hs b/tests/examples/ghc80/T10890_2B.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10890_2B.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T10890_2B where - -class B a where - has :: a diff --git a/tests/examples/ghc80/T10891.hs b/tests/examples/ghc80/T10891.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10891.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} - -module T10891 where - -import Language.Haskell.TH -import System.IO - -class C a where - f :: a -> Int - -class C' a where - type F a :: * - type F a = a - f' :: a -> Int - -class C'' a where - data Fd a :: * - -instance C' Int where - type F Int = Bool - f' = id - -instance C'' Int where - data Fd Int = B Bool | C Char - -$(return []) - -test :: () -test = - $(let - display :: Name -> Q () - display q = do - i <- reify q - runIO (hPutStrLn stderr (pprint i) >> hFlush stderr) - in do - display ''C - display ''C' - display ''C'' - [| () |]) diff --git a/tests/examples/ghc80/T10895.hs b/tests/examples/ghc80/T10895.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10895.hs +++ /dev/null @@ -1,1 +0,0 @@ -module NotMain where diff --git a/tests/examples/ghc80/T10897a.hs b/tests/examples/ghc80/T10897a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10897a.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module T10897a where -pattern Single :: a -> a -pattern Single x = x diff --git a/tests/examples/ghc80/T10897b.hs b/tests/examples/ghc80/T10897b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10897b.hs +++ /dev/null @@ -1,4 +0,0 @@ -module B where -import T10897a - -Single y = True diff --git a/tests/examples/ghc80/T10904.hs b/tests/examples/ghc80/T10904.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10904.hs +++ /dev/null @@ -1,28 +0,0 @@ -import Control.Concurrent -import Control.Monad -import Foreign -import Foreign.C.Types -import System.Environment - - -foreign import ccall safe "finalizerlib.h init_value" - init_value :: Ptr CInt -> IO () - -foreign import ccall safe "finalizerlib.h &finalize_value" - finalize_value :: FinalizerPtr CInt - - -allocateValue :: IO () -allocateValue = do - fp <- mallocForeignPtrBytes 10000 - withForeignPtr fp init_value - addForeignPtrFinalizer finalize_value fp - - -main :: IO () -main = do - [n] <- fmap (fmap read) getArgs - _ <- forkIO (loop n) - loop n - where - loop n = replicateM_ n allocateValue diff --git a/tests/examples/ghc80/T10908.hs b/tests/examples/ghc80/T10908.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10908.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -fwarn-missing-exported-sigs #-} - -module Bug (Data.List.intercalate, x) where - -import qualified Data.List - -intercalate = True - -x :: Bool -x = intercalate diff --git a/tests/examples/ghc80/T10929.hs b/tests/examples/ghc80/T10929.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10929.hs +++ /dev/null @@ -1,31 +0,0 @@ -module T10929 where - -x1 :: [Integer] -x1 = [5 .. 3] - -x2 :: [Integer] -x2 = [3 .. 5] - -x3 :: [Integer] -x3 = [5, 3 .. 1] - -x4 :: [Integer] -x4 = [5, (3+0) .. 1] - -x5 :: [Integer] -x5 = [1, 3 .. 5] - -x6 :: [Integer] -x6 = [1, (3+0) .. 5] - -x7 :: [Integer] -x7 = [5, 7 .. 1] - -x8 :: [Integer] -x8 = [5, (7+0) .. 1] - -x9 :: [Integer] -x9 = [3, 1 .. 5] - -x10 :: [Integer] -x10 = [3, (1+0) .. 5] diff --git a/tests/examples/ghc80/T10931.hs b/tests/examples/ghc80/T10931.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10931.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} - -{-# OPTIONS_GHC -Wall #-} - -module T10931 ( BugC(..) ) where - -data IdT f a = IdC (f a) - -class ( m ~ Outer m (Inner m) ) => BugC (m :: * -> *) where - type Inner m :: * -> * - type Outer m :: (* -> *) -> * -> * - - bug :: ( forall n. ( n ~ Outer n (Inner n) - , Outer n ~ Outer m - ) - => Inner n a) - -> m a - -instance BugC (IdT m) where - type Inner (IdT m) = m - type Outer (IdT m) = IdT - - bug f = IdC f diff --git a/tests/examples/ghc80/T10935.hs b/tests/examples/ghc80/T10935.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10935.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# OPTIONS_GHC -fwarn-monomorphism-restriction #-} - -module T10935 where - -f x = let y = x+1 in (y,y) diff --git a/tests/examples/ghc80/T10942.hs b/tests/examples/ghc80/T10942.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10942.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Main where - -import DynFlags -import GHC - -import Control.Monad.IO.Class (liftIO) -import System.Environment -import HeaderInfo -import Outputable -import StringBuffer - -main :: IO () -main = do - [libdir] <- getArgs - runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - let dflags' = dflags `gopt_set` Opt_KeepRawTokenStream - `gopt_set` Opt_Haddock - filename = "T10942_A.hs" - setSessionDynFlags dflags' - stringBuffer <- liftIO $ hGetStringBuffer filename - liftIO $ print (map unLoc (getOptions dflags' stringBuffer filename)) diff --git a/tests/examples/ghc80/T10942_A.hs b/tests/examples/ghc80/T10942_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10942_A.hs +++ /dev/null @@ -1,16 +0,0 @@ -{- - -A normal comment, to check if we can still pick up the CPP directive after it. - --} --- Check that we can parse a file with leading comments - --- ^ haddock --- * haddock --- | haddock --- $ haddock -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} -module T10942 where - -main = return () diff --git a/tests/examples/ghc80/T10945.hs b/tests/examples/ghc80/T10945.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10945.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module T10945 where - -import Language.Haskell.TH - -$$(return [ - SigD (mkName "m") - (ForallT [PlainTV (mkName "a")] - [] - (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) - , FunD (mkName "m") - [Clause [VarP (mkName "x")] (NormalB (VarE (mkName "x"))) []] - ]) diff --git a/tests/examples/ghc80/T10946.hs b/tests/examples/ghc80/T10946.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10946.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module T10946 where - -import Language.Haskell.TH - -m :: a -> a -m x = $$([||_||]) diff --git a/tests/examples/ghc80/T10955dyn.hs b/tests/examples/ghc80/T10955dyn.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10955dyn.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Foreign -import Foreign.C.Types -foreign import ccall "bar" dle :: IO CInt - -main = dle >>= print diff --git a/tests/examples/ghc80/T10962.hs b/tests/examples/ghc80/T10962.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10962.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} - -module Main where - -import GHC.Base - -main :: IO () -main = do - -- Overflow. - let (# w1, i1 #) = subWordC# 1## 3## - print (W# w1, I# i1) - - -- No overflow. - let (# w2, i2 #) = subWordC# 3## 1## - print (W# w2, I# i2) diff --git a/tests/examples/ghc80/T10971a.hs b/tests/examples/ghc80/T10971a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10971a.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-} -module T10971a where - -import Data.Traversable (fmapDefault) - -f = \x -> length x -g = \f x -> fmapDefault f x -h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/ghc80/T10971b.hs b/tests/examples/ghc80/T10971b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10971b.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE MonomorphismRestriction, NoExtendedDefaultRules #-} -module T10971b where -import Data.Traversable (fmapDefault) -f = \x -> length x -g = \f x -> fmapDefault f x -h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/ghc80/T10971c.hs b/tests/examples/ghc80/T10971c.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10971c.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-} -module T10971c where - -import Data.Traversable (fmapDefault) - -f = \x -> length x -g = \f x -> fmapDefault f x -h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/ghc80/T10971d.hs b/tests/examples/ghc80/T10971d.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10971d.hs +++ /dev/null @@ -1,6 +0,0 @@ -import T10971c - -main = do - print $ f (Just 1) - print $ g (+1) (Just 5) - print $ h (const 5) Nothing diff --git a/tests/examples/ghc80/T10997.hs b/tests/examples/ghc80/T10997.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10997.hs +++ /dev/null @@ -1,6 +0,0 @@ -module T10997 where - -import T10997a - -foo :: Exp a -> String -foo Tru = "True" diff --git a/tests/examples/ghc80/T10997_1.hs b/tests/examples/ghc80/T10997_1.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10997_1.hs +++ /dev/null @@ -1,15 +0,0 @@ -module T10997_1 where - -import T10997_1a - -{- With ghc-7.10.2: - - The interface for ‘T10997a’ - Declaration for Just' - Pattern synonym Just': - Iface type variable out of scope: k - Cannot continue after interface file error --} - -bar :: (Showable a) => Maybe a -> Maybe a -bar (Just' a) = Just' a diff --git a/tests/examples/ghc80/T10997_1a.hs b/tests/examples/ghc80/T10997_1a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10997_1a.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns, ConstraintKinds, TypeFamilies, PolyKinds, KindSignatures #-} -module T10997_1a where - -import GHC.Exts - -type family Showable (a :: k) :: Constraint where - Showable (a :: *) = (Show a) - Showable a = () - -extractJust :: Maybe a -> (Bool, a) -extractJust (Just a) = (True, a) -extractJust _ = (False, undefined) - -pattern Just' :: Showable a => a -> (Maybe a) -pattern Just' a <- (extractJust -> (True, a)) where - Just' a = Just a - diff --git a/tests/examples/ghc80/T10997a.hs b/tests/examples/ghc80/T10997a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10997a.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE GADTs, PatternSynonyms #-} - -module T10997a where - -data Exp ty where - LitB :: Bool -> Exp Bool - -pattern Tru :: () => b ~ Bool => Exp b -pattern Tru = LitB True - - diff --git a/tests/examples/ghc80/T10999.hs b/tests/examples/ghc80/T10999.hs deleted file mode 100644 --- a/tests/examples/ghc80/T10999.hs +++ /dev/null @@ -1,8 +0,0 @@ -module T10999 where - -import qualified Data.Set as Set - -f :: _ => () -> _ -f _ = Set.fromList undefined - -g = map fst $ Set.toList $ f () diff --git a/tests/examples/ghc80/T11010.hs b/tests/examples/ghc80/T11010.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11010.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ExistentialQuantification, GADTSyntax #-} -{-# LANGUAGE TypeFamilies #-} - -module T11010 where - -data Expr a where - Fun :: String -> (a -> b) -> (Expr a -> Expr b) - -ggFun :: String -> (a -> b) -> (Expr a -> Expr b) -ggFun = undefined - -pattern IntFun :: (a ~ Int) => String -> (a -> b) -> (Expr a -> Expr b) -pattern IntFun str f x = Fun str f x - --- Alternative syntax for pattern synonyms: --- pattern --- Suc :: () => (a ~ Int) => Expr a -> Expr Int --- Suc n <- IntFun _ _ n where --- Suc n = IntFun "suc" (+ 1) n -pattern Suc :: (a ~ Int) => Expr a -> Expr Int -pattern Suc n <- IntFun _ _ n where - Suc n = IntFun "suc" (+ 1) n diff --git a/tests/examples/ghc80/T11016.hs b/tests/examples/ghc80/T11016.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11016.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-} - -module T11016 where - -f1 :: (?x :: Int, _) => Int -f1 = ?x - -f2 :: (?x :: Int) => _ -f2 = ?x diff --git a/tests/examples/ghc80/T11039.hs b/tests/examples/ghc80/T11039.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11039.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Foo () where - -data A a = A a - -pattern Q :: () => (A ~ f) => a -> f a -pattern Q a = A a diff --git a/tests/examples/ghc80/T11053.hs b/tests/examples/ghc80/T11053.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11053.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} --- turn on with -fwarn-missing-pat-syn-sigs - -module Foo where - --- Should warn because of missing signature -pattern T = True - -pattern J a = Just a - -pattern J1 a <- Just a - -pattern J2{b} = Just b - -pattern J3{c} <- Just c - -pattern F :: Bool -pattern F = False diff --git a/tests/examples/ghc80/T11067.hs b/tests/examples/ghc80/T11067.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11067.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} - -module T11067 where - -import Data.Monoid -import GHC.Exts (Constraint) - -type family Skolem (p :: k -> Constraint) :: k -type family SkolemF (p :: k2 -> Constraint) (f :: k1 -> k2) :: k1 - --- | A quantified constraint -type Forall (p :: k -> Constraint) = p (Skolem p) -type ForallF (p :: k2 -> Constraint) (f :: k1 -> k2) = p (f (SkolemF p f)) - --- These work -class ForallF Monoid t => Monoid1 t -instance ForallF Monoid t => Monoid1 t - -class ForallF Monoid1 t => Monoid2 t -instance ForallF Monoid1 t => Monoid2 t - --- Changing f a ~ g a to, (Ord (f a), Ord (g a)), say, removes the error -class (f a ~ g a) => H f g a -instance (f a ~ g a) => H f g a - --- This one gives a superclass cycle error. -class Forall (H f g) => H1 f g -instance Forall (H f g) => H1 f g diff --git a/tests/examples/ghc80/T11071.hs b/tests/examples/ghc80/T11071.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11071.hs +++ /dev/null @@ -1,28 +0,0 @@ -module T11071 where - -import Data.List (lines) -import qualified Data.Map as M () -import qualified Data.IntMap as M () -import qualified Data.IntMap as M () -- just to see if this confused the code - -import qualified Data.Ord as Ord hiding (Down) - -import qualified Data.Map as M' hiding (size, filter) -import qualified Data.Map as M' hiding (size) -import qualified Data.IntMap as M' hiding (size) -import qualified System.IO as M' () -- unrelated - -ignore :: a -> IO () -ignore = const (return ()) - -main = do - ignore NoSuchModule.foo -- no such module - ignore Data.List.foobar -- does not exist (one import) - ignore M.foobar -- does not exist (two imports) - ignore M'.foobar -- does not exist (three imports) - ignore Data.List.sort -- needs import - ignore Data.List.unlines -- needs import, similar to imported - ignore M.size -- multiple modules to import from - ignore M.valid -- only one module to import from - ignore Ord.Down -- explicit hiding - ignore M'.size -- hidden and/or missing in import list diff --git a/tests/examples/ghc80/T11071a.hs b/tests/examples/ghc80/T11071a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11071a.hs +++ /dev/null @@ -1,16 +0,0 @@ -module T11071 where - -import Data.List (lines) -import Data.IntMap () -import Data.Ord hiding (Down) -import Prelude hiding (True) - -ignore :: a -> IO () -ignore = const (return ()) - -main = do - ignore intersperse -- missing in import list (one import) - ignore foldl' -- missing in import list (two imports) - ignore Down -- explicitly hidden - ignore True -- explicitly hidden from prelude (not really special) - ignore foobar -- genuinely out of scope diff --git a/tests/examples/ghc80/T11076.hs b/tests/examples/ghc80/T11076.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11076.hs +++ /dev/null @@ -1,15 +0,0 @@ -{- - Test case for a problem where GHC had incorrect strictness - information for foreign calls with lifted arguments - -} -{-# OPTIONS_GHC -O0 #-} -module Main where - -import T11076A -import Control.Exception -x :: Bool -x = error "OK: x has been forced" - -main :: IO () -main = print (testBool x) `catch` - \(ErrorCall e) -> putStrLn e -- x should be forced diff --git a/tests/examples/ghc80/T11076A.hs b/tests/examples/ghc80/T11076A.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11076A.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# OPTIONS_GHC -O #-} -{-# LANGUAGE MagicHash, - ForeignFunctionInterface, - UnliftedFFITypes, - GHCForeignImportPrim, - BangPatterns - #-} -module T11076A where - -import GHC.Exts -import Unsafe.Coerce - -{- - If the demand type for the foreign call argument is incorrectly strict, - the bang pattern can be optimized out - -} -testBool :: Bool -> Int -testBool !x = I# (cmm_testPrim (unsafeCoerce x)) -{-# INLINE testBool #-} - -foreign import prim "testPrim" cmm_testPrim :: Any -> Int# diff --git a/tests/examples/ghc80/T11077.hs b/tests/examples/ghc80/T11077.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11077.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T11077 (module X, foo) where -import Data.List as X -foo = undefined diff --git a/tests/examples/ghc80/T11103.hs b/tests/examples/ghc80/T11103.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11103.hs +++ /dev/null @@ -1,20 +0,0 @@ --- When using DuplicateRecordFields with TemplateHaskell, it is not possible to --- reify ambiguous names that are output by reifying field labels. --- See also overloadedrecflds/should_run/overloadedrecfldsrun04.hs - -{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -data R = MkR { foo :: Int, bar :: Int } -data S = MkS { foo :: Int } - -$(do info <- reify ''R - case info of - TyConI (DataD _ _ _ [RecC _ [(foo_n, _, _), (bar_n, _, _)]] _) - -> do { reify bar_n -- This is unambiguous - ; reify foo_n -- This is ambiguous - ; return [] - } - _ -> error "unexpected result of reify") diff --git a/tests/examples/ghc80/T11112.hs b/tests/examples/ghc80/T11112.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11112.hs +++ /dev/null @@ -1,4 +0,0 @@ -module T11112 where - -sort :: Ord s -> [s] -> [s] -sort xs = xs diff --git a/tests/examples/ghc80/T11128.hs b/tests/examples/ghc80/T11128.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11128.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -fwarn-noncanonical-monad-instances #-} - --- | Test noncanonical-monad-instances warnings -module T11128 where - -import Control.Applicative as A -import Control.Monad as M - ----------------------------------------------------------------------------- --- minimal definition - -data T0 a = T0 a deriving Functor - -instance A.Applicative T0 where - pure = T0 - (<*>) = M.ap - -instance M.Monad T0 where - (>>=) = undefined - ----------------------------------------------------------------------------- --- trigger all 4 warnings - -data T1 a = T1 a deriving Functor - -instance A.Applicative T1 where - pure = return - (<*>) = M.ap - (*>) = (M.>>) - -instance M.Monad T1 where - (>>=) = undefined - return = T1 - (>>) = undefined - ----------------------------------------------------------------------------- --- backward compat canonical defintion - -data T2 a = T2 a deriving Functor - -instance Applicative T2 where - pure = T2 - (<*>) = ap - (*>) = undefined - -instance M.Monad T2 where - (>>=) = undefined - return = pure - (>>) = (*>) diff --git a/tests/examples/ghc80/T11136.hs b/tests/examples/ghc80/T11136.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11136.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T11136 where - -class C a where - type D a - type instance D a x = x diff --git a/tests/examples/ghc80/T11148.hs b/tests/examples/ghc80/T11148.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11148.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} - -module T11148 where - -data family G a b c d -data instance G Int b Float d = G deriving Functor - -data family H a b c d -data instance H [b] b d c = H deriving Functor diff --git a/tests/examples/ghc80/T11155.hs b/tests/examples/ghc80/T11155.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11155.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# OPTIONS_GHC -O -fno-full-laziness #-} -module T11155 where - -foo :: Bool -{-# NOINLINE foo #-} -foo = error "rk" - -bar x = let t :: Char - t = case foo of { True -> 'v'; False -> 'y' } - in [t] - diff --git a/tests/examples/ghc80/T11164.hs b/tests/examples/ghc80/T11164.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11164.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T11164 where - -import T11164b (T) diff --git a/tests/examples/ghc80/T11164a.hs b/tests/examples/ghc80/T11164a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11164a.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T11164a where - -data family T a diff --git a/tests/examples/ghc80/T11164b.hs b/tests/examples/ghc80/T11164b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11164b.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T11164b where - -import T11164a - -data instance T Int = MkT diff --git a/tests/examples/ghc80/T11167.hs b/tests/examples/ghc80/T11167.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11167.hs +++ /dev/null @@ -1,21 +0,0 @@ -module T11167 where - -data SomeException - -newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r} - -runContT' :: ContT r m a -> (a -> m r) -> m r -runContT' = runContT - -catch_ :: IO a -> (SomeException -> IO a) -> IO a -catch_ = undefined - -foo :: IO () -foo = (undefined :: ContT () IO a) - `runContT` (undefined :: a -> IO ()) - `catch_` (undefined :: SomeException -> IO ()) - -foo' :: IO () -foo' = (undefined :: ContT () IO a) - `runContT'` (undefined :: a -> IO ()) - `catch_` (undefined :: SomeException -> IO ()) diff --git a/tests/examples/ghc80/T11167_ambig.hs b/tests/examples/ghc80/T11167_ambig.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11167_ambig.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module T11167_ambig where - -data SomeException - -newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r} -newtype ContT' r m a = ContT' {runContT :: (a -> m r) -> m r} - -runContT' :: ContT r m a -> (a -> m r) -> m r -runContT' = runContT - -catch_ :: IO a -> (SomeException -> IO a) -> IO a -catch_ = undefined - -foo :: IO () -foo = (undefined :: ContT () IO a) - `runContT` (undefined :: a -> IO ()) - `catch_` (undefined :: SomeException -> IO ()) - -foo' :: IO () -foo' = (undefined :: ContT () IO a) - `runContT'` (undefined :: a -> IO ()) - `catch_` (undefined :: SomeException -> IO ()) diff --git a/tests/examples/ghc80/T11167_ambiguous_fixity.hs b/tests/examples/ghc80/T11167_ambiguous_fixity.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11167_ambiguous_fixity.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module T11167_ambiguous_fixity where -import T11167_ambiguous_fixity_A -import T11167_ambiguous_fixity_B - -x a = (a :: A) `foo` 0 diff --git a/tests/examples/ghc80/T11167_ambiguous_fixity_A.hs b/tests/examples/ghc80/T11167_ambiguous_fixity_A.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11167_ambiguous_fixity_A.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module T11167_ambiguous_fixity_A where -data A = MkA { foo :: Int -> Int } -data C = MkC { foo :: Int -> Int } -infixr 3 `foo` diff --git a/tests/examples/ghc80/T11167_ambiguous_fixity_B.hs b/tests/examples/ghc80/T11167_ambiguous_fixity_B.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11167_ambiguous_fixity_B.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T11167_ambiguous_fixity_B where -data B = MkB { foo :: Int -> Int } -infixl 5 `foo` diff --git a/tests/examples/ghc80/T11173.hs b/tests/examples/ghc80/T11173.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11173.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module T11173 where -import T11173a (A(..)) - --- Check that the fixity declaration applied to the field 'foo' is used -x b = b `foo` b `foo` 0 diff --git a/tests/examples/ghc80/T11173a.hs b/tests/examples/ghc80/T11173a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11173a.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module T11173a where - -data A = A { foo :: Int -> Int, bar :: Int -> Int } -newtype B = B { foo :: Int -> Int } -infixr 5 `foo` -infixr 5 `bar` - --- This is well-typed only if the fixity is correctly applied -y b = b `bar` b `bar` 0 diff --git a/tests/examples/ghc80/T11182.hs b/tests/examples/ghc80/T11182.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11182.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE Strict #-} --- | Strict should imply StrictData -module Main where - -data Lazy a = Lazy ~a - -main :: IO () -main = - case Lazy undefined of - Lazy _ -> putStrLn "Lazy" diff --git a/tests/examples/ghc80/T11187.hs b/tests/examples/ghc80/T11187.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11187.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module T11187 where -import Data.Type.Coercion - -type family X - -coercionXX :: Coercion X X -coercionXX = Coercion - -coercionXX1 :: Coercion X X -coercionXX1 = c where - c :: x ~ X => Coercion x x - c = Coercion - -coercionXX2 :: Coercion X X -coercionXX2 = c where c = Coercion diff --git a/tests/examples/ghc80/T11192.hs b/tests/examples/ghc80/T11192.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11192.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} - -module T11192 where - -fails :: a -fails = - let go :: _ - go 0 a = a - in go (0 :: Int) undefined - -succeeds :: a -succeeds = - let go :: _ - go _ a = a - in go (0 :: Int) undefined diff --git a/tests/examples/ghc80/T11193.hs b/tests/examples/ghc80/T11193.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11193.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE Strict #-} - -module Main where - -main = do - ~a <- return (error "don't error here!") - b <- return (error "error here!") -- this binding should be strict - print "should never reach here" diff --git a/tests/examples/ghc80/T11208.hs b/tests/examples/ghc80/T11208.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11208.hs +++ /dev/null @@ -1,8 +0,0 @@ -module T11208 where - -import qualified Prelude as P - -f n = n P.+ 1 - -g h (P.Just x) = P.Just (h x) -g _ P.Nothing = P.Nothing diff --git a/tests/examples/ghc80/T11216.hs b/tests/examples/ghc80/T11216.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11216.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE RebindableSyntax #-} - -module Bug where - -foo :: (a, b) -> () -foo x | (_,_) <- x = () diff --git a/tests/examples/ghc80/T11224.hs b/tests/examples/ghc80/T11224.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11224.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE PatternSynonyms , ViewPatterns #-} - --- inlining a pattern synonym shouldn't change semantics - -import Text.Read - --- pattern PRead :: () => Read a => a -> String -pattern PRead a <- (readMaybe -> Just a) - -foo :: String -> Int -foo (PRead x) = (x::Int) -foo (PRead xs) = sum (xs::[Int]) -foo _ = 666 - -bar :: String -> Int -bar (readMaybe -> Just x) = (x::Int) -bar (readMaybe -> Just xs) = sum (xs::[Int]) -bar _ = 666 - -main :: IO () -main = do - print $ foo "1" -- 1 - print $ foo "[1,2,3]" -- 666 -- ??? - print $ foo "xxx" -- 666 - - print $ bar "1" -- 1 - print $ bar "[1,2,3]" -- 6 - print $ bar "xxx" -- 666 diff --git a/tests/examples/ghc80/T11232.hs b/tests/examples/ghc80/T11232.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11232.hs +++ /dev/null @@ -1,15 +0,0 @@ -module T11232 where - -import Control.Monad -import Data.Data - -mkMp :: ( MonadPlus m - , Typeable a - , Typeable b - ) - => (b -> m b) - -> a - -> m a -mkMp ext = unM (maybe (M (const mzero)) id (gcast (M ext))) - -newtype M m x = M { unM :: x -> m x } diff --git a/tests/examples/ghc80/T11237.hs b/tests/examples/ghc80/T11237.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11237.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE GADTs #-} -module TypeInTypeBug where - -import qualified Data.Kind - -data Works :: Data.Kind.Type where - WorksConstr :: Works - -type Set = Data.Kind.Type - -data ShouldWork :: Set where - ShouldWorkConstr :: ShouldWork diff --git a/tests/examples/ghc80/T1133Aa.hs b/tests/examples/ghc80/T1133Aa.hs deleted file mode 100644 --- a/tests/examples/ghc80/T1133Aa.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T1133Aa where - -import {-# SOURCE #-} T1133A diff --git a/tests/examples/ghc80/T1133a.hs b/tests/examples/ghc80/T1133a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T1133a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T1133a where - -import {-# SOURCE #-} T1133 diff --git a/tests/examples/ghc80/T11381.hs b/tests/examples/ghc80/T11381.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11381.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T11381 where - --- ensure that this code does not compile without InjectiveTypeFamilies and that --- injectivity error is not reported. -type family F a = r | r -> a -type instance F Int = Bool -type instance F Int = Char diff --git a/tests/examples/ghc80/T11959.hs b/tests/examples/ghc80/T11959.hs deleted file mode 100644 --- a/tests/examples/ghc80/T11959.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Main where - -import T11959Lib (Vec2(..), pattern (:>)) - -main = return () diff --git a/tests/examples/ghc80/T17a.hs b/tests/examples/ghc80/T17a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T17a.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unused-top-binds #-} - --- Trac #17 - -module Temp (foo, bar, quux) where - -top :: Int -top = 1 - -foo :: () -foo = let True = True in () - -bar :: Int -> Int -bar match = 1 - -quux :: Int -quux = let local = True - in 2 diff --git a/tests/examples/ghc80/T17b.hs b/tests/examples/ghc80/T17b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T17b.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unused-local-binds #-} - --- Trac #17 - -module Temp (foo, bar, quux) where - -top :: Int -top = 1 - -foo :: () -foo = let True = True in () - -bar :: Int -> Int -bar match = 1 - -quux :: Int -quux = let local = True - in 2 diff --git a/tests/examples/ghc80/T17c.hs b/tests/examples/ghc80/T17c.hs deleted file mode 100644 --- a/tests/examples/ghc80/T17c.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unused-pattern-binds #-} - --- Trac #17 - -module Temp (foo, bar, quux) where - -top :: Int -top = 1 - -foo :: () -foo = let True = True in () - -bar :: Int -> Int -bar match = 1 - -quux :: Int -quux = let local = True - in 2 diff --git a/tests/examples/ghc80/T17d.hs b/tests/examples/ghc80/T17d.hs deleted file mode 100644 --- a/tests/examples/ghc80/T17d.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unused-matches #-} - --- Trac #17 - -module Temp (foo, bar, quux) where - -top :: Int -top = 1 - -foo :: () -foo = let True = True in () - -bar :: Int -> Int -bar match = 1 - -quux :: Int -quux = let local = True - in 2 diff --git a/tests/examples/ghc80/T17e.hs b/tests/examples/ghc80/T17e.hs deleted file mode 100644 --- a/tests/examples/ghc80/T17e.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unused-binds #-} - --- Trac #17 - -module Temp (foo, bar, quux) where - -top :: Int -top = 1 - -foo :: () -foo = let True = True in () - -bar :: Int -> Int -bar match = 1 - -quux :: Int -quux = let local = True - in 2 diff --git a/tests/examples/ghc80/T1830_1.hs b/tests/examples/ghc80/T1830_1.hs deleted file mode 100644 --- a/tests/examples/ghc80/T1830_1.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T1830_1 where - -import Language.Haskell.TH.Syntax (Lift) - -data Foo a = Foo a deriving Lift diff --git a/tests/examples/ghc80/T1830_2.hs b/tests/examples/ghc80/T1830_2.hs deleted file mode 100644 --- a/tests/examples/ghc80/T1830_2.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE DeriveLift #-} -module T1830_2 where - -import Language.Haskell.TH.Syntax (Lift) - -data Nothing deriving Lift diff --git a/tests/examples/ghc80/T1830_3.hs b/tests/examples/ghc80/T1830_3.hs deleted file mode 100644 --- a/tests/examples/ghc80/T1830_3.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Language.Haskell.TH.Syntax (lift) -import T1830_3a - -main :: IO () -main = do - print ($(lift algDT1) == algDT1) - print ($(lift algDT2) == algDT2) - print ($(lift algDT3) == algDT3) - print ($(lift prim) == prim) - print ($(lift df1) == df1) - print ($(lift df2) == df2) - print ($(lift df3) == df3) diff --git a/tests/examples/ghc80/T1830_3a.hs b/tests/examples/ghc80/T1830_3a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T1830_3a.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -module T1830_3a where - -import GHC.Exts -import Language.Haskell.TH.Syntax (Lift(..)) - -data AlgDT a b c = NormalCon a b - | RecCon { recCon1 :: a, recCon2 :: b} - | a :^: b - deriving (Eq, Lift) - -data Prim = Prim Char# Double# Int# Float# Word# - deriving (Eq, Lift) - --- We can't test this for equality easily due to the unstable nature of --- primitive string literal equality. We include this anyway to ensure that --- deriving Lift for datatypes with Addr# in them does in fact work. -data AddrHash = AddrHash Addr# - deriving Lift - -data Empty deriving Lift - -data family DataFam a b c - -data instance DataFam Int b c = DF1 Int | DF2 b - deriving (Eq, Lift) - -newtype instance DataFam Char b c = DF3 Char - deriving (Eq, Lift) - -algDT1, algDT2, algDT3 :: AlgDT Int String () -algDT1 = NormalCon 1 "foo" -algDT2 = RecCon 2 "bar" -algDT3 = 3 :^: "baz" - -prim :: Prim -prim = Prim 'a'# 1.0## 1# 1.0# 1## - -df1, df2 :: DataFam Int Char () -df1 = DF1 1 -df2 = DF2 'a' - -df3 :: DataFam Char () () -df3 = DF3 'b' diff --git a/tests/examples/ghc80/T2006.hs b/tests/examples/ghc80/T2006.hs deleted file mode 100644 --- a/tests/examples/ghc80/T2006.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} -{-# LANGUAGE GADTs #-} - -module T2006 where - -data Expr a vs where - EPrim :: String -> a -> Expr a vs - EVar :: Expr a (a,vs) - -interpret :: Expr a () -> a -interpret (EPrim _ a) = a --- interpret EVar = error "unreachable" - diff --git a/tests/examples/ghc80/T2204.hs b/tests/examples/ghc80/T2204.hs deleted file mode 100644 --- a/tests/examples/ghc80/T2204.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T2204 where - -f :: String -> Int -f "01" = 0 - -g :: Int -> Int -g 0 = 0 diff --git a/tests/examples/ghc80/T2632.hs b/tests/examples/ghc80/T2632.hs deleted file mode 100644 --- a/tests/examples/ghc80/T2632.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- Trac #2632 - -module MkData where - -import Language.Haskell.TH - -op :: Num v => v -> v -> v -op a b = a + b - -decl1 = [d| func = 0 `op` 3 |] - -decl2 = [d| op x y = x - func = 0 `op` 3 |] - diff --git a/tests/examples/ghc80/T2931.hs b/tests/examples/ghc80/T2931.hs deleted file mode 100644 --- a/tests/examples/ghc80/T2931.hs +++ /dev/null @@ -1,7 +0,0 @@ --- Trac #2931 - -module Foo where -a = 1 - --- NB: no newline after the 'a'! -b = 'a diff --git a/tests/examples/ghc80/T2991.hs b/tests/examples/ghc80/T2991.hs deleted file mode 100644 --- a/tests/examples/ghc80/T2991.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main where --- Test that there are actually entries in the .mix file for an imported --- literate module generated with --make. -import T2991LiterateModule -main = return () diff --git a/tests/examples/ghc80/T3078.hs b/tests/examples/ghc80/T3078.hs deleted file mode 100644 --- a/tests/examples/ghc80/T3078.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE PatternGuards #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T3078 where - -data T = A Int | B Int - -funny :: T -> Int -funny t = n - where - n | A x <- t = x - | B x <- t = x diff --git a/tests/examples/ghc80/T322.hs b/tests/examples/ghc80/T322.hs deleted file mode 100644 --- a/tests/examples/ghc80/T322.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# OPTIONS -fwarn-incomplete-patterns -fwarn-overlapping-patterns -Werror #-} - -module T322 where - -instance (Num a) => Num (Maybe a) where - (Just a) + (Just b) = Just (a + b) - _ + _ = Nothing - - (Just a) - (Just b) = Just (a - b) - _ - _ = Nothing - - (Just a) * (Just b) = Just (a * b) - _ * _ = Nothing - - negate (Just a) = Just (negate a) - negate _ = Nothing - - abs (Just a) = Just (abs a) - abs _ = Nothing - - signum (Just a) = Just (signum a) - signum _ = Nothing - - fromInteger = Just . fromInteger - -f :: Maybe Int -> Int -f 1 = 1 -f Nothing = 2 -f _ = 3 diff --git a/tests/examples/ghc80/T3468a.hs b/tests/examples/ghc80/T3468a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T3468a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T3468a where - -import {-# SOURCE #-} T3468 diff --git a/tests/examples/ghc80/T3572.hs b/tests/examples/ghc80/T3572.hs deleted file mode 100644 --- a/tests/examples/ghc80/T3572.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TemplateHaskellQuotes #-} - --- Trac #3572 - -module Main where - -import Language.Haskell.TH -import Language.Haskell.TH.Ppr - -main = putStrLn . pprint =<< runQ [d| data Void |] diff --git a/tests/examples/ghc80/T365.hs b/tests/examples/ghc80/T365.hs deleted file mode 100644 --- a/tests/examples/ghc80/T365.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF ./test_preprocessor.txt #-} -module Main where - -main = print "Hello World" diff --git a/tests/examples/ghc80/T366.hs b/tests/examples/ghc80/T366.hs deleted file mode 100644 --- a/tests/examples/ghc80/T366.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -XGADTs -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T366 where - -data T a where - C1 :: T Char - C2 :: T Float - -exhaustive :: T Char -> Char -exhaustive C1 = ' ' diff --git a/tests/examples/ghc80/T3927.hs b/tests/examples/ghc80/T3927.hs deleted file mode 100644 --- a/tests/examples/ghc80/T3927.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T3927 where - -data T a where - T1 :: T Int - T2 :: T Bool - --- f1 is exhaustive -f1 :: T a -> T a -> Bool -f1 T1 T1 = True -f1 T2 T2 = False diff --git a/tests/examples/ghc80/T3927a.hs b/tests/examples/ghc80/T3927a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T3927a.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} -{-# LANGUAGE GADTs, TypeFamilies #-} - -module T3927a where - -type family F a -type instance F a = () - -data Foo a where - FooA :: Foo () - FooB :: Foo Int - -f :: a -> Foo (F a) -> () -- F a can only be () so only FooA is accepted -f _ FooA = () - diff --git a/tests/examples/ghc80/T4056.hs b/tests/examples/ghc80/T4056.hs deleted file mode 100644 --- a/tests/examples/ghc80/T4056.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-} -{-# LANGUAGE TemplateHaskellQuotes #-} - -module T4056 where -import Language.Haskell.TH - -astTest :: Q [Dec] -astTest = [d| - class C t where - op :: [t] -> [t] - op = undefined - |] - -class D t where - bop :: [t] -> [t] - bop = undefined diff --git a/tests/examples/ghc80/T4139.hs b/tests/examples/ghc80/T4139.hs deleted file mode 100644 --- a/tests/examples/ghc80/T4139.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - -module T4139 where - -data F a where - FInt :: F Int - FBool :: F Bool - -class Baz a where - baz :: F a -> G a -instance Baz Int where - baz _ = GInt -instance Baz Bool where - baz _ = GBool - -data G a where - GInt :: G Int - GBool :: G Bool - -bar :: Baz a => F a -> () -bar a@(FInt) = - case baz a of - GInt -> () - -- GBool -> () -bar _ = () - - diff --git a/tests/examples/ghc80/T4169.hs b/tests/examples/ghc80/T4169.hs deleted file mode 100644 --- a/tests/examples/ghc80/T4169.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- Crashed GHC 6.12 - -module T4165 where - -import Language.Haskell.TH -class Numeric a where - fromIntegerNum :: a - fromIntegerNum = undefined - -ast :: Q [Dec] -ast = [d| - instance Numeric Int - |] diff --git a/tests/examples/ghc80/T4170.hs b/tests/examples/ghc80/T4170.hs deleted file mode 100644 --- a/tests/examples/ghc80/T4170.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module T4170 where - -import Language.Haskell.TH - -class LOL a - -lol :: Q [Dec] -lol = [d| - instance LOL Int - |] - -instance LOL Int diff --git a/tests/examples/ghc80/T5001b.hs b/tests/examples/ghc80/T5001b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T5001b.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -module T5001b where - -class GEnum a where - genum :: [a] - default genum :: [a] - genum = undefined - -instance GEnum Int where - {-# INLINE genum #-} diff --git a/tests/examples/ghc80/T5333.hs b/tests/examples/ghc80/T5333.hs deleted file mode 100644 --- a/tests/examples/ghc80/T5333.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE Arrows, NoMonomorphismRestriction #-} -module T5333 where - -import Prelude hiding ( id, (.) ) -import Control.Arrow - -cc1 :: a e b -> a e b -> a e b -cc1 = undefined - --- With GHC < 7.10.1, the following compile failures occured: --- --- ghc: panic! (the 'impossible' happened) --- (GHC version 7.8.4 for x86_64-unknown-linux): --- mkCmdEnv Not found: base:GHC.Desugar.>>>{v 02V} - --- 'g' fails to compile. -g = proc (x, y, z) -> - ((returnA -< x) &&& (returnA -< y) &&& (returnA -< z)) - --- 'f' compiles: --- - without an infix declaration --- - with the infixl declaration --- and fails with the infixr declaration -infixr 6 `cc1` --- infixl 6 `cc1` - -f = proc (x, y, z) -> - ((returnA -< x) `cc1` (returnA -< y) `cc1` (returnA -< z)) diff --git a/tests/examples/ghc80/T5721.hs b/tests/examples/ghc80/T5721.hs deleted file mode 100644 --- a/tests/examples/ghc80/T5721.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module T5371 where -import Language.Haskell.TH - -f :: a -> Name -f (x :: a) = ''a diff --git a/tests/examples/ghc80/T5821.hs b/tests/examples/ghc80/T5821.hs deleted file mode 100644 --- a/tests/examples/ghc80/T5821.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -module T5821 where - -type family T a -type instance T Int = Bool - -foo :: Num a => a -> T a -foo = undefined - -{-# SPECIALISE foo :: Int -> Bool #-} diff --git a/tests/examples/ghc80/T5884Other.hs b/tests/examples/ghc80/T5884Other.hs deleted file mode 100644 --- a/tests/examples/ghc80/T5884Other.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T5884Other where - -data Pair a = Pair a a diff --git a/tests/examples/ghc80/T5908.hs b/tests/examples/ghc80/T5908.hs deleted file mode 100644 --- a/tests/examples/ghc80/T5908.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# LANGUAGE - ExplicitForAll - , GADTs - , RebindableSyntax #-} -module T5908 - ( Writer - , runWriter - , execWriter - , WriterT - , runWriterT - , execWriterT - , tell - ) where - -import Control.Category (Category (id), (>>>)) - -import Prelude hiding (Monad (..), id) -import qualified Prelude - -newtype Identity a = Identity { runIdentity :: a } - -class Monad m where - (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b - (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b - return :: a -> m ex ex a - fail :: String -> m e x a - - {-# INLINE (>>) #-} - m >> k = m >>= \ _ -> k - fail = error - -type Writer w = WriterT w Identity - -runWriter :: Writer w e x a -> (a, w e x) -runWriter = runIdentity . runWriterT - -execWriter :: Writer w e x a -> w e x -execWriter m = snd (runWriter m) - -newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) } - -execWriterT :: Prelude.Monad m => WriterT w m e x a -> m (w e x) -execWriterT m = do - ~(_, w) <- runWriterT m - return w - where - (>>=) = (Prelude.>>=) - return = Prelude.return - -instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where - return a = WriterT $ return (a, id) - where - return = Prelude.return - m >>= k = WriterT $ do - ~(a, w) <- runWriterT m - ~(b, w') <- runWriterT (k a) - return (b, w >>> w') - where - (>>=) = (Prelude.>>=) - return = Prelude.return - fail msg = WriterT $ fail msg - where - fail = Prelude.fail - -tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x () -tell w = WriterT $ return ((), w) - where - return = Prelude.return - - diff --git a/tests/examples/ghc80/T6018.hs b/tests/examples/ghc80/T6018.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6018.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoMonomorphismRestriction #-} - -module T6018 where - -import T6018a -- defines G, identical to F - -type family F a b c = (result :: k) | result -> a b c -type instance F Int Char Bool = Bool -type instance F Char Bool Int = Int -type instance F Bool Int Char = Char - - -type instance G Bool Int Char = Char - -type family I (a :: k) b (c :: k) = r | r -> a b -type instance I Int Char Bool = Bool -type instance I Int Char Int = Bool -type instance I Bool Int Int = Int - --- this is injective - a type variable introduced in the LHS is not mentioned on --- RHS but we don't claim injectivity in that argument. -type family J a (b :: k) = r | r -> a -type instance J Int b = Char - -type MaybeSyn a = Maybe a -newtype MaybeNew a = MaybeNew (Maybe a) - --- make sure we look through type synonyms... -type family K a = r | r -> a -type instance K a = MaybeSyn a - --- .. but not newtypes -type family M a = r | r -> a -type instance M (Maybe a) = MaybeSyn a -type instance M (MaybeNew a) = MaybeNew a - --- Closed type families - --- these are simple conversions from open type families. They should behave the --- same -type family FClosed a b c = result | result -> a b c where - FClosed Int Char Bool = Bool - FClosed Char Bool Int = Int - FClosed Bool Int Char = Char - -type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where - IClosed Int Char Bool = Bool - IClosed Int Char Int = Bool - IClosed Bool Int Int = Int - -type family JClosed a (b :: k) = r | r -> a where - JClosed Int b = Char - -type family KClosed a = r | r -> a where - KClosed a = MaybeSyn a - --- Here the last equation might return both Int and Char but we have to --- recognize that it is not possible due to equation overlap -type family Bak a = r | r -> a where - Bak Int = Char - Bak Char = Int - Bak a = a - --- This is similar, except that the last equation contains concrete type. Since --- it is overlapped it should be dropped with a warning -type family Foo a = r | r -> a where - Foo Int = Bool - Foo Bool = Int - Foo Bool = Bool - --- this one was tricky in the early implementation of injectivity. Now it is --- identical to the above but we still keep it as a regression test. -type family Bar a = r | r -> a where - Bar Int = Bool - Bar Bool = Int - Bar Bool = Char - --- Now let's use declared type families. All the below definitions should work - --- No ambiguity for any of the arguments - all are injective -f :: F a b c -> F a b c -f x = x - --- From 1st instance of F: a ~ Int, b ~ Char, c ~ Bool -fapp :: Bool -fapp = f True - --- now the closed variant of F -fc :: FClosed a b c -> FClosed a b c -fc x = x - -fcapp :: Bool -fcapp = fc True - --- The last argument is not injective so it must be instantiated -i :: I a b Int -> I a b Int -i x = x - --- From 1st instance of I: a ~ Int, b ~ Char -iapp :: Bool -iapp = i True - --- again, closed variant of I -ic :: IClosed a b Int -> IClosed a b Int -ic x = x - -icapp :: Bool -icapp = ic True - --- Now we have to test weird closed type families: -bak :: Bak a -> Bak a -bak x = x - -bakapp1 :: Char -bakapp1 = bak 'c' - -bakapp2 :: Double -bakapp2 = bak 1.0 - -bakapp3 :: () -bakapp3 = bak () - -foo :: Foo a -> Foo a -foo x = x - -fooapp1 :: Bool -fooapp1 = foo True - -bar :: Bar a -> Bar a -bar x = x - -barapp1 :: Bool -barapp1 = bar True - -barapp2 :: Int -barapp2 = bar 1 - --- Declarations below test more liberal RHSs of injectivity annotations: --- permiting variables to appear in different order than the one in which they --- were declared. -type family H a b = r | r -> b a -type family Hc a b = r | r -> b a where - Hc a b = a b -class Hcl a b where - type Ht a b = r | r -> b a - --- repeated tyvars in the RHS of injectivity annotation: no warnings or errors --- (consistent with behaviour for functional dependencies) -type family Jx a b = r | r -> a a -type family Jcx a b = r | r -> a a where - Jcx a b = a b -class Jcl a b where - type Jt a b = r | r -> a a - -type family Kx a b = r | r -> a b b -type family Kcx a b = r | r -> a b b where - Kcx a b = a b -class Kcl a b where - type Kt a b = r | r -> a b b - --- Declaring kind injectivity. Here we only claim that knowing the RHS --- determines the LHS kind but not the type. -type family L (a :: k1) = (r :: k2) | r -> k1 where - L 'True = Int - L 'False = Int - L Maybe = 3 - L IO = 3 - -data KProxy (a :: *) = KProxy -type family KP (kproxy :: KProxy k) = r | r -> k -type instance KP ('KProxy :: KProxy Bool) = Int -type instance KP ('KProxy :: KProxy *) = Char - -kproxy_id :: KP ('KProxy :: KProxy k) -> KP ('KProxy :: KProxy k) -kproxy_id x = x - -kproxy_id_use = kproxy_id 'a' - --- Now test some awkward cases from The Injectivity Paper. All should be --- accepted. -type family Gx a -type family Hx a -type family Gi a = r | r -> a -type instance Gi Int = Char -type family Hi a = r | r -> a - -type family F2 a = r | r -> a -type instance F2 [a] = [Gi a] -type instance F2 (Maybe a) = Hi a -> Int - -type family F4 a = r | r -> a -type instance F4 [a] = (Gx a, a, a, a) -type instance F4 (Maybe a) = (Hx a, a, Int, Bool) - -type family G2 a b = r | r -> a b -type instance G2 a Bool = (a, a) -type instance G2 Bool b = (b, Bool) - -type family G6 a = r | r -> a -type instance G6 [a] = [Gi a] -type instance G6 Bool = Int - -g6_id :: G6 a -> G6 a -g6_id x = x - -g6_use :: [Char] -g6_use = g6_id "foo" - --- A sole exception to "bare variables in the RHS" rule -type family Id (a :: k) = (result :: k) | result -> a -type instance Id a = a - --- This makes sure that over-saturated type family applications at the top-level --- are accepted. -type family IdProxy (a :: k) b = r | r -> a -type instance IdProxy a b = (Id a) b - --- make sure we look through type synonyms properly -type IdSyn a = Id a -type family IdProxySyn (a :: k) b = r | r -> a -type instance IdProxySyn a b = (IdSyn a) b - --- this has bare variable in the RHS but all LHS varaiables are also bare so it --- should be accepted -type family Fa (a :: k) (b :: k) = (r :: k2) | r -> k -type instance Fa a b = a - --- Taken from #9587. This exposed a bug in the solver. -type family Arr (repr :: * -> *) (a :: *) (b :: *) = (r :: *) | r -> repr a b - -class ESymantics repr where - int :: Int -> repr Int - add :: repr Int -> repr Int -> repr Int - - lam :: (repr a -> repr b) -> repr (Arr repr a b) - app :: repr (Arr repr a b) -> repr a -> repr b - -te4 = let c3 = lam (\f -> lam (\x -> f `app` (f `app` (f `app` x)))) - in (c3 `app` (lam (\x -> x `add` int 14))) `app` (int 0) - --- This used to fail during development -class Manifold' a where - type Base a = r | r -> a - project :: a -> Base a - unproject :: Base a -> a - -id' :: forall a. ( Manifold' a ) => Base a -> Base a -id' = project . unproject diff --git a/tests/examples/ghc80/T6018Afail.hs b/tests/examples/ghc80/T6018Afail.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6018Afail.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018Afail where - -type family G a b c = (result :: *) | result -> a b c -type instance G Int Char Bool = Bool -type instance G Char Bool Int = Int diff --git a/tests/examples/ghc80/T6018Bfail.hs b/tests/examples/ghc80/T6018Bfail.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6018Bfail.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018Bfail where - -type family H a b c = (result :: *) | result -> a b c diff --git a/tests/examples/ghc80/T6018Cfail.hs b/tests/examples/ghc80/T6018Cfail.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6018Cfail.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018Cfail where - -import T6018Bfail - -type instance H Int Char Bool = Bool -type instance H Char Bool Int = Int diff --git a/tests/examples/ghc80/T6018Dfail.hs b/tests/examples/ghc80/T6018Dfail.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6018Dfail.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018Dfail where - -import T6018Bfail - -type instance H Bool Int Char = Int diff --git a/tests/examples/ghc80/T6018a.hs b/tests/examples/ghc80/T6018a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6018a.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018a where - -import {-# SOURCE #-} T6018 -- test support for hs-boot files - -type family G a b c = (result :: *) | result -> a b c -type instance G Int Char Bool = Bool -type instance G Char Bool Int = Int - -type instance F Bool Int Char = Char diff --git a/tests/examples/ghc80/T6018fail.hs b/tests/examples/ghc80/T6018fail.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6018fail.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds, - MultiParamTypeClasses, FlexibleInstances #-} - -module T6018fail where - -import T6018Afail -- defines G, identical to F -import T6018Cfail -- imports H from T6018Bfail, defines some equations for H -import T6018Dfail -- imports H from T6018Bfail, defines conflicting eqns - -type family F a b c = (result :: *) | result -> a b c -type instance F Int Char Bool = Bool -type instance F Char Bool Int = Int -type instance F Bool Int Char = Int - -type instance G Bool Int Char = Int - -type family I a b c = r | r -> a b -type instance I Int Char Bool = Bool -type instance I Int Int Int = Bool -type instance I Bool Int Int = Int - --- Id is injective... -type family Id a = result | result -> a -type instance Id a = a - --- ...but despite that we disallow a call to Id -type family IdProxy a = r | r -> a -type instance IdProxy a = Id a - -data N = Z | S N - --- P is not injective, although the user declares otherwise. This --- should be rejected on the grounds of calling a type family in the --- RHS. -type family P (a :: N) (b :: N) = (r :: N) | r -> a b -type instance P Z m = m -type instance P (S n) m = S (P n m) - --- this is not injective - not all injective type variables mentioned --- on LHS are mentioned on RHS -type family J a b c = r | r -> a b -type instance J Int b c = Char - --- same as above, but tyvar is now nested inside a tycon -type family K (a :: N) (b :: N) = (r :: N) | r -> a b -type instance K (S n) m = S m - --- Make sure we look through type synonyms to catch errors -type MaybeSyn a = Id a -type family L a = r | r -> a -type instance L a = MaybeSyn a - --- These should fail because given the RHS kind there is no way to determine LHS --- kind -class PolyKindVarsC a where - type PolyKindVarsF a = (r :: k) | r -> a - -instance PolyKindVarsC '[] where - type PolyKindVarsF '[] = '[] - -type family PolyKindVars (a :: k0) = (r :: k1) | r -> a -type instance PolyKindVars '[] = '[] - --- This should fail because there is no way to determine k from the RHS -type family Fc (a :: k) (b :: k) = r | r -> k -type instance Fc a b = Int - --- This should fail because there is no way to determine a, b and k from the RHS -type family Gc (a :: k) (b :: k) = r | r -> a b -type instance Gc a b = Int - --- fails because injectivity is not compositional in this case -type family F1 a = r | r -> a -type instance F1 [a] = Maybe (GF1 a) -type instance F1 (Maybe a) = Maybe (GF2 a) - -type family GF1 a = r | r -> a -type instance GF1 Int = Bool - -type family GF2 a = r | r -> a -type instance GF2 Int = Bool - -type family HF1 a -type instance HF1 Bool = Bool - -type family W1 a = r | r -> a -type instance W1 [a] = a - -type family W2 a = r | r -> a -type instance W2 [a] = W2 a - --- not injective because of infinite types -type family Z1 a = r | r -> a -type instance Z1 [a] = (a, a) -type instance Z1 (Maybe b) = (b, [b]) - -type family G1 a = r | r -> a -type instance G1 [a] = [a] -type instance G1 (Maybe b) = [(b, b)] - -type family G3 a b = r | r -> b -type instance G3 a Int = (a, Int) -type instance G3 a Bool = (Bool, a) - -type family G4 a b = r | r -> a b -type instance G4 a b = [a] - -type family G5 a = r | r -> a -type instance G5 [a] = [GF1 a] -- GF1 injective -type instance G5 Int = [Bool] - -type family G6 a = r | r -> a -type instance G6 [a] = [HF1 a] -- HF1 not injective -type instance G6 Bool = Int - -type family G7a a b (c :: k) = r | r -> a b -type family G7 a b (c :: k) = r | r -> a b c -type instance G7 a b c = [G7a a b c] - -class C a b where - type FC a (b :: *) = r | r -> b - type instance FC a b = b - -instance C Int Char where - type FC Int Char = Bool - --- this should fail because the default instance conflicts with one of the --- earlier instances -instance C Int Bool {- where - type FC Int Bool = Bool-} - --- and this should fail because it violates "bare variable in the RHS" --- restriction -instance C Char a diff --git a/tests/examples/ghc80/T6018failclosed.hs b/tests/examples/ghc80/T6018failclosed.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6018failclosed.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds, UndecidableInstances #-} - -module T6018failclosed where - --- Id is injective... -type family IdClosed a = result | result -> a where - IdClosed a = a - --- ...but despite that we disallow a call to Id -type family IdProxyClosed (a :: *) = r | r -> a where - IdProxyClosed a = IdClosed a - -data N = Z | S N - --- PClosed is not injective, although the user declares otherwise. This --- should be rejected on the grounds of calling a type family in the --- RHS. -type family PClosed (a :: N) (b :: N) = (r :: N) | r -> a b where - PClosed Z m = m - PClosed (S n) m = S (PClosed n m) - --- this is not injective - not all injective type variables mentioned --- on LHS are mentioned on RHS -type family JClosed a b c = r | r -> a b where - JClosed Int b c = Char - --- this is not injective - not all injective type variables mentioned --- on LHS are mentioned on RHS (tyvar is now nested inside a tycon) -type family KClosed (a :: N) (b :: N) = (r :: N) | r -> a b where - KClosed (S n) m = S m - --- hiding a type family application behind a type synonym should be rejected -type MaybeSynClosed a = IdClosed a -type family LClosed a = r | r -> a where - LClosed a = MaybeSynClosed a - -type family FClosed a b c = (result :: *) | result -> a b c where - FClosed Int Char Bool = Bool - FClosed Char Bool Int = Int - FClosed Bool Int Char = Int - -type family IClosed a b c = r | r -> a b where - IClosed Int Char Bool = Bool - IClosed Int Int Int = Bool - IClosed Bool Int Int = Int - -type family E2 (a :: Bool) = r | r -> a where - E2 False = True - E2 True = False - E2 a = False - --- This exposed a subtle bug in the implementation during development. After --- unifying the RHS of (1) and (2) the LHS substitution was done only in (2) --- which made it look like an overlapped equation. This is not the case and this --- definition should be rejected. The first two equations are here to make sure --- that the internal implementation does list indexing corrcectly (this is a bit --- tricky because the list is kept in reverse order). -type family F a b = r | r -> a b where - F Float IO = Float - F Bool IO = Bool - F a IO = IO a -- (1) - F Char b = b Int -- (2) - --- This should fail because there is no way to determine a, b and k from the RHS -type family Gc (a :: k) (b :: k) = r | r -> k where - Gc a b = Int diff --git a/tests/examples/ghc80/T6018failclosed2.hs b/tests/examples/ghc80/T6018failclosed2.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6018failclosed2.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T6018failclosed2 where - --- this one is a strange beast. Last equation is unreachable and thus it is --- removed. It is then impossible to typecheck barapp and thus we generate an --- error -type family Bar a = r | r -> a where - Bar Int = Bool - Bar Bool = Int - Bar Bool = Char - -bar :: Bar a -> Bar a -bar x = x - -barapp :: Char -barapp = bar 'c' diff --git a/tests/examples/ghc80/T6018rnfail.hs b/tests/examples/ghc80/T6018rnfail.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6018rnfail.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE TypeFamilies, PolyKinds #-} - -module T6018rnfail where - --- IA = injectivity annotation `| foo -> bar` - --- use incorrect tyvar in LHS of IA -type family F a = r | a -> a -type family Fc a = r | a -> a where - Fc a = a -class Fcl a where - type Ft a = r | a -> a - --- declare result tyvar to be duplicate (without IA) -type family G a = a -type family Gc a = a where - Gc a = a - --- declare result tyvar to be duplicate (with IA) -type family Gb a = a | a -> a -type family Gcb a = a | a -> a where - Gcb a = a -class Gclb a where -- here we want two errors - type Gtb a = a | a -> a - --- not in-scope tyvar in RHS of IA -type family I a b = r | r -> c -type family Ic a b = r | r -> c where - Ic a b = a -class Icl a b where - type It a b = r | r -> c - --- not in-scope tyvar in LHS of IA -type family L a b = r | c -> a -type family Lc a b = r | c -> a where - Lc a b = a -class Lcl a b where - type Lt a b = r | c -> a - --- result variable shadows variable in class head -class M a b where - type Mt b = a | a -> b - --- here b is out-of-scope -class N a b where - type Nt a = r | r -> a b - --- result is out of scope. Not possible for associated types -type family O1 a | r -> a -type family Oc1 a | r -> a where - Oc1 a = a -type family O2 a :: * | r -> a -type family Oc2 a :: * | r -> a where - Oc2 a = a diff --git a/tests/examples/ghc80/T6018th.hs b/tests/examples/ghc80/T6018th.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6018th.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds #-} - -module T6018th where - -import Language.Haskell.TH - --- Test that injectivity works correct with TH. This test is not as exhaustive --- as the original T6018 test. - --- type family F a b c = (result :: k) | result -> a b c --- type instance F Int Char Bool = Bool --- type instance F Char Bool Int = Int --- type instance F Bool Int Char = Char -$( return - [ OpenTypeFamilyD - (mkName "F") - [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] - (TyVarSig (KindedTV (mkName "result") (VarT (mkName "k")))) - (Just $ InjectivityAnn (mkName "result") - [(mkName "a"), (mkName "b"), (mkName "c") ]) - , TySynInstD - (mkName "F") - (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Bool")] - ( ConT (mkName "Bool"))) - , TySynInstD - (mkName "F") - (TySynEqn [ ConT (mkName "Char"), ConT (mkName "Bool") - , ConT (mkName "Int")] - ( ConT (mkName "Int"))) - , TySynInstD - (mkName "F") - (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") - , ConT (mkName "Char")] - ( ConT (mkName "Char"))) - ] ) - --- this is injective - a type variables mentioned on LHS is not mentioned on RHS --- but we don't claim injectivity in that argument. --- --- type family J a (b :: k) = r | r -> a ----type instance J Int b = Char -$( return - [ OpenTypeFamilyD - (mkName "J") - [ PlainTV (mkName "a"), KindedTV (mkName "b") (VarT (mkName "k")) ] - (TyVarSig (PlainTV (mkName "r"))) - (Just $ InjectivityAnn (mkName "r") [mkName "a"]) - , TySynInstD - (mkName "J") - (TySynEqn [ ConT (mkName "Int"), VarT (mkName "b") ] - ( ConT (mkName "Int"))) - ] ) - --- Closed type families - --- type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where --- IClosed Int Char Bool = Bool --- IClosed Int Char Int = Bool --- IClosed Bool Int Int = Int - -$( return - [ ClosedTypeFamilyD - (mkName "I") - [ KindedTV (mkName "a") StarT, KindedTV (mkName "b") StarT - , KindedTV (mkName "c") StarT ] - (TyVarSig (PlainTV (mkName "r"))) - (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")]) - [ TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Bool")] - ( ConT (mkName "Bool")) - , TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Int")] - ( ConT (mkName "Bool")) - , TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") - , ConT (mkName "Int")] - ( ConT (mkName "Int")) - ] - ] ) - --- reification test -$( do { decl@([ClosedTypeFamilyD _ _ _ (Just inj) _]) <- - [d| type family Bak a = r | r -> a where - Bak Int = Char - Bak Char = Int - Bak a = a |] - ; return decl - } - ) - --- Check whether incorrect injectivity declarations are caught - --- type family I a b c = r | r -> a b --- type instance I Int Char Bool = Bool --- type instance I Int Int Int = Bool --- type instance I Bool Int Int = Int -$( return - [ OpenTypeFamilyD - (mkName "H") - [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] - (TyVarSig (PlainTV (mkName "r"))) - (Just $ InjectivityAnn (mkName "r") - [(mkName "a"), (mkName "b") ]) - , TySynInstD - (mkName "H") - (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Bool")] - ( ConT (mkName "Bool"))) - , TySynInstD - (mkName "H") - (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Int") - , ConT (mkName "Int")] - ( ConT (mkName "Bool"))) - , TySynInstD - (mkName "H") - (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") - , ConT (mkName "Int")] - ( ConT (mkName "Int"))) - ] ) diff --git a/tests/examples/ghc80/T6062.hs b/tests/examples/ghc80/T6062.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6062.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module T6062 where -x = [| False True |] diff --git a/tests/examples/ghc80/T6124.hs b/tests/examples/ghc80/T6124.hs deleted file mode 100644 --- a/tests/examples/ghc80/T6124.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - -module T6124 where - -newtype A = MkA Int -newtype B = MkB Char - -data T a where - A :: T A - B :: T B - -f :: T A -> A -f A = undefined diff --git a/tests/examples/ghc80/T7411.hs b/tests/examples/ghc80/T7411.hs deleted file mode 100644 --- a/tests/examples/ghc80/T7411.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Control.Exception -import Control.DeepSeq -main = evaluate (('a' : undefined) `deepseq` return () :: IO ()) diff --git a/tests/examples/ghc80/T7669a.hs b/tests/examples/ghc80/T7669a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T7669a.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE EmptyCase #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} - -module T7669 where - -data Void - -foo :: Void -> () -foo x = case x of {} diff --git a/tests/examples/ghc80/T7672.hs b/tests/examples/ghc80/T7672.hs deleted file mode 100644 --- a/tests/examples/ghc80/T7672.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T7672 where -import qualified T7672a as XX -data T = S XX.T diff --git a/tests/examples/ghc80/T7672a.hs b/tests/examples/ghc80/T7672a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T7672a.hs +++ /dev/null @@ -1,2 +0,0 @@ -module T7672a(Decl.T) where -import {-# SOURCE #-} qualified T7672 as Decl diff --git a/tests/examples/ghc80/T7765.hs b/tests/examples/ghc80/T7765.hs deleted file mode 100644 --- a/tests/examples/ghc80/T7765.hs +++ /dev/null @@ -1,1 +0,0 @@ -module Main where diff --git a/tests/examples/ghc80/T7788.hs b/tests/examples/ghc80/T7788.hs deleted file mode 100644 --- a/tests/examples/ghc80/T7788.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module T7788 where - -data Proxy a = Proxy - -foo :: Proxy (F (Fix Id)) -> () -foo = undefined - -newtype Fix a = Fix (a (Fix a)) -newtype Id a = Id a - -type family F a -type instance F (Fix a) = F (a (Fix a)) -type instance F (Id a) = F a - -main :: IO () -main = print $ foo Proxy diff --git a/tests/examples/ghc80/T8030.hs b/tests/examples/ghc80/T8030.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8030.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PolyKinds, FlexibleContexts, TypeFamilies #-} -module T8030 where - --- The types of op1 and op2 are both ambiguous --- and should be reported as such - -class C (a :: k) where - type Pr a :: * - op1 :: Pr a - op2 :: Pr a -> Pr a -> Pr a - diff --git a/tests/examples/ghc80/T8034.hs b/tests/examples/ghc80/T8034.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8034.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module T8034 where - -class C a where - type F a - foo :: F a -> F a diff --git a/tests/examples/ghc80/T8101b.hs b/tests/examples/ghc80/T8101b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8101b.hs +++ /dev/null @@ -1,8 +0,0 @@ - -module A where - -data ABC = A | B | C - -abc :: ABC -> Int -abc x = case x of - A -> 1 diff --git a/tests/examples/ghc80/T8131b.hs b/tests/examples/ghc80/T8131b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8131b.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples #-} -import GHC.Prim -import GHC.IO - -main = IO $ \s -> - let (# s1, p0 #) = newByteArray# 10# s - (# s2, p #) = unsafeFreezeByteArray# p0 s1 - (# s3, q #) = newByteArray# 10# s2 - in (# copyByteArray# p 0# q 0# 10# s, () #) diff --git a/tests/examples/ghc80/T8274.hs b/tests/examples/ghc80/T8274.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8274.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE MagicHash #-} -module T8274 where - -import GHC.Prim - -data P = Positives Int# Float# Double# Char# Word# -data N = Negatives Int# Float# Double# - -p = Positives 42# 4.23# 4.23## '4'# 4## -n = Negatives -4# -4.0# -4.0## diff --git a/tests/examples/ghc80/T8455.hs b/tests/examples/ghc80/T8455.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8455.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE DataKinds #-} - -module T8455 where - -ty = [t| 5 |] diff --git a/tests/examples/ghc80/T8550.hs b/tests/examples/ghc80/T8550.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8550.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE TypeFamilies, GADTs, UndecidableInstances #-} - -module T8550 where - -type family F a -type instance F () = F () -data A where - A :: F () ~ () => A -x :: A -x = A - -main :: IO () -main = seq A (return ()) - --- Note: This worked in GHC 7.8, but I (Richard E) think this regression --- is acceptable. diff --git a/tests/examples/ghc80/T8555.hs b/tests/examples/ghc80/T8555.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8555.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module T8555 where -import Data.Coerce - -foo :: Coercible [a] [b] => a -> b -foo = coerce diff --git a/tests/examples/ghc80/T8633.hs b/tests/examples/ghc80/T8633.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8633.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Main where -import Language.Haskell.TH.Syntax - -t1 = case mkName "^.." of - Name (OccName ".") (NameQ (ModName "^")) -> error "bug0" - Name (OccName "^..") NameS -> return () - -t2 = case mkName "Control.Lens.^.." of - Name (OccName ".") (NameQ (ModName "Control.Lens.^")) -> error "bug1" - Name (OccName "^..") (NameQ (ModName "Control.Lens")) -> return () - -t3 = case mkName "Data.Bits..&." of - Name (OccName ".&.") (NameQ (ModName "Data.Bits")) -> return () - -t4 = case mkName "abcde" of - Name (OccName "abcde") NameS -> return () - -main :: IO () -main = do t1; t2; t3; t4 diff --git a/tests/examples/ghc80/T8743a.hs b/tests/examples/ghc80/T8743a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8743a.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T8743a where - -import {-# SOURCE #-} T8743 () diff --git a/tests/examples/ghc80/T8759a.hs b/tests/examples/ghc80/T8759a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8759a.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE PatternSynonyms #-} - -module T8759a where - -foo = [d| pattern Q = False |] diff --git a/tests/examples/ghc80/T8799.hs b/tests/examples/ghc80/T8799.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8799.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module T8555 where -import Data.Coerce - -foo :: Coercible a b => b -> a -foo = coerce - -bar :: (Coercible a b, Coercible b c) => b -> c -> a -bar b c = coerce c diff --git a/tests/examples/ghc80/T8970.hs b/tests/examples/ghc80/T8970.hs deleted file mode 100644 --- a/tests/examples/ghc80/T8970.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T8970 where - -data K = Foo - | Bar - -data D1 :: K -> * where - F1 :: D1 Foo - B1 :: D1 Bar - -class C (a :: K -> *) where - data D2 a :: K -> * - foo :: a k -> D2 a k -> Bool - -instance C D1 where - data D2 D1 k where - F2 :: D2 D1 Foo - B2 :: D2 D1 Bar - foo F1 F2 = True - foo B1 B2 = True diff --git a/tests/examples/ghc80/T9015.hs b/tests/examples/ghc80/T9015.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9015.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Main where - -import GHC -import DynFlags -import System.Environment -import GhcMonad - -testStrings = [ - "import Data.Maybe" - , "import qualified Data.Maybe" - , "import Data.Maybe (isJust)" - - , "add a b = a+b" - , "data Foo = Foo String" - , "deriving instance Show Foo" - , "{-# NOVECTORISE foo #-}" - , "{-# WARNING Foo \"Just a warning\" #-}" - , "{-# ANN foo (Just \"Hello\") #-}" - , "{-# RULES \"map/map\" forall f g xs. map f (map g xs) = map (f.g) xs #-}" - , "class HasString a where\n\ - \ update :: a -> (String -> String) -> a\n\ - \ upcase :: a -> a\n\ - \ upcase x = update x (fmap toUpper)\n\ - \ content :: a -> String\n\ - \ default content :: Show a => a -> String\n\ - \ content = show" - , "instance HasString Foo where\n\ - \ update (Foo s) f = Foo (f s)\n\ - \ content (Foo s) = s" - - , "add a b" - , "let foo = add a b" - , "x <- foo y" - , "5 + 8" - - , "a <-" - , "2 +" - , "@#" - ] - -main = do - [libdir] <- getArgs - runGhc (Just libdir) $ do - liftIO (putStrLn "Is import:") - testWithParser isImport - - liftIO (putStrLn "Is declaration:") - testWithParser isDecl - - liftIO (putStrLn "Is statement:") - testWithParser isStmt - - where - testWithParser parser = do - dflags <- getSessionDynFlags - liftIO . putStrLn . unlines $ map (testExpr (parser dflags)) testStrings - - testExpr parser expr = do - expr ++ ": " ++ show (parser expr) diff --git a/tests/examples/ghc80/T9017.hs b/tests/examples/ghc80/T9017.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9017.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PolyKinds #-} - -module T9017 where - -import Control.Arrow - -foo :: a b (m b) -foo = arr return diff --git a/tests/examples/ghc80/T9177a.hs b/tests/examples/ghc80/T9177a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9177a.hs +++ /dev/null @@ -1,6 +0,0 @@ -module T9177a where - -foo3 = bar -foo4 = Fun - - diff --git a/tests/examples/ghc80/T9204a.hs b/tests/examples/ghc80/T9204a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9204a.hs +++ /dev/null @@ -1,2 +0,0 @@ -module T9204a where -import {-# SOURCE #-} T9204 diff --git a/tests/examples/ghc80/T9204b.hs b/tests/examples/ghc80/T9204b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9204b.hs +++ /dev/null @@ -1,5 +0,0 @@ -module T9204b where - -import T9204b2 - -data P a = P diff --git a/tests/examples/ghc80/T9204b2.hs b/tests/examples/ghc80/T9204b2.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9204b2.hs +++ /dev/null @@ -1,3 +0,0 @@ -module T9204b2 where - -import {-# SOURCE #-} T9204b diff --git a/tests/examples/ghc80/T9233.hs b/tests/examples/ghc80/T9233.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9233.hs +++ /dev/null @@ -1,12 +0,0 @@ -module T9233 where - -import T9233a -import Data.Functor.Identity - -upds :: (Monad m) => [String -> Options -> m Options] -upds = [ - \a o -> return o { flags = (flags o) { f1 = splitComma a ++ " " ++ f1 (flags o) } } - ] - -setAll :: Options -> Options -setAll _ = (getOpt upds :: Identity ()) `seq` undefined diff --git a/tests/examples/ghc80/T9233a.hs b/tests/examples/ghc80/T9233a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9233a.hs +++ /dev/null @@ -1,128 +0,0 @@ -module T9233a where - - -data X = X { - f1 :: String, - f2 :: !Bool, - f3 :: !Bool, - f4 :: !Bool, - f5 :: !Bool, - f6 :: !Bool, - f7 :: !Bool, - f8 :: !Bool, - f9 :: !Bool, - f10 :: !Bool, - f11 :: !Bool, - f12 :: !Bool, - f13 :: !Bool, - f14 :: !Bool, - f15 :: !Bool, - f16 :: !Bool, - f17 :: !Bool, - f18 :: !Bool, - f19 :: !Bool, - f20 :: !Bool, - f21 :: !Bool, - f22 :: !Bool, - f23 :: !Bool, - f24 :: !Bool, - f25 :: !Bool, - f26 :: !Bool, - f27 :: !Bool, - f28 :: !Bool, - f29 :: !Bool, - f30 :: !Bool, - f31 :: !Bool, - f32 :: !Bool, - f33 :: !Bool, - f34 :: !Bool, - f35 :: !Bool, - f36 :: !Bool, - f37 :: !Bool, - f38 :: !Bool, - f39 :: !Bool, - f40 :: !Bool, - f41 :: !Bool, - f42 :: !Bool, - f43 :: !Bool, - f44 :: !Bool, - f45 :: !Bool, - f46 :: !Bool, - f47 :: !Bool, - f48 :: !Bool, - f49 :: !Bool, - f50 :: !Bool, - f51 :: !Bool, - f52 :: !Bool, - f53 :: !Bool, - f54 :: !Bool, - f55 :: !Bool, - f56 :: !Bool, - f57 :: !Bool, - f58 :: !Bool, - f59 :: !Bool, - f60 :: !Bool, - f61 :: !Bool, - f62 :: !Bool, - f63 :: !Bool, - f64 :: !Bool, - f65 :: !Bool, - f66 :: !Bool, - f67 :: !Bool, - f68 :: !Bool, - f69 :: !Bool, - f70 :: !Bool, - f71 :: !Bool, - f72 :: !Bool, - f73 :: !Bool, - f74 :: !Bool, - f75 :: !Bool, - f76 :: !Bool, - f77 :: !Bool, - f78 :: !Bool, - f79 :: !Bool, - f80 :: !Bool, - f81 :: !Bool, - f82 :: !Bool, - f83 :: !Bool, - f84 :: !Bool, - f85 :: !Bool, - f86 :: !Bool, - f87 :: !Bool, - f88 :: !Bool, - f89 :: !Bool, - f90 :: !Bool, - f91 :: !Bool, - f92 :: !Bool, - f93 :: !Bool, - f94 :: !Bool, - f95 :: !Bool, - f96 :: !Bool, - f97 :: !Bool, - f98 :: !Bool, - f99 :: !Bool, - f100 :: !Bool - } - -data Options = Options { - flags :: !X, - o2 :: !Bool, - o3 :: !Bool, - o4 :: !Bool, - o5 :: !Bool, - o6 :: !Bool, - o7 :: !Bool, - o8 :: !Bool, - o9 :: !Bool, - o10 :: !Bool, - o11 :: !Bool, - o12 :: !Bool - } - -splitComma :: String -> String -splitComma _ = "a" -{-# NOINLINE splitComma #-} - -getOpt :: Monad m => [String -> Options -> m Options] -> m () -getOpt _ = return () -{-# NOINLINE getOpt #-} diff --git a/tests/examples/ghc80/T9238.hs b/tests/examples/ghc80/T9238.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9238.hs +++ /dev/null @@ -1,16 +0,0 @@ -compareDouble :: Double -> Double -> Ordering -compareDouble x y = - case (isNaN x, isNaN y) of - (True, True) -> EQ - (True, False) -> LT - (False, True) -> GT - (False, False) -> - -- Make -0 less than 0 - case (x == 0, y == 0, isNegativeZero x, isNegativeZero y) of - (True, True, True, False) -> LT - (True, True, False, True) -> GT - _ -> x `compare` y - -main = do - let l = [-0, 0] - print [ (x, y, compareDouble x y) | x <- l, y <- l ] diff --git a/tests/examples/ghc80/T9260.hs b/tests/examples/ghc80/T9260.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9260.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE DataKinds, TypeOperators, GADTs #-} - -module T9260 where - -import GHC.TypeLits - -data Fin n where - Fzero :: Fin (n + 1) - Fsucc :: Fin n -> Fin (n + 1) - -test :: Fin 1 -test = Fsucc Fzero - -{- Only the second error is legitimate. - -% ghc --version -The Glorious Glasgow Haskell Compilation System, version 7.8.2 -% ghc -ignore-dot-ghci /tmp/Error.hs -[1 of 1] Compiling Error ( /tmp/Error.hs, /tmp/Error.o ) - -/tmp/Error.hs:12:8: - Couldn't match type ‘0’ with ‘1’ - Expected type: Fin 1 - Actual type: Fin (0 + 1) - In the expression: Fsucc Fzero - In an equation for ‘test’: test = Fsucc Fzero - -/tmp/Error.hs:12:14: - Couldn't match type ‘1’ with ‘0’ - Expected type: Fin 0 - Actual type: Fin (0 + 1) - In the first argument of ‘Fsucc’, namely ‘Fzero’ - In the expression: Fsucc Fzero --} diff --git a/tests/examples/ghc80/T9430.hs b/tests/examples/ghc80/T9430.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9430.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} - -module Main where - -import GHC.Exts - -checkI - :: (Int, Int) -- ^ expected results - -> (Int# -> Int# -> (# Int#, Int# #)) -- ^ primop - -> Int -- ^ first argument - -> Int -- ^ second argument - -> Maybe String -- ^ maybe error -checkI (expX, expY) op (I# a) (I# b) = - case op a b of - (# x, y #) - | I# x == expX && I# y == expY -> Nothing - | otherwise -> - Just $ - "Expected " ++ show expX ++ " and " ++ show expY - ++ " but got " ++ show (I# x) ++ " and " ++ show (I# y) -checkW - :: (Word, Word) -- ^ expected results - -> (Word# -> Word# -> (# Word#, Word# #)) -- ^ primop - -> Word -- ^ first argument - -> Word -- ^ second argument - -> Maybe String -- ^ maybe error -checkW (expX, expY) op (W# a) (W# b) = - case op a b of - (# x, y #) - | W# x == expX && W# y == expY -> Nothing - | otherwise -> - Just $ - "Expected " ++ show expX ++ " and " ++ show expY - ++ " but got " ++ show (W# x) ++ " and " ++ show (W# y) - -checkW2 - :: (Word, Word) -- ^ expected results - -> (Word# -> Word# -> Word# -> (# Word#, Word# #)) - -- ^ primop - -> Word -- ^ first argument - -> Word -- ^ second argument - -> Word -- ^ third argument - -> Maybe String -- ^ maybe error -checkW2 (expX, expY) op (W# a) (W# b) (W# c) = - case op a b c of - (# x, y #) - | W# x == expX && W# y == expY -> Nothing - | otherwise -> - Just $ - "Expected " ++ show expX ++ " and " ++ show expY - ++ " but got " ++ show (W# x) ++ " and " ++ show (W# y) - -check :: String -> Maybe String -> IO () -check s (Just err) = error $ "Error for " ++ s ++ ": " ++ err -check _ Nothing = return () - -main :: IO () -main = do - -- First something trivial - check "addIntC# maxBound 0" $ checkI (maxBound, 0) addIntC# maxBound 0 - check "addIntC# 0 maxBound" $ checkI (maxBound, 0) addIntC# 0 maxBound - -- Overflows - check "addIntC# maxBound 1" $ checkI (minBound, 1) addIntC# maxBound 1 - check "addIntC# 1 maxBound" $ checkI (minBound, 1) addIntC# 1 maxBound - check "addIntC# maxBound 2" $ checkI (minBound + 1, 1) addIntC# maxBound 2 - check "addIntC# 2 maxBound" $ checkI (minBound + 1, 1) addIntC# 2 maxBound - check "addIntC# minBound minBound" $ - checkI (0, 1) addIntC# minBound minBound - - -- First something trivial - check "subIntC# minBound 0" $ checkI (minBound, 0) subIntC# minBound 0 - -- Overflows - check "subIntC# minBound 1" $ checkI (maxBound, 1) subIntC# minBound 1 - check "subIntC# minBound 1" $ checkI (maxBound - 1, 1) subIntC# minBound 2 - check "subIntC# 0 minBound" $ checkI (minBound, 1) subIntC# 0 minBound - check "subIntC# -1 minBound" $ checkI (maxBound, 0) subIntC# (-1) minBound - check "subIntC# minBound -1" $ - checkI (minBound + 1, 0) subIntC# minBound (-1) - - -- First something trivial (note that the order of results is different!) - check "plusWord2# maxBound 0" $ checkW (0, maxBound) plusWord2# maxBound 0 - check "plusWord2# 0 maxBound" $ checkW (0, maxBound) plusWord2# 0 maxBound - -- Overflows - check "plusWord2# maxBound 1" $ - checkW (1, minBound) plusWord2# maxBound 1 - check "plusWord2# 1 maxBound" $ - checkW (1, minBound) plusWord2# 1 maxBound - check "plusWord2# maxBound 2" $ - checkW (1, minBound + 1) plusWord2# maxBound 2 - check "plusWord2# 2 maxBound" $ - checkW (1, minBound + 1) plusWord2# 2 maxBound - - check "timesWord2# maxBound 0" $ checkW (0, 0) timesWord2# maxBound 0 - check "timesWord2# 0 maxBound" $ checkW (0, 0) timesWord2# 0 maxBound - check "timesWord2# maxBound 1" $ checkW (0, maxBound) timesWord2# maxBound 1 - check "timesWord2# 1 maxBound" $ checkW (0, maxBound) timesWord2# 1 maxBound - -- Overflows - check "timesWord2# " $ checkW (1, 0) timesWord2# (2 ^ 63) 2 - check "timesWord2# " $ checkW (2, 0) timesWord2# (2 ^ 63) (2 ^ 2) - check "timesWord2# " $ checkW (4, 0) timesWord2# (2 ^ 63) (2 ^ 3) - check "timesWord2# " $ checkW (8, 0) timesWord2# (2 ^ 63) (2 ^ 4) - check "timesWord2# maxBound 2" $ - checkW (1, maxBound - 1) timesWord2# maxBound 2 - check "timesWord2# 2 maxBound" $ - checkW (1, maxBound - 1) timesWord2# 2 maxBound - check "timesWord2# maxBound 3" $ - checkW (2, maxBound - 2) timesWord2# maxBound 3 - check "timesWord2# 3 maxBound" $ - checkW (2, maxBound - 2) timesWord2# 3 maxBound - - check "quotRemWord2# 0 0 1" $ checkW2 (0, 0) quotRemWord2# 0 0 1 - check "quotRemWord2# 0 4 2" $ checkW2 (2, 0) quotRemWord2# 0 4 2 - check "quotRemWord2# 0 7 3" $ checkW2 (2, 1) quotRemWord2# 0 7 3 - check "quotRemWord2# 1 0 (2 ^ 63)" $ - checkW2 (2, 0) quotRemWord2# 1 0 (2 ^ 63) - check "quotRemWord2# 1 1 (2 ^ 63)" $ - checkW2 (2, 1) quotRemWord2# 1 1 (2 ^ 63) - check "quotRemWord2# 1 0 maxBound" $ - checkW2 (1, 1) quotRemWord2# 1 0 maxBound - check "quotRemWord2# 2 0 maxBound" $ - checkW2 (2, 2) quotRemWord2# 2 0 maxBound - check "quotRemWord2# 1 maxBound maxBound" $ - checkW2 (2, 1) quotRemWord2# 1 maxBound maxBound - check "quotRemWord2# (2 ^ 63) 0 maxBound" $ - checkW2 (2 ^ 63, 2 ^ 63) quotRemWord2# (2 ^ 63) 0 maxBound - check "quotRemWord2# (2 ^ 63) maxBound maxBound" $ - checkW2 (2 ^ 63 + 1, 2 ^ 63) quotRemWord2# (2 ^ 63) maxBound maxBound diff --git a/tests/examples/ghc80/T9554.hs b/tests/examples/ghc80/T9554.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9554.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TypeFamilies, UndecidableInstances #-} - -module T9554 where - -import Data.Proxy - -type family F a where - F a = F (F a) - -foo :: Proxy (F Bool) -> Proxy (F Int) -foo x = x - -main = case foo Proxy of Proxy -> putStrLn "Made it!" diff --git a/tests/examples/ghc80/T9600-1.hs b/tests/examples/ghc80/T9600-1.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9600-1.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -import Control.Applicative - -newtype Foo a = Foo (a -> a) deriving Applicative diff --git a/tests/examples/ghc80/T9600.hs b/tests/examples/ghc80/T9600.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9600.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Control.Applicative - -newtype Foo a = Foo (a -> a) deriving Applicative diff --git a/tests/examples/ghc80/T9824.hs b/tests/examples/ghc80/T9824.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9824.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# OPTIONS_GHC -fwarn-unused-matches #-} - -module T9824 where - -foo = [p| (x, y) |] diff --git a/tests/examples/ghc80/T9839_02.hs b/tests/examples/ghc80/T9839_02.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9839_02.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = return () diff --git a/tests/examples/ghc80/T9839_03.hs b/tests/examples/ghc80/T9839_03.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9839_03.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = return () diff --git a/tests/examples/ghc80/T9839_04.hs b/tests/examples/ghc80/T9839_04.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9839_04.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = return () diff --git a/tests/examples/ghc80/T9839_05.hs b/tests/examples/ghc80/T9839_05.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9839_05.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = return () diff --git a/tests/examples/ghc80/T9839_06.hs b/tests/examples/ghc80/T9839_06.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9839_06.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = return () diff --git a/tests/examples/ghc80/T9840.hs b/tests/examples/ghc80/T9840.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9840.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T9840 where - -import T9840a - -type family X :: * -> * where - -type family F (a :: * -> *) where - -foo :: G (F X) -> G (F X) -foo x = x diff --git a/tests/examples/ghc80/T9840a.hs b/tests/examples/ghc80/T9840a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9840a.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module T9840a where - -import {-# SOURCE #-} T9840 - -type family G a where - -bar :: X a -> X a -bar = id diff --git a/tests/examples/ghc80/T9858a.hs b/tests/examples/ghc80/T9858a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9858a.hs +++ /dev/null @@ -1,35 +0,0 @@ --- From comment:76 in Trac #9858 --- This exploit still works in GHC 7.10.1. --- By Shachaf Ben-Kiki, Ørjan Johansen and Nathan van Doorn - -{-# LANGUAGE Safe #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ImpredicativeTypes #-} - -module T9858a where - -import Data.Typeable - -type E = (:~:) -type PX = Proxy (((),()) => ()) -type PY = Proxy (() -> () -> ()) - -data family F p a b - -newtype instance F a b PX = ID (a -> a) -newtype instance F a b PY = UC (a -> b) - -{-# NOINLINE ecast #-} -ecast :: E p q -> f p -> f q -ecast Refl = id - -supercast :: F a b PX -> F a b PY -supercast = case cast e of - Just e' -> ecast e' - where - e = Refl - e :: E PX PX - -uc :: a -> b -uc = case supercast (ID id) of UC f -> f diff --git a/tests/examples/ghc80/T9858b.hs b/tests/examples/ghc80/T9858b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9858b.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE FlexibleContexts #-} - -module T9858b where -import Data.Typeable - -test = typeRep (Proxy :: Proxy (Eq Int => Int)) - - - diff --git a/tests/examples/ghc80/T9858c.hs b/tests/examples/ghc80/T9858c.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9858c.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -module Main(main) where - -import Data.Typeable -import GHC.Exts - -test1 :: Bool -test1 = typeRep (Proxy :: Proxy (() :: *)) == - typeRep (Proxy :: Proxy (() :: Constraint)) - -test2 :: Bool -test2 = typeRepTyCon (typeRep (Proxy :: Proxy (Int,Int))) == - typeRepTyCon (typeRep (Proxy :: Proxy (Eq Int, Eq Int))) - -main :: IO () -main = print (test1,test2) - - - diff --git a/tests/examples/ghc80/T9858d.hs b/tests/examples/ghc80/T9858d.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9858d.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module Main where - -import Data.Typeable - -data A = A - -main = print $ typeRep (Proxy :: Proxy A) == typeRep (Proxy :: Proxy 'A) diff --git a/tests/examples/ghc80/T9858e.hs b/tests/examples/ghc80/T9858e.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9858e.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE ImpredicativeTypes, FlexibleContexts #-} - -module T9858e where -import Data.Typeable - -i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep -i p = typeRep p - -j = i (Proxy :: Proxy (Eq Int => Int)) diff --git a/tests/examples/ghc80/T9867.hs b/tests/examples/ghc80/T9867.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9867.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-} - -module T9867 where - -pattern Nil = [] :: [a] diff --git a/tests/examples/ghc80/T9878b.hs b/tests/examples/ghc80/T9878b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9878b.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE StaticPointers #-} -module T9878b where - -import GHC.StaticPtr - -f = deRefStaticPtr (static True) diff --git a/tests/examples/ghc80/T9938.hs b/tests/examples/ghc80/T9938.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9938.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -import Control.Monad -import Control.Monad.Trans.State - -solve :: Int -> StateT () [] () -solve carry | carry > 0 = - do guard (0 == carry) - solve (carry -1) -solve 0 = mzero - -main :: IO () -main = return () diff --git a/tests/examples/ghc80/T9938B.hs b/tests/examples/ghc80/T9938B.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9938B.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Main where - -import Control.Monad -import Control.Monad.Trans.State - -solve :: Int -> StateT () [] () -solve 0 = mzero -solve carry | carry > 0 = - do guard (0 == carry) - solve (carry -1) - -main :: IO () -main = return () diff --git a/tests/examples/ghc80/T9939.hs b/tests/examples/ghc80/T9939.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9939.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE GADTs #-} - -module T9939 where - -f1 :: (Eq a, Ord a) => a -> a -> Bool --- Eq a redundant -f1 x y = (x == y) && (x > y) - -f2 :: (Eq a, Ord a) => a -> a -> Bool --- Ord a redundant, but Eq a is reported -f2 x y = (x == y) - -f3 :: (Eq a, a ~ b, Eq b) => a -> b -> Bool --- Eq b redundant -f3 x y = x==y - -data Equal a b where - EQUAL :: Equal a a - -f4 :: (Eq a, Eq b) => a -> b -> Equal a b -> Bool --- Eq b redundant -f4 x y EQUAL = y==y - diff --git a/tests/examples/ghc80/T9951.hs b/tests/examples/ghc80/T9951.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9951.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T9951 where - -f :: [a] -> () -f x = case x of - [] -> () - (_:_) -> () - diff --git a/tests/examples/ghc80/T9951b.hs b/tests/examples/ghc80/T9951b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9951b.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T9951b where - -f :: String -> Bool -f "ab" = True diff --git a/tests/examples/ghc80/T9964.hs b/tests/examples/ghc80/T9964.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9964.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE UnboxedTuples #-} -module T9964 where - -import GHC.Base - -crash :: IO () -crash = IO (\s -> - let - {-# NOINLINE s' #-} - s' = s - in (# s', () #)) diff --git a/tests/examples/ghc80/T9968.hs b/tests/examples/ghc80/T9968.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9968.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-} - -module T9968 where - -class C a b -data X = X deriving (C Int) - diff --git a/tests/examples/ghc80/T9968a.hs b/tests/examples/ghc80/T9968a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9968a.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} - -module T9968 where - -import Data.Bifunctor - -data Blah a b = A a | B b - deriving (Bifunctor) diff --git a/tests/examples/ghc80/T9973.hs b/tests/examples/ghc80/T9973.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9973.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# OPTIONS_GHC -fwarn-redundant-constraints #-} - -module T9973 where - -duplicateDecl :: (Eq t) => t -> IO () --- Trac #9973 was a bogus "redundant constraint" here -duplicateDecl sigs - = do { newSpan <- return typeSig - - -- **** commenting out the next three lines causes the original warning to disappear - ; let rowOffset = case typeSig of { _ -> 1 } - - ; undefined } - where - typeSig = definingSigsNames sigs - - -definingSigsNames :: (Eq t) => t -> () -definingSigsNames x = undefined - where - _ = x == x -- Suppress the complaint on this - diff --git a/tests/examples/ghc80/T9975a.hs b/tests/examples/ghc80/T9975a.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9975a.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternSynonyms #-} -module T9975a where - -data Test = Test { x :: Int } -pattern Test wat = Test { x = wat } - diff --git a/tests/examples/ghc80/T9975b.hs b/tests/examples/ghc80/T9975b.hs deleted file mode 100644 --- a/tests/examples/ghc80/T9975b.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternSynonyms #-} -module T9975b where - -data Test = Test { x :: Int } -pattern PTest wat = Test { x = wat } - diff --git a/tests/examples/ghc80/TH_abstractFamily.hs b/tests/examples/ghc80/TH_abstractFamily.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_abstractFamily.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module TH_abstractFamily where - -import Language.Haskell.TH - --- Empty closed type families are okay... -ds1 :: Q [Dec] -ds1 = [d| type family F a where |] - --- ...but abstract ones should result in a type error -ds2 :: Q [Dec] -ds2 = [d| type family G a where .. |] diff --git a/tests/examples/ghc80/TH_bracket1.hs b/tests/examples/ghc80/TH_bracket1.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_bracket1.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- Check that declarations in a bracket shadow the top-level --- declarations, rather than clashing with them. - -module TH_bracket1 where - -foo = 1 -bar = [d| foo = 1 |] diff --git a/tests/examples/ghc80/TH_bracket2.hs b/tests/examples/ghc80/TH_bracket2.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_bracket2.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module TH_bracket2 where - -d_show = [d| data A = A - - instance Show A where - show _ = "A" - |] diff --git a/tests/examples/ghc80/TH_bracket3.hs b/tests/examples/ghc80/TH_bracket3.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_bracket3.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskellQuotes #-} - -module TH_bracket3 where - -d_class = [d| class Classy a b where - f :: a -> b - - instance Classy Int Bool where - f x = if x == 0 then True else False - |] diff --git a/tests/examples/ghc80/TH_finalizer.hs b/tests/examples/ghc80/TH_finalizer.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_finalizer.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module ShouldCompile where - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -$( do - addModFinalizer (do b <- getQ; reportWarning (show (b::Maybe Bool))) - return [] ) -$( putQ True >> return [] ) diff --git a/tests/examples/ghc80/TH_localname.hs b/tests/examples/ghc80/TH_localname.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_localname.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module TH_localname where - -x = \y -> [| y |] diff --git a/tests/examples/ghc80/TH_namePackage.hs b/tests/examples/ghc80/TH_namePackage.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_namePackage.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Language.Haskell.TH - -eitherName, fooName, moduleFooName :: Name -eitherName = ''Either -fooName = mkName "foo" -moduleFooName = mkName "Module.foo" - -main :: IO () -main = do - print $ nameBase eitherName - print $ nameBase fooName - print $ nameBase moduleFooName - - print $ nameModule eitherName - print $ nameModule fooName - print $ nameModule moduleFooName - - print $ namePackage eitherName - print $ namePackage fooName - print $ namePackage moduleFooName diff --git a/tests/examples/ghc80/TH_nameSpace.hs b/tests/examples/ghc80/TH_nameSpace.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_nameSpace.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Data.Maybe (Maybe(..)) -import Data.Ord (Ord) -import Language.Haskell.TH (mkName, nameSpace) - -main :: IO () -main = mapM_ (print . nameSpace) - [ 'Prelude.id - , mkName "id" - , 'Data.Maybe.Just - , ''Data.Maybe.Maybe - , ''Data.Ord.Ord - ] diff --git a/tests/examples/ghc80/TH_ppr1.hs b/tests/examples/ghc80/TH_ppr1.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_ppr1.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Main (main) where - -import Language.Haskell.TH - -u1 :: a -u1 = undefined - -u2 :: a -u2 = undefined - -f :: a -f = undefined - -(.+.) :: a -(.+.) = undefined - -main :: IO () -main = do runQ [| f u1 u2 |] >>= p - runQ [| u1 `f` u2 |] >>= p - runQ [| (.+.) u1 u2 |] >>= p - runQ [| u1 .+. u2 |] >>= p - runQ [| (:) u1 u2 |] >>= p - runQ [| u1 : u2 |] >>= p - runQ [| \((:) x xs) -> x |] >>= p - runQ [| \(x : xs) -> x |] >>= p - runQ [d| class Foo a b where - foo :: a -> b |] >>= p - runQ [| \x -> (x, 1 `x` 2) |] >>= p - runQ [| \(+) -> ((+), 1 + 2) |] >>= p - runQ [| (f, 1 `f` 2) |] >>= p - runQ [| ((.+.), 1 .+. 2) |] >>= p - -p :: Ppr a => a -> IO () -p = putStrLn . pprint - diff --git a/tests/examples/ghc80/TH_reifyType1.hs b/tests/examples/ghc80/TH_reifyType1.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_reifyType1.hs +++ /dev/null @@ -1,13 +0,0 @@ --- test reification of monomorphic types - -module TH_reifyType1 -where - -import Language.Haskell.TH - -foo :: Int -> Int -foo x = x + 1 - -type_foo :: InfoQ -type_foo = reify 'foo - diff --git a/tests/examples/ghc80/TH_reifyType2.hs b/tests/examples/ghc80/TH_reifyType2.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_reifyType2.hs +++ /dev/null @@ -1,9 +0,0 @@ --- test reification of polymorphic types - -module TH_reifyType1 -where - -import Language.Haskell.TH - -type_length :: InfoQ -type_length = reify 'length diff --git a/tests/examples/ghc80/TH_repE1.hs b/tests/examples/ghc80/TH_repE1.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_repE1.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- test the representation of literals and also explicit type annotations - -module TH_repE1 -where - -import Language.Haskell.TH - -integralExpr :: ExpQ -integralExpr = [| 42 |] - -intExpr :: ExpQ -intExpr = [| 42 :: Int |] - -integerExpr :: ExpQ -integerExpr = [| 42 :: Integer |] - -charExpr :: ExpQ -charExpr = [| 'x' |] - -stringExpr :: ExpQ -stringExpr = [| "A String" |] - -fractionalExpr :: ExpQ -fractionalExpr = [| 1.2 |] - -floatExpr :: ExpQ -floatExpr = [| 1.2 :: Float |] - -doubleExpr :: ExpQ -doubleExpr = [| 1.2 :: Double |] diff --git a/tests/examples/ghc80/TH_repE3.hs b/tests/examples/ghc80/TH_repE3.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_repE3.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- test the representation of literals and also explicit type annotations - -module TH_repE1 -where - -import Language.Haskell.TH - -emptyListExpr :: ExpQ -emptyListExpr = [| [] |] - -singletonListExpr :: ExpQ -singletonListExpr = [| [4] |] - -listExpr :: ExpQ -listExpr = [| [4,5,6] |] - -consExpr :: ExpQ -consExpr = [| 4:5:6:[] |] - diff --git a/tests/examples/ghc80/TH_scope.hs b/tests/examples/ghc80/TH_scope.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_scope.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} --- Test for Trac #2188 - -module TH_scope where - -f g = [d| f :: Int - f = g - g :: Int - g = 4 |] diff --git a/tests/examples/ghc80/TH_spliceE5_prof_ext.hs b/tests/examples/ghc80/TH_spliceE5_prof_ext.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_spliceE5_prof_ext.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module Main where - -import TH_spliceE5_prof_ext_Lib - -v1 = "foo" - -main = putStrLn $(expandVars ["v1","v2"]) --- The splice expands to refer to both v1 and v2, --- and the test checks that we don't dependency-analyse --- the program so that one or the other isn't in scope --- to the type checker - - -v2 = "bar" diff --git a/tests/examples/ghc80/TH_spliceE5_prof_ext_Lib.hs b/tests/examples/ghc80/TH_spliceE5_prof_ext_Lib.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_spliceE5_prof_ext_Lib.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} -module TH_spliceE5_prof_ext_Lib where - -import Language.Haskell.TH - -expandVars :: [String] -> Q Exp -expandVars s = [| concat $(return (ListE (map f s))) |] - where - f x = VarE (mkName x) diff --git a/tests/examples/ghc80/TH_tf2.hs b/tests/examples/ghc80/TH_tf2.hs deleted file mode 100644 --- a/tests/examples/ghc80/TH_tf2.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -- 'bar' is ambiguous - -module TH_tf2 where - -{- -$( [d| class C a where - data T a - foo :: Bool -> T a |] ) - -$( [d| instance C Int where - data T Int = TInt Bool - foo b = TInt (b && b) |] ) - -$( [d| instance C Float where - data T Float = TFloat {flag :: Bool} - foo b = TFloat {flag = b && b} |] ) --} - -class D a where - type S a - bar :: S a -> Int - -instance D Int where - type S Int = Bool - bar c = if c then 1 else 2 diff --git a/tests/examples/ghc80/TcCustomSolverSuper.hs b/tests/examples/ghc80/TcCustomSolverSuper.hs deleted file mode 100644 --- a/tests/examples/ghc80/TcCustomSolverSuper.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -module TcCustomSolverSuper where - -import GHC.TypeLits -import Data.Typeable - -{- - -When solving super-class instances, GHC solves the evidence without -using the solver (see `tcSuperClasses` in `TcInstDecls`). - -However, some classes need to be excepted from this behavior, -as they have custom solving rules, and this test checks that -we got this right. --} - - -class (Typeable x, KnownNat x) => C x -class (Typeable x, KnownSymbol x) => D x - -instance C 2 -instance D "2" - diff --git a/tests/examples/ghc80/Templates.hs b/tests/examples/ghc80/Templates.hs deleted file mode 100644 --- a/tests/examples/ghc80/Templates.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeFamilies, FlexibleInstances, OverlappingInstances, TypeOperators, PatternGuards #-} -module Object.Templates( - makeName, - makeObject, - makeObjectFlexible - ) where - -import Object.Letters -import Object.Types - -import Prelude hiding ((.)) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax -import Data.Char -import Data.Maybe - --- | --- implements 'makeObject' or 'makeObjectFlexible' depending on the first argument -makeObject' :: Bool -> Name -> Q [Dec] -makeObject' flexible name = go name where - go :: Name -> Q [Dec] - go obj = do - (name, vars, fields) <- reify name >>= getInfo - let objType = foldl AppT (ConT name) (VarT<*vars) - outputDecls <- if flexible - then return [] - else [d| - type instance Output $(return objType) (Method m) = - MethodOutput $(return objType) (Method m) - type instance Output $(return objType) (Method m := input) = - MethodOutput $(return objType) (Method m := input) - |] - fieldDecls <- (sequence $ makeField name vars <* fields) *> concat - return $ outputDecls ++ fieldDecls --- "(Object.Example.Foo,[x_1627454179],[(Object.Example._bar,NotStrict,ConT GHC.Types.Int),(Object.Example._baz,NotStrict,ConT GHC.Types.Char),(Object.Example._blub,NotStrict,VarT x_1627454179)])" - makeField :: Name -> [Name] -> VarStrictType -> Q [Dec] - makeField _ _ (name,_,_) | '_' /= head (nameBase name) = fail $ show name ++ " did not start with underscore" - makeField name vars (fName, _, fType) = do - (decs1,(typeName,dataName)) <- makeName' (tail $ nameBase fName) - methodOutput <- lookupTypeName "Object.Types.MethodOutput" *> fromMaybe (error "no MethodOutput in scope") - let objType = foldl AppT (ConT name) (VarT<*vars) - - let methodOutInst = TySynInstD methodOutput $ TySynEqn [objType, ConT typeName] fType - actionInst <- [d| - instance Action $(return objType) $(return $ ConT typeName) where - object . _ = $(return $ VarE fName) object - |] - - matchType <- [t| $(return $ ConT typeName) := $(return $ VarT $ mkName "value") |] - let methodSetOutInst = TySynInstD methodOutput $ TySynEqn [objType, matchType] objType - actionSetInst <- [d| - instance (value ~ $(return fType)) => Action $(return objType) $(return matchType) where - object . ( _ := v) = $(recUpdE [e|object|] [return (fName, VarE $ mkName "v")]) - |] - - return $ [methodOutInst,methodSetOutInst] ++ actionInst ++ actionSetInst ++ decs1 - diff --git a/tests/examples/ghc80/Test.hs b/tests/examples/ghc80/Test.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Test where - -import QQ - -f' = f . (+ 1) - -[pq| foo |] -- Expands to f :: Int -> Int -f x = x + 1 diff --git a/tests/examples/ghc80/Test10255.hs b/tests/examples/ghc80/Test10255.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10255.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Test10255 where - -import Data.Maybe - -fob (f :: (Maybe t -> Int)) = - undefined diff --git a/tests/examples/ghc80/Test10268.hs b/tests/examples/ghc80/Test10268.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10268.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TemplateHaskell,TypeOperators,DataKinds #-} - -module Test10268 where - -th = $footemplate - -give :: b -> Pattern '[b] a -give = undefined - -pfail :: Pattern '[] a -pfail = undefined diff --git a/tests/examples/ghc80/Test10269.hs b/tests/examples/ghc80/Test10269.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10269.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Test10269 where - - -(f =*= g) sa i = undefined diff --git a/tests/examples/ghc80/Test10276.hs b/tests/examples/ghc80/Test10276.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10276.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} - -module Test10276 where - -f1 = [| bar |] -f2 = [e| bar |] - -class QQExp a b where - qqExp x = [||fst $ runState $$(qqExpM x) - ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] - -class QQExp2 a b where - qqExp x = [e||fst $ runState $$(qqExpM x) - ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] diff --git a/tests/examples/ghc80/Test10278.hs b/tests/examples/ghc80/Test10278.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10278.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables,GADTs #-} -module Test10278 where - -extremumNewton :: forall tag. forall tag1. tag -> tag1 -> Int -extremumNewton = undefined - -extremumNewton1 :: (Eq a, Fractional a) => - (forall tag. forall tag1. - Tower tag1 (Tower tag a) - -> Tower tag1 (Tower tag a)) - -> a -> [a] -extremumNewton1 f x0 = zeroNewton (diffUU f) x0 - -data MaybeDefault v where - SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v - SetTo2:: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v - SetTo3 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v - {- - SetTo4 :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a]) - -} diff --git a/tests/examples/ghc80/Test10280.hs b/tests/examples/ghc80/Test10280.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10280.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TupleSections #-} -module Test10280 where - -foo2 = atomicModifyIORef ciTokens ((,()) . f) diff --git a/tests/examples/ghc80/Test10307.hs b/tests/examples/ghc80/Test10307.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10307.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Test10307 where - -class Foldable t where - type FoldableConstraint t x :: * - type FoldableConstraint t x = () diff --git a/tests/examples/ghc80/Test10309.hs b/tests/examples/ghc80/Test10309.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10309.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE GADTs #-} -module Test10309 where - -data H1 a b where - C3 :: (Num a) => { field :: a -- ^ hello docs - } -> H1 Int Int diff --git a/tests/examples/ghc80/Test10312.hs b/tests/examples/ghc80/Test10312.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10312.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE ParallelListComp, - TransformListComp, - RecordWildCards #-} -module Test10312 where --- From --- https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html - -import GHC.Exts -import qualified Data.Map as M -import Data.Ord (comparing) -import Data.List (sortBy) - --- Let’s look at a simple, normal list comprehension to start: - -regularListComp :: [Int] -regularListComp = [ x + y * z - | x <- [0..10] - , y <- [10..20] - , z <- [20..30] - ] - -parallelListComp :: [Int] -parallelListComp = [ x + y * z - | x <- [0..10] - | y <- [10..20] - | z <- [20..30] - ] - --- fibs :: [Int] --- fibs = 0 : 1 : zipWith (+) fibs (tail fibs) - -fibs :: [Int] -fibs = 0 : 1 : [ x + y - | x <- fibs - | y <- tail fibs - ] - -fiblikes :: [Int] -fiblikes = 0 : 1 : [ x + y + z - | x <- fibs - | y <- tail fibs - | z <- tail (tail fibs) - ] - --- TransformListComp -data Character = Character - { firstName :: String - , lastName :: String - , birthYear :: Int - } deriving (Show, Eq) - -friends :: [Character] -friends = [ Character "Phoebe" "Buffay" 1963 - , Character "Chandler" "Bing" 1969 - , Character "Rachel" "Green" 1969 - , Character "Joey" "Tribbiani" 1967 - , Character "Monica" "Geller" 1964 - , Character "Ross" "Geller" 1966 - ] - -oldest :: Int -> [Character] -> [String] -oldest k tbl = [ firstName ++ " " ++ lastName - | Character{..} <- tbl - , then sortWith by birthYear - , then take k - ] - -groupByLargest :: Ord b => (a -> b) -> [a] -> [[a]] -groupByLargest f = sortBy (comparing (negate . length)) . groupWith f - -bestBirthYears :: [Character] -> [(Int, [String])] -bestBirthYears tbl = [ (the birthYear, firstName) - | Character{..} <- tbl - , then group by birthYear using groupByLargest - ] - -uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs - , let d' = ppDir d - , then group by Down (p,d') using groupWith ] diff --git a/tests/examples/ghc80/Test10313.hs b/tests/examples/ghc80/Test10313.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10313.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE MagicHash, UnliftedFFITypes #-} -{-# LANGUAGE ForeignFunctionInterface #-} - -module Test10313 where - -import "b\x61se" Data.List - -{-# WARNING Logic - , solverCheckAndGetModel - "New Z3 API support is still incomplete and fragile: \ - \you may experience segmentation faults!" - #-} - -{-# Deprecated Logic - , solverCheckAndGetModel - "Deprecation: \ - \you may experience segmentation faults!" - #-} - -data {-# Ctype "foo\x63" "b\x61r" #-} Logic = Logic - --- Should warn -foo1 x = x -{-# RULES "foo1\x67" [ 1] forall x. foo1 x = x #-} - -foreign import prim unsafe "a\x62" a :: IO Int - -{-# INLINE strictStream #-} -strictStream (Bitstream l v) - = {-# CORE "Strict Bitstream stre\x61m" #-} - S.concatMap stream (GV.stream v) - `S.sized` - Exact l - -b = {-# SCC "foo\x64" #-} 006 - -c = {-# GENERATED "foob\x61r" 1 : 2 - 3 : 4 #-} 0.00 diff --git a/tests/examples/ghc80/Test10354.hs b/tests/examples/ghc80/Test10354.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10354.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -module Test10354 where - -f :: ((Eq a, _)) => a -> a -> Bool -f x y = x == y - -bar :: ( ) => a-> Bool -bar = undefined - -baz :: _ => a -> String -baz = undefined - -foo :: ForceError -foo = undefined diff --git a/tests/examples/ghc80/Test10357.hs b/tests/examples/ghc80/Test10357.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10357.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} -module Test10357 where - -legendres = one : x : - [ multPoly - (poly LE [recip (n' + 1)]) - (addPoly (poly LE [0, 2 * n' + 1] `multPoly` p_n) - (poly LE [-n'] `multPoly` p_nm1) - ) - | n <- [1..], let n' = fromInteger n - | p_n <- tail legendres - | p_nm1 <- legendres - ] diff --git a/tests/examples/ghc80/Test10358.hs b/tests/examples/ghc80/Test10358.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10358.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Test10358 where - -mtGamma x v d = - let !x_2 = x*x; !x_4 = x_2*x_2 - v3 = v*v*v - dv = d * v3 - in 5 diff --git a/tests/examples/ghc80/Test10396.hs b/tests/examples/ghc80/Test10396.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10396.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Test10396 where - -errors :: IO () -errors= do - let ls :: Int = undefined - return () diff --git a/tests/examples/ghc80/Test11018.hs b/tests/examples/ghc80/Test11018.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test11018.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -module Test11018 where - -nonUnicode :: forall a . a -> IO Int -nonUnicode _ = do - x <- readChar - return 4 - --- ^ An opaque ESD handle for recording data from the soundcard via ESD. -data Recorder fr ch (r ∷ * -> *) - = Recorder { - reCloseH :: !(FinalizerHandle r) - } - -f :: Arrow a => a (Int,Int,Int) Int -f = proc (x,y,z) -> returnA -< x+y - -f2 :: Arrow a => a (Int,Int,Int) Int -f2 = proc (x,y,z) -> returnA >- x+y - -g :: ArrowApply a => Int -> a (a Int Int,Int) Int -g y = proc (x,z) -> x -<< 2+y - -g2 :: ArrowApply a => Int -> a (a Int Int,Int) Int -g2 y = proc (x,z) -> x >>- 2+y - --- ------------------------------------- - -unicode ∷ ∀ a . a → IO Int -unicode _ = do - x ← readChar - return 4 - --- ^ An opaque ESD handle for recording data from the soundcard via ESD. -data RecorderU fr ch (r ∷ ★ → ★) - = RecorderU { - reCloseHU ∷ !(FinalizerHandle r) - } - -fU :: Arrow a ⇒ a (Int,Int,Int) Int -fU = proc (x,y,z) -> returnA ⤙ x+y - -f2U :: Arrow a ⇒ a (Int,Int,Int) Int -f2U = proc (x,y,z) -> returnA ⤚ x+y - -gU :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int -gU y = proc (x,z) -> x ⤛ 2+y - -g2U :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int -g2U y = proc (x,z) -> x ⤜ 2+y diff --git a/tests/examples/ghc80/TestBoolFormula.hs b/tests/examples/ghc80/TestBoolFormula.hs deleted file mode 100644 --- a/tests/examples/ghc80/TestBoolFormula.hs +++ /dev/null @@ -1,36 +0,0 @@ -module TestBoolFormula where - -class ManyOps a where - aOp :: a -> a -> Bool - aOp = undefined - bOp :: a -> a -> Bool - bOp = undefined - cOp :: a -> a -> Bool - cOp = undefined - dOp :: a -> a -> Bool - dOp = undefined - eOp :: a -> a -> Bool - eOp = undefined - fOp :: a -> a -> Bool - fOp = undefined - {-# MINIMAL ( aOp) - | ( bOp , cOp) - | ((dOp | eOp) , fOp) - #-} - -class Foo a where - bar :: a -> a -> Bool - foo :: a -> a -> Bool - baq :: a -> a -> Bool - baq = undefined - baz :: a -> a -> Bool - baz = undefined - quux :: a -> a -> Bool - quux = undefined - {-# MINIMAL bar, (foo, baq | foo, quux) #-} - -instance Foo Int where - bar = undefined - baz = undefined - quux = undefined - foo = undefined diff --git a/tests/examples/ghc80/TestUtils.hs b/tests/examples/ghc80/TestUtils.hs deleted file mode 100644 --- a/tests/examples/ghc80/TestUtils.hs +++ /dev/null @@ -1,5 +0,0 @@ - -module Math.NumberTheory.TestUtils where - -class (f `Compose` g) x - diff --git a/tests/examples/ghc80/Trac10045.hs b/tests/examples/ghc80/Trac10045.hs deleted file mode 100644 --- a/tests/examples/ghc80/Trac10045.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Trac10045 where - -newtype Meta = Meta () - -foo (Meta ws1) = - let copy :: _ - copy w from = copy w 1 - in copy ws1 1 diff --git a/tests/examples/ghc80/TransAssociated.hs b/tests/examples/ghc80/TransAssociated.hs deleted file mode 100644 --- a/tests/examples/ghc80/TransAssociated.hs +++ /dev/null @@ -1,9 +0,0 @@ -module TransAssociated(A(..)) where - -import Associated (A(..)) - -foo = MkA 5 -baz = NoA - -qux (MkA x) = x -qux NoA = 0 diff --git a/tests/examples/ghc80/TransBundle.hs b/tests/examples/ghc80/TransBundle.hs deleted file mode 100644 --- a/tests/examples/ghc80/TransBundle.hs +++ /dev/null @@ -1,9 +0,0 @@ -module TransAssociated(A(..)) where - -import Bundle (A(..)) - -foo = MkA 5 -baz = NoA - -qux (MkA x) = x -qux NoA = 0 diff --git a/tests/examples/ghc80/TypeFamilyInstanceLHS.hs b/tests/examples/ghc80/TypeFamilyInstanceLHS.hs deleted file mode 100644 --- a/tests/examples/ghc80/TypeFamilyInstanceLHS.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module TypeFamilyInstanceLHS where - -type family F (a :: *) (b :: *) :: * -type instance F Int _ = Int -type instance F Bool _ = Bool - -foo :: F Int Char -> Int -foo = id diff --git a/tests/examples/ghc80/TypeLevelVec.hs b/tests/examples/ghc80/TypeLevelVec.hs deleted file mode 100644 --- a/tests/examples/ghc80/TypeLevelVec.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TypeInType, UnicodeSyntax, GADTs, NoImplicitPrelude, - TypeOperators, TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} - -module TypeLevelVec where - -import Data.Kind - -data ℕ ∷ Type where - O ∷ ℕ - S ∷ ℕ → ℕ - -type family x + y where - O + n = n - S m + n = S (m + n) -infixl 5 + - -data Vec ∷ ℕ → Type → Type where - Nil ∷ Vec O a - (:>) ∷ a → Vec n a → Vec (S n) a -infixr 8 :> - -type family (x ∷ Vec n a) ++ (y ∷ Vec m a) ∷ Vec (n + m) a where - Nil ++ y = y - (x :> xs) ++ y = x :> (xs ++ y) -infixl 5 ++ diff --git a/tests/examples/ghc80/TypeSkolEscape.hs b/tests/examples/ghc80/TypeSkolEscape.hs deleted file mode 100644 --- a/tests/examples/ghc80/TypeSkolEscape.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes, PolyKinds, TypeInType #-} - -module TypeSkolEscape where - -import GHC.Types -import GHC.Exts - -type Bad = forall (v :: Levity) (a :: TYPE v). a diff --git a/tests/examples/ghc80/TypedSplice.hs b/tests/examples/ghc80/TypedSplice.hs deleted file mode 100644 --- a/tests/examples/ghc80/TypedSplice.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NamedWildCards #-} -{-# LANGUAGE PartialTypeSignatures #-} -module TypedSplice where - -import Language.Haskell.TH - -metaExp :: Q (TExp (Bool -> Bool)) -metaExp = [|| not :: _ -> _b ||] diff --git a/tests/examples/ghc80/UnicodeRules.hs b/tests/examples/ghc80/UnicodeRules.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/Vta1.hs b/tests/examples/ghc80/Vta1.hs deleted file mode 100644 --- a/tests/examples/ghc80/Vta1.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE TypeApplications, ScopedTypeVariables, PolyKinds, - TypeFamilies, RankNTypes, - FlexibleContexts #-} --- tests about visible type application - -module Vta1 where - -quad :: a -> b -> c -> d -> (a, b, c, d) -quad = (,,,) - -silly = quad @_ @Bool @Char @_ 5 True 'a' "Hello" - -pairup_nosig x y = (x, y) - -pairup_sig :: a -> b -> (a,b) -pairup_sig u w = (u, w) - -answer_sig = pairup_sig @Bool @Int False 7 -- --- (False, 7) :: (Bool, Int) - -answer_read = show (read @Int "3") -- "3" :: String -answer_show = show @Integer (read "5") -- "5" :: String -answer_showread = show @Int (read @Int "7") -- "7" :: String - -intcons a = (:) @Int a - -intpair x y = pairup_sig @Int x y - -answer_pairup = pairup_sig @Int 5 True -- (5, True) :: (Int, Bool) -answer_intpair = intpair 1 "hello" -- (1, "hello") :: (Int, String) -answer_intcons = intcons 7 [] -- [7] :: [Int] - -type family F a -type instance F Char = Bool - -g :: F a -> a -g _ = undefined - -f :: Char -f = g True - -answer = g @Char False - -mapSame :: forall b. (forall a. a -> a) -> [b] -> [b] -mapSame _ [] = [] -mapSame fun (x:xs) = fun @b x : (mapSame @b fun xs) - -pair :: forall a. a-> (forall b. b -> (a, b)) -pair x y = (x, y) - -b = pair @Int 3 @Bool True -c = mapSame id [1,2,3] -d = pair 3 @Bool True - -pairnum :: forall a. Num a => forall b. b -> (a, b) -pairnum = pair 3 - -e = (pair 3 :: forall a. Num a => forall b. b -> (a, b)) @Int @Bool True -h = pairnum @Int @Bool True - -data First (a :: * -> *) = F -data Proxy (a :: k) = P -- This expands to P (kind variable) (type variable) -data Three (a :: * -> k -> *) = T - -foo :: Proxy a -> Int -foo _ = 0 - -first :: First a -> Int -first _ = 0 - -fTest = first F -fMaybe = first @Maybe F - -test = foo P -bar = foo @Bool P -- should work - -too :: Three a -> Int -too _ = 3 - -threeBase = too T -threeOk = too @Either T - -blah = Nothing @Int - -newtype N = MkN { unMkN :: forall a. Show a => a -> String } - -n = MkN show - -boo = unMkN n @Bool - -boo2 :: forall (a :: * -> *) . Proxy a -> Bool -boo2 _ = False - -base = boo2 P -bar'= boo2 @Maybe P -- should work diff --git a/tests/examples/ghc80/Vta2.hs b/tests/examples/ghc80/Vta2.hs deleted file mode 100644 --- a/tests/examples/ghc80/Vta2.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE RankNTypes, TypeApplications #-} - - -module Vta2 where - -checkIf :: Bool -> (forall a. a -> a) -> (Bool, Int) -checkIf _ = if True - then \f -> (f True, f 5) - else \f -> (f False, f @Int 3) - -checkCase :: Bool -> (forall a. a -> a) -> (Bool, Int) -checkCase _ = case True of - True -> \f -> (f True, f 5) - False -> \f -> (f False, f @Int 3) diff --git a/tests/examples/ghc80/WCompatWarningsNotOn.hs b/tests/examples/ghc80/WCompatWarningsNotOn.hs deleted file mode 100644 --- a/tests/examples/ghc80/WCompatWarningsNotOn.hs +++ /dev/null @@ -1,26 +0,0 @@ --- Test purpose: --- Ensure that not using -Wcompat does not enable its warnings - --- {-# OPTIONS_GHC -Wcompat #-} --- {-# OPTIONS_GHC -Wno-compat #-} - -module WCompatWarningsNotOn where - -import qualified Data.Semigroup as Semi - -monadFail :: Monad m => m a -monadFail = do - Just _ <- undefined - undefined - -(<>) = undefined -- Semigroup warnings - --- -fwarn-noncanonical-monoid-instances -newtype S = S Int - -instance Semi.Semigroup S where - (<>) = mappend - -instance Semi.Monoid S where - S a `mappend` S b = S (a+b) - mempty = S 0 diff --git a/tests/examples/ghc80/WCompatWarningsOff.hs b/tests/examples/ghc80/WCompatWarningsOff.hs deleted file mode 100644 --- a/tests/examples/ghc80/WCompatWarningsOff.hs +++ /dev/null @@ -1,26 +0,0 @@ --- Test purpose: --- Ensure that using -Wno-compat does not switch on warnings - --- {-# OPTIONS_GHC -Wcompat #-} -{-# OPTIONS_GHC -Wno-compat #-} - -module WCompatWarningsOff where - -import qualified Data.Semigroup as Semi - -monadFail :: Monad m => m a -monadFail = do - Just _ <- undefined - undefined - -(<>) = undefined -- Semigroup warnings - --- -fwarn-noncanonical-monoid-instances -newtype S = S Int - -instance Semi.Semigroup S where - (<>) = mappend - -instance Semi.Monoid S where - S a `mappend` S b = S (a+b) - mempty = S 0 diff --git a/tests/examples/ghc80/WCompatWarningsOn.hs b/tests/examples/ghc80/WCompatWarningsOn.hs deleted file mode 100644 --- a/tests/examples/ghc80/WCompatWarningsOn.hs +++ /dev/null @@ -1,26 +0,0 @@ --- Test purpose: --- Ensure that -Wcompat switches on the right warnings - -{-# OPTIONS_GHC -Wcompat #-} --- {-# OPTIONS_GHC -Wno-compat #-} - -module WCompatWarningsOn where - -import qualified Data.Semigroup as Semi - -monadFail :: Monad m => m a -monadFail = do - Just _ <- undefined - undefined - -(<>) = undefined -- Semigroup warnings - --- -fwarn-noncanonical-monoid-instances -newtype S = S Int - -instance Semi.Semigroup S where - (<>) = mappend - -instance Semi.Monoid S where - S a `mappend` S b = S (a+b) - mempty = S 0 diff --git a/tests/examples/ghc80/WCompatWarningsOnOff.hs b/tests/examples/ghc80/WCompatWarningsOnOff.hs deleted file mode 100644 --- a/tests/examples/ghc80/WCompatWarningsOnOff.hs +++ /dev/null @@ -1,26 +0,0 @@ --- Test purpose: --- Ensure that -Wno-compat disables a previously set -Wcompat - -{-# OPTIONS_GHC -Wcompat #-} -{-# OPTIONS_GHC -Wno-compat #-} - -module WCompatWarningsOnOff where - -import qualified Data.Semigroup as Semi - -monadFail :: Monad m => m a -monadFail = do - Just _ <- undefined - undefined - -(<>) = undefined -- Semigroup warnings - --- -fwarn-noncanonical-monoid-instances -newtype S = S Int - -instance Semi.Semigroup S where - (<>) = mappend - -instance Semi.Monoid S where - S a `mappend` S b = S (a+b) - mempty = S 0 diff --git a/tests/examples/ghc80/Zwaluw.hs b/tests/examples/ghc80/Zwaluw.hs deleted file mode 100644 --- a/tests/examples/ghc80/Zwaluw.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} - -module Web.Zwaluw ( - -- * Types - Router, (:-)(..), (<>), - - -- * Running routers - parse, unparse, - parse1, unparse1, - - -- * Constructing routers - -- | The @constrN@ functions are helper functions to lift constructors of - -- datatypes to routers. Their first argument is the constructor; their - -- second argument is a (partial) destructor. - constr0, constr1, constr2, - int, slash, lit - ) where - -import Prelude hiding ((.), id) -import Control.Monad -import Control.Category -import Control.Arrow (first) -import Data.Monoid - -infixr 8 <> -infixr 8 :- - --- | Infix operator for 'mappend'. -(<>) :: Monoid m => m -> m -> m -(<>) = mappend - -data Router a b = Router - { ser :: b -> [(a, String)] - , prs :: String -> [(a -> b, String)] } - -data a :- b = a :- b deriving (Eq, Show) - -xmap :: (b -> a) -> (a -> b) -> Router r a -> Router r b -xmap f g (Router s p) = Router (s . f) ((fmap . liftM . first . fmap) g p) - -instance Category (Router) where - id = lit "" - Router sf pf . Router sg pg = Router - (\a -> do - (b, s) <- sf a - (c, s') <- sg b - return (c, s ++ s')) - (\s -> do - (f, s') <- pf s - (g, s'') <- pg s' - return (f . g, s'')) - -instance Monoid (Router a b) where - mempty = Router (const mzero) (const mzero) - Router sf pf `mappend` Router sg pg = Router - (\s -> sf s `mplus` sg s) - (\s -> pf s `mplus` pg s) - -parse :: Router () a -> String -> [a] -parse p = concatMap (\(a, s) -> if (s == "") then [a ()] else []) . prs p - -parse1 :: Router () (a :- ()) -> String -> [a] -parse1 p s = map (\(r :- ()) -> r) (parse p s) - -unparse :: Router () a -> a -> [String] -unparse p = map snd . ser p - -unparse1 :: Router () (a :- ()) -> a -> [String] -unparse1 p x = unparse p (x :- ()) - -maph :: (b -> a) -> (a -> b) -> Router i (a :- o) -> Router i (b :- o) -maph f g = xmap (\(h :- t) -> f h :- t) (\(h :- t) -> g h :- t) - -opt :: Eq a => a -> Router r (a :- r) -> Router r (a :- r) -opt a p = p <> push a - -nil :: Router r ([a] :- r) -nil = constr0 [] $ \x -> do [] <- x; Just () - -cons :: Router (a :- [a] :- r) ([a] :- r) -cons = constr2 (:) $ \x -> do a:as <- x; return (a, as) - --- many :: Eq a => (forall r. Router r (a :- r)) -> Router r ([a] :- r) --- many p = nil <> many1 p - --- many1 :: Eq a => (forall r. Router r (a :- r)) -> Router r ([a] :- r) --- many1 p = cons . p . many p - -satisfy :: (Char -> Bool) -> Router r (Char :- r) -satisfy p = Router - (\(c :- a) -> if (p c) then return (a, [c]) else mzero) - (\s -> case s of - [] -> mzero - (c:cs) -> if (p c) then return ((c :-), cs) else mzero) - -char :: Router r (Char :- r) -char = satisfy (const True) - -digitChar :: Router r (Char :- r) -digitChar = satisfy (\c -> c >= '0' && c <= '9') - -digit :: Router r (Int :- r) -digit = maph (head . show) (read . (:[])) digitChar - - --- | Routes a constant string. -lit :: String -> Router r r -lit l = Router - (\b -> return (b, l)) - (\s -> let (s1, s2) = splitAt (length l) s in if s1 == l then return (id, s2) else mzero) - --- | Routes a slash. -slash :: Router r r -slash = lit "/" - --- | Routes any integer. -int :: Router r (Int :- r) --- int = maph show read $ many1 digitChar -int = Router - (\(i :- a) -> return (a, show i)) - (\s -> let l = reads s in map (first (:-)) l) - - - -push :: Eq h => h -> Router r (h :- r) -push h = Router - (\(h' :- t) -> do guard (h == h'); return (t, "")) - (\s -> return ((h :-), s)) - -left :: Router (a :- r) (Either a b :- r) -left = constr1 Left $ \x -> do Left a <- x; return a - -right :: Router (b :- r) (Either a b :- r) -right = constr1 Right $ \x -> do Right b <- x; return b - -eitherP :: Router r (a :- r) -> Router r (b :- r) -> Router r (Either a b :- r) -eitherP l r = left . l <> right . r - --- | For example: --- --- > nil :: Router r ([a] :- r) --- > nil = constr0 [] $ \x -> do [] <- x; Just () -constr0 :: o -> (Maybe o -> Maybe ()) -> Router r (o :- r) -constr0 c d = Router - (\(a :- t) -> maybe mzero (\_ -> return (t, "")) (d (return a))) - (\s -> return ((c :-), s)) - --- | For example: --- --- > left :: Router (a :- r) (Either a b :- r) --- > left = constr1 Left $ \x -> do Left a <- x; return a -constr1 :: (a -> o) -> (Maybe o -> Maybe a) -> Router (a :- r) (o :- r) -constr1 c d = Router - (\(a :- t) -> maybe mzero (\a -> return (a :- t, "")) (d (return a))) - (\s -> return (\(a :- t) -> c a :- t, s)) - --- | For example: --- --- > cons :: Router (a :- [a] :- r) ([a] :- r) --- > cons = constr2 (:) $ \x -> do a:as <- x; return (a, as) -constr2 :: (a -> b -> o) -> (Maybe o -> Maybe (a, b)) -> - Router (a :- b :- r) (o :- r) -constr2 c d = Router - (\(a :- t) -> - maybe mzero (\(a, b) -> return (a :- b :- t, "")) (d (return a))) - (\s -> return (\(a :- b :- t) -> c a b :- t, s)) - diff --git a/tests/examples/ghc80/ado001.hs b/tests/examples/ghc80/ado001.hs deleted file mode 100644 --- a/tests/examples/ghc80/ado001.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo #-} -module Main where - -import Control.Applicative -import Text.PrettyPrint - -(a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..] - --- a | b -test1 :: M () -test1 = do - x1 <- a - x2 <- b - const (return ()) (x1,x2) - --- no parallelism -test2 :: M () -test2 = do - x1 <- a - x2 <- const g x1 - const (return ()) (x1,x2) - --- a | (b;g) | e -test3 :: M () -test3 = do - x1 <- a - x2 <- b - x3 <- const g x2 - x4 <- e - return () `const` (x1,x2,x3,x4) - --- (a ; (b | g)) | c --- or --- ((a | b); g) | c -test4 :: M () -test4 = do - x1 <- a - x2 <- b - x3 <- const g x1 - x4 <- c - return () `const` (x2,x3,x4) - --- (a | b | c); (g | h) -test5 :: M () -test5 = do - x1 <- a - x2 <- b - x3 <- c - x4 <- const g x1 - x5 <- const h x3 - return () `const` (x3,x4,x5) - --- b/c in parallel, e/f in parallel --- a; (b | (c; (d; (e | (f; g))))) -test6 :: M () -test6 = do - x1 <- a - x2 <- const b x1 - x3 <- const c x1 - x4 <- const d x3 - x5 <- const e x4 - x6 <- const f x4 - x7 <- const g x6 - return () `const` (x1,x2,x3,x4,x5,x6,x7) - --- (a | b); (c | d) -test7 :: M () -test7 = do - x1 <- a - x2 <- b - x3 <- const c x1 - x4 <- const d x2 - return () `const` (x3,x4) - --- a; (b | c | d) --- --- alternative (but less good): --- ((a;b) | c); d -test8 :: M () -test8 = do - x1 <- a - x2 <- const b x1 - x3 <- c - x4 <- const d x1 - return () `const` (x2,x3,x4) - --- test that Lets don't get in the way --- ((a | (b; c)) | d) | e -test9 :: M () -test9 = do - x1 <- a - let x = doc "x" -- this shouldn't get in the way of grouping a/b - x2 <- b - x3 <- const c x2 - x4 <- d - x5 <- e - let y = doc "y" - return () - --- ((a | b) ; (c | d)) | e -test10 :: M () -test10 = do - x1 <- a - x2 <- b - let z1 = (x1,x2) - x3 <- const c x1 - let z2 = (x1,x2) - x4 <- const d z1 - x5 <- e - return (const () (x3,x4,x5)) - -main = mapM_ run - [ test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - , test10 - ] - --- Testing code, prints out the structure of a monad/applicative expression - -newtype M a = M (Bool -> (Maybe Doc, a)) - -maybeParen True d = parens d -maybeParen _ d = d - -run :: M a -> IO () -run (M m) = print d where (Just d,_) = m False - -instance Functor M where - fmap f m = m >>= return . f - -instance Applicative M where - pure a = M $ \_ -> (Nothing, a) - M f <*> M a = M $ \p -> - let (Just d1, f') = f True - (Just d2, a') = a True - in - (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a') - -instance Monad M where - return = pure - M m >>= k = M $ \p -> - let (d1, a) = m True - (d2, b) = case k a of M f -> f True - in - case (d1,d2) of - (Nothing,Nothing) -> (Nothing, b) - (Just d, Nothing) -> (Just d, b) - (Nothing, Just d) -> (Just d, b) - (Just d1, Just d2) -> (Just (maybeParen p (d1 <> semi <+> d2)), b) - -doc :: String -> M () -doc d = M $ \_ -> (Just (text d), ()) diff --git a/tests/examples/ghc80/ado002.hs b/tests/examples/ghc80/ado002.hs deleted file mode 100644 --- a/tests/examples/ghc80/ado002.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ApplicativeDo,ScopedTypeVariables #-} -module Test where - --- Test that type errors aren't affected by ApplicativeDo -f :: IO Int -f = do - x <- getChar - y <- getChar 'a' -- type error - print (x,y) - -g :: IO (Int,Int) -g = do - x <- getChar - y <- getChar - return (y,x) - -h :: IO (Int,Int) -h = do - x1 <- getChar - x2 <- getChar - x3 <- const (return ()) x1 - x4 <- getChar - x5 <- getChar x4 - return (x2,x4) diff --git a/tests/examples/ghc80/ado003.hs b/tests/examples/ghc80/ado003.hs deleted file mode 100644 --- a/tests/examples/ghc80/ado003.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -module ShouldFail where - -g :: IO () -g = do - x <- getChar - 'a' <- return (3::Int) -- type error - return () diff --git a/tests/examples/ghc80/ado004.hs b/tests/examples/ghc80/ado004.hs deleted file mode 100644 --- a/tests/examples/ghc80/ado004.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# OPTIONS_GHC -ddump-types #-} -module Test where - --- This is a do expression that typechecks with only an Applicative constraint -test1 :: Applicative f => (Int -> f Int) -> f Int -test1 f = do - x <- f 3 - y <- f 4 - return (x + y) - --- Test we can also infer the Applicative version of the type -test2 f = do - x <- f 3 - y <- f 4 - return (x + y) - --- This one will use join -test3 f g = do - x <- f 3 - y <- f 4 - g y x - --- This one needs a tuple -test4 f g = do - x <- f 3 - y <- f 4 - let r = g y x - r - --- This one used to need a big tuple, now it compiles to ApplicativeLastStmt -test5 f g = do - x01 <- f 01 - x02 <- f 02 - x03 <- f 03 - x04 <- f 04 - x05 <- f 05 - x06 <- f 06 - x07 <- f 07 - x08 <- f 08 - x09 <- f 09 - x11 <- f 11 - x12 <- f 12 - x13 <- f 13 - x14 <- f 14 - x15 <- f 15 - x16 <- f 16 - x17 <- f 17 - x18 <- f 18 - x19 <- f 19 - x20 <- f 20 - x21 <- f 21 - x22 <- f 22 - x23 <- f 23 - x24 <- f 24 - x25 <- f 25 - x26 <- f 26 - x27 <- f 27 - x28 <- f 28 - x29 <- f 29 - x30 <- f 30 - x31 <- f 31 - x32 <- f 32 - x33 <- f 33 - x34 <- f 34 - x35 <- f 35 - x36 <- f 36 - x37 <- f 37 - x38 <- f 38 - x39 <- f 39 - x40 <- f 40 - x41 <- f 41 - x42 <- f 42 - x43 <- f 43 - x44 <- f 44 - x45 <- f 45 - x46 <- f 46 - x47 <- f 47 - x48 <- f 48 - x49 <- f 49 - x50 <- f 50 - x51 <- f 51 - x52 <- f 52 - x53 <- f 53 - x54 <- f 54 - x55 <- f 55 - x56 <- f 56 - x57 <- f 57 - x58 <- f 58 - x59 <- f 59 - x60 <- f 60 - x61 <- f 61 - x62 <- f 62 - x63 <- f 63 - x64 <- f 64 - x65 <- f 65 - x66 <- f 66 - x67 <- f 67 - x68 <- f 68 - x69 <- f 69 - x70 <- f 70 - let r = g x70 x01 - r - --- This one needs a big tuple -test6 f g = do - x01 <- f 01 - x02 <- f 02 - x03 <- f 03 - x04 <- f 04 - x05 <- f 05 - x06 <- f 06 - x07 <- f 07 - x08 <- f 08 - x09 <- f 09 - x11 <- f 11 - x12 <- f 12 - x13 <- f 13 - x14 <- f 14 - x15 <- f 15 - x16 <- f 16 - x17 <- f 17 - x18 <- f 18 - x19 <- f 19 - x20 <- f 20 - x21 <- f 21 - x22 <- f 22 - x23 <- f 23 - x24 <- f 24 - x25 <- f 25 - x26 <- f 26 - x27 <- f 27 - x28 <- f 28 - x29 <- f 29 - x30 <- f 30 - x31 <- f 31 - x32 <- f 32 - x33 <- f 33 - x34 <- f 34 - x35 <- f 35 - x36 <- f 36 - x37 <- f 37 - x38 <- f 38 - x39 <- f 39 - x40 <- f 40 - x41 <- f 41 - x42 <- f 42 - x43 <- f 43 - x44 <- f 44 - x45 <- f 45 - x46 <- f 46 - x47 <- f 47 - x48 <- f 48 - x49 <- f 49 - x50 <- f 50 - x51 <- f 51 - x52 <- f 52 - x53 <- f 53 - x54 <- f 54 - x55 <- f 55 - x56 <- f 56 - x57 <- f 57 - x58 <- f 58 - x59 <- f 59 - x60 <- f 60 - x61 <- f 61 - x62 <- f 62 - x63 <- f 63 - x64 <- f 64 - x65 <- f 65 - x66 <- f 66 - x67 <- f 67 - x68 <- f 68 - x69 <- f 69 - x70 <- f x01 - x71 <- f 70 - x71 `const` - [ x01 - , x02 - , x03 - , x04 - , x05 - , x06 - , x07 - , x08 - , x09 - , x11 - , x12 - , x13 - , x14 - , x15 - , x16 - , x17 - , x18 - , x19 - , x20 - , x21 - , x22 - , x23 - , x24 - , x25 - , x26 - , x27 - , x28 - , x29 - , x30 - , x31 - , x32 - , x33 - , x34 - , x35 - , x36 - , x37 - , x38 - , x39 - , x40 - , x41 - , x42 - , x43 - , x44 - , x45 - , x46 - , x47 - , x48 - , x49 - , x50 - , x51 - , x52 - , x53 - , x54 - , x55 - , x56 - , x57 - , x58 - , x59 - , x60 - , x61 - , x62 - , x63 - , x64 - , x65 - , x66 - , x67 - , x68 - , x69 - , x70 - , x71 ] diff --git a/tests/examples/ghc80/ado005.hs b/tests/examples/ghc80/ado005.hs deleted file mode 100644 --- a/tests/examples/ghc80/ado005.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# OPTIONS_GHC -ddump-types #-} -module Test where - --- This should fail to typecheck because it needs Monad -test :: Applicative f => (Int -> f Int) -> f Int -test f = do - x <- f 3 - y <- f x - return (x + y) diff --git a/tests/examples/ghc80/ado006.hs b/tests/examples/ghc80/ado006.hs deleted file mode 100644 --- a/tests/examples/ghc80/ado006.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -module Test where - --- This exposed a bug in zonking ApplicativeLastStmt -test :: IO Int -test - = do - x <- return () - h <- return (\_ -> 3) - return (h ()) diff --git a/tests/examples/ghc80/ado007.hs b/tests/examples/ghc80/ado007.hs deleted file mode 100644 --- a/tests/examples/ghc80/ado007.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE RebindableSyntax #-} -module Test where - -import Control.Applicative -import Control.Monad -import Prelude - --- Caused a -dcore-lint failure with an earlier version of --- ApplicativeDo due to the polymorphic let binding. -test :: IO [Char] -test = do - x <- return 'a' - y <- return 'b' - let f | y == 'c' = id | otherwise = id - return (map f []) diff --git a/tests/examples/ghc80/boolFormula.hs b/tests/examples/ghc80/boolFormula.hs deleted file mode 100644 --- a/tests/examples/ghc80/boolFormula.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/determinism001.hs b/tests/examples/ghc80/determinism001.hs deleted file mode 100644 --- a/tests/examples/ghc80/determinism001.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Main where - -import Digraph - -main = mapM_ print - [ test001 - , test002 - , test003 - , test004 - ] - --- These check that the result of SCCs doesn't depend on the order of the key --- type (Int here). - -test001 = testSCC [("a", 1, []), ("b", 2, []), ("c", 3, [])] - -test002 = testSCC [("a", 2, []), ("b", 3, []), ("c", 1, [])] - -test003 = testSCC [("b", 1, []), ("c", 2, []), ("a", 3, [])] - -test004 = testSCC [("b", 2, []), ("c", 3, []), ("a", 1, [])] - -testSCC = flattenSCCs . stronglyConnCompFromEdgedVertices diff --git a/tests/examples/ghc80/export-class.hs b/tests/examples/ghc80/export-class.hs deleted file mode 100644 --- a/tests/examples/ghc80/export-class.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Foo (MyClass(.., P)) where - -pattern P = Nothing - -class MyClass a where - foo :: a -> Int diff --git a/tests/examples/ghc80/export-ps-rec-sel.hs b/tests/examples/ghc80/export-ps-rec-sel.hs deleted file mode 100644 --- a/tests/examples/ghc80/export-ps-rec-sel.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Foo( R(P,x)) where - -data Q = Q Int - -data R = R - -pattern P{x} = Q x diff --git a/tests/examples/ghc80/export-record-selector.hs b/tests/examples/ghc80/export-record-selector.hs deleted file mode 100644 --- a/tests/examples/ghc80/export-record-selector.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Foo ( A(foo) ) where - -data A a = A a - -pattern P :: Int -> A Int -pattern P{foo} = A foo diff --git a/tests/examples/ghc80/export-super-class-fail.hs b/tests/examples/ghc80/export-super-class-fail.hs deleted file mode 100644 --- a/tests/examples/ghc80/export-super-class-fail.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ViewPatterns #-} - -module Foo ( B(P) ) where - -class (f ~ A) => C f a where - build :: a -> f a - destruct :: f a -> a - -data A a = A a - -data B a = B a - -instance C A Int where - build n = A n - destruct (A n) = n - - -pattern P :: C f a => a -> f a -pattern P x <- (destruct -> x) - where - P x = build x diff --git a/tests/examples/ghc80/export-super-class.hs b/tests/examples/ghc80/export-super-class.hs deleted file mode 100644 --- a/tests/examples/ghc80/export-super-class.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ViewPatterns #-} - -module Foo ( A(P) ) where - -class (f ~ A) => C f a where - build :: a -> f a - destruct :: f a -> a - -data A a = A a - -instance C A Int where - build n = A n - destruct (A n) = n - - -pattern P :: C f a => a -> f a -pattern P x <- (destruct -> x) - where - P x = build x diff --git a/tests/examples/ghc80/export-syntax.hs b/tests/examples/ghc80/export-syntax.hs deleted file mode 100644 --- a/tests/examples/ghc80/export-syntax.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Foo(A(.., B)) where - -data A = A | B diff --git a/tests/examples/ghc80/export-type-synonym.hs b/tests/examples/ghc80/export-type-synonym.hs deleted file mode 100644 --- a/tests/examples/ghc80/export-type-synonym.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Foo ( A(P) ) where - -data A = A -data B = B - -type C = B - -pattern P :: C -pattern P = B diff --git a/tests/examples/ghc80/export-type.hs b/tests/examples/ghc80/export-type.hs deleted file mode 100644 --- a/tests/examples/ghc80/export-type.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Export (A(..,MyB), B(MyA), C(MyC)) where - -data A = A - -data B = B - -pattern MyB = B - -pattern MyA = A - -data C a = C - -pattern MyC = B diff --git a/tests/examples/ghc80/frontend01.hs b/tests/examples/ghc80/frontend01.hs deleted file mode 100644 --- a/tests/examples/ghc80/frontend01.hs +++ /dev/null @@ -1,1 +0,0 @@ -main = putStrLn "hello world" diff --git a/tests/examples/ghc80/haddockA034.hs b/tests/examples/ghc80/haddockA034.hs deleted file mode 100644 --- a/tests/examples/ghc80/haddockA034.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -module Hi where - --- | This is a GADT. -data Hi where - -- | This is a GADT constructor. - Hi :: () -> Hi diff --git a/tests/examples/ghc80/listcomps.hs b/tests/examples/ghc80/listcomps.hs deleted file mode 100644 --- a/tests/examples/ghc80/listcomps.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - --- This program must be called with GHC's libdir as the single command line --- argument. -module Main where - --- import Data.Generics -import Data.Data -import Data.List -import System.IO -import GHC -import BasicTypes -import DynFlags -import MonadUtils -import Outputable -import ApiAnnotation -import Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import System.Exit -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Dynamic ( fromDynamic,Dynamic ) - -main::IO() -main = do - [libdir] <- getArgs - testOneFile libdir "ListComprehensions" - exitSuccess - -testOneFile libdir fileName = do - ((anns,cs),p) <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - t <- typecheckModule p - d <- desugarModule t - l <- loadModule d - let ts=typecheckedSource l - r =renamedSource l - return (pm_annotations p,p) - - let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p) - - putStrLn (pp spans) - putStrLn "--------------------------------" - putStrLn (intercalate "\n" [showAnns anns]) - - where - getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))] - getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns - - getAllSrcSpans :: (Data t) => t -> [SrcSpan] - getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast - where - getSrcSpan :: SrcSpan -> [SrcSpan] - getSrcSpan ss = [ss] - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPpr unsafeGlobalDynFlags a - - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/tests/examples/ghc80/mixed-pat-syn-record-sels.hs b/tests/examples/ghc80/mixed-pat-syn-record-sels.hs deleted file mode 100644 --- a/tests/examples/ghc80/mixed-pat-syn-record-sels.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Foo where - - -pattern A { a } = Just a -pattern B { b } = Just b - -foo :: Maybe a -> Maybe Bool -foo x = x { a = True, b = False } diff --git a/tests/examples/ghc80/multi-export.hs b/tests/examples/ghc80/multi-export.hs deleted file mode 100644 --- a/tests/examples/ghc80/multi-export.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Foo (A(B, C)) where - -data A a = A - -pattern B :: A Int -pattern B = A - -pattern C :: A String -pattern C = A diff --git a/tests/examples/ghc80/overloadedlabelsfail01.hs b/tests/examples/ghc80/overloadedlabelsfail01.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedlabelsfail01.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedLabels, DataKinds, FlexibleContexts #-} - -import GHC.OverloadedLabels - --- No instance for (OverloadedLabel "x" t0) -a = #x - --- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0) -b = #x #y - --- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t) -c :: IsLabel "x" t => t -c = #y - -main = return () diff --git a/tests/examples/ghc80/overloadedlabelsrun01.hs b/tests/examples/ghc80/overloadedlabelsrun01.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedlabelsrun01.hs +++ /dev/null @@ -1,29 +0,0 @@ --- Basic tests of overloaded labels - -{-# LANGUAGE OverloadedLabels - , DataKinds - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , NoMonomorphismRestriction - #-} - -import GHC.OverloadedLabels - -instance IsLabel "true" Bool where - fromLabel _ = True - -instance IsLabel "false" Bool where - fromLabel _ = False - -a :: IsLabel "true" t => t -a = #true - -b = #false - -c :: Bool -c = #true - -main = do print (a :: Bool) - print (b :: Bool) - print c diff --git a/tests/examples/ghc80/overloadedlabelsrun02.hs b/tests/examples/ghc80/overloadedlabelsrun02.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedlabelsrun02.hs +++ /dev/null @@ -1,61 +0,0 @@ --- Using overloaded labels to provide nice syntactic sugar for a --- term representation using de Bruijn indices - -{-# LANGUAGE OverloadedLabels - , DataKinds - , FlexibleContexts - , FlexibleInstances - , GADTs - , KindSignatures - , MultiParamTypeClasses - , NoMonomorphismRestriction - , OverlappingInstances - , ScopedTypeVariables - , StandaloneDeriving - , TypeOperators - #-} - -import GHC.OverloadedLabels -import Data.Proxy ( Proxy(..) ) -import GHC.TypeLits ( Symbol ) - -instance x ~ y => IsLabel x (Proxy y) where - fromLabel _ = Proxy - -data Elem (x :: Symbol) g where - Top :: Elem x (x ': g) - Pop :: Elem x g -> Elem x (y ': g) -deriving instance Show (Elem x g) - - -class IsElem x g where - which :: Elem x g - -instance IsElem x (x ': g) where - which = Top - -instance IsElem x g => IsElem x (y ': g) where - which = Pop which - - -data Tm g where - Var :: Elem x g -> Tm g - App :: Tm g -> Tm g -> Tm g - Lam :: Tm (x ': g) -> Tm g -deriving instance Show (Tm g) - -instance IsElem x g => IsLabel x (Tm g) where - fromLabel _ = Var (which :: Elem x g) - -lam :: Proxy x -> Tm (x ': g) -> Tm g -lam _ = Lam - -s = lam #x #x -t = lam #x (lam #y (#x `App` #y)) - -u :: IsElem "z" g => Tm g -u = #z `App` #z - -main = do print s - print t - print (u :: Tm '["z"]) diff --git a/tests/examples/ghc80/overloadedlabelsrun03.hs b/tests/examples/ghc80/overloadedlabelsrun03.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedlabelsrun03.hs +++ /dev/null @@ -1,21 +0,0 @@ --- Using overloaded labels as strings, slightly pointlessly - -{-# LANGUAGE OverloadedLabels - , DataKinds - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , ScopedTypeVariables - , TypeFamilies - , TypeSynonymInstances - #-} - -import GHC.OverloadedLabels -import Data.Proxy ( Proxy(..) ) -import GHC.TypeLits ( KnownSymbol, symbolVal ) - -instance (KnownSymbol x, c ~ Char) => IsLabel x [c] where - fromLabel _ = symbolVal (Proxy :: Proxy x) - -main = do putStrLn #x - print $ #x ++ #y diff --git a/tests/examples/ghc80/overloadedrecfldsfail01.hs b/tests/examples/ghc80/overloadedrecfldsfail01.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail01.hs +++ /dev/null @@ -1,19 +0,0 @@ --- Test ambiguous updates are rejected with appropriate error messages - -{-# LANGUAGE DuplicateRecordFields #-} - -data R = MkR { w :: Bool, x :: Int, y :: Bool } -data S = MkS { w :: Bool, x :: Int, y :: Bool } -data T = MkT { x :: Int, z :: Bool } -data U = MkU { y :: Bool } - --- Straightforward ambiguous update -upd1 r = r { x = 3 } - --- No type has all these fields -upd2 r = r { x = 3, y = True, z = False } - --- User-specified type does not have these fields -upd3 r = r { w = True, x = 3, y = True } :: U - -main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail02.hs b/tests/examples/ghc80/overloadedrecfldsfail02.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail02.hs +++ /dev/null @@ -1,9 +0,0 @@ --- Test selectors cannot be used ambiguously - -{-# LANGUAGE DuplicateRecordFields #-} - -data R = MkR { x :: Int, y :: Bool } -data S = MkS { x :: Int } - -main = do print (x (MkS 42)) - print (y (MkR 42 42)) diff --git a/tests/examples/ghc80/overloadedrecfldsfail03.hs b/tests/examples/ghc80/overloadedrecfldsfail03.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail03.hs +++ /dev/null @@ -1,10 +0,0 @@ --- Test that a top-level definition with the same name as a record --- field is rejected - -{-# LANGUAGE DuplicateRecordFields #-} - -foo = True - -data T = MkT { foo :: Int } - -main = print foo diff --git a/tests/examples/ghc80/overloadedrecfldsfail04.hs b/tests/examples/ghc80/overloadedrecfldsfail04.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail04.hs +++ /dev/null @@ -1,14 +0,0 @@ --- Test that importing an overloaded field and using it as a selector --- leads to a suitable error - -{-# LANGUAGE DuplicateRecordFields #-} - -import OverloadedRecFldsFail04_A as I - --- Qualified overloaded fields are not allowed here -x' = I.x - --- But this is okay -f e = e { I.x = True, I.y = False } - -main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail05.hs b/tests/examples/ghc80/overloadedrecfldsfail05.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail05.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -fwarn-unused-binds -Werror #-} - -module Main (main, T(MkT)) where - -data S = MkS { foo :: Int } -data T = MkT { foo :: Int } - --- This should count as a use of S(foo) but not T(foo) -main = print ((\ MkS{foo=foo} -> foo) (MkS 3)) diff --git a/tests/examples/ghc80/overloadedrecfldsfail06.hs b/tests/examples/ghc80/overloadedrecfldsfail06.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail06.hs +++ /dev/null @@ -1,18 +0,0 @@ --- Check that unused imports are reported correctly in the presence of --- DuplicateRecordFields - -{-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -Werror -fwarn-unused-imports #-} - -import OverloadedRecFldsFail06_A (U(x, y), V(MkV, MkV2, x, y), Unused(unused), u, getY) -import qualified OverloadedRecFldsFail06_A as M (U(x)) -import qualified OverloadedRecFldsFail06_A as N (V(x, y)) -import qualified OverloadedRecFldsFail06_A as P (U(x), V(x)) - -v = MkV2 True - --- Check that this counts a use of U(x) and V(y) but not U(y) or V(x)... -main = do print (u { x = True } :: U) - print ((\ MkV2{y=y} -> y) v) - print (N.x v) - print (getY (v { P.x = 3 })) diff --git a/tests/examples/ghc80/overloadedrecfldsfail07.hs b/tests/examples/ghc80/overloadedrecfldsfail07.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail07.hs +++ /dev/null @@ -1,9 +0,0 @@ --- Test type errors contain field names, not selector names - -{-# LANGUAGE DuplicateRecordFields #-} - -data T = MkT { x :: Int } - -y = x x - -main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail08.hs b/tests/examples/ghc80/overloadedrecfldsfail08.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail08.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} - -data family F a -data instance F Int = MkFInt { x :: Int } -data instance F Bool = MkFBool { y :: Bool } - --- No data type has both these fields, but they belong to the same --- lexical parent (F). This used to confuse DuplicateRecordFields. -foo e = e { x = 3, y = True } - -main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail09.hs b/tests/examples/ghc80/overloadedrecfldsfail09.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail09.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} - -data S = MkS { x :: Int } -data T = MkT { x :: Int } - --- This tests what happens when an ambiguous record update is used in --- a splice: since it can't be represented in TH, it should error --- cleanly, rather than panicking or silently using one field. -foo = [e| (MkS 3) { x = 3 } |] - -main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail10.hs b/tests/examples/ghc80/overloadedrecfldsfail10.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail10.hs +++ /dev/null @@ -1,11 +0,0 @@ --- Modules A and B both declare F(foo) --- Module C declares F($sel:foo:MkFChar) but exports A.F(foo) as well --- Thus we can't export F(..) even with DuplicateRecordFields enabled - -{-# LANGUAGE DuplicateRecordFields #-} -module Main (main, F(..)) where - -import OverloadedRecFldsFail10_B -import OverloadedRecFldsFail10_C - -main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail11.hs b/tests/examples/ghc80/overloadedrecfldsfail11.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail11.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -Werror #-} -import OverloadedRecFldsFail11_A - -main = print (foo (MkS True :: S)) diff --git a/tests/examples/ghc80/overloadedrecfldsfail12.hs b/tests/examples/ghc80/overloadedrecfldsfail12.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail12.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -Werror #-} - -import OverloadedRecFldsFail12_A - -data S = MkS { foo :: Bool } - --- Use of foo and bar should give deprecation warnings -f :: T -> T -f e = e { foo = 3, bar = 3 } - -s :: T -> Int -s = foo - -main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail13.hs b/tests/examples/ghc80/overloadedrecfldsfail13.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail13.hs +++ /dev/null @@ -1,20 +0,0 @@ --- Test that giving a stupid type annotation to an ambiguous field --- yields a sensible error message - -{-# LANGUAGE DuplicateRecordFields #-} - -data S = MkS { x :: Int } -data T = MkT { x :: Bool } -data U = MkU - -a = x (MkU :: U) - -b = x (MkU :: a) - -c :: U -> Int -c = x - -d :: a -> Int -d = x - -main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsfail14.hs b/tests/examples/ghc80/overloadedrecfldsfail14.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsfail14.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - --- Test that we deal gracefully with non-fields in updates - -data S = MkS { x :: Int } -data T = MkT { x :: Int } - -y :: Bool -y = True - --- y isn't a field -f r = r { x = 3, y = False } - -main = return () diff --git a/tests/examples/ghc80/overloadedrecfldsrun01.hs b/tests/examples/ghc80/overloadedrecfldsrun01.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsrun01.hs +++ /dev/null @@ -1,28 +0,0 @@ --- Test that unambiguous constructions remain valid when --- DuplicateRecordFields is enabled - -{-# LANGUAGE DuplicateRecordFields #-} - -data S = MkS { x :: Int } - deriving Show - -data T = MkT { x :: Bool, y :: Bool -> Bool, tField :: Bool } - -data U a = MkU { x :: a, y :: a } - --- Construction is unambiguous -s = MkS { x = 42 } -t = MkT { x = True, y = id, tField = False } - --- Pattern matching is unambiguous -get_x MkS{x=x} = x - --- Resolving ambiguous monomorphic updates -a = t { x = False, y = not, tField = True } -- only T has all these fields -b = s { x = 3 } :: S -- type being pushed in -c = (t :: T) { x = False } -- type signature on record expression - --- Unambiguous selectors are in scope normally -z = tField t - -main = print (get_x b) diff --git a/tests/examples/ghc80/overloadedrecfldsrun02.hs b/tests/examples/ghc80/overloadedrecfldsrun02.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsrun02.hs +++ /dev/null @@ -1,6 +0,0 @@ --- This module does not enable -XDuplicateRecordFields, but it should --- still be able to refer to non-overloaded fields like `y` - -import OverloadedRecFldsRun02_A - -main = print (y u) diff --git a/tests/examples/ghc80/overloadedrecfldsrun03.hs b/tests/examples/ghc80/overloadedrecfldsrun03.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsrun03.hs +++ /dev/null @@ -1,25 +0,0 @@ --- Test that DuplicateRecordFields can be used along with --- TypeFamilies (with selectors only if unambiguous) - -{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} - -data family F a - -data instance F Int = MkFInt { foo :: Int } -data instance F Bool = MkFBool { bar :: Bool, baz :: Bool } - - -data family G a - -data instance G Int = MkGInt { foo :: Int } -data instance G Bool = MkGBool { bar :: Bool } - -x = MkFBool { bar = False, baz = True } - -y :: F Bool -y = x { bar = True } - -get_bar MkFBool{bar=bar} = bar - -main = do print (baz y) - print (get_bar y) diff --git a/tests/examples/ghc80/overloadedrecfldsrun04.hs b/tests/examples/ghc80/overloadedrecfldsrun04.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsrun04.hs +++ /dev/null @@ -1,30 +0,0 @@ --- Test that DuplicateRecordFields works with TemplateHaskell - -{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - --- Splice in a datatype with field... -$(return [DataD [] (mkName "R") [] [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []]) - --- New TH story means reify only sees R if we do this: -$(return []) - --- ... and check that we can inspect it -main = do putStrLn $(do { info <- reify ''R - ; case info of - TyConI (DataD _ _ _ [RecC _ [(n, _, _)]] _) -> - do { info' <- reify n - ; lift (pprint info ++ "\n" ++ pprint info') - } - _ -> error "unexpected result of reify" - }) - putStrLn $(do { info <- reify 'foo - ; case info of - VarI n _ _ -> - do { info' <- reify n - ; lift (pprint info ++ "\n" ++ pprint info') - } - }) - print (foo (MkR { foo = 42 })) diff --git a/tests/examples/ghc80/overloadedrecfldsrun05.hs b/tests/examples/ghc80/overloadedrecfldsrun05.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsrun05.hs +++ /dev/null @@ -1,27 +0,0 @@ --- Test that DuplicateRecordFields works with NamedFieldPuns and --- RecordWildCards - -{-# LANGUAGE DuplicateRecordFields, NamedFieldPuns, RecordWildCards #-} - -data S = MkS { foo :: Int } - deriving Show -data T = MkT { foo :: Int } - deriving Show - -f MkS{foo} = MkT{foo} - -g MkT{..} = MkS{..} - -h e = let foo = 6 in e { foo } :: S - -main = do print a - print b - print c - print d - where - foo = 42 - - a = MkS{foo} - b = f a - c = g b - d = h c diff --git a/tests/examples/ghc80/overloadedrecfldsrun06.hs b/tests/examples/ghc80/overloadedrecfldsrun06.hs deleted file mode 100644 --- a/tests/examples/ghc80/overloadedrecfldsrun06.hs +++ /dev/null @@ -1,21 +0,0 @@ --- Test that ambiguous selectors can be disambiguated by providing --- type signatures in various places - -{-# LANGUAGE DuplicateRecordFields #-} - -data S = MkS { x :: Int } -data T = MkT { x :: Bool } -data U a = MkU { x :: a } - -x_for_s :: S -> Int -x_for_s = x - -x_for_t = x :: T -> Bool - -x_for_u u = x (u :: U Int) - -k :: (T -> Bool) -> Bool -k f = f (MkT True) - -main = do print (x_for_s (MkS 42)) - print (k x) diff --git a/tests/examples/ghc80/performGC.hs b/tests/examples/ghc80/performGC.hs deleted file mode 100644 --- a/tests/examples/ghc80/performGC.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Main (main) where - --- Test for #10545 - -import System.Environment -import Control.Concurrent -import Control.Exception -import Control.Monad -import RandomPGC -import System.Mem -import qualified Data.Set as Set - -main = do - [n] <- getArgs - forkIO $ doSomeWork - forM [1..read n] $ \n -> do print n; threadDelay 1000; performMinorGC - -doSomeWork :: IO () -doSomeWork = forever $ do - ns <- replicateM 10000 randomIO :: IO [Int] - ms <- replicateM 1000 randomIO - let set = Set.fromList ns - elems = filter (`Set.member` set) ms - evaluate $ sum elems diff --git a/tests/examples/ghc80/plugins07.hs b/tests/examples/ghc80/plugins07.hs deleted file mode 100644 --- a/tests/examples/ghc80/plugins07.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -{-# NOINLINE x #-} -x = "foo" - -main = putStrLn (show x) diff --git a/tests/examples/ghc80/pmc001.hs b/tests/examples/ghc80/pmc001.hs deleted file mode 100644 --- a/tests/examples/ghc80/pmc001.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE TypeFamilies, GADTs #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module PMC001 where - -data family T a - -data instance T [a] where - MkT1 :: T [Int] - MkT2 :: Char -> T [Char] - MkT3 :: T [a] - -f :: T [a] -> T [a] -> Bool -f MkT1 MkT1 = True -f (MkT2 _) (MkT2 _) = True -f MkT3 MkT3 = True - -g :: T [a] -> T [a] -> Bool -g x y - | MkT1 <- x, MkT1 <- y = True - | (MkT2 _) <- x, (MkT2 _) <- y = True - | MkT3 <- x, MkT3 <- y = True diff --git a/tests/examples/ghc80/pmc002.hs b/tests/examples/ghc80/pmc002.hs deleted file mode 100644 --- a/tests/examples/ghc80/pmc002.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module PMC002 where - -f :: [a] -> Bool -f [] = True -f x | (_:_) <- x = False -- exhaustive diff --git a/tests/examples/ghc80/pmc003.hs b/tests/examples/ghc80/pmc003.hs deleted file mode 100644 --- a/tests/examples/ghc80/pmc003.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module PMC003 where - -f :: Bool -> Bool -> () -f _ False = () -f True False = () -f _ _ = () - diff --git a/tests/examples/ghc80/pmc004.hs b/tests/examples/ghc80/pmc004.hs deleted file mode 100644 --- a/tests/examples/ghc80/pmc004.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} -{-# LANGUAGE GADTs #-} - -module PMC004 where - -data F a where - F1 :: F Int - F2 :: F Bool - -data G a where - G1 :: G Int - G2 :: G Char - -h :: F a -> G a -> () -h F1 G1 = () -h _ G1 = () diff --git a/tests/examples/ghc80/pmc005.hs b/tests/examples/ghc80/pmc005.hs deleted file mode 100644 --- a/tests/examples/ghc80/pmc005.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} -{-# LANGUAGE GADTs #-} - -module PMC005 where - -data T a where - TList :: T [a] - TBool :: T Bool - -foo :: T c -> T c -> () -foo TList _ = () -foo _ TList = () diff --git a/tests/examples/ghc80/pmc006.hs b/tests/examples/ghc80/pmc006.hs deleted file mode 100644 --- a/tests/examples/ghc80/pmc006.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module PMC006 where - -len :: [a] -> Int -len xs = case xs of - [] -> 0 - (_:ys) -> case () of - () | (_:_) <- xs -> 1 + len ys - --- -- we would like these to work too but they don't yet --- --- len :: [a] -> Int --- len [] = 0 --- len xs = case xs of --- (_:ys) -> 1 + len ys --- --- len :: [a] -> Int --- len xs = case xs of --- [] -> 0 --- ys -> case ys of --- (_:zs) -> 1 + len zs diff --git a/tests/examples/ghc80/pmc007.hs b/tests/examples/ghc80/pmc007.hs deleted file mode 100644 --- a/tests/examples/ghc80/pmc007.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module PMC007 where - --- overloaded -f "ab" = () -f "ac" = () - --- non-overloaded -g :: String -> () -g "ab" = () -g "ac" = () - --- non-overloaded due to type inference -h :: String -> () -h s = let s' = s - in case s' of - "ab" -> () - "ac" -> () diff --git a/tests/examples/ghc80/poly-export-fail2.hs b/tests/examples/ghc80/poly-export-fail2.hs deleted file mode 100644 --- a/tests/examples/ghc80/poly-export-fail2.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Foo (A(P)) where - -data A = A - -data B = B - -pattern P :: () => (f ~ B) => f -pattern P = B diff --git a/tests/examples/ghc80/poly-export.hs b/tests/examples/ghc80/poly-export.hs deleted file mode 100644 --- a/tests/examples/ghc80/poly-export.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} -module Foo (Foo(P)) where - -data Foo a = Foo a - -instance C Foo where - build a = Foo a - destruct (Foo a) = a - -class C f where - build :: a -> f a - destruct :: f a -> a - -pattern P :: C f => a -> f a -pattern P x <- (destruct -> x) - where - P x = build x diff --git a/tests/examples/ghc80/poly-export2.hs b/tests/examples/ghc80/poly-export2.hs deleted file mode 100644 --- a/tests/examples/ghc80/poly-export2.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE FlexibleInstances #-} -module Foo (A(P,Q)) where - -data A a = A a - -pattern P :: Show a => a -> A a -pattern P a = A a - -pattern Q :: (A ~ f) => a -> f a -pattern Q a = A a diff --git a/tests/examples/ghc80/poly-export3.hs b/tests/examples/ghc80/poly-export3.hs deleted file mode 100644 --- a/tests/examples/ghc80/poly-export3.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} - --- Testing polykindedness - -module Foo ( A(P) ) where - -data A a = A - -pattern P = A diff --git a/tests/examples/ghc80/records-check-sels.hs b/tests/examples/ghc80/records-check-sels.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-check-sels.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Qux where - --- Make sure selectors aren't generated for normal synonyms - -pattern Uni a = Just a - -pattern a :+: b = (a, b) - -qux = a (Just True) diff --git a/tests/examples/ghc80/records-compile.hs b/tests/examples/ghc80/records-compile.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-compile.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module ShouldCompile where - -pattern Single{x} = [x] - --- Selector -selector :: Int -selector = x [5] - -update :: [String] -update = ["String"] { x = "updated" } diff --git a/tests/examples/ghc80/records-exquant.hs b/tests/examples/ghc80/records-exquant.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-exquant.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ExistentialQuantification #-} -module ExQuant where - -data Showable = forall a . Show a => Showable a - -pattern Nasty{a} = Showable a - -qux = a (Showable True) - -foo = (Showable ()) { a = True } diff --git a/tests/examples/ghc80/records-mixing-fields.hs b/tests/examples/ghc80/records-mixing-fields.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-mixing-fields.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -data MyRec = MyRec { foo :: Int, qux :: String } - -pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} - -updater,updater1, updater2 :: MyRec -> MyRec -updater a = a {f1 = 1 } - -updater1 a = a {f1 = 1, qux = "two" } - -updater2 a = a {f1 = 1, foo = 2 } diff --git a/tests/examples/ghc80/records-no-uni-update.hs b/tests/examples/ghc80/records-no-uni-update.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-no-uni-update.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module RecordPats where - --- No updates -pattern Uni{a,b} <- (a, b) - -foo = ("a","b") { a = "b" } diff --git a/tests/examples/ghc80/records-no-uni-update2.hs b/tests/examples/ghc80/records-no-uni-update2.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-no-uni-update2.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module RecordPats where - --- No updates -pattern Uni{a} <- Just a - -qux = a (Just True) - -qux2 (Uni b) = b - -foo = Uni { a = "b" } diff --git a/tests/examples/ghc80/records-poly-update.hs b/tests/examples/ghc80/records-poly-update.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-poly-update.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module Main where - -pattern ReqNoProv :: Show a => a -> Maybe a -pattern ReqNoProv{j} = Just j - -data A = A deriving Show - -p1 = Just True - -p6 = p1 {j = A} - -main = print p6 diff --git a/tests/examples/ghc80/records-poly.hs b/tests/examples/ghc80/records-poly.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-poly.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -module PolyPat where - --- Testing whether type changing updates work correctly. - -pattern MyTuple :: a -> b -> (a, b) -pattern MyTuple{mfst, msnd} = (mfst, msnd) - - -expr1 :: (Int, String) -> (Int, Int) -expr1 a = a { msnd = 2} - -expr3 a = a { msnd = 2} - -expr2 :: (a, b) -> a -expr2 a = mfst a diff --git a/tests/examples/ghc80/records-prov-req.hs b/tests/examples/ghc80/records-prov-req.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-prov-req.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns, GADTs, RankNTypes, - StandaloneDeriving, FlexibleInstances #-} -module ShouldCompile where - --- Testing that selectors work properly with prov and req thetas - -data T a b where - MkT :: (Show b) => a -> b -> T a b - -deriving instance Show (T Int A) - -data G a b = MkG { care :: a, y :: (Show b => b) } - -pattern ExNumPat :: (Eq b) => (Show b) => b -> T Int b -pattern ExNumPat{x} = MkT 42 x - -data A = A | B deriving (Show, Eq) - -f3 :: T Int A -f3 = (MkT 42 A) { x = B } - -f5 :: T Int A -f5 = (ExNumPat A) { x = B } - - -f4 = (MkG 42 True) { y = False } diff --git a/tests/examples/ghc80/records-req-only.hs b/tests/examples/ghc80/records-req-only.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-req-only.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Main where - -import Prelude (Maybe(..), Show(..), String, Bool(..), print) - -pattern ReqNoProv :: Show a => a -> Maybe a -pattern ReqNoProv{j} = Just j - -p1 = ReqNoProv True - -p7 (ReqNoProv _) = ReqNoProv False - -p6 = p1 {j = False} - -main = print p6 diff --git a/tests/examples/ghc80/records-req.hs b/tests/examples/ghc80/records-req.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-req.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-} - --- Pattern synonyms - -module ShouldCompile where - -data T a where - MkT :: (Eq b) => a -> b -> T a - -f :: (Show a) => a -> Bool -f = undefined - -pattern P{x} <- MkT (f -> True) x diff --git a/tests/examples/ghc80/records-run.hs b/tests/examples/ghc80/records-run.hs deleted file mode 100644 --- a/tests/examples/ghc80/records-run.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Main where - -pattern Bi{a, b} = (a, b) - -foo = ("a","b") - -main = do - print foo - print (a foo) - print (b foo) - print (foo {a = "c"}) - print (foo {a = "fst", b = "snd"}) diff --git a/tests/examples/ghc80/spec-inline-determ.hs b/tests/examples/ghc80/spec-inline-determ.hs deleted file mode 100644 --- a/tests/examples/ghc80/spec-inline-determ.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Roman where - --- This is a simplified version of simplCore/should_compile/spec-inline.hs --- --- It reproduces a problem where workers get specialized in different ways --- depending on the values of uniques. --- --- Compare: --- --- $s$wgo_s1CN :: Int# -> Int -> Int# --- [LclId, Arity=2, Str=DmdType ] --- $s$wgo_s1CN = --- \ (sc_s1CI :: Int#) (sc_s1CJ :: Int) -> --- case tagToEnum# @ Bool (<=# sc_s1CI 0#) of _ [Occ=Dead] { --- False -> --- $wgo_s1BU (Just @ Int (I# (-# sc_s1CI 1#))) (Just @ Int sc_s1CJ); --- True -> 0# --- } --- --- vs --- --- $s$wgo_s18mTj :: Int -> Int# -> Int# --- [LclId, Arity=2, Str=DmdType ] --- $s$wgo_s18mTj = --- \ (sc_s18mTn :: Int) (sc_s18mTo :: Int#) -> --- case tagToEnum# @ Bool (<=# sc_s18mTo 0#) of _ [Occ=Dead] { --- False -> --- $wgo_s18mUc --- (Just @ Int (I# (-# sc_s18mTo 1#))) (Just @ Int sc_s18mTn); --- True -> 0# --- } - -foo :: Int -> Int -foo n = - go (Just n) (Just (6::Int)) - where - go Nothing (Just x) = go (Just 10) (Just x) - go (Just n) (Just x) - | n <= 0 = 0 - | otherwise = go (Just (n-1)) (Just x) diff --git a/tests/examples/ghc80/stringSource.hs b/tests/examples/ghc80/stringSource.hs deleted file mode 100644 --- a/tests/examples/ghc80/stringSource.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - --- This program must be called with GHC's libdir as the single command line --- argument. -module Main where - --- import Data.Generics -import Data.Data -import Data.List -import System.IO -import GHC -import BasicTypes -import DynFlags -import FastString -import ForeignCall -import MonadUtils -import Outputable -import HsDecls -import Bag (filterBag,isEmptyBag) -import System.Directory (removeFile) -import System.Environment( getArgs ) -import qualified Data.Map as Map -import Data.Dynamic ( fromDynamic,Dynamic ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName - -testOneFile libdir fileName = do - ((anns,cs),p) <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - let mn =mkModuleName fileName - addTarget Target { targetId = TargetModule mn - , targetAllowObjCode = True - , targetContents = Nothing } - load LoadAllTargets - modSum <- getModSummary mn - p <- parseModule modSum - return (pm_annotations p,p) - - let tupArgs = gq (pm_parsed_source p) - - putStrLn (pp tupArgs) - -- putStrLn (intercalate "\n" [showAnns anns]) - - where - gq ast = everything (++) ([] `mkQ` doWarningTxt - `extQ` doImportDecl - `extQ` doCType - `extQ` doRuleDecl - `extQ` doCCallTarget - `extQ` doHsExpr - ) ast - - doWarningTxt :: WarningTxt -> [(String,[Located (SourceText,FastString)])] - doWarningTxt ((WarningTxt _ ss)) = [("w",map conv ss)] - doWarningTxt ((DeprecatedTxt _ ss)) = [("d",map conv ss)] - - doImportDecl :: ImportDecl RdrName - -> [(String,[Located (SourceText,FastString)])] - doImportDecl (ImportDecl _ _ Nothing _ _ _ _ _ _) = [] - doImportDecl (ImportDecl _ _ (Just ss) _ _ _ _ _ _) - = [("i",[conv (noLoc ss)])] - - doCType :: CType -> [(String,[Located (SourceText,FastString)])] - doCType (CType src (Just (Header hs hf)) c) - = [("c",[noLoc (hs,hf),noLoc c])] - doCType (CType src Nothing c) = [("c",[noLoc c])] - - doRuleDecl :: RuleDecl RdrName - -> [(String,[Located (SourceText,FastString)])] - doRuleDecl (HsRule ss _ _ _ _ _ _) = [("r",[ss])] - - doCCallTarget :: CCallTarget - -> [(String,[Located (SourceText,FastString)])] - doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])] - - doHsExpr :: HsExpr RdrName -> [(String,[Located (SourceText,FastString)])] - doHsExpr (HsCoreAnn src ss _) = [("co",[conv (noLoc ss)])] - doHsExpr (HsSCC src ss _) = [("sc",[conv (noLoc ss)])] - doHsExpr (HsTickPragma src (ss,_,_) _) = [("tp",[conv (noLoc ss)])] - doHsExpr _ = [] - - conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs) - -showAnns anns = "[\n" ++ (intercalate "\n" - $ map (\((s,k),v) - -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) - $ Map.toList anns) - ++ "]\n" - -pp a = showPpr unsafeGlobalDynFlags a - --- --------------------------------------------------------------------- - --- Copied from syb for the test - - --- | Generic queries of type \"r\", --- i.e., take any \"a\" and return an \"r\" --- -type GenericQ r = forall a. Data a => a -> r - - --- | Make a generic query; --- start from a type-specific case; --- return a constant otherwise --- -mkQ :: ( Typeable a - , Typeable b - ) - => r - -> (b -> r) - -> a - -> r -(r `mkQ` br) a = case cast a of - Just b -> br b - Nothing -> r - --- | Extend a generic query by a type-specific case -extQ :: ( Typeable a - , Typeable b - ) - => (a -> q) - -> (b -> q) - -> a - -> q -extQ f g a = maybe (f a) g (cast a) - - --- | Summarise all nodes in top-down, left-to-right order -everything :: (r -> r -> r) -> GenericQ r -> GenericQ r - --- Apply f to x to summarise top-level node; --- use gmapQ to recurse into immediate subterms; --- use ordinary foldl to reduce list of intermediate results - -everything k f x = foldl k (f x) (gmapQ (everything k f) x) diff --git a/tests/examples/ghc80/t10255.hs b/tests/examples/ghc80/t10255.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10255.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10268.hs b/tests/examples/ghc80/t10268.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10268.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10269.hs b/tests/examples/ghc80/t10269.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10269.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10278.hs b/tests/examples/ghc80/t10278.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10278.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10280.hs b/tests/examples/ghc80/t10280.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10280.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10307.hs b/tests/examples/ghc80/t10307.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10307.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10309.hs b/tests/examples/ghc80/t10309.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10309.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10312.hs b/tests/examples/ghc80/t10312.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10312.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10354.hs b/tests/examples/ghc80/t10354.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10354.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10357.hs b/tests/examples/ghc80/t10357.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10357.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10358.hs b/tests/examples/ghc80/t10358.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10358.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10396.hs b/tests/examples/ghc80/t10396.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10396.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/t10399.hs b/tests/examples/ghc80/t10399.hs deleted file mode 100644 --- a/tests/examples/ghc80/t10399.hs +++ /dev/null @@ -1,7 +0,0 @@ -import CheckUtils -import System.Environment( getArgs ) - -main::IO() -main = do - [libdir,fileName] <- getArgs - testOneFile libdir fileName diff --git a/tests/examples/ghc80/tc265.hs b/tests/examples/ghc80/tc265.hs deleted file mode 100644 --- a/tests/examples/ghc80/tc265.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -module Tc265 where - -data T a = MkT (F a) -type family F a where - F (T a) = a - F (T Int) = Bool diff --git a/tests/examples/ghc80/tcfail223.hs b/tests/examples/ghc80/tcfail223.hs deleted file mode 100644 --- a/tests/examples/ghc80/tcfail223.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} -module ShouldFail where - -class Class1 a -class Class1 a => Class2 a -class Class2 a => Class3 a - --- This was wrongfully accepted by ghc-7.0 to ghc-7.10. --- It is missing a `Class1 a` constraint. -instance Class3 a => Class2 a diff --git a/tests/examples/ghc80/update-existential.hs b/tests/examples/ghc80/update-existential.hs deleted file mode 100644 --- a/tests/examples/ghc80/update-existential.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE - NoImplicitPrelude - , ExistentialQuantification - #-} - -module Test where - -hGetContents handle_ = handle_{ haType=SemiClosedHandle} - -data HandleType = SemiClosedHandle - -class Show a where - show :: a -> a - --- they have to check whether the handle has indeed been closed. -data Handle__ - = forall dev . (Show dev) => - Handle__ { - haDevice :: !dev, - haType :: HandleType -- type (read/write/append etc.) -} diff --git a/tests/examples/ghc810/T16326_Compile1.hs b/tests/examples/ghc810/T16326_Compile1.hs deleted file mode 100644 --- a/tests/examples/ghc810/T16326_Compile1.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnicodeSyntax #-} -module T16326_Compile1 where - -import Data.Kind - -type DApply a (b :: a -> Type) (f :: forall (x :: a) -> b x) (x :: a) = - f x - -type DComp a - (b :: a -> Type) - (c :: forall (x :: a). b x -> Type) - (f :: forall (x :: a). forall (y :: b x) -> c y) - (g :: forall (x :: a) -> b x) - (x :: a) = - f (g x) - --- Ensure that ElimList has a CUSK, beuas it is --- is used polymorphically its RHS (c.f. #16344) -type family ElimList (a :: Type) - (p :: [a] -> Type) - (s :: [a]) - (pNil :: p '[]) - (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)) - :: p s where - forall a p pNil (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)). - ElimList a p '[] pNil pCons = - pNil - forall a p x xs pNil (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)). - ElimList a p (x:xs) pNil pCons = - pCons x xs (ElimList a p xs pNil pCons) - -data Proxy' :: forall k -> k -> Type where - MkProxy' :: forall k (a :: k). Proxy' k a - -type family Proxy2' ∷ ∀ k → k → Type where - Proxy2' = Proxy' - diff --git a/tests/examples/ghc810/T17296.hs b/tests/examples/ghc810/T17296.hs deleted file mode 100644 --- a/tests/examples/ghc810/T17296.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -module T17296 where - -import Data.Foldable -import Data.Kind -import Language.Haskell.TH hiding (Type) -import System.IO - -data family Foo1 :: Type -> Type -data instance Foo1 Bool = Foo1Bool -data instance Foo1 (Maybe a) - -data family Foo2 :: k -> Type -data instance Foo2 Bool = Foo2Bool -data instance Foo2 (Maybe a) -data instance Foo2 :: Char -> Type -data instance Foo2 :: (Char -> Char) -> Type where - -data family Foo3 :: k -data instance Foo3 -data instance Foo3 Bool = Foo3Bool -data instance Foo3 (Maybe a) -data instance Foo3 :: Char -> Type -data instance Foo3 :: (Char -> Char) -> Type where - -$(do let test :: Name -> Q () - test n = do i <- reify n - runIO $ do hPutStrLn stderr $ pprint i - hPutStrLn stderr "" - hFlush stderr - - traverse_ test [''Foo1, ''Foo2, ''Foo3] - pure []) - diff --git a/tests/examples/ghc810/T3391.hs b/tests/examples/ghc810/T3391.hs deleted file mode 100644 --- a/tests/examples/ghc810/T3391.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -v0 #-} - --- We should only generate one set of generic to/from functions --- for T, despite the multiple chunks caused by the TH splices --- See #3391 - -module T3391 where - -data T = MkT - -$(return []) - -$(return []) - diff --git a/tests/examples/ghc810/TH_scope.hs b/tests/examples/ghc810/TH_scope.hs deleted file mode 100644 --- a/tests/examples/ghc810/TH_scope.hs +++ /dev/null @@ -1,10 +0,0 @@ --- Test for #2188 -{-# LANGUAGE TemplateHaskellQuotes #-} - -module TH_scope where - -f g = [d| f :: Int - f = g - g :: Int - g = 4 |] - diff --git a/tests/examples/ghc810/TH_unresolvedInfix.hs b/tests/examples/ghc810/TH_unresolvedInfix.hs deleted file mode 100644 --- a/tests/examples/ghc810/TH_unresolvedInfix.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NoStarIsType #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - -module Main where - -import TH_unresolvedInfix_Lib -import Language.Haskell.TH - --------------------------------------------------------------------------------- --- Expressions -- --------------------------------------------------------------------------------- -exprs = [ --------------- Completely-unresolved bindings - $( n +? (n *? n) ), - $( (n +? n) *? n ), - $( n +? (n +? n) ), - $( (n +? n) +? n ), - -- VarE version - $( uInfixE n plus2 (uInfixE n plus2 n) ), - $( uInfixE (uInfixE n plus2 n) plus2 n ), - $( uInfixE n plus3 (uInfixE n plus3 n) ), - $( uInfixE (uInfixE n plus3 n) plus3 n ), - ---------------- Completely-resolved bindings - $( n +! (n *! n) ), - $( (n +! n) *! n ), - $( n +! (n +! n) ), - $( (n +! n) +! n ), - --------------- Mixed resolved/unresolved - $( (n +! n) *? (n +? n) ), - $( (n +? n) *? (n +! n) ), - $( (n +? n) *! (n +! n) ), - $( (n +? n) *! (n +? n) ), - --------------- Parens - $( ((parensE ((n +? n) *? n)) +? n) *? n ), - $( (parensE (n +? n)) *? (parensE (n +? n)) ), - $( parensE ((n +? n) *? (n +? n)) ), - --------------- Sections - $( infixE (Just $ n +? n) plus Nothing ) N, - -- see B.hs for the (non-compiling) other version of the above - $( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N - ] - --------------------------------------------------------------------------------- --- Patterns -- --------------------------------------------------------------------------------- -patterns = [ --------------- Completely-unresolved patterns - case N :+ (N :* N) of - [p1|unused|] -> True, - case N :+ (N :* N) of - [p2|unused|] -> True, - case (N :+ N) :+ N of - [p3|unused|] -> True, - case (N :+ N) :+ N of - [p4|unused|] -> True, --------------- Completely-resolved patterns - case N :+ (N :* N) of - [p5|unused|] -> True, - case (N :+ N) :* N of - [p6|unused|] -> True, - case N :+ (N :+ N) of - [p7|unused|] -> True, - case (N :+ N) :+ N of - [p8|unused|] -> True, --------------- Mixed resolved/unresolved - case ((N :+ N) :* N) :+ N of - [p9|unused|] -> True, - case N :+ (N :* (N :+ N)) of - [p10|unused|] -> True, - case (N :+ N) :* (N :+ N) of - [p11|unused|] -> True, - case (N :+ N) :* (N :+ N) of - [p12|unused|] -> True, --------------- Parens - case (N :+ (N :* N)) :+ (N :* N) of - [p13|unused|] -> True, - case (N :+ N) :* (N :+ N) of - [p14|unused|] -> True, - case (N :+ (N :* N)) :+ N of - [p15|unused|] -> True - ] - --------------------------------------------------------------------------------- --- Types -- --------------------------------------------------------------------------------- - --------------- Completely-unresolved types -_t1 = 1 `Plus` (1 `Times` 1) :: $( int $+? (int $*? int) ) -_t2 = 1 `Plus` (1 `Times` 1) :: $( (int $+? int) $*? int ) -_t3 = (1 `Plus` 1) `Plus` 1 :: $( int $+? (int $+? int) ) -_t4 = (1 `Plus` 1) `Plus` 1 :: $( (int $+? int) $+? int ) --------------- Completely-resolved types -_t5 = 1 `Plus` (1 `Times` 1) :: $( int $+! (int $*! int) ) -_t6 = (1 `Plus` 1) `Times` 1 :: $( (int $+! int) $*! int ) -_t7 = 1 `Plus` (1 `Plus` 1) :: $( int $+! (int $+! int) ) -_t8 = (1 `Plus` 1) `Plus` 1 :: $( (int $+! int) $+! int ) --------------- Mixed resolved/unresolved -_t9 = ((1 `Plus` 1) `Times` 1) `Plus` 1 :: $( (int $+! int) $*? (int $+? int) ) -_t10 = 1 `Plus` (1 `Times` (1 `Plus` 1)) :: $( (int $+? int) $*? (int $+! int) ) -_t11 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+! int) ) -_t12 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+? int) ) --------------- Parens -_t13 = (1 `Plus` (1 `Times` 1)) `Plus` (1 `Times` 1) :: $( ((parensT ((int $+? int) $*? int)) $+? int) $*? int ) -_t14 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (parensT (int $+? int)) $*? (parensT (int $+? int)) ) -_t15 = (1 `Plus` (1 `Times` 1)) `Plus` 1 :: $( parensT ((int $+? int) $*? (int $+? int)) ) - -main = do - mapM_ print exprs - mapM_ print patterns - -- check that there are no Parens or UInfixes in the output - runQ [|N :* N :+ N|] >>= print - runQ [|(N :* N) :+ N|] >>= print - runQ [p|N :* N :+ N|] >>= print - runQ [p|(N :* N) :+ N|] >>= print - runQ [t|Int * Int + Int|] >>= print - runQ [t|(Int * Int) + Int|] >>= print - - -- pretty-printing of unresolved infix expressions - let ne = ConE $ mkName "N" - np = ConP (mkName "N") [] - nt = ConT (mkName "Int") - plusE = ConE (mkName ":+") - plusP = (mkName ":+") - plusT = (mkName "+") - putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UInfixE ne plusE (UInfixE ne plusE ne))) - putStrLn $ pprint (ParensE ne) - putStrLn $ pprint (InfixP np plusP (UInfixP np plusP (UInfixP np plusP np))) - putStrLn $ pprint (ParensP np) - putStrLn $ pprint (InfixT nt plusT (UInfixT nt plusT (UInfixT nt plusT nt))) - putStrLn $ pprint (ParensT nt) - diff --git a/tests/examples/ghc810/TH_unresolvedInfix_Lib.hs b/tests/examples/ghc810/TH_unresolvedInfix_Lib.hs deleted file mode 100644 --- a/tests/examples/ghc810/TH_unresolvedInfix_Lib.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NoStarIsType #-} - -module TH_unresolvedInfix_Lib where - -import Language.Haskell.TH -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Quote - -infixl 6 :+ -infixl 7 :* - -data Tree = N - | Tree :+ Tree - | Tree :* Tree - --- custom instance, including redundant parentheses -instance Show Tree where - show N = "N" - show (a :+ b) = "(" ++ show a ++ " :+ " ++ show b ++ ")" - show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")" - --- VarE versions -infixl 6 +: -infixl 7 *: -(+:) = (:+) -(*:) = (:*) - -n = conE (mkName "N") -plus = conE (mkName ":+") -times = conE (mkName ":*") - -a +? b = uInfixE a plus b -a *? b = uInfixE a times b -a +! b = infixApp a plus b -a *! b = infixApp a times b - -plus2 = varE (mkName "+:") -times2 = varE (mkName "*:") -plus3 = conE ('(:+)) - - --------------------------------------------------------------------------------- --- Patterns -- --------------------------------------------------------------------------------- --- The only way to test pattern splices is using QuasiQuotation -mkQQ pat = QuasiQuoter undefined (const pat) undefined undefined -p = conP (mkName "N") [] -plus' = mkName ":+" -times' = mkName ":*" - -a ^+? b = uInfixP a plus' b -a ^*? b = uInfixP a times' b -a ^+! b = infixP a plus' b -a ^*! b = infixP a times' b - --------------- Completely-unresolved patterns -p1 = mkQQ ( p ^+? (p ^*? p) ) -p2 = mkQQ ( (p ^+? p) ^*? p ) -p3 = mkQQ ( p ^+? (p ^+? p) ) -p4 = mkQQ ( (p ^+? p) ^+? p ) --------------- Completely-resolved patterns -p5 = mkQQ ( p ^+! (p ^*! p) ) -p6 = mkQQ ( (p ^+! p) ^*! p ) -p7 = mkQQ ( p ^+! (p ^+! p) ) -p8 = mkQQ ( (p ^+! p) ^+! p ) --------------- Mixed resolved/unresolved -p9 = mkQQ ( (p ^+! p) ^*? (p ^+? p) ) -p10 = mkQQ ( (p ^+? p) ^*? (p ^+! p) ) -p11 = mkQQ ( (p ^+? p) ^*! (p ^+! p) ) -p12 = mkQQ ( (p ^+? p) ^*! (p ^+? p) ) --------------- Parens -p13 = mkQQ ( ((parensP ((p ^+? p) ^*? p)) ^+? p) ^*? p ) -p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) ) -p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) ) - --------------------------------------------------------------------------------- --- Types -- --------------------------------------------------------------------------------- - -infixl 6 + -infixl 7 * -data (+) a b = Plus a b -data (*) a b = Times a b - -int = conT (mkName "Int") -tyPlus = mkName "+" -tyTimes = mkName "*" - -a $+? b = uInfixT a tyPlus b -a $*? b = uInfixT a tyTimes b -a $+! b = infixT a tyPlus b -a $*! b = infixT a tyTimes b - diff --git a/tests/examples/ghc810/mod181.hs b/tests/examples/ghc810/mod181.hs deleted file mode 100644 --- a/tests/examples/ghc810/mod181.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE ImportQualifiedPost #-} - --- If 'ImportQualifiedPost' is enabled 'qualified' can appear in --- postpositive position. - -import Prelude qualified - -main = Prelude.undefined - diff --git a/tests/examples/ghc810/saks029.hs b/tests/examples/ghc810/saks029.hs deleted file mode 100644 --- a/tests/examples/ghc810/saks029.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE PolyKinds, DataKinds, RankNTypes, TypeFamilies #-} - -module SAKS_029 where - -import Data.Kind -import Data.Proxy -import Data.Type.Bool - -type IfK :: forall j m n. forall (e :: Proxy (j :: Bool)) -> m -> n -> If j m n -type family IfK e f g where - IfK (_ :: Proxy True) f _ = f - IfK (_ :: Proxy False) _ g = g - diff --git a/tests/examples/ghc810/saks032.hs b/tests/examples/ghc810/saks032.hs deleted file mode 100644 --- a/tests/examples/ghc810/saks032.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, RankNTypes #-} - -module SAKS_032 where - -import Data.Kind -import Data.Proxy - -type Const :: Type -> forall k. k -> Type -data Const a b = Const a - -type F :: Type -> Type -> forall k. k -> Type -type family F a b :: forall k. k -> Type where - F () () = Proxy - F a b = Const (a,b) - -type F1 :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type -type family F1 a b - -type F2 :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type -type family F2 a b :: forall r2. (r1, r2) -> Type - diff --git a/tests/examples/ghc82/Completesig03A.hs b/tests/examples/ghc82/Completesig03A.hs deleted file mode 100644 --- a/tests/examples/ghc82/Completesig03A.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Completesig03A where - -data A = A | B - -{-# COMPLETE A #-} - diff --git a/tests/examples/ghc82/Lib.hs b/tests/examples/ghc82/Lib.hs deleted file mode 100644 --- a/tests/examples/ghc82/Lib.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE UnboxedSums, MagicHash #-} - -module Lib (flip, getInt) where - -import GHC.Exts -import Prelude (Int) - -{-# NOINLINE flip #-} -flip :: (# Int | Int# #) -> (# Int# | Int #) -flip (# i | #) = (# | i #) -flip (# | i #) = (# i | #) - -{-# NOINLINE getInt #-} -getInt :: (# Int# | Int #) -> Int -getInt (# i | #) = I# i -getInt (# | i #) = i - diff --git a/tests/examples/ghc82/List2.hs b/tests/examples/ghc82/List2.hs deleted file mode 100644 --- a/tests/examples/ghc82/List2.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE GADTs #-} ------------------------------------------------------------------------------ --- | --- Module : Type.Family.List --- Copyright : Copyright (C) 2015 Kyle Carter --- License : BSD3 --- --- Maintainer : Kyle Carter --- Stability : experimental --- Portability : RankNTypes --- --- Convenient aliases and type families for working with --- type-level lists. ----------------------------------------------------------------------------- - -module Type.Family.List where - -import Type.Family.Constraint -import Type.Family.Monoid -import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>)) -import Type.Class.Witness - -type Ø = '[] -type (:<) = '(:) -infixr 5 :< - diff --git a/tests/examples/ghc82/Ppr048.hs b/tests/examples/ghc82/Ppr048.hs deleted file mode 100644 --- a/tests/examples/ghc82/Ppr048.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Ppr048 where - -{-# SCc foo #-} -foo :: Int -> Int -foo x = x - -{-# SCc foo2 "label" #-} -foo2 :: () -foo2 = () - diff --git a/tests/examples/ghc82/T11727.hs b/tests/examples/ghc82/T11727.hs deleted file mode 100644 --- a/tests/examples/ghc82/T11727.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module T11727 where - -pattern A,B :: Int -pattern A = 5 -pattern B = 5 - diff --git a/tests/examples/ghc82/T13050.hs b/tests/examples/ghc82/T13050.hs deleted file mode 100644 --- a/tests/examples/ghc82/T13050.hs +++ /dev/null @@ -1,7 +0,0 @@ -module HolesInfix where - -f, g, q :: Int -> Int -> Int -f x y = _ x y -g x y = x `_` y -q x y = x `_a` y - diff --git a/tests/examples/ghc82/T13594.hs b/tests/examples/ghc82/T13594.hs deleted file mode 100644 --- a/tests/examples/ghc82/T13594.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} - -module Bug where - -x :: forall a b. (a ~ Integer, b ~ Integer) => (a, b) -!x = (1, 2) -~y = (1, 2) diff --git a/tests/examples/ghc82/brackets.hs b/tests/examples/ghc82/brackets.hs deleted file mode 100644 --- a/tests/examples/ghc82/brackets.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UnicodeSyntax #-} - --- See Trac #10162 and #11743 for details - -module ShouldCompile where - -import Control.Arrow -import Language.Haskell.TH - -handle :: ArrowPlus a => a (b,s) c -> a (b,(String,s)) c -> a (b,s) c -handle f h = proc (b,s) -> (f -< (b,s)) <+> (h -< (b,("FAIL",s))) - -f :: ArrowPlus a => a (Int,Int) String -f = proc (x,y) -> - ⦇handle - (returnA -< show y) - (\s -> returnA -< s ++ show x) - ⦈ - -g :: ArrowPlus a => a (Int,Int) String -g = proc (x,y) -> - ⦇handle - (\msg -> returnA -< msg ++ show y) - (\s msg -> returnA -< s ++ show x) - ⦈ ("hello " ++ show x) - -h :: ArrowPlus a => a (Int,Int) Int -h = proc (x,y) -> - ( - (\z -> returnA -< x + z) - <+> - (\z -> returnA -< y + z) - ) (x*y) - - -matches :: PatQ -> ExpQ -matches pat = ⟦\x -> - case x of - $pat -> True - _ -> False - ⟧ - diff --git a/tests/examples/ghc82/completesig01.hs b/tests/examples/ghc82/completesig01.hs deleted file mode 100644 --- a/tests/examples/ghc82/completesig01.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -Wall #-} -module Simple where - -pattern Foo :: () -pattern Foo = () - -a :: () -> () -a Foo = () - -data A = B | C | D - -{-# COMPLETE Foo #-} -{-# COMPLETE B,C #-} -{-# COMPLETE B #-} - -b :: A -> A -b B = B -b C = C - diff --git a/tests/examples/ghc84/Functors.hs b/tests/examples/ghc84/Functors.hs deleted file mode 100644 --- a/tests/examples/ghc84/Functors.hs +++ /dev/null @@ -1,530 +0,0 @@ --- | Types are great. Lifting them into some sort of applicative functor makes --- them even better. This module is an homage to our favorite applicatives, and --- to the semigroups with which they are instrinsically connected. - -{-# LANGUAGE NoImplicitPrelude #-} -- Prelude is bad -{-# LANGUAGE DeriveFunctor #-} -- Writing Functor instances is boring - -module Acme.Functors - ( - -- * Lifted-but-why - LiftedButWhy (..) - - -- * Or-not - , OrNot (..) - - -- * Two - , Two (..) - - -- * Any-number-of - , AnyNumberOf (..), (~~) - - -- * One-or-more - , OneOrMore (..) - - -- * Also-extra-thing - , Also (..) - - -- * Or-instead-other-thing - , OrInstead (..) - - -- * Or-instead-other-thing ("first" variant) - , OrInsteadFirst (..) - - -- * Determined-by-parameter - , DeterminedBy (..) - - ) where - -import Acme.Functors.Classes - - --------------------------------------------------------------------------------- --- Lifted-but-why --------------------------------------------------------------------------------- - --- | __@LiftedButWhy@__ is a boring functor that just has one value and no other --- structure or interesting properties. - -data LiftedButWhy a = - - LiftedButWhy a - -- ^ A value that has been lifted for some damned reason. - -- - -- ... Okay, to be honest, this one is /nobody's/ favorite, but it is - -- included here for completeness. - - deriving (Eq, Functor, Show) - --- | > pure = LiftedButWhy --- > --- > LiftedButWhy f <*> LiftedButWhy a = LiftedButWhy (f a) - -instance Applicative LiftedButWhy where - - pure = LiftedButWhy - - LiftedButWhy f <*> LiftedButWhy a = LiftedButWhy (f a) - --- | > LiftedButWhy a >>= f = f a -instance Monad LiftedButWhy where - - LiftedButWhy a >>= f = f a - --- | > LiftedButWhy x <> LiftedButWhy y = LiftedButWhy (x <> y) - -instance Semigroup a => Semigroup (LiftedButWhy a) where - - LiftedButWhy x <> LiftedButWhy y = LiftedButWhy (x <> y) - --- | > mempty = LiftedButWhy mempty - -instance Monoid a => Monoid (LiftedButWhy a) where - - mempty = LiftedButWhy mempty - - --------------------------------------------------------------------------------- --- Or-not --------------------------------------------------------------------------------- - --- | __@OrNot@__ is somehow slightly more interesting than @LiftedButWhy@, even --- though it may actually contain /less/. Instead of a value, there might /not/ --- be a value. --- --- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to --- be present. If any of them are absent, the whole expression evaluates to --- @Nope@. - -data OrNot a = ActuallyYes a -- ^ Some normal value. - | Nope -- ^ Chuck Testa. - deriving (Eq, Functor, Show) - --- | If you have a function @f@ that might not actually be there, and a value --- @a@ that might not actually be there, lifted application @(\<*\>)@ gives you --- @f a@ only if both of them are actually there. --- --- > pure = ActuallyYes --- > --- > ActuallyYes f <*> ActuallyYes a = ActuallyYes (f a) --- > _ <*> _ = Nope - -instance Applicative OrNot where - - pure = ActuallyYes - - ActuallyYes f <*> ActuallyYes a = ActuallyYes (f a) - _ <*> _ = Nope - -instance Monad OrNot where - - ActuallyYes a >>= f = f a - Nope >>= _ = Nope - --- | If you have value @a@ that may not actually be there, and another value --- @a'@ that might not actually be there, the lifted semigroup operation --- @(\<\>)@ gives you @a \<\> a'@ only if both of them are actually there. --- --- > ActuallyYes a <> ActuallyYes a' = ActuallyYes (a <> a') --- > _ <> _ = Nope - -instance Semigroup a => Semigroup (OrNot a) where - - ActuallyYes a <> ActuallyYes a' = ActuallyYes (a <> a') - _ <> _ = Nope - --- | > mempty = ActuallyYes mempty - -instance Monoid a => Monoid (OrNot a) where - - mempty = ActuallyYes mempty - - --------------------------------------------------------------------------------- --- Two --------------------------------------------------------------------------------- - --- | __@Two@__ is /two/ values. Yep. Just two values. - -data Two a = Two { firstOfTwo :: a -- ^ One value. - , secondOfTwo :: a -- ^ Another value. - } - deriving (Eq, Functor, Show) - --- | If you have two functions @f@ and @g@ and two values @a@ and @a'@, then you --- can apply them with @(\<*\>)@ to get two results @f a@ and @g a'@. --- --- > pure a = Two a a --- > --- > Two f g <*> Two a a' = Two (f a) (g a') - -instance Applicative Two where - - pure a = Two a a - - Two f g <*> Two a a' = Two (f a) (g a') - --- | > Two x y <> Two x' y' = Two (x <> x') (y <> y') - -instance Semigroup a => Semigroup (Two a) where - - Two x y <> Two x' y' = Two (x <> x') (y <> y') - --- | > mempty = Two mempty mempty - -instance Monoid a => Monoid (Two a) where - - mempty = Two mempty mempty - - --------------------------------------------------------------------------------- --- Any-number-of --------------------------------------------------------------------------------- - --- | __@AnyNumberOf@__ starts to get exciting. Any number of values you want. --- Zero... one ... two ... three ... four ... five ... The possibilities are --- /truly/ endless. - -data AnyNumberOf a = - - OneAndMaybeMore a (AnyNumberOf a) - -- ^ One value, and maybe even more after that! - - | ActuallyNone -- ^ Oh. Well this is less fun. - - deriving (Eq, Functor, Show) - --- | Alias for 'OneAndMaybeMore' which provides some brevity. - -(~~) :: a -> AnyNumberOf a -> AnyNumberOf a -(~~) = OneAndMaybeMore - -infixr 5 ~~ - --- | You can use this to apply any number of functions to any number of --- arguments. --- --- > pure a = OneAndMaybeMore a ActuallyNone --- > --- > OneAndMaybeMore f fs <*> OneAndMaybeMore x xs = --- > OneAndMaybeMore (f x) (fs <*> xs) --- > _ <*> _ = ActuallyNone --- --- Example: --- --- > ( (+ 1) ~~ (* 2) ~~ (+ 5) ~~ ActuallyNone ) --- > <*> ( 1 ~~ 6 ~~ 4 ~~ 37 ~~ ActuallyNone ) --- > = ( 7 ~~ 12 ~~ 9 ~~ ActuallyNone ) --- --- This example demonstrates how when there are more arguments than functions, --- any excess arguments (in this case, the @37@) are ignored. - -instance Applicative AnyNumberOf where - - pure a = OneAndMaybeMore a ActuallyNone - - OneAndMaybeMore f fs <*> OneAndMaybeMore x xs = - OneAndMaybeMore (f x) (fs <*> xs) - _ <*> _ = ActuallyNone - --- | The operation of combining some number of @a@ with some other number of @a@ --- is sometimes referred to as /zipping/. --- --- > OneAndMaybeMore x xs <> OneAndMaybeMore y ys = --- > OneAndMaybeMore (x <> y) (xs <> ys) --- > _ <> _ = ActuallyNone - -instance Semigroup a => Semigroup (AnyNumberOf a) where - - OneAndMaybeMore x xs <> OneAndMaybeMore y ys = - OneAndMaybeMore (x <> y) (xs <> ys) - _ <> _ = ActuallyNone - --- | > mempty = mempty ~~ mempty - -instance Monoid a => Monoid (AnyNumberOf a) where - - mempty = mempty ~~ mempty - - --------------------------------------------------------------------------------- --- One-or-more --------------------------------------------------------------------------------- - --- | __@OneOrMore@__ is more restrictive than AnyNumberOf, yet somehow actually --- /more/ interesting, because it excludes that dull situation where there --- aren't any values at all. - -data OneOrMore a = OneOrMore - { theFirstOfMany :: a -- ^ Definitely at least this one. - , possiblyMore :: AnyNumberOf a -- ^ And perhaps others. - } deriving (Eq, Functor, Show) - --- | > pure a = OneOrMore a ActuallyNone --- > --- > OneOrMore f fs <*> OneOrMore x xs = OneOrMore (f x) (fs <*> xs) - -instance Applicative OneOrMore where - - pure a = OneOrMore a ActuallyNone - - OneOrMore f fs <*> OneOrMore x xs = OneOrMore (f x) (fs <*> xs) - --- | --- > OneOrMore a more <> OneOrMore a' more' = --- > OneOrMore a (more <> OneAndMaybeMore a' more') - -instance Semigroup a => Semigroup (OneOrMore a) where - - OneOrMore a more <> OneOrMore a' more' = - OneOrMore a (more <> OneAndMaybeMore a' more') - --- | > mempty = OneOrMore mempty ActuallyNone - -instance Monoid a => Monoid (OneOrMore a) where - - mempty = OneOrMore mempty ActuallyNone - - --------------------------------------------------------------------------------- --- Also-extra-thing --------------------------------------------------------------------------------- - --- | __@Also extraThing@__ is a functor in which each value has an @extraThing@ --- of some other type that tags along with it. - -data (Also extraThing) a = Also - { withoutExtraThing :: a -- ^ A value. - , theExtraThing :: extraThing -- ^ An additional thing that tags along. - } - deriving (Eq, Functor, Show) - --- | Dragging the @extraThing@ along can be a bit of a burden. It prevents @Also --- extraThing@ from being an applicative functor — unless the @extraThing@ can --- pull its weight by bringing a monoid to the table. --- --- > pure = (`Also` mempty) --- > --- > (f `Also` extra1) <*> (a `Also` extra2) = f a --- > `Also` (extra1 <> extra2) - -instance Monoid extraThing => Applicative (Also extraThing) where - - pure = (`Also` mempty) - - (f `Also` extra1) <*> (a `Also` extra2) = f a - `Also` (extra1 <> extra2) - --- | --- > (a `Also` extra1) <> (a' `Also` extra2) = (a <> a') --- > `Also` (extra1 <> extra2) - -instance (Semigroup extraThing, Semigroup a) => Semigroup ((Also extraThing) a) - where - - (a `Also` extra1) <> (a' `Also` extra2) = (a <> a') - `Also` (extra1 <> extra2) - --- | > mempty = Also mempty mempty - -instance (Monoid extraThing, Monoid a) => Monoid ((Also extraThing) a) - where - - mempty = Also mempty mempty - - --------------------------------------------------------------------------------- --- Or-instead-other-thing --------------------------------------------------------------------------------- - --- | __@OrInstead otherThing@__ is a functor in which, instead of having a --- value, can actually just have some totally unrelated @otherThing@ instead. --- --- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to --- be present. If any of them are the @otherThing@ instead, then the whole --- expression evaluates to the combination of the @otherThing@s. - -data (OrInstead otherThing) a = - NotInstead a -- ^ Some normal value. - | Instead otherThing -- ^ Some totally unrelated other thing. - deriving (Eq, Functor, Show) - --- | The possibility of having an @otherThing@ obstructs this functor's ability --- to be applicative, much like the extra thing in @Also extraThing@ does. In --- this case, since we do not need an empty value for the @otherThing@, it needs --- only a semigroup to be in compliance. --- --- > pure = NotInstead --- > --- > NotInstead f <*> NotInstead a = NotInstead (f a) --- > Instead other1 <*> Instead other2 = Instead (other1 <> other2) --- > Instead other <*> _ = Instead other --- > _ <*> Instead other = Instead other - -instance Semigroup otherThing => Applicative (OrInstead otherThing) where - - pure = NotInstead - - NotInstead f <*> NotInstead a = NotInstead (f a) - Instead other1 <*> Instead other2 = Instead (other1 <> other2) - Instead other <*> _ = Instead other - _ <*> Instead other = Instead other - --- | --- > NotInstead a <> NotInstead a' = NotInstead (a <> a') --- > Instead other1 <> Instead other2 = Instead (other1 <> other2) --- > Instead other <> _ = Instead other --- > _ <> Instead other = Instead other - -instance (Semigroup otherThing, Semigroup a) => - Semigroup ((OrInstead otherThing) a) where - - NotInstead a <> NotInstead a' = NotInstead (a <> a') - Instead other1 <> Instead other2 = Instead (other1 <> other2) - Instead other <> _ = Instead other - _ <> Instead other = Instead other - --- > mempty = NotInstead mempty - -instance (Semigroup otherThing, Monoid a) => Monoid ((OrInstead otherThing) a) - where - - mempty = NotInstead mempty - - --------------------------------------------------------------------------------- --- Or-instead-first-thing --------------------------------------------------------------------------------- - --- | __@OrInsteadFirst otherThing@__ looks a lot like @OrInstead otherThing@, --- but it manages to always be an applicative functor — and even a monad too — --- by handling the @otherThing@s a bit more hamfistedly. --- --- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to --- be present. If any of them are the @otherThing@ instead, then the whole --- expression evaluates to the /first/ @otherThing@ encountered, ignoring any --- additional @otherThings@ that may subsequently pop up - -data (OrInsteadFirst otherThing) a = - NotInsteadFirst a -- ^ Some normal value. - | InsteadFirst otherThing -- ^ Some totally unrelated other thing. - deriving (Eq, Functor, Show) - --- | --- > pure = NotInsteadFirst --- > --- > NotInsteadFirst f <*> NotInsteadFirst a = NotInsteadFirst (f a) --- > InsteadFirst other <*> _ = InsteadFirst other --- > _ <*> InsteadFirst other = InsteadFirst other - -instance Applicative (OrInsteadFirst otherThing) where - - pure = NotInsteadFirst - - NotInsteadFirst f <*> NotInsteadFirst a = NotInsteadFirst (f a) - InsteadFirst other <*> _ = InsteadFirst other - _ <*> InsteadFirst other = InsteadFirst other - --- | --- > InsteadFirst other >>= _ = InsteadFirst other --- > NotInsteadFirst a >>= f = f a - -instance Monad (OrInsteadFirst otherThing) where - - InsteadFirst other >>= _ = InsteadFirst other - NotInsteadFirst a >>= f = f a - --- | --- > NotInsteadFirst a <> NotInsteadFirst a' = NotInsteadFirst (a <> a') --- > InsteadFirst other <> _ = InsteadFirst other --- > _ <> InsteadFirst other = InsteadFirst other - -instance (Semigroup otherThing, Semigroup a) => - Semigroup ((OrInsteadFirst otherThing) a) where - - NotInsteadFirst a <> NotInsteadFirst a' = NotInsteadFirst (a <> a') - InsteadFirst other <> _ = InsteadFirst other - _ <> InsteadFirst other = InsteadFirst other - --- | > mempty = NotInsteadFirst mempty - -instance (Semigroup otherThing, Monoid a) => - Monoid ((OrInsteadFirst otherThing) a) where - - mempty = NotInsteadFirst mempty - - --------------------------------------------------------------------------------- --- Determined-by-parameter --------------------------------------------------------------------------------- - --- | __@DeterminedBy parameter@__ is a value that... well, we're not really sure --- what it is. We'll find out once a @parameter@ is provided. --- --- The mechanism for deciding /how/ the value is determined from the --- @parameter@ is opaque; all you can do is test it with different parameters --- and see what results. There aren't even @Eq@ or @Show@ instances, which is --- annoying. - -data DeterminedBy parameter a = Determination ((->) parameter a) - deriving (Functor) - --- | --- > pure a = Determination (\_ -> a) --- > --- > Determination f <*> Determination a = Determination (\x -> f x (a x)) - -instance Applicative (DeterminedBy parameter) where - - pure a = Determination (\_ -> a) - - Determination f <*> Determination a = Determination (\x -> f x (a x)) - --- | --- > Determination fa >>= ff = --- > Determination (\x -> let Determination f = ff (fa x) in f x) - -instance Monad (DeterminedBy parameter) where - - Determination fa >>= ff = - Determination (\x -> let Determination f = ff (fa x) in f x) - --- | > Determination f <> Determination g = Determination (\x -> f x <> g x) - -instance Semigroup a => Semigroup ((DeterminedBy parameter) a) where - - Determination f <> Determination g = Determination (\x -> f x <> g x) - --- | > mempty = Determination (\_ -> mempty) - -instance Monoid a => Monoid ((DeterminedBy parameter) a) where - - mempty = Determination (\_ -> mempty) - - -{- - --------------------------------------------------------------------------------- --- Notes --------------------------------------------------------------------------------- - -LiftedButWhy is Identity. - -OrNot is Maybe, but with a different semigroup and monoid. - -Two doesn't have an analogue in the standard library as far as I know. - -AnyNumberOf is ZipList. - -OneOrMore is NonEmpty. - -Also is (,), the 2-tuple. - -OrInstead is AccValidation from the 'validation' package. - -OrInsteadFirst is Either. - -DeterminedBy is (->) also known as a function, whose functor is also known as -Reader. - --} diff --git a/tests/examples/ghc84/Main.hs b/tests/examples/ghc84/Main.hs deleted file mode 100644 --- a/tests/examples/ghc84/Main.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, StandaloneDeriving, TypeFamilies, GADTs - , ViewPatterns, TypeOperators, TypeApplications, StandaloneDeriving - , UnicodeSyntax, PatternSynonyms, FlexibleContexts, DataKinds, UndecidableInstances - , TypeFamilyDependencies #-} - --- invoke as: ghci Main.hs -ddump-parsed -ddump-rn --- or in GHCi: :set -ddump-parsed -ddump-rn - -import TyFamWitnesses -import Language.Haskell.TH hiding (Type) -import Data.Type.Equality hiding (apply) -import Type.Reflection -import Unsafe.Coerce (unsafeCoerce) -import Data.Char (ord) -import GHC.TypeLits - - -stuffhave = [d| type family Foo a b where - Foo a a = Int - Foo (IO a) a = Float - Foo (IO a) b = Bool - Foo a Char = String - Foo a b = Char |] - -stuffhave1 = [d| type family Bar a where Bar Bool = Bool; Bar a = IO a |] - -stuffhave2 = [d| type family Elim a b where Elim a (a -> b) = b; Elim a (c -> b) = c -> Elim a b |] - - -witnesses [d| type family Foo a b where - Foo a a = Int - Foo (IO a) a = Float - Foo (IO a) b = Bool - Foo a Char = String - Foo a b = Char |] - -deriving instance Show (FooRefl a b) - --- now you can: --- --- >>> :info FooRefl --- type role FooRefl nominal nominal --- data FooRefl a b where --- Foo0 :: (Foo a a ~ Int) => FooRefl a a --- Foo1 :: (Foo (IO b) b ~ Float) => FooRefl (IO b) b --- Foo2 :: (Foo (IO a1) b ~ Bool) => FooRefl (IO a1) b --- Foo3 :: (Foo a Char ~ String) => FooRefl a Char --- Foo4 :: (Foo a b ~ Char) => FooRefl a b --- -- Defined at Main.hs:13:1 --- instance Show (FooRefl a b) -- Defined at Main.hs:14:1 --- --- >>> :info reify_Foo --- reify_Foo :: TypeRep a -> TypeRep b -> Maybe (FooRefl a b) --- -- Defined at Main.hs:13:1 --- --- >>> reify_Foo (typeOf getChar) (typeRep @Char) --- Just Foo1 --- - -witnesses [d| type family Bar a where Bar Bool = Bool; Bar a = IO a |] -deriving instance Show (BarRefl a) - -witnesses [d| type family Elim a b where Elim a (a -> b) = b; Elim a (c -> b) = c -> Elim a b |] -deriving instance Show (ElimRefl a b) - -pure [] - -stuffwant2 = [d| - fooRefl :: forall a b . TypeRep a -> TypeRep b -> Maybe (FooRefl a b) - fooRefl a b | Just HRefl <- eqTypeRep a b = pure Foo0 - fooRefl a b | Refl <- unsafeCoerce Refl :: Foo a b :~: Char = pure Foo1 - |] - -stuffhave3 = [d| data Peano = Z | S Peano - type family ToPeano (n :: Nat) :: Peano where ToPeano 0 = Z; ToPeano n = S (ToPeano (n-1)) - type family FromPeano (p :: Peano) :: Nat where FromPeano Z = 0; FromPeano (S n) = 1 + FromPeano n - |] - - -witnesses [d| data Peano = Z | S Peano - type family ToPeano (n :: Nat) :: Peano where ToPeano 0 = Z; ToPeano n = S (ToPeano (n-1)) - type family FromPeano (p :: Peano) :: Nat where FromPeano Z = 0; FromPeano (S n) = 1 + FromPeano n - |] - - -deriving instance Show (ToPeanoRefl n) -deriving instance Show (FromPeanoRefl p) - -witnesses [d| type family Unspell (w :: Symbol) = (r :: Nat) | r -> w where - Unspell "zero" = 0 - Unspell "one" = 1 - Unspell "two" = 2 - Unspell "three" = 3 - |] -deriving instance Show (UnspellRefl w) - -main = runQ (witnesses stuffhave2) >>= print - -test@Just{} = reify_Elim (typeRep @Integer) (typeOf ((+1)::Integer->Integer)) - -lemma :: v -> TypeRep f -> TypeRep v - -> Maybe (TypeRep (v `Elim` f), f -> v `Elim` f) -lemma w f v = do d `Fun'` c <- pure f - witness <- v `reify_Elim` f - case witness of - Elim0 -> pure (c, ($ w)) - Elim1 -> do (e, g) <- lemma w c v - pure (d `Fun` e, (g.)) - -data Tag = Source | Destination | CheckSource Bool | CheckDest Bool | Cut Bool - -newtype TaggedAction (t :: Tag) = Tagged (IO ()) - -data Action where - Action :: Typeable t ⇒ TaggedAction t → Action - Catalyst :: Typeable (c → d) ⇒ (c → d) → Action - -pattern A :: forall k a. () => forall b. (TaggedAction b ~~ a) => TypeRep b → TypeRep a -pattern A b ← (eqTypeRep (typeRep @TaggedAction) → Just HRefl) `App` b - - -reaction :: Action → Action → Maybe Action -reaction (Catalyst f) (Action v) = do (rep, f') ← lemma v (typeOf f) (typeOf v) - pure $ case rep of - _ `Fun'` _ → withTypeable rep (Catalyst $ f' f) - A indx → withTypeable indx (Action $ f' f) - - -member :: Eq a => a -> [a] -> Bool -member = elem - -y $$ x = ($ y).($ x) - ---Just (t3r, (($ elem) -> t3)) = lemma 'j' (typeOf $ member @Char) (typeOf 'j') -- https://ghc.haskell.org/trac/ghc/ticket/14293 -Just (t3r, (($ "joe").($ elem) -> t3@True)) = lemma 'j' (typeOf $ member @Char) (typeOf 'j') -Just (t4r, (($ 'o').($ elem) -> t4@True)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe") --- Just (t4'r, ('x' $$ elem -> t4'@False)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe") -- Same bug -Just (t4'r, (($ 'x').($ elem) -> t4'@False)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe") - -t0@Nothing = lemma "joe" (typeOf ord) (typeOf "joe") - - -Just u0 = reify_FromPeano (typeRep @Z) -Just u1 = reify_FromPeano (typeRep @(S Z)) -Just u2 = reify_FromPeano (typeRep @(S (S Z))) - -Just un0 = reify_Unspell (typeRep @"zero") -Just un1 = reify_Unspell (typeRep @"one") -Just un2 = reify_Unspell (typeRep @"two") - diff --git a/tests/examples/ghc84/T13747.hs b/tests/examples/ghc84/T13747.hs deleted file mode 100644 --- a/tests/examples/ghc84/T13747.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} - -module T13747 where - -class C a where - type family TC a :: * - -class D a where - data family TD a :: * - -instance C Int where - type instance TC Int = Int - -instance D Double where - data instance TD Double = TDDouble - -instance D Int where - newtype instance TD Int = TDInt Int - -instance D Char where - data instance TD Char where - C1 :: TD Char - C2 :: TD Char - diff --git a/tests/examples/ghc84/Types.hs b/tests/examples/ghc84/Types.hs deleted file mode 100644 --- a/tests/examples/ghc84/Types.hs +++ /dev/null @@ -1,392 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -{-# OPTIONS_GHC -Wno-duplicate-exports #-} - -module Graphics.UI.Threepenny.Editors.Types - ( - -- * GenericWidgets - GenericWidget(..) - , edited - , contents - , widgetControl - , widgetTidings - -- * Editors - , Editor(.., Horizontally, horizontally, Vertically, vertically) - , liftElement - , dimapE - , applyE - -- ** Editor composition - , (|*|), (|*), (*|) - , (-*-), (-*), (*-) - , field - , fieldLayout - -- ** Editor constructors - , editorUnit - , editorIdentity - , editorString - , editorText - , editorCheckBox - , editorReadShow - , editorEnumBounded - , editorSelection - , editorSum - , editorJust - , EditorCollection(..) - , editorCollection - , editorList - , EditorCollectionConfig(..) - , defaultEditorCollectionConfig - -- ** Representation of empty values - , HasEmpty(..) - ) where - -import Control.Monad -import Data.Biapplicative -import Data.Maybe -import Data.HasEmpty -import qualified Data.Foldable as F -import Data.Functor.Compose -import Data.Functor.Identity -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Profunctor -import Data.Text (Text) -import qualified Data.Text as Text -import Graphics.UI.Threepenny.Attributes -import Graphics.UI.Threepenny.Core as UI hiding (empty) -import Graphics.UI.Threepenny.Editors.Layout -import Graphics.UI.Threepenny.Editors.Utils -import Graphics.UI.Threepenny.Elements -import Graphics.UI.Threepenny.Events -import Graphics.UI.Threepenny.Widgets -import Text.Read - -data GenericWidget control a = GenericWidget - { widgetTidings :: Tidings a -- ^ The dynamic contents of the widget. - , widgetControl :: control -- ^ The actual widget. - } - deriving Functor - -instance Bifunctor GenericWidget where - bimap f g (GenericWidget t e) = GenericWidget (g <$> t) (f e) - -traverseControl :: Applicative f => (control -> f control') -> GenericWidget control a -> f (GenericWidget control' a) -traverseControl f (GenericWidget t e) = GenericWidget t <$> f e - -edited :: GenericWidget el a -> Event a -edited = rumors . widgetTidings - -contents :: GenericWidget el a -> Behavior a -contents = facts . widgetTidings - -instance Widget el => Widget (GenericWidget el a) where - getElement = getElement . widgetControl - -instance Renderable el => Renderable (GenericWidget el a) where - render = render . widgetControl - -renderEditor :: Renderable w => GenericWidget w a -> UI (GenericWidget Element a) -renderEditor = traverseControl render - --- | An editor for values of type @inner@ inside a datatype @outer@ realized by a @widget@. --- --- All the three type arguments are functorial, but @outer@ is contravariant, so @Editor@ is a 'Biapplicative' functor and a 'Profunctor' (via 'dimapE'). --- --- 'Biapplicative' allows to compose editors on both their @widget@ and @inner@ structure. When @widget@ is monoidal, widget composition is implicit and 'Applicative' suffices. --- --- 'Profunctor' allows to apply an @inner@ editor to an @outer@ datatype. --- --- Once 'create'd, an 'Editor' yields a tuple of an @widget@ and a @Tidings inner@ which can be integrated in a threepenny app. --- - -newtype Editor outer widget inner = Editor { - create :: Behavior outer -> UI (GenericWidget widget inner) - } - --- | Lift an HTML element into a vacuous editor. -liftElement :: UI el -> Editor a el () -liftElement el = Editor $ \_ -> GenericWidget (pure ()) <$> el - -bimapEditor :: (el -> el') -> (b -> b') -> Editor a el b -> Editor a el' b' -bimapEditor g h = Editor . fmap (fmap (bimap g h)) . create - -dimapE :: (a' -> a) -> (b -> b') -> Editor a el b -> Editor a' el b' -dimapE g h = unCoer . dimap (fmap g) h . coer - where - coer = Star . (Compose .) . create - unCoer = Editor . fmap getCompose . runStar - -applyE :: (el1 -> el2 -> el) -> Editor in_ el1 (a -> b) -> Editor in_ el2 a -> Editor in_ el b -applyE combineElements a b = Editor $ \s -> do - a <- create a s - b <- create b s - return $ GenericWidget (widgetTidings a <*> widgetTidings b) (widgetControl a `combineElements` widgetControl b) - -instance Functor (Editor a el) where - fmap = dimapE id - -instance Bifunctor (Editor a) where - bimap = bimapEditor - -instance Biapplicative (Editor a) where - bipure w o = Editor $ \_ -> return $ GenericWidget (pure o) w - (<<*>>) = applyE ($) - -instance Monoid el => Applicative (Editor a el) where - pure = bipure mempty - (<*>) = applyE mappend - --- | Applicative modifier for vertical composition of editor factories. --- This can be used in conjunction with ApplicativeDo as: --- --- > editorPerson = vertically $ do --- > firstName <- Vertically $ field "First:" firstName editor --- > lastName <- Vertically $ field "Last:" lastName editor --- > age <- Vertically $ field "Age:" age editor --- > return Person{..} --- --- DEPRECATED: Use the 'Vertical' layout builder instead -pattern Vertically :: Editor a Layout b -> Editor a Vertical b -pattern Vertically {vertically} <- (withLayout getVertical -> vertically) where Vertically a = withLayout Vertical a - --- | Applicative modifier for horizontal composition of editor factories. --- This can be used in conjunction with ApplicativeDo as: --- --- > editorPerson = horizontally $ do --- > firstName <- Horizontally $ field "First:" firstName editor --- > lastName <- Horizontally $ field "Last:" lastName editor --- > age <- Horizontally $ field "Age:" age editor --- > return Person{..} --- --- DEPRECATED: Use the 'Horizontal' layout builder instead -pattern Horizontally :: Editor a Layout b -> Editor a Horizontal b -pattern Horizontally {horizontally} <- (withLayout getHorizontal -> horizontally) where Horizontally a = withLayout Horizontal a - -infixl 4 |*|, -*- -infixl 5 |*, *|, -*, *- - --- | Apply a layout builder. -withLayout :: (layout -> layout') -> Editor a layout b -> Editor a layout' b -withLayout f = bimap f id - --- | Left-right editor composition -(|*|) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a -a |*| b = withLayout getHorizontal $ withLayout Horizontal a <*> withLayout Horizontal b - --- | Left-right composition of an element with a editor -(*|) :: UI Element -> Editor s Layout a -> Editor s Layout a -e *| a = withLayout getHorizontal $ liftElement(return $ horizontal e) *> withLayout Horizontal a - --- | Left-right composition of an element with a editor -(|*) :: Editor s Layout a -> UI Element -> Editor s Layout a -a |* e = withLayout getHorizontal $ withLayout Horizontal a <* liftElement(return $ horizontal e) - --- | Left-right editor composition -(-*-) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a -a -*- b = withLayout getVertical $ withLayout Vertical a <*> withLayout Vertical b - --- | Left-right composition of an element with a editor -(*-) :: UI Element -> Editor s Layout a -> Editor s Layout a -e *- a = withLayout getVertical $ liftElement(return $ vertical e) *> withLayout Vertical a - --- | Left-right composition of an element with a editor -(-*) :: Editor s Layout a -> UI Element -> Editor s Layout a -a -* e = withLayout getVertical $ withLayout Vertical a <* liftElement(return $ vertical e) - --- | A helper that arranges a label and an editor horizontally, --- wrapped in the given monoidal layout builder. -fieldLayout :: (Renderable m, Renderable m') => (Layout -> m') -> String -> (out -> inn) -> Editor inn m a -> Editor out m' a -fieldLayout l name f e = withLayout l (string name *| first getLayout (dimapE f id e)) - --- | A helper that arranges a label --- and an editor horizontally. -field :: Renderable m => String -> (out -> inn) -> Editor inn m a -> Editor out Layout a -field name f e = string name *| first getLayout (dimapE f id e) - -editorUnit :: Editor b Element b -editorUnit = Editor $ \b -> do - t <- new - return $ GenericWidget (tidings b never) t - -editorCheckBox :: Editor Bool Element Bool -editorCheckBox = Editor $ \b -> do - t <- sink checked b $ input # set type_ "checkbox" - return $ GenericWidget (tidings b $ checkedChange t) t - -editorString :: Editor String TextEntry String -editorString = Editor $ \b -> do - w <- askWindow - t <- entry b - liftIOLater $ do - initialValue <- currentValue b - _ <- runUI w $ set value initialValue (element t) - return () - return $ GenericWidget (userText t) t - -editorText :: Editor Text TextEntry Text -editorText = dimapE Text.unpack Text.pack editorString - -editorReadShow :: (Read a, Show a) => Editor (Maybe a) TextEntry (Maybe a) -editorReadShow = Editor $ \b -> do - e <- create editorString (maybe "" show <$> b) - let readIt "" = Nothing - readIt x = readMaybe x - let t = tidings b (readIt <$> edited e) - return $ GenericWidget t (widgetControl e) - --- An editor that presents a choice of values. -editorEnumBounded - :: (Bounded a, Enum a, Ord a, Show a) - => Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a) -editorEnumBounded = editorSelection (pure $ enumFrom minBound) - --- | An editor that presents a dynamic choice of values. -editorSelection - :: Ord a - => Behavior [a] -> Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a) -editorSelection options display = Editor $ \b -> do - l <- listBox options b display - return $ GenericWidget (tidings b (rumors $ userSelection l)) l - --- | Ignores 'Nothing' values and only updates for 'Just' values -editorJust :: Editor (Maybe b) el (Maybe b) -> Editor b el b -editorJust (Editor editor) = Editor $ \b -> do - e <- editor (Just <$> b) - let ev = filterJust (edited e) - return $ GenericWidget (tidings b ev) (widgetControl e) - --- | An editor for union types, built from editors for its constructors. -editorSum - :: (Ord tag, Show tag, Renderable el) - => (Layout -> Layout -> Layout) -> [(tag, Editor a el a)] -> (a -> tag) -> Editor a Layout a -editorSum combineLayout options selector = Editor $ \ba -> do - options <- mapM (\(tag, Editor mk) -> (tag,) <$> (mk ba >>= renderEditor)) options - let tag = selector <$> ba - tag' <- calmB tag - let build a = lookup a options - -- build a tag selector following the current tag - l <- listBox (pure $ fmap fst options) (Just <$> tag) (pure (string . show)) - -- a placeholder for the constructor editor - nestedEditor <- - new # sink children ((\x -> [maybe (error "editorSum") widgetControl (build x)]) <$> tag') - -- - let composed = combineLayout (Single (return $ getElement l)) (Single $ return nestedEditor) - -- the result event fires when any of the nested editors or the tag selector fire. - let editedEvents = fmap (edited . snd) options - eTag = filterJust $ rumors (userSelection l) - taggedOptions = sequenceA [(tag, ) <$> contents e | (tag, e) <- options] - editedTag = filterJust $ flip lookup <$> taggedOptions <@> eTag - editedE = head <$> unions (editedTag : editedEvents) - return $ GenericWidget (tidings ba editedE) composed - -editorIdentity :: Editor a el a -> Editor (Identity a) el (Identity a) -editorIdentity = dimapE runIdentity Identity - --------------------------- --- EditorCollection - -data EditorCollection k w = EditorCollection - { selector :: ListBox k - , add, remove :: Element - , selected :: w - } - -instance Renderable w => Renderable (EditorCollection k w) where - render EditorCollection{..} = - column - [row [ element selector, element add, element remove] - ,render selected] - -data EditorCollectionConfig k v = EditorCollectionConfig - { eccNewKey :: Behavior k -- ^ Current value to use for creating a new key - , eccAfterDelKey :: Behavior (Maybe k) -- ^ Current value to use if the selected key is deleted - , eccTemplate :: v -- ^ Value to use for creating new items - , eccOptions :: Behavior (Set k) -- ^ Currently user select able keys - , eccDisplay :: Behavior (k -> UI Element) -- ^ How to render a key - } - -defaultEditorCollectionConfig - :: (Enum k, Ord k, Show k, HasEmpty v) - => Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v -defaultEditorCollectionConfig db = EditorCollectionConfig - { eccTemplate = emptyValue - , eccOptions = options - , eccDisplay = pure (UI.string . show) - , eccNewKey = maybe (toEnum 0) succ . Set.lookupMax <$> options - , eccAfterDelKey = deletedKey <$> (fst <$> db) <*> options - } - where - options = Map.keysSet . snd <$> db - - deletedKey Nothing _ = Nothing - deletedKey (Just k) kk = Set.lookupLT k kk `mplus` Set.lookupGT k kk - --- | A barebones editor for collections of editable items. --- Displays an index selector, add and delete buttons, and an editor for the selected item. --- Limitations: --- - Won't work with recursive data structures, due to the lack of FRP switch. -editorCollection - :: forall k v w. - (Ord k, Renderable w) - => (Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v) - -> Editor v w v - -> Editor (Maybe k, Map k v) (EditorCollection k w) (Maybe k, Map k v) -editorCollection mkConfig editorOne = Editor $ \(ba :: Behavior (Maybe k, Map k v)) -> mdo - let EditorCollectionConfig{..} = mkConfig ba - (selectedKey, db) = (fst <$> ba, snd <$> ba) - sel <- create (editorSelection (Set.toList <$> eccOptions) eccDisplay) (fst <$> ba) - one <- create editorOne $ (\(k, db) -> fromMaybe eccTemplate (k >>= (`Map.lookup` db))) <$> ba - addB <- button #+ [string "+"] - remB <- button #+ [string "-"] - let insert i = Map.insert i eccTemplate - editsDb = head <$> unions - [ replace <$> ba <@> edited one - , insert <$> eccNewKey <*> db <@ click addB - , delete <$> ba <@ click remB - ] - editsKey = head <$> unions - [ edited sel - , Just <$> eccNewKey <@ click addB - , eccAfterDelKey <@ click remB - ] - tids = (,) <$> tidings selectedKey editsKey <*> tidings db editsDb - return $ GenericWidget tids (EditorCollection (widgetControl sel) addB remB (widgetControl one)) - where - replace (Just i,xx) x = Map.alter (const $ Just x) i xx - replace (Nothing,x) _ = x - delete (Just i,xx) = Map.delete i xx - delete (_,xx) = xx - --- | A barebones editor for collections of editable items. --- Displays an index selector, add and delete buttons, and an editor for the selected item. --- Limitations: --- - Won't work with recursive data structures, due to the lack of FRP switch. -editorList - :: (HasEmpty a, Renderable w) - => Editor a w a -> Editor (Maybe Int, [a]) (EditorCollection Int w) (Maybe Int, [a]) -editorList e = - dimapE (second (Map.fromAscList . zip [0 ..])) (second F.toList) $ - editorCollection config e - where - (<&>) = flip (<$>) - infixl 1 <&> - config ba = - (defaultEditorCollectionConfig ba) - { eccAfterDelKey = - ba <&> (\(i,m) -> - i >>= (\i -> - if Map.member (i + 1) m - then return i - else let i' = max 0 (i - 1) - in guard(i'>=0) >> return i')) - } - diff --git a/tests/examples/ghc86/Arith.hs b/tests/examples/ghc86/Arith.hs deleted file mode 100644 --- a/tests/examples/ghc86/Arith.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} - -module Arith where - -data E a b = E (a -> b) (b -> a) - -eqRefl :: E a a -eqRefl = E id id - --- just to construct unique strings -data W -data M a - --- terms -data Var a where - VarW :: Var W - VarM :: Var (M a) - --- expose s in the type level making sure it is a string -data Abs s e1 where - Abs :: (Var s) -> e1 -> Abs (Var s) e1 - -data App e1 e2 = App e1 e2 -data Lit = Lit - -data TyBase = TyBase -data TyArr t1 t2 = TyArr t1 t2 - --- (x:ty) in G -data IN g p where - INOne :: IN (g,(x,ty)) (x,ty) - INShift :: IN g0 (x,ty) -> IN (g0,a) (x,ty) - -data INEX g x where - INEX :: IN g (x,v) -> INEX g x - - --- G1 subseteq G2 -type SUP g1 g2 = forall a. IN g1 a -> IN g2 a - --- typing derivations -data DER g a ty where - DVar :: IN (g,g0) ((Var a),ty) -> DER (g,g0) (Var a) ty -- the g,g0 makes sure that env is non-empty - DApp :: DER g a1 (TyArr ty1 ty2) -> - DER g a2 ty1 -> DER g (App a1 a2) ty2 - DAbs :: DER (g,(Var a,ty1)) e ty2 -> - DER g (Abs (Var a) e) (TyArr ty1 ty2) - DLit :: DER g Lit TyBase - --- G |- \x.x : a -> a -test1 :: DER g (Abs (Var W) (Var W)) (TyArr ty ty) -test1 = DAbs (DVar INOne) - --- G |- (\x.x) Lit : Lit -test2 :: DER g (App (Abs (Var W) (Var W)) Lit) TyBase -test2 = DApp (DAbs (DVar INOne)) DLit - --- G |- \x.\y. x y : (C -> C) -> C -> C -test3 :: DER g (Abs (Var W) (Abs (Var (M W)) (App (Var W) (Var (M W))))) (TyArr (TyArr ty ty) (TyArr ty ty)) -test3 = DAbs (DAbs (DApp (DVar (INShift INOne)) (DVar INOne))) - -data ISVAL e where - ISVALAbs :: ISVAL (Abs (Var v) e) - ISVALLit :: ISVAL Lit - -data React e1 e2 where - SUBSTReact :: React (Abs (Var y) e) v - --- evaluation -data EDER e1 e2 where - -- EVar :: IN (a,val) -> ISVAL val -> EDER c a val - EApp1 :: EDER e1 e1' -> EDER (App e1 e2) (App e1' e2) - EApp2 :: ISVAL v1 -> EDER e2 e2' -> EDER (App v1 e2) (App v1 e2') - EAppAbs :: ISVAL v2 -> React (Abs (Var v) e) v2 -> EDER (App (Abs (Var v) e) v2) e1 - --- (\x.x) 3 -> 3 --- test4 :: EDER (App (Abs (Var W) (Var W)) Lit) Lit --- test4 = EAppAbs ISVALLit SUBSTEqVar - - --- existential -data REDUCES e1 where - REDUCES :: EDER e1 e2 -> REDUCES e1 - --- data WFEnv x c g where --- WFOne :: ISVAL v -> DER g v ty -> WFEnv (Var x) (c,(Var x,v)) (g,(Var x,ty)) --- WFShift :: WFEnv v c0 g0 -> WFEnv v (c0,(y,y1)) (g0,(z,z1)) - --- data WFENVWRAP c g where --- WFENVWRAP :: (forall v ty . IN g (v,ty) -> WFEnv v c g) -> WFENVWRAP c g - - --- data INEXVAL c x where --- INEXVAL :: IN c (x,v) -> ISVAL v -> INEXVAL c x - --- -- the first cool theorem! --- fromTEnvToEnv :: IN g (x,ty) -> WFEnv x c g -> INEXVAL c x --- fromTEnvToEnv INOne (WFOne isv _) = INEXVAL INOne isv --- fromTEnvToEnv (INShift ind1) (WFShift ind2) = --- case (fromTEnvToEnv ind1 ind2) of --- INEXVAL i isv -> INEXVAL (INShift i) isv - - -data ISLAMBDA v where ISLAMBDA :: ISLAMBDA (Abs (Var x) e) -data ISLIT v where ISLIT :: ISLIT Lit - -data EXISTAbs where - EXISTSAbs :: (Abs (Var x) e) -> EXISTAbs - -bot = bot - -canFormsLam :: ISVAL v -> DER g v (TyArr ty1 ty2) -> ISLAMBDA v -canFormsLam ISVALAbs _ = ISLAMBDA --- canFormsLam ISVALLit _ = bot <== unfortunately I cannot catch this ... requires some exhaustiveness check :-( - -canFormsLit :: ISVAL v -> DER g v TyBase -> ISLIT v -canFormsLit ISVALLit _ = ISLIT - -data NULL - -progress :: DER NULL e ty -> Either (ISVAL e) (REDUCES e) - -progress (DAbs prem) = Left ISVALAbs -progress (DLit) = Left ISVALLit --- progress (DVar iw) = bot <== here is the cool trick! I cannot even wite this down! -progress (DApp e1 e2) = - case (progress e1) of - Right (REDUCES r1) -> Right (REDUCES (EApp1 r1)) - Left isv1 -> case (progress e2) of - Right (REDUCES r2) -> Right (REDUCES (EApp2 isv1 r2)) - Left isv2 -> case (canFormsLam isv1 e1) of - ISLAMBDA -> Right (REDUCES (EAppAbs isv2 SUBSTReact)) - - --- case fromTEnvToEnv iw (f iw) of --- INEXVAL i isv -> Right (REDUCES (EVar i isv)) --- progress (WFENVWRAP f) (DApp e1 e2) = --- case (progress (WFENVWRAP f) e1) of --- Right (REDUCES r1) -> Right (REDUCES (EApp1 r1)) --- Left isv1 -> case (progress (WFENVWRAP f) e2) of --- Right (REDUCES r2) -> Right (REDUCES (EApp2 isv1 r2)) --- Left isv2 -> case (canFormsLam isv1 e1) of --- ISLAMBDA -> EAppAbs isv2 e1 - diff --git a/tests/examples/ghc86/BadTelescope.hs b/tests/examples/ghc86/BadTelescope.hs deleted file mode 100644 --- a/tests/examples/ghc86/BadTelescope.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module BadTelescope where - -import Data.Kind - -data SameKind :: k -> k -> Type - -data X a k (b :: k) (c :: SameKind a b) diff --git a/tests/examples/ghc86/BadTelescope2.hs b/tests/examples/ghc86/BadTelescope2.hs deleted file mode 100644 --- a/tests/examples/ghc86/BadTelescope2.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TypeInType, ExplicitForAll #-} - -module BadTelescope2 where - -import Data.Kind -import Data.Proxy - -data SameKind :: k -> k -> Type - -foo :: forall a k (b :: k). SameKind a b -foo = undefined - -bar :: forall a (c :: Proxy b) (d :: Proxy a). Proxy c -> SameKind b d -bar = undefined diff --git a/tests/examples/ghc86/BadTelescope3.hs b/tests/examples/ghc86/BadTelescope3.hs deleted file mode 100644 --- a/tests/examples/ghc86/BadTelescope3.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeInType, ExplicitForAll #-} - -module BadTelescope3 where - -import Data.Kind - -data SameKind :: k -> k -> Type - -type S a k (b :: k) = SameKind a b diff --git a/tests/examples/ghc86/BadTelescope4.hs b/tests/examples/ghc86/BadTelescope4.hs deleted file mode 100644 --- a/tests/examples/ghc86/BadTelescope4.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, TypeInType #-} -module BadTelescope4 where - -import Data.Proxy -import Data.Kind - -data SameKind :: k -> k -> Type - -data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - -data Borked a (b :: k) = forall (c :: k). B (Proxy c) - -- this last one is OK. But there was a bug involving renaming - -- that failed here, so the test case remains. diff --git a/tests/examples/ghc86/Boot1.hs b/tests/examples/ghc86/Boot1.hs deleted file mode 100644 --- a/tests/examples/ghc86/Boot1.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module Boot where - -import A - -data Data = forall n. Class n => D n - diff --git a/tests/examples/ghc86/ConDeclEmptyCtx.hs b/tests/examples/ghc86/ConDeclEmptyCtx.hs deleted file mode 100644 --- a/tests/examples/ghc86/ConDeclEmptyCtx.hs +++ /dev/null @@ -1,3 +0,0 @@ -module ConDeclEmptyCtx where - -data Foo a = () => Foo a diff --git a/tests/examples/ghc86/Dep3.hs b/tests/examples/ghc86/Dep3.hs deleted file mode 100644 --- a/tests/examples/ghc86/Dep3.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-} - -module Dep3 where - -import Data.Kind -import GHC.Exts ( Constraint ) - -type Star1 = Type - -data Id1 (a :: Star1) where - Id1 :: a -> Id1 a - -data Id1' :: Star1 -> Type where - Id1' :: a -> Id1' a - -type family Star2 x where - Star2 x = Type - -data Id2a (a :: Star2 Constraint) = Id2a a - - -data Id2 (a :: Star2 Constraint) where - Id2 :: a -> Id2 a - -data Id2' :: Star2 Constraint -> Type where - Id2' :: a -> Id2' a diff --git a/tests/examples/ghc86/GADT.hs b/tests/examples/ghc86/GADT.hs deleted file mode 100644 --- a/tests/examples/ghc86/GADT.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -data Empty -data NonEmpty - -data SafeList x y where - Nil :: SafeList x Empty - Cons:: Eq x => x -> SafeList x y -> SafeList x NonEmpty - One :: Eq x => x -> SafeList x Empty -> SafeList x NonEmpty - -safeHead :: SafeList x NonEmpty -> x -safeHead (Cons x _) = x - -foo = Cons 3 (Cons 6 (Cons 9 Nil)) - - -data Dict x where - DictN :: Num x => x -> Dict x - DictE :: Eq x => x -> Dict x - -data Exist where - Exist :: forall a. a -> Exist diff --git a/tests/examples/ghc86/HashTab.hs b/tests/examples/ghc86/HashTab.hs deleted file mode 100644 --- a/tests/examples/ghc86/HashTab.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Data.HashTable --- Copyright : (c) The University of Glasgow 2003 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- An implementation of extensible hash tables, as described in --- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988, --- pp. 446--457. The implementation is also derived from the one --- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@). --- ------------------------------------------------------------------------------ - -module Data.HashTab ( - -- * Basic hash table operations - HashTable, new, insert, delete, lookup, update, - -- * Converting to and from lists - fromList, toList, - -- * Hash functions - -- $hash_functions - hashInt, hashString, - prime, - -- * Diagnostics - longestChain - ) where - --- This module is imported by Data.Typeable, which is pretty low down in the --- module hierarchy, so don't import "high-level" modules - --- Right now we import high-level modules with gay abandon. -import Prelude hiding ( lookup ) -import Data.Tuple ( fst ) -import Data.Bits -import Data.Maybe -import Data.List ( maximumBy, partition, concat, foldl ) -import Data.Int ( Int32 ) - -import Data.Array.Base -import Data.Array hiding (bounds) -import Data.Array.IO - -import Data.Char ( ord ) -import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) -import Control.Monad ( mapM, sequence_ ) - - ------------------------------------------------------------------------ - -readHTArray :: HTArray a -> Int32 -> IO a -readMutArray :: MutArray a -> Int32 -> IO a -writeMutArray :: MutArray a -> Int32 -> a -> IO () -freezeArray :: MutArray a -> IO (HTArray a) -thawArray :: HTArray a -> IO (MutArray a) -newMutArray :: (Int32, Int32) -> a -> IO (MutArray a) -#if defined(DEBUG) || defined(__NHC__) -type MutArray a = IOArray Int32 a -type HTArray a = MutArray a -newMutArray = newArray -readHTArray = readArray -readMutArray = readArray -writeMutArray = writeArray -freezeArray = return -thawArray = return -#else -type MutArray a = IOArray Int32 a -type HTArray a = Array Int32 a -newMutArray = newArray -readHTArray arr i = return $! (unsafeAt arr (fromIntegral i)) -readMutArray arr i = unsafeRead arr (fromIntegral i) -writeMutArray arr i x = unsafeWrite arr (fromIntegral i) x -freezeArray = unsafeFreeze -thawArray = unsafeThaw -#endif - -newtype HashTable key val = HashTable (IORef (HT key val)) --- TODO: the IORef should really be an MVar. - -data HT key val - = HT { - kcount :: !Int32, -- Total number of keys. - buckets :: !(HTArray [(key,val)]), - bmask :: !Int32, - hash_fn :: key -> Int32, - cmp :: key -> key -> Bool - } - --- ----------------------------------------------------------------------------- --- Sample hash functions - --- $hash_functions --- --- This implementation of hash tables uses the low-order /n/ bits of the hash --- value for a key, where /n/ varies as the hash table grows. A good hash --- function therefore will give an even distribution regardless of /n/. --- --- If your keyspace is integrals such that the low-order bits between --- keys are highly variable, then you could get away with using 'id' --- as the hash function. --- --- We provide some sample hash functions for 'Int' and 'String' below. - --- | A sample hash function for 'Int', implemented as simply @(x `mod` P)@ --- where P is a suitable prime (currently 1500007). Should give --- reasonable results for most distributions of 'Int' values, except --- when the keys are all multiples of the prime! --- -hashInt :: Int -> Int32 -hashInt = (`rem` prime) . fromIntegral - --- | A sample hash function for 'String's. The implementation is: --- --- > hashString = fromIntegral . foldr f 0 --- > where f c m = ord c + (m * 128) `rem` 1500007 --- --- which seems to give reasonable results. --- -hashString :: String -> Int32 -hashString = fromIntegral . foldl f 0 - where f m c = ord c + (m * 128) `rem` fromIntegral prime - --- | A prime larger than the maximum hash table size -prime :: Int32 -prime = 1500007 - --- ----------------------------------------------------------------------------- --- Parameters - -tABLE_MAX = 1024 * 1024 :: Int32 -- Maximum size of hash table -#if tABLE_MIN -#else -tABLE_MIN = 16 :: Int32 - -hLOAD = 4 :: Int32 -- Maximum average load of a single hash bucket - -hYSTERESIS = 0 :: Int32 -- entries to ignore in load computation -#endif - -{- Hysteresis favors long association-list-like behavior for small tables. -} - --- ----------------------------------------------------------------------------- --- Creating a new hash table - --- | Creates a new hash table. The following property should hold for the @eq@ --- and @hash@ functions passed to 'new': --- --- > eq A B => hash A == hash B --- -new - :: (key -> key -> Bool) -- ^ @eq@: An equality comparison on keys - -> (key -> Int32) -- ^ @hash@: A hash function on keys - -> IO (HashTable key val) -- ^ Returns: an empty hash table - -new cmpr hash = do - -- make a new hash table with a single, empty, segment - let mask = tABLE_MIN-1 - bkts' <- newMutArray (0,mask) [] - bkts <- freezeArray bkts' - - let - kcnt = 0 - ht = HT { buckets=bkts, kcount=kcnt, bmask=mask, - hash_fn=hash, cmp=cmpr } - - table <- newIORef ht - return (HashTable table) - --- ----------------------------------------------------------------------------- --- Inserting a key\/value pair into the hash table - --- | Inserts a key\/value mapping into the hash table. --- --- Note that 'insert' doesn't remove the old entry from the table - --- the behaviour is like an association list, where 'lookup' returns --- the most-recently-inserted mapping for a key in the table. The --- reason for this is to keep 'insert' as efficient as possible. If --- you need to update a mapping, then we provide 'update'. --- -insert :: HashTable key val -> key -> val -> IO () - -insert (HashTable ref) key val = do - table@HT{ kcount=k, buckets=bkts, bmask=b } <- readIORef ref - let table1 = table{ kcount = k+1 } - indx = bucketIndex table key - bucket <- readHTArray bkts indx - bkts' <- thawArray bkts - writeMutArray bkts' indx ((key,val):bucket) - freezeArray bkts' - table2 <- - if tooBig k b - then expandHashTable table1 - else return table1 - writeIORef ref table2 - -tooBig :: Int32 -> Int32 -> Bool -tooBig k b = k-hYSTERESIS > hLOAD * b - -bucketIndex :: HT key val -> key -> Int32 -bucketIndex HT{ hash_fn=hash, bmask=mask } key = - let h = hash key - in (h .&. mask) - -expandHashTable :: HT key val -> IO (HT key val) -expandHashTable - table@HT{ buckets=bkts, bmask=mask } = do - let - oldsize = mask + 1 - newmask = mask + mask + 1 - newsize = newmask + 1 - -- - if newsize > tABLE_MAX - then return table - else do - -- - newbkts' <- newMutArray (0,newmask) [] - - let - table'=table{ bmask=newmask } - splitBucket oldindex = do - bucket <- readHTArray bkts oldindex - let (oldb,newb) = partition ((oldindex==).bucketIndex table' . fst) bucket - writeMutArray newbkts' oldindex oldb - writeMutArray newbkts' (oldindex + oldsize) newb - mapM_ splitBucket [0..mask] - - newbkts <- freezeArray newbkts' - - return ( table'{ buckets=newbkts } ) - --- ----------------------------------------------------------------------------- --- Deleting a mapping from the hash table - --- Remove a key from a bucket -deleteBucket :: (key -> Bool) -> [(key,val)] -> (Int32, [(key, val)]) -deleteBucket _ [] = (0,[]) -deleteBucket del (pair@(k,_):bucket) = - case deleteBucket del bucket of - (dels, bucket') | del k -> dels' `seq` (dels', bucket') - | otherwise -> (dels, pair:bucket') - where dels' = dels + 1 - --- | Remove an entry from the hash table. -delete :: HashTable key val -> key -> IO () - -delete (HashTable ref) key = do - table@HT{ buckets=bkts, kcount=kcnt, cmp=cmpr } <- readIORef ref - let indx = bucketIndex table key - bkts' <- thawArray bkts - bucket <- readMutArray bkts' indx - let (removed,bucket') = deleteBucket (cmpr key) bucket - writeMutArray bkts' indx bucket' - freezeArray bkts' - writeIORef ref ( table{kcount = kcnt - removed} ) - --- ----------------------------------------------------------------------------- --- Updating a mapping in the hash table - --- | Updates an entry in the hash table, returning 'True' if there was --- already an entry for this key, or 'False' otherwise. After 'update' --- there will always be exactly one entry for the given key in the table. --- --- 'insert' is more efficient than 'update' if you don't care about --- multiple entries, or you know for sure that multiple entries can't --- occur. However, 'update' is more efficient than 'delete' followed --- by 'insert'. -update :: HashTable key val -> key -> val -> IO Bool - -update (HashTable ref) key val = do - table@HT{ kcount=k, buckets=bkts, cmp=cmpr, bmask=b } <- readIORef ref - let indx = bucketIndex table key - bkts' <- thawArray bkts - bucket <- readMutArray bkts' indx - let (deleted,bucket') = deleteBucket (cmpr key) bucket - k' = k + 1 - deleted - table1 = table{ kcount=k' } - - writeMutArray bkts' indx ((key,val):bucket') - freezeArray bkts' - table2 <- - if tooBig k' b -- off by one from insert's resize heuristic. - then expandHashTable table1 - else return table1 - writeIORef ref table2 - return (deleted>0) - --- ----------------------------------------------------------------------------- --- Looking up an entry in the hash table - --- | Looks up the value of a key in the hash table. -lookup :: HashTable key val -> key -> IO (Maybe val) - -lookup (HashTable ref) key = do - table@HT{ buckets=bkts, cmp=cmpr } <- readIORef ref - let indx = bucketIndex table key - bucket <- readHTArray bkts indx - case [ val | (key',val) <- bucket, cmpr key key' ] of - [] -> return Nothing - (v:_) -> return (Just v) - --- ----------------------------------------------------------------------------- --- Converting to/from lists - --- | Convert a list of key\/value pairs into a hash table. Equality on keys --- is taken from the Eq instance for the key type. --- -fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val) -fromList hash list = do - table <- new (==) hash - sequence_ [ insert table k v | (k,v) <- list ] - return table - --- | Converts a hash table to a list of key\/value pairs. --- -toList :: (Ord key, Ord val) => HashTable key val -> IO [(key,val)] -toList (HashTable ref) = do - HT{ buckets=bkts, bmask=b } <- readIORef ref - fmap concat (mapM (readHTArray bkts) [0..b]) - --- ----------------------------------------------------------------------------- --- Diagnostics - --- | This function is useful for determining whether your hash function --- is working well for your data set. It returns the longest chain --- of key\/value pairs in the hash table for which all the keys hash to --- the same bucket. If this chain is particularly long (say, longer --- than 10 elements), then it might be a good idea to try a different --- hash function. --- -longestChain :: HashTable key val -> IO [(key,val)] -longestChain (HashTable ref) = do - HT{ buckets=bkts, bmask=b } <- readIORef ref - let lengthCmp (_:x)(_:y) = lengthCmp x y - lengthCmp [] [] = EQ - lengthCmp [] _ = LT - lengthCmp _ [] = GT - fmap (maximumBy lengthCmp) (mapM (readHTArray bkts) [0..b]) - diff --git a/tests/examples/ghc86/KindEqualities2.hs b/tests/examples/ghc86/KindEqualities2.hs deleted file mode 100644 --- a/tests/examples/ghc86/KindEqualities2.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll, - TemplateHaskell, UndecidableInstances, ScopedTypeVariables, - TypeInType #-} - -module KindEqualities2 where - -import Data.Kind -import GHC.Exts ( Any ) - -data Kind = Star | Arr Kind Kind - -data Ty :: Kind -> Type where - TInt :: Ty Star - TBool :: Ty Star - TMaybe :: Ty (Arr Star Star) - TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2 - - -data TyRep (k :: Kind) (t :: Ty k) where - TyInt :: TyRep Star TInt - TyBool :: TyRep Star TBool - TyMaybe :: TyRep (Arr Star Star) TMaybe - TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b) - -type family IK (k :: Kind) -type instance IK Star = Type -type instance IK (Arr k1 k2) = IK k1 -> IK k2 - -$(return []) -- necessary because the following instances depend on the - -- previous ones. - -type family I (t :: Ty k) :: IK k -type instance I TInt = Int -type instance I TBool = Bool -type instance I TMaybe = Maybe -type instance I (TApp a b) = (I a) (I b) - -zero :: forall (a :: Ty 'Star). TyRep Star a -> I a -zero TyInt = 0 -zero TyBool = False -zero (TyApp TyMaybe TyInt) = Nothing - -main = print $ zero (TyApp TyMaybe TyInt) diff --git a/tests/examples/ghc86/LiftedConstructors.hs b/tests/examples/ghc86/LiftedConstructors.hs deleted file mode 100644 --- a/tests/examples/ghc86/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 :: [Type] -> Type 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/ghc86/Parser.hs b/tests/examples/ghc86/Parser.hs deleted file mode 100644 --- a/tests/examples/ghc86/Parser.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE UnboxedSums #-} -{-# LANGUAGE UnboxedTuples #-} - -{-# OPTIONS_GHC - -Weverything - -fno-warn-unsafe - -fno-warn-implicit-prelude - -fno-warn-missing-import-lists - -fno-warn-noncanonical-monoid-instances - -O2 -#-} - -module Packed.Bytes.Parser - ( Parser(..) - , Result(..) - , Leftovers(..) - , parseStreamST - , any - , failure - ) where - -import Control.Applicative -import Data.Primitive (ByteArray(..)) -import GHC.Int (Int(I#)) -import GHC.ST (ST(..),runST) -import GHC.Types (TYPE) -import GHC.Word (Word8(W8#)) -import Packed.Bytes (Bytes(..)) -import Packed.Bytes.Stream.ST (ByteStream(..)) -import Prelude hiding (any,replicate) - -import qualified Data.Primitive as PM -import qualified Control.Monad - -import GHC.Exts (Int#,ByteArray#,Word#,State#,(+#),(-#),(>#),indexWord8Array#) - -type Bytes# = (# ByteArray#, Int#, Int# #) -type Maybe# (a :: TYPE r) = (# (# #) | a #) -type Leftovers# s = (# Bytes# , ByteStream s #) -type Result# s a = (# Maybe# (Leftovers# s), Maybe# a #) - -data Result s a = Result - { resultLeftovers :: !(Maybe (Leftovers s)) - , resultValue :: !(Maybe a) - } - -data Leftovers s = Leftovers - { leftoversChunk :: {-# UNPACK #-} !Bytes - -- ^ The last chunk pulled from the stream - , leftoversStream :: ByteStream s - -- ^ The remaining stream - } - -data PureResult a = PureResult - { pureResultLeftovers :: {-# UNPACK #-} !Bytes - , pureResultValue :: !(Maybe a) - } deriving (Show) - -emptyByteArray :: ByteArray -emptyByteArray = runST (PM.newByteArray 0 >>= PM.unsafeFreezeByteArray) - -parseStreamST :: ByteStream s -> Parser a -> ST s (Result s a) -parseStreamST stream (Parser f) = ST $ \s0 -> - case f (# | (# (# unboxByteArray emptyByteArray, 0#, 0# #), stream #) #) s0 of - (# s1, r #) -> (# s1, boxResult r #) - -boxResult :: Result# s a -> Result s a -boxResult (# leftovers, val #) = case val of - (# (# #) | #) -> Result (boxLeftovers leftovers) Nothing - (# | a #) -> Result (boxLeftovers leftovers) (Just a) - -boxLeftovers :: Maybe# (Leftovers# s) -> Maybe (Leftovers s) -boxLeftovers (# (# #) | #) = Nothing -boxLeftovers (# | (# theBytes, stream #) #) = Just (Leftovers (boxBytes theBytes) stream) - -instance Functor Parser where - fmap = mapParser - --- Remember to write liftA2 by hand at some point. -instance Applicative Parser where - pure = pureParser - (<*>) = Control.Monad.ap - -instance Monad Parser where - return = pure - (>>=) = bindLifted - -newtype Parser a = Parser - { getParser :: forall s. - Maybe# (Leftovers# s) - -> State# s - -> (# State# s, Result# s a #) - } - -nextNonEmpty :: ByteStream s -> State# s -> (# State# s, Maybe# (Leftovers# s) #) -nextNonEmpty (ByteStream f) s0 = case f s0 of - (# s1, r #) -> case r of - (# (# #) | #) -> (# s1, (# (# #) | #) #) - (# | (# theBytes@(# _,_,len #), stream #) #) -> case len of - 0# -> nextNonEmpty stream s1 - _ -> (# s1, (# | (# theBytes, stream #) #) #) - -withNonEmpty :: forall s b. - Maybe# (Leftovers# s) - -> State# s - -> (State# s -> (# State# s, Result# s b #)) - -> (Word# -> Bytes# -> ByteStream s -> State# s -> (# State# s, Result# s b #)) - -- The first argument is a Word8, not a full machine word. - -- The second argument is the complete,non-empty chunk - -- with the head byte still intact. - -> (# State# s, Result# s b #) -withNonEmpty (# (# #) | #) s0 g _ = g s0 -withNonEmpty (# | (# bytes0@(# arr0,off0,len0 #), stream0 #) #) s0 g f = case len0 ># 0# of - 1# -> f (indexWord8Array# arr0 off0) bytes0 stream0 s0 - _ -> case nextNonEmpty stream0 s0 of - (# s1, r #) -> case r of - (# (# #) | #) -> g s1 - (# | (# bytes1@(# arr1, off1, _ #), stream1 #) #) -> - f (indexWord8Array# arr1 off1) bytes1 stream1 s1 - --- | Consume the next byte from the input. -any :: Parser Word8 -any = Parser go where - go :: Maybe# (Leftovers# s) -> State# s -> (# State# s, Result# s Word8 #) - go m s0 = withNonEmpty m s0 - (\s -> (# s, (# (# (# #) | #), (# (# #) | #) #) #)) - (\theByte theBytes stream s -> - (# s, (# (# | (# unsafeDrop# 1# theBytes, stream #) #), (# | W8# theByte #) #) #) - ) - --- TODO: improve this -mapParser :: (a -> b) -> Parser a -> Parser b -mapParser f p = bindLifted p (pureParser . f) - -pureParser :: a -> Parser a -pureParser a = Parser $ \leftovers0 s0 -> - (# s0, (# leftovers0, (# | a #) #) #) - -bindLifted :: Parser a -> (a -> Parser b) -> Parser b -bindLifted (Parser f) g = Parser $ \leftovers0 s0 -> case f leftovers0 s0 of - (# s1, (# leftovers1, val #) #) -> case val of - (# (# #) | #) -> (# s1, (# leftovers1, (# (# #) | #) #) #) - (# | x #) -> case g x of - Parser k -> k leftovers1 s1 - --- This assumes that the Bytes is longer than the index. It also does --- not eliminate zero-length references to byte arrays. -unsafeDrop# :: Int# -> Bytes# -> Bytes# -unsafeDrop# i (# arr, off, len #) = (# arr, off +# i, len -# i #) - -unboxByteArray :: ByteArray -> ByteArray# -unboxByteArray (ByteArray arr) = arr - -boxBytes :: Bytes# -> Bytes -boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c) - -failure :: Parser a -failure = Parser (\m s -> (# s, (# m, (# (# #) | #) #) #)) - diff --git a/tests/examples/ghc86/RAE_T32a.hs b/tests/examples/ghc86/RAE_T32a.hs deleted file mode 100644 --- a/tests/examples/ghc86/RAE_T32a.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds, - PolyKinds, TypeFamilies, GADTs, TypeInType #-} - -module RAE_T32a where - -import Data.Kind - -data family Sing (k :: Type) :: k -> Type - -data TyArr' (a :: Type) (b :: Type) :: Type -type TyArr (a :: Type) (b :: Type) = TyArr' a b -> Type -type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2 -data TyPi' (a :: Type) (b :: TyArr a Type) :: Type -type TyPi (a :: Type) (b :: TyArr a Type) = TyPi' a b -> Type -type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b -$(return []) - -data MkStar (p :: Type) (x :: TyArr' p Type) -type instance MkStar p @@ x = Type -$(return []) - -data Sigma (p :: Type) (r :: TyPi p (MkStar p)) :: Type where - Sigma :: - forall (p :: Type) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a). - Sing Type p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b -> Sigma p r -$(return []) - -data instance Sing Sigma (Sigma p r) x where - SSigma :: - forall (p :: Type) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a) - (sp :: Sing Type p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) (sb :: Sing (r @@@ a) b). - Sing (Sing (r @@@ a) b) sb -> - Sing (Sigma p r) ('Sigma sp sr sa sb) - --- I (RAE) believe this last definition is ill-typed. diff --git a/tests/examples/ghc86/RAE_T32b.hs b/tests/examples/ghc86/RAE_T32b.hs deleted file mode 100644 --- a/tests/examples/ghc86/RAE_T32b.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, DataKinds, PolyKinds, - RankNTypes, TypeOperators, TypeInType #-} - -module RAE_T32b where - -import Data.Kind - -data family Sing (k :: Type) :: k -> Type - -data TyArr (a :: Type) (b :: Type) :: Type -type family (a :: TyArr k1 k2 -> Type) @@ (b :: k1) :: k2 -$(return []) - -data Sigma (p :: Type) (r :: TyArr p Type -> Type) :: Type where - Sigma :: forall (p :: Type) (r :: TyArr p Type -> Type) (a :: p) (b :: r @@ a). - Sing Type p -> Sing (TyArr p Type -> Type) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r -$(return []) - -data instance Sing (Sigma p r) (x :: Sigma p r) :: Type where - SSigma :: forall (p :: Type) (r :: TyArr p Type -> Type) (a :: p) (b :: r @@ a) - (sp :: Sing Type p) (sr :: Sing (TyArr p Type -> Type) r) (sa :: Sing p a) (sb :: Sing (r @@ a) b). - Sing (Sing (r @@ a) b) sb -> - Sing (Sigma p r) ('Sigma sp sr sa sb) diff --git a/tests/examples/ghc86/Rae31.hs b/tests/examples/ghc86/Rae31.hs deleted file mode 100644 --- a/tests/examples/ghc86/Rae31.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds, - TypeFamilies, TypeInType #-} - -module A where - -import Data.Kind - -data family Sing (k :: Type) :: k -> Type -type Sing' (x :: k) = Sing k x -data TyFun' (a :: Type) (b :: Type) :: Type -type TyFun (a :: Type) (b :: Type) = TyFun' a b -> Type -type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2 -data TyPi' (a :: Type) (b :: TyFun a Type) :: Type -type TyPi (a :: Type) (b :: TyFun a Type) = TyPi' a b -> Type -type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b -$(return []) - -data A (a :: Type) (b :: a) (c :: TyFun' a Type) -- A :: forall a -> a -> a ~> Type -type instance (@@) (A a b) c = Type -$(return []) -data B (a :: Type) (b :: TyFun' a Type) -- B :: forall a -> a ~> Type -type instance (@@) (B a) b = TyPi a (A a b) -$(return []) -data C (a :: Type) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) Type) diff --git a/tests/examples/ghc86/RaeBlogPost.hs b/tests/examples/ghc86/RaeBlogPost.hs deleted file mode 100644 --- a/tests/examples/ghc86/RaeBlogPost.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies, - TypeInType #-} -{-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-} - -module RaeBlogPost where - -import Data.Kind - --- a Proxy type with an explicit kind -data Proxy k (a :: k) = P -prox :: Proxy * Bool -prox = P - -prox2 :: Proxy Bool 'True -prox2 = P - --- implicit kinds still work -data A -data B :: A -> Type -data C :: B a -> Type -data D :: C b -> Type -data E :: D c -> Type --- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> Type - --- a kind-indexed GADT -data TypeRep (a :: k) where - TInt :: TypeRep Int - TMaybe :: TypeRep Maybe - TApp :: TypeRep a -> TypeRep b -> TypeRep (a b) - -zero :: TypeRep a -> a -zero TInt = 0 -zero (TApp TMaybe _) = Nothing - -data Nat = Zero | Succ Nat -type family a + b where - 'Zero + b = b - ('Succ a) + b = 'Succ (a + b) - -data Vec :: Type -> Nat -> Type where - Nil :: Vec a 'Zero - (:>) :: a -> Vec a n -> Vec a ('Succ n) -infixr 5 :> - --- promoted GADT, and using + as a "kind family": -type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where - 'Nil ++ y = y - (h ':> t) ++ y = h ':> (t ++ y) - --- datatype that mentions Type -data U = Star (Type) - | Bool Bool - --- kind synonym -type Monadish = Type -> Type -class MonadTrans (t :: Monadish -> Monadish) where - lift :: Monad m => m a -> t m a -data Free :: Monadish where - Return :: a -> Free a - Bind :: Free a -> (a -> Free b) -> Free b - --- yes, Type really does have type Type. -type Star = (Type :: (Type :: (Type :: Type))) diff --git a/tests/examples/ghc86/RenamingStar.hs b/tests/examples/ghc86/RenamingStar.hs deleted file mode 100644 --- a/tests/examples/ghc86/RenamingStar.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module RenamingStar where - -data Foo :: Type diff --git a/tests/examples/ghc86/ST.hs b/tests/examples/ghc86/ST.hs deleted file mode 100644 --- a/tests/examples/ghc86/ST.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnboxedSums #-} - -{-# OPTIONS_GHC -O2 #-} - -module Packed.Bytes.Stream.ST - ( ByteStream(..) - , empty - , unpack - , fromBytes - ) where - -import Data.Primitive (Array,ByteArray(..)) -import Data.Semigroup (Semigroup) -import Data.Word (Word8) -import GHC.Exts (RealWorld,State#,Int#,ByteArray#) -import GHC.Int (Int(I#)) -import GHC.ST (ST(..)) -import Packed.Bytes (Bytes(..)) -import System.IO (Handle) -import qualified Data.Primitive as PM -import qualified Data.Semigroup as SG -import qualified Packed.Bytes as B - -type Bytes# = (# ByteArray#, Int#, Int# #) - -newtype ByteStream s = ByteStream - (State# s -> (# State# s, (# (# #) | (# Bytes# , ByteStream s #) #) #) ) - -fromBytes :: Bytes -> ByteStream s -fromBytes b = ByteStream - (\s0 -> (# s0, (# | (# unboxBytes b, empty #) #) #)) - -nextChunk :: ByteStream s -> ST s (Maybe (Bytes,ByteStream s)) -nextChunk (ByteStream f) = ST $ \s0 -> case f s0 of - (# s1, r #) -> case r of - (# (# #) | #) -> (# s1, Nothing #) - (# | (# theBytes, theStream #) #) -> (# s1, Just (boxBytes theBytes, theStream) #) - -empty :: ByteStream s -empty = ByteStream (\s -> (# s, (# (# #) | #) #) ) - -boxBytes :: Bytes# -> Bytes -boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c) - -unboxBytes :: Bytes -> Bytes# -unboxBytes (Bytes (ByteArray a) (I# b) (I# c)) = (# a,b,c #) - -unpack :: ByteStream s -> ST s [Word8] -unpack stream = ST (unpackInternal stream) - -unpackInternal :: ByteStream s -> State# s -> (# State# s, [Word8] #) -unpackInternal (ByteStream f) s0 = case f s0 of - (# s1, r #) -> case r of - (# (# #) | #) -> (# s1, [] #) - (# | (# bytes, stream #) #) -> case unpackInternal stream s1 of - (# s2, ws #) -> (# s2, B.unpack (boxBytes bytes) ++ ws #) - diff --git a/tests/examples/ghc86/SlidingTypeSyn.hs b/tests/examples/ghc86/SlidingTypeSyn.hs deleted file mode 100644 --- a/tests/examples/ghc86/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 :: Type -> Type) 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/ghc86/T10134a.hs b/tests/examples/ghc86/T10134a.hs deleted file mode 100644 --- a/tests/examples/ghc86/T10134a.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -module T10134a where - -import GHC.TypeLits - -data Vec :: Nat -> Type -> Type where - Nil :: Vec 0 a - (:>) :: a -> Vec n a -> Vec (n + 1) a diff --git a/tests/examples/ghc86/T10279.hs b/tests/examples/ghc86/T10279.hs deleted file mode 100644 --- a/tests/examples/ghc86/T10279.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module T10279 where -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - --- NB: rts-1.0 is used here because it doesn't change. --- You do need to pick the right version number, otherwise the --- error message doesn't recognize it as a source package ID, --- (This is OK, since it will look obviously wrong when they --- try to find the package in their package database.) -blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A")))) - diff --git a/tests/examples/ghc86/T10321.hs b/tests/examples/ghc86/T10321.hs deleted file mode 100644 --- a/tests/examples/ghc86/T10321.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -module T10321 where - -import GHC.TypeLits - -data Vec :: Nat -> Type -> Type where - Nil :: Vec 0 a - (:>) :: a -> Vec n a -> Vec (n + 1) a - -infixr 5 :> diff --git a/tests/examples/ghc86/T10638.hs b/tests/examples/ghc86/T10638.hs deleted file mode 100644 --- a/tests/examples/ghc86/T10638.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-} -{-# LANGUAGE TemplateHaskell #-} - -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 successfully 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/ghc86/T10689a.hs b/tests/examples/ghc86/T10689a.hs deleted file mode 100644 --- a/tests/examples/ghc86/T10689a.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE TypeOperators - , DataKinds - , PolyKinds - , TypeFamilies - , GADTs - , UndecidableInstances - , RankNTypes - , ScopedTypeVariables - #-} - -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Werror #-} -{-# OPTIONS_GHC -O1 -fspec-constr #-} - -{- -ghc-stage2: panic! (the 'impossible' happened) - (GHC version 7.11.20150723 for x86_64-unknown-linux): - Template variable unbound in rewrite rule --} - -module List (sFoldr1) where - -data Proxy t - -data family Sing (a :: k) - -data TyFun (a :: Type) (b :: Type) - -type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2 - -data instance Sing (f :: TyFun k1 k2 -> Type) = - 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)) -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 -> Type) - -> Type) - (t_afdZ :: [a_afdP]) = - Foldr1 t_afdY t_afdZ -data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) - -> Type) - (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 - -> Type) - -> Type) (TyFun [a_afdP] a_afdP -> Type)) -type instance Apply Foldr1Sym0 l = Foldr1Sym1 l - -type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP - -> Type) - -> Type) - (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 -> Type) -> Type) - (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/ghc86/T10819.hs b/tests/examples/ghc86/T10819.hs deleted file mode 100644 --- a/tests/examples/ghc86/T10819.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} - -module T10819 where - -import T10819_Lib - -import Language.Haskell.TH.Syntax - -class C a b | b -> a where - f :: b -> a - -data D = X - -instance C Int D where - f X = 2 - -$(doSomeTH "N" (mkName "D") - [DerivClause Nothing [ConT (mkName "C") `AppT` ConT (mkName "Int")]]) - -thing :: N -thing = N X - -thing1 :: Int -thing1 = f thing - diff --git a/tests/examples/ghc86/T10891.hs b/tests/examples/ghc86/T10891.hs deleted file mode 100644 --- a/tests/examples/ghc86/T10891.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} - -module T10891 where - -import Language.Haskell.TH -import System.IO - -class C a where - f :: a -> Int - -class C' a where - type F a :: * - type F a = a - f' :: a -> Int - -class C'' a where - data Fd a :: * - -instance C' Int where - type F Int = Bool - f' = id - -instance C'' Int where - data Fd Int = B Bool | C Char - -$(return []) - -test :: () -test = - $(let - display :: Name -> Q () - display q = do - i <- reify q - runIO (hPutStrLn stderr (pprint i) >> hFlush stderr) - in do - display ''C - display ''C' - display ''C'' - [| () |]) - diff --git a/tests/examples/ghc86/T10934.hs b/tests/examples/ghc86/T10934.hs deleted file mode 100644 --- a/tests/examples/ghc86/T10934.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE - ScopedTypeVariables - , DataKinds - , GADTs - , RankNTypes - , TypeOperators - , PolyKinds -- Comment out PolyKinds and the bug goes away. - #-} -{-# OPTIONS_GHC -O #-} - -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it - -module KeyValue where - -data AccValidation err a = AccFailure err | AccSuccess a - -data KeyValueError = MissingValue - -type WithKeyValueError = AccValidation [KeyValueError] - -missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs -missing = rpure missingField - where - missingField :: forall x. (WithKeyValueError :. f) x - missingField = Compose $ AccFailure [MissingValue] - -data Rec :: (u -> Type) -> [u] -> Type where - RNil :: Rec f '[] - (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) - -newtype Compose (f :: l -> Type) (g :: k -> l) (x :: k) - = Compose { getCompose :: f (g x) } - -type (:.) f g = Compose f g - -class RecApplicative rs where - rpure - :: (forall x. f x) - -> Rec f rs diff --git a/tests/examples/ghc86/T11142.hs b/tests/examples/ghc86/T11142.hs deleted file mode 100644 --- a/tests/examples/ghc86/T11142.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeInType, RankNTypes #-} - -module T11142 where - -import Data.Kind - -data SameKind :: k -> k -> Type - -foo :: forall b. (forall k (a :: k). SameKind a b) -> () -foo = undefined diff --git a/tests/examples/ghc86/T11484.hs b/tests/examples/ghc86/T11484.hs deleted file mode 100644 --- a/tests/examples/ghc86/T11484.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} - -module T11484 where - -import Data.Kind - -type TySyn (k :: *) (a :: k) = () - -$([d| type TySyn2 (k :: *) (a :: k) = () |]) - diff --git a/tests/examples/ghc86/T12478_5.hs b/tests/examples/ghc86/T12478_5.hs deleted file mode 100644 --- a/tests/examples/ghc86/T12478_5.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UnboxedSums #-} -module T12478_5 where - -import Language.Haskell.TH - -foo :: $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) - -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) -foo $(conP (unboxedSumDataName 1 2) [conP '() []]) - = $(conE (unboxedSumDataName 2 2) `appE` conE '()) -foo $(conP (unboxedSumDataName 2 2) [conP '() []]) - = $(conE (unboxedSumDataName 2 2) `appE` conE '()) - -foo2 :: (# () | () #) - -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) -foo2 (# () | #) = $(conE (unboxedSumDataName 2 2) `appE` conE '()) -foo2 $(conP (unboxedSumDataName 2 2) [conP '() []]) = (# | () #) - diff --git a/tests/examples/ghc86/T14164.hs b/tests/examples/ghc86/T14164.hs deleted file mode 100644 --- a/tests/examples/ghc86/T14164.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -module T14164 where - -data G (x :: a) = GNil | GCons (G x) - -type family F (xs :: [a]) (g :: G (z :: a)) = (res :: [a]) | res -> a where - F (x:xs) GNil = x:xs - F (x:xs) (GCons rest) = x:F xs rest - diff --git a/tests/examples/ghc86/T14650.hs b/tests/examples/ghc86/T14650.hs deleted file mode 100644 --- a/tests/examples/ghc86/T14650.hs +++ /dev/null @@ -1,77 +0,0 @@ -module MergeSort ( - msortBy - ) where - -infixl 7 :% -infixr 6 :& - -data LenList a = LL {-# UNPACK #-} !Int Bool [a] - -data LenListAnd a b = {-# UNPACK #-} !(LenList a) :% b - -data Stack a - = End - | {-# UNPACK #-} !(LenList a) :& (Stack a) - -msortBy :: (a -> a -> Ordering) -> [a] -> [a] -msortBy cmp = mergeSplit End where - splitAsc n _ _ _ | n `seq` False = undefined - splitAsc n as _ [] = LL n True as :% [] - splitAsc n as a bs@(b:bs') = case cmp a b of - GT -> LL n False as :% bs - _ -> splitAsc (n + 1) as b bs' - - splitDesc n _ _ _ | n `seq` False = undefined - splitDesc n rs a [] = LL n True (a:rs) :% [] - splitDesc n rs a bs@(b:bs') = case cmp a b of - GT -> splitDesc (n + 1) (a:rs) b bs' - _ -> LL n True (a:rs) :% bs - - mergeLL (LL na fa as) (LL nb fb bs) = LL (na + nb) True $ mergeLs na as nb bs where - mergeLs nx _ ny _ | nx `seq` ny `seq` False = undefined - mergeLs 0 _ ny ys = if fb then ys else take ny ys - mergeLs _ [] ny ys = if fb then ys else take ny ys - mergeLs nx xs 0 _ = if fa then xs else take nx xs - mergeLs nx xs _ [] = if fa then xs else take nx xs - mergeLs nx xs@(x:xs') ny ys@(y:ys') = case cmp x y of - GT -> y:mergeLs nx xs (ny - 1) ys' - _ -> x:mergeLs (nx - 1) xs' ny ys - - push ssx px@(LL nx _ _) = case ssx of - End -> px :% ssx - py@(LL ny _ _) :& ssy -> case ssy of - End - | nx >= ny -> mergeLL py px :% ssy - pz@(LL nz _ _) :& ssz - | nx >= ny || nx + ny >= nz -> case nx > nz of - False -> push ssy $ mergeLL py px - _ -> case push ssz $ mergeLL pz py of - pz' :% ssz' -> push (pz' :& ssz') px - _ -> px :% ssx - - mergeAll _ px | px `seq` False = undefined - mergeAll ssx px@(LL nx _ xs) = case ssx of - End -> xs - py@(LL _ _ _) :& ssy -> case ssy of - End -> case mergeLL py px of - LL _ _ xys -> xys - pz@(LL nz _ _) :& ssz -> case nx > nz of - False -> mergeAll ssy $ mergeLL py px - _ -> case push ssz $ mergeLL pz py of - pz' :% ssz' -> mergeAll (pz' :& ssz') px - - mergeSplit ss _ | ss `seq` False = undefined - mergeSplit ss [] = case ss of - End -> [] - px :& ss' -> mergeAll ss' px - mergeSplit ss as@(a:as') = case as' of - [] -> mergeAll ss $ LL 1 True as - b:bs -> case cmp a b of - GT -> case splitDesc 2 [a] b bs of - px :% rs -> case push ss px of - px' :% ss' -> mergeSplit (px' :& ss') rs - _ -> case splitAsc 2 as b bs of - px :% rs -> case push ss px of - px' :% ss' -> mergeSplit (px' :& ss') rs - {-# INLINABLE mergeSplit #-} - diff --git a/tests/examples/ghc86/T2632.hs b/tests/examples/ghc86/T2632.hs deleted file mode 100644 --- a/tests/examples/ghc86/T2632.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --- 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/ghc86/T3263-2.hs b/tests/examples/ghc86/T3263-2.hs deleted file mode 100644 --- a/tests/examples/ghc86/T3263-2.hs +++ /dev/null @@ -1,39 +0,0 @@ --- Trac #3263. New kind of warning on monadic bindings that discard a monadic result -{-# LANGUAGE RankNTypes #-} - -module T3263 where - -import Control.Monad.Fix - --- No warning -t1 :: Monad m => m Int -t1 = do - return 10 - --- No warning -t2 :: Monad m => m (m Int) -t2 = return (return 10) - --- No warning -t3 :: Monad m => m (m Int) -t3 = do - return 10 - return (return 10) - --- Warning -t4 :: forall m. Monad m => m Int -t4 = do - return (return 10 :: m Int) - return 10 - --- No warning -t5 :: forall m. Monad m => m Int -t5 = do - _ <- return (return 10 :: m Int) - return 10 - --- Warning -t6 :: forall m. MonadFix m => m Int -t6 = mdo - return (return 10 :: m Int) - return 10 diff --git a/tests/examples/ghc86/T3391.hs b/tests/examples/ghc86/T3391.hs deleted file mode 100644 --- a/tests/examples/ghc86/T3391.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -v0 #-} - --- We should only generate one set of generic to/from functions --- for T, despite the multiple chunks caused by the TH splices --- See Trac #3391 - -module T3391 where - -data T = MkT - -$(return []) - -$(return []) - diff --git a/tests/examples/ghc86/T3572.hs b/tests/examples/ghc86/T3572.hs deleted file mode 100644 --- a/tests/examples/ghc86/T3572.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TemplateHaskell #-} - --- 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/ghc86/T3927b.hs b/tests/examples/ghc86/T3927b.hs deleted file mode 100644 --- a/tests/examples/ghc86/T3927b.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T3927b where - -import Data.Proxy -import GHC.Exts - -data Message - -data SocketType = Dealer | Push | Pull - -data SocketOperation = Read | Write - -type family Restrict (a :: SocketOperation) (as :: [SocketOperation]) :: Constraint where - Restrict a (a ': as) = () - Restrict x (a ': as) = Restrict x as - Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!") - -type family Implements (t :: SocketType) :: [SocketOperation] where - Implements Dealer = ['Read, Write] - Implements Push = '[Write] - Implements Pull = '[ 'Read] - -data SockOp :: SocketType -> SocketOperation -> Type where - SRead :: SockOp sock 'Read - SWrite :: SockOp sock Write - -data Socket :: SocketType -> Type where - Socket :: proxy sock - -> (forall op . Restrict op (Implements sock) => SockOp sock op -> Operation op) - -> Socket sock - -type family Operation (op :: SocketOperation) :: Type where - Operation 'Read = IO Message - Operation Write = Message -> IO () - -class Restrict 'Read (Implements t) => Readable t where - readSocket :: Socket t -> Operation 'Read - readSocket (Socket _ f) = f (SRead :: SockOp t 'Read) - -instance Readable Dealer - -type family Writable (t :: SocketType) :: Constraint where - Writable Dealer = () - Writable Push = () - -dealer :: Socket Dealer -dealer = Socket (Proxy :: Proxy Dealer) f - where - f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op - f SRead = undefined - f SWrite = undefined - -push :: Socket Push -push = Socket (Proxy :: Proxy Push) f - where - f :: Restrict op (Implements Push) => SockOp Push op -> Operation op - f SWrite = undefined - -pull :: Socket Pull -pull = Socket (Proxy :: Proxy Pull) f - where - f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op - f SRead = undefined - -foo :: IO Message -foo = readSocket dealer diff --git a/tests/examples/ghc86/T4056.hs b/tests/examples/ghc86/T4056.hs deleted file mode 100644 --- a/tests/examples/ghc86/T4056.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} - -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/ghc86/T4169.hs b/tests/examples/ghc86/T4169.hs deleted file mode 100644 --- a/tests/examples/ghc86/T4169.hs +++ /dev/null @@ -1,15 +0,0 @@ --- Crashed GHC 6.12 -{-# LANGUAGE TemplateHaskell #-} - -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/ghc86/T4170.hs b/tests/examples/ghc86/T4170.hs deleted file mode 100644 --- a/tests/examples/ghc86/T4170.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -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/ghc86/T5217.hs b/tests/examples/ghc86/T5217.hs deleted file mode 100644 --- a/tests/examples/ghc86/T5217.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} - -module T5217 where -import Language.Haskell.TH - -$([d| data T a b where { T1 :: Int -> T Int Char - ; T2 :: a -> T a a - ; T3 :: a -> T [a] a - ; T4 :: a -> b -> T b [a] } |]) - diff --git a/tests/examples/ghc86/T6018th.hs b/tests/examples/ghc86/T6018th.hs deleted file mode 100644 --- a/tests/examples/ghc86/T6018th.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE TypeFamilyDependencies, DataKinds, UndecidableInstances, - PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} -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 (TypeFamilyHead - (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 (TypeFamilyHead - (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 (TypeFamilyHead - (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 (TypeFamilyHead _ _ _ (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 (TypeFamilyHead - (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/ghc86/T6062.hs b/tests/examples/ghc86/T6062.hs deleted file mode 100644 --- a/tests/examples/ghc86/T6062.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module T6062 where -x = [| False True |] - diff --git a/tests/examples/ghc86/T8455.hs b/tests/examples/ghc86/T8455.hs deleted file mode 100644 --- a/tests/examples/ghc86/T8455.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} - -module T8455 where - -ty = [t| 5 |] - diff --git a/tests/examples/ghc86/T8759a.hs b/tests/examples/ghc86/T8759a.hs deleted file mode 100644 --- a/tests/examples/ghc86/T8759a.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE TemplateHaskell #-} - -module T8759a where - -foo = [d| pattern Q = False |] - diff --git a/tests/examples/ghc86/T8807.hs b/tests/examples/ghc86/T8807.hs deleted file mode 100644 --- a/tests/examples/ghc86/T8807.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE ConstraintKinds, RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} - -module T8807 where - -import Data.Proxy - -foo :: $( [t| forall a b. a b => Proxy a -> b -> b |] ) -foo = undefined - diff --git a/tests/examples/ghc86/T9367.hs b/tests/examples/ghc86/T9367.hs deleted file mode 100644 --- a/tests/examples/ghc86/T9367.hs +++ /dev/null @@ -1,5 +0,0 @@ -x = "abc" -main = print x --- This file has Windows line endings (CRLF) on purpose. Do not remove. --- See #9367. - diff --git a/tests/examples/ghc86/T9632.hs b/tests/examples/ghc86/T9632.hs deleted file mode 100644 --- a/tests/examples/ghc86/T9632.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module T9632 where - -import Data.Kind - -data B = T | F -data P :: B -> Type - -type B' = B -data P' :: B' -> Type diff --git a/tests/examples/ghc86/T9662.hs b/tests/examples/ghc86/T9662.hs deleted file mode 100644 --- a/tests/examples/ghc86/T9662.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} - -module T9662 where - -data Exp a = Exp -data (a:.b) = a:.b - -type family Plain e :: Type -type instance Plain (Exp a) = a -type instance Plain (a:.b) = Plain a :. Plain b - -class (Plain (Unlifted pattern) ~ Tuple pattern) => Unlift pattern where - type Unlifted pattern - type Tuple pattern - -modify :: (Unlift pattern) => - pattern -> - (Unlifted pattern -> a) -> - Exp (Tuple pattern) -> Exp (Plain a) -modify p f = undefined - - -data Atom a = Atom - -atom :: Atom a -atom = Atom - - -instance (Unlift pa, int ~ Atom Int) => Unlift (pa :. int) where - type Unlifted (pa :. int) = Unlifted pa :. Exp Int - type Tuple (pa :. int) = Tuple pa :. Int - - -data Shape sh = Shape - -backpermute :: - (Exp sh -> Exp sh') -> - (Exp sh' -> Exp sh) -> - Shape sh -> Shape sh' -backpermute = undefined - -test :: Shape (sh:.k:.m:.n) -> Shape (sh:.m:.n:.k) -test = - backpermute - (modify (atom:.atom:.atom:.atom) - (\(sh:.k:.m:.n) -> (sh:.m:.n:.k))) - id - --- With this arg instead of just 'id', it worked --- (modify (atom:.atom:.atom:.atom) --- (\(ix:.m:.n:.k) -> (ix:.k:.m:.n))) - diff --git a/tests/examples/ghc86/T9824.hs b/tests/examples/ghc86/T9824.hs deleted file mode 100644 --- a/tests/examples/ghc86/T9824.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# OPTIONS_GHC -fwarn-unused-matches #-} -{-# LANGUAGE TemplateHaskell #-} - -module T9824 where - -foo = [p| (x, y) |] - diff --git a/tests/examples/ghc86/TH_abstractFamily.hs b/tests/examples/ghc86/TH_abstractFamily.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_abstractFamily.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -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/ghc86/TH_bracket1.hs b/tests/examples/ghc86/TH_bracket1.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_bracket1.hs +++ /dev/null @@ -1,9 +0,0 @@ --- Check that declarations in a bracket shadow the top-level -{-# LANGUAGE TemplateHaskell #-} --- declarations, rather than clashing with them. - -module TH_bracket1 where - -foo = 1 -bar = [d| foo = 1 |] - diff --git a/tests/examples/ghc86/TH_bracket2.hs b/tests/examples/ghc86/TH_bracket2.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_bracket2.hs +++ /dev/null @@ -1,10 +0,0 @@ - -{-# LANGUAGE TemplateHaskell #-} -module TH_bracket2 where - -d_show = [d| data A = A - - instance Show A where - show _ = "A" - |] - diff --git a/tests/examples/ghc86/TH_bracket3.hs b/tests/examples/ghc86/TH_bracket3.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_bracket3.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} - -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/ghc86/TH_class1.hs b/tests/examples/ghc86/TH_class1.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_class1.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} -{-# LANGUAGE TemplateHaskell #-} - -module TH_class1 where - -$( [d| class Classy a b c d | a -> b c, c -> d where - f :: a -> b -> c -> d - |] ) - diff --git a/tests/examples/ghc86/TH_dataD1.hs b/tests/examples/ghc86/TH_dataD1.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_dataD1.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH_dataD1 where - -import Language.Haskell.TH - -ds :: Q [Dec] -ds = [d| - $(do { d <- dataD (cxt []) (mkName "D") [] Nothing - [normalC (mkName "K") []] [] - ; return [d]}) - |] - diff --git a/tests/examples/ghc86/TH_localname.hs b/tests/examples/ghc86/TH_localname.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_localname.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH_localname where - -x = \y -> [| y |] - diff --git a/tests/examples/ghc86/TH_lookupName.hs b/tests/examples/ghc86/TH_lookupName.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_lookupName.hs +++ /dev/null @@ -1,37 +0,0 @@ --- test 'lookupTypeName' and 'lookupValueName' -{-# LANGUAGE TemplateHaskell #-} - -import Language.Haskell.TH - -import qualified TH_lookupName_Lib -import qualified TH_lookupName_Lib as TheLib - -f :: String -f = "TH_lookupName.f" - -data D = D - -$(return []) - -main = mapM_ print [ - -- looking up values - $(do { Just n <- lookupValueName "f" ; varE n }), - $(do { Nothing <- lookupTypeName "f"; [| "" |] }), - -- looking up types - $(do { Just n <- lookupTypeName "String"; sigE [| "" |] (conT n) }), - $(do { Nothing <- lookupValueName "String"; [| "" |] }), - -- namespacing - $(do { Just n <- lookupValueName "D"; DataConI{} <- reify n; [| "" |] }), - $(do { Just n <- lookupTypeName "D"; TyConI{} <- reify n; [| "" |] }), - -- qualified lookup - $(do { Just n <- lookupValueName "TH_lookupName_Lib.f"; varE n }), - $(do { Just n <- lookupValueName "TheLib.f"; varE n }), - -- shadowing - $(TheLib.lookup_f), - $( [| let f = "local f" in $(TheLib.lookup_f) |] ), - $( [| let f = "local f" in $(do { Just n <- lookupValueName "f"; varE n }) |] ), - $( [| let f = "local f" in $(varE 'f) |] ), - let f = "local f" in $(TheLib.lookup_f), - let f = "local f" in $(varE 'f) - ] - diff --git a/tests/examples/ghc86/TH_ppr1.hs b/tests/examples/ghc86/TH_ppr1.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_ppr1.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} - -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/ghc86/TH_raiseErr1.hs b/tests/examples/ghc86/TH_raiseErr1.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_raiseErr1.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH_raiseErr1 where -import Language.Haskell.TH - -foo = $(do { report True "Error test succeeded"; fail "" }) - diff --git a/tests/examples/ghc86/TH_recover.hs b/tests/examples/ghc86/TH_recover.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_recover.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Language.Haskell.TH - --- The recover successfully find that 'ola' is not in scope --- and use '1' instead - -y = $(recover (return (LitE (IntegerL 1))) - (reify (mkName ("ola")) >> return (LitE (IntegerL 2)))) - -main = print y - diff --git a/tests/examples/ghc86/TH_reifyDecl1.hs b/tests/examples/ghc86/TH_reifyDecl1.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_reifyDecl1.hs +++ /dev/null @@ -1,88 +0,0 @@ --- test reification of data declarations -{-# LANGUAGE TemplateHaskell #-} - -{-# LANGUAGE TypeFamilies #-} -module TH_reifyDecl1 where - -import System.IO -import Language.Haskell.TH -import Text.PrettyPrint.HughesPJ - -infixl 3 `m1` - --- simple -data T = A | B - --- parametric -data R a = C a | D - --- recursive -data List a = Nil | Cons a (List a) - --- infix operator -data Tree a = Leaf | Tree a :+: Tree a - --- type declaration -type IntList = [Int] - --- newtype declaration -newtype Length = Length Int - --- simple class -class C1 a where - m1 :: a -> Int - --- class with instances -class C2 a where - m2 :: a -> Int -instance C2 Int where - m2 x = x - --- associated types -class C3 a where - type AT1 a - data AT2 a - -instance C3 Int where - type AT1 Int = Bool - data AT2 Int = AT2Int - --- type family -type family TF1 a - --- type family, with instances -type family TF2 a -type instance TF2 Bool = Bool - --- data family -data family DF1 a - --- data family, with instances -data family DF2 a -data instance DF2 Bool = DBool - -$(return []) - -test :: () -test = $(let - display :: Name -> Q () - display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) } - in do { display ''T - ; display ''R - ; display ''List - ; display ''Tree - ; display ''IntList - ; display ''Length - ; display 'Leaf - ; display 'm1 - ; display ''C1 - ; display ''C2 - ; display ''C3 - ; display ''AT1 - ; display ''AT2 - ; display ''TF1 - ; display ''TF2 - ; display ''DF1 - ; display ''DF2 - ; [| () |] }) - diff --git a/tests/examples/ghc86/TH_reifyDecl2.hs b/tests/examples/ghc86/TH_reifyDecl2.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_reifyDecl2.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH_reifyDecl2 where - -import Language.Haskell.TH -import System.IO - -$( - do x <- reify ''Maybe - runIO $ hPutStrLn stderr $ pprint x - return [] - ) - diff --git a/tests/examples/ghc86/TH_reifyInstances.hs b/tests/examples/ghc86/TH_reifyInstances.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_reifyInstances.hs +++ /dev/null @@ -1,51 +0,0 @@ --- test reifyInstances -{-# LANGUAGE TemplateHaskell #-} - -{-# LANGUAGE TypeFamilies #-} -module TH_reifyInstances where - -import System.IO -import Language.Haskell.TH -import Text.PrettyPrint.HughesPJ - --- classes -class C1 a where f1 :: a - -class C2 a where f2 :: a -instance C2 Int where f2 = 0 -instance C2 Bool where f2 = True - --- type families -type family T1 a - -type family T2 a -type instance T2 Int = Char -type instance T2 Bool = Int - --- data families -data family D1 a - -data family D2 a -data instance D2 Int = DInt | DInt2 -data instance D2 Bool = DBool - -$(return []) - -test :: () -test = $(let - display :: Name -> Q () - display n = do - { intTy <- [t| Int |] - ; is1 <- reifyInstances n [intTy] - ; runIO $ hPutStrLn stderr (nameBase n) - ; runIO $ hPutStrLn stderr (pprint is1) - } - in do { display ''C1 - ; display ''C2 - ; display ''T1 - ; display ''T2 - ; display ''D1 - ; display ''D2 - ; [| () |] - }) - diff --git a/tests/examples/ghc86/TH_reifyMkName.hs b/tests/examples/ghc86/TH_reifyMkName.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_reifyMkName.hs +++ /dev/null @@ -1,16 +0,0 @@ --- Trac #2339 -{-# LANGUAGE TemplateHaskell #-} - -module Foo where - -import System.IO -import Language.Haskell.TH - -type C = Int - -$(do - a <- reify $ mkName "C" - runIO $ hPutStrLn stderr (show a) - return [] - ) - diff --git a/tests/examples/ghc86/TH_repE1.hs b/tests/examples/ghc86/TH_repE1.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_repE1.hs +++ /dev/null @@ -1,32 +0,0 @@ --- test the representation of literals and also explicit type annotations -{-# LANGUAGE TemplateHaskell #-} - -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/ghc86/TH_repE2.hs b/tests/examples/ghc86/TH_repE2.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_repE2.hs +++ /dev/null @@ -1,37 +0,0 @@ --- test the representation of literals and also explicit type annotations -{-# LANGUAGE TemplateHaskell #-} - -module Main -where - -import Language.Haskell.TH - -main :: IO () -main = mapM_ putStrLn [show an_integral, show an_int, show an_integer, - show an_char, show an_string, show an_fractional, - show an_float, show an_double] - -an_integral :: Integer -an_integral = $( [| 42 |] ) - -an_int :: Int -an_int = $( [| 42 :: Int |] ) - -an_integer :: Integer -an_integer = $( [| 98765432123456789876 :: Integer |] ) - -an_char :: Char -an_char = $( [| 'x' |] ) - -an_string :: String -an_string = $( [| "A String" |] ) - -an_fractional :: Double -an_fractional = $( [| 1.2 |] ) - -an_float :: Float -an_float = $( [| 1.2 :: Float |] ) - -an_double :: Double -an_double = $( [| 1.2 :: Double |] ) - diff --git a/tests/examples/ghc86/TH_repE3.hs b/tests/examples/ghc86/TH_repE3.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_repE3.hs +++ /dev/null @@ -1,20 +0,0 @@ --- test the representation of literals and also explicit type annotations -{-# LANGUAGE TemplateHaskell #-} - -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/ghc86/TH_repGuard.hs b/tests/examples/ghc86/TH_repGuard.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_repGuard.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main -where - -import Language.Haskell.TH -import System.IO - -$( - do ds <- [d| - foo :: Int -> Int - foo x - | x == 5 = 6 - foo x = 7 - |] - runIO $ do { putStrLn (pprint ds); hFlush stdout } - return ds - ) - -$( - do ds <- [d| - bar :: Maybe Int -> Int - bar x - | Just y <- x = y - bar _ = 9 - |] - runIO $ do { putStrLn (pprint ds) ; hFlush stdout } - return ds - ) - -main :: IO () -main = do putStrLn $ show $ foo 5 - putStrLn $ show $ foo 8 - putStrLn $ show $ bar (Just 2) - putStrLn $ show $ bar Nothing - diff --git a/tests/examples/ghc86/TH_repGuardOutput.hs b/tests/examples/ghc86/TH_repGuardOutput.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_repGuardOutput.hs +++ /dev/null @@ -1,30 +0,0 @@ --- test the representation of unboxed literals -{-# LANGUAGE TemplateHaskell #-} - -module Main -where - -$( - [d| - foo :: Int -> Int - foo x - | x == 5 = 6 - foo x = 7 - |] - ) - -$( - [d| - bar :: Maybe Int -> Int - bar x - | Just y <- x = y - bar _ = 9 - |] - ) - -main :: IO () -main = do putStrLn $ show $ foo 5 - putStrLn $ show $ foo 8 - putStrLn $ show $ bar (Just 2) - putStrLn $ show $ bar Nothing - diff --git a/tests/examples/ghc86/TH_repPatSig.hs b/tests/examples/ghc86/TH_repPatSig.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_repPatSig.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module Main -where - -import TH_repPatSig_asserts - -assertFoo [d| foo :: Int -> Int - foo (x :: Int) = x - |] - -assertCon [| \(x :: Either Char Int -> (Char, Int)) -> x |] - -assertVar [| \(x :: Maybe a) -> case x of Just y -> (y :: a) |] - -main :: IO () -main = return () - diff --git a/tests/examples/ghc86/TH_repPatSigTVar.hs b/tests/examples/ghc86/TH_repPatSigTVar.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_repPatSigTVar.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module Main -where - -import Language.Haskell.TH - -$([d| f = \(_ :: Either a b) -> $(sigE (varE 'undefined) (varT ''c)) |]) - -main :: IO () -main = return () - diff --git a/tests/examples/ghc86/TH_repPrim.hs b/tests/examples/ghc86/TH_repPrim.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_repPrim.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MagicHash #-} --- test the representation of unboxed literals - -module Main where - -import GHC.Exts -import GHC.Float -import Language.Haskell.TH -import Text.PrettyPrint -import System.IO - -main :: IO () -main = do putStrLn $ show $ $( do e <- [| I# 20# |] - runIO $ putStrLn $ show e - runIO $ putStrLn $ pprint e - runIO $ hFlush stdout - return e ) - putStrLn $ show $ $( do e <- [| W# 32## |] - runIO $ putStrLn $ show e - runIO $ putStrLn $ pprint e - runIO $ hFlush stdout - return e ) - putStrLn $ show $ $( do e <- [| F# 12.3# |] - runIO $ putStrLn $ show e - runIO $ putStrLn $ pprint e - runIO $ hFlush stdout - return e ) - putStrLn $ show $ $( do e <- [| D# 24.6## |] - runIO $ putStrLn $ show e - runIO $ putStrLn $ pprint e - runIO $ hFlush stdout - return e ) - diff --git a/tests/examples/ghc86/TH_repPrim2.hs b/tests/examples/ghc86/TH_repPrim2.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_repPrim2.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples #-} -{-# LANGUAGE TemplateHaskell #-} --- test the representation of unboxed literals - -module Main where - -import GHC.Exts -import GHC.Float -import Language.Haskell.TH -import Text.PrettyPrint -import System.IO - -main :: IO () -main = do putStrLn $ show $ $( do e <- [| 20# |] - runIO $ putStrLn $ show e - runIO $ putStrLn $ pprint e - runIO $ hFlush stdout - [| I# $( return e) |] ) - putStrLn $ show $ $( do e <- [| 32## |] - runIO $ putStrLn $ show e - runIO $ putStrLn $ pprint e - runIO $ hFlush stdout - [| W# $(return e) |] ) - putStrLn $ show $ $( do e <- [| 12.3# |] - runIO $ putStrLn $ show e - runIO $ putStrLn $ pprint e - runIO $ hFlush stdout - [| F# $(return e) |] ) - putStrLn $ show $ $( do e <- [| 24.6## |] - runIO $ putStrLn $ show e - runIO $ putStrLn $ pprint e - runIO $ hFlush stdout - [| D# $(return e) |] ) - diff --git a/tests/examples/ghc86/TH_repPrimOutput.hs b/tests/examples/ghc86/TH_repPrimOutput.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_repPrimOutput.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TemplateHaskell #-} --- test the representation of unboxed literals - -module Main -where - -import GHC.Exts -import GHC.Float -import Language.Haskell.TH -import Text.PrettyPrint -import System.IO - -main :: IO () -main = do putStrLn $ show $ $( do e <- [| I# 20# |] - return e ) - putStrLn $ show $ $( do e <- [| W# 32## |] - return e ) - putStrLn $ show $ $( do e <- [| F# 12.3# |] - return e ) - putStrLn $ show $ $( do e <- [| D# 24.6## |] - return e ) - diff --git a/tests/examples/ghc86/TH_repPrimOutput2.hs b/tests/examples/ghc86/TH_repPrimOutput2.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_repPrimOutput2.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE MagicHash, UnboxedTuples #-} -{-# LANGUAGE TemplateHaskell #-} --- test the representation of unboxed literals - -module Main -where - -import GHC.Exts -import GHC.Float -import Language.Haskell.TH -import Text.PrettyPrint -import System.IO - -main :: IO () -main = do putStrLn $ show $ $( do e <- [| 20# |] - [| I# $(return e) |] ) - putStrLn $ show $ $( do e <- [| 32## |] - [| W# $(return e) |] ) - putStrLn $ show $ $( do e <- [| 12.3# |] - [| F# $(return e) |] ) - putStrLn $ show $ $( do e <- [| 24.6## |] - [| D# $(return e) |] ) - diff --git a/tests/examples/ghc86/TH_scope.hs b/tests/examples/ghc86/TH_scope.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_scope.hs +++ /dev/null @@ -1,10 +0,0 @@ --- Test for Trac #2188 -{-# LANGUAGE TemplateHaskell #-} - -module TH_scope where - -f g = [d| f :: Int - f = g - g :: Int - g = 4 |] - diff --git a/tests/examples/ghc86/TH_sections.hs b/tests/examples/ghc86/TH_sections.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_sections.hs +++ /dev/null @@ -1,11 +0,0 @@ --- Test for trac #2956 -{-# LANGUAGE TemplateHaskell #-} - -module TH_sections where - -two :: Int -two = $( [| (1 +) 1 |] ) - -three :: Int -three = $( [| (+ 2) 1 |] ) - diff --git a/tests/examples/ghc86/TH_spliceD2.hs b/tests/examples/ghc86/TH_spliceD2.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_spliceD2.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH_spliceD2 where - -import qualified TH_spliceD2_Lib - -$( [d| data T = T TH_spliceD2_Lib.T |] ) - diff --git a/tests/examples/ghc86/TH_spliceDecl1.hs b/tests/examples/ghc86/TH_spliceDecl1.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_spliceDecl1.hs +++ /dev/null @@ -1,12 +0,0 @@ --- test splicing of a generated data declarations -{-# LANGUAGE TemplateHaskell #-} - -module TH_spliceDecl1 -where - -import Language.Haskell.TH - - --- splice a simple data declaration -$(return [DataD [] (mkName "T") [] Nothing [NormalC (mkName "C") []] []]) - diff --git a/tests/examples/ghc86/TH_spliceDecl2.hs b/tests/examples/ghc86/TH_spliceDecl2.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_spliceDecl2.hs +++ /dev/null @@ -1,13 +0,0 @@ --- test splicing of quoted data and newtype declarations -{-# LANGUAGE TemplateHaskell #-} - -module TH_spliceDecl2 -where - -import Language.Haskell.TH - --- splice a simple quoted declaration (x 2) -$([d| data T1 = C1 |]) - -$([d| newtype T2 = C2 String |]) - diff --git a/tests/examples/ghc86/TH_spliceDecl3.hs b/tests/examples/ghc86/TH_spliceDecl3.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_spliceDecl3.hs +++ /dev/null @@ -1,13 +0,0 @@ --- test splicing of reified and renamed data declarations -{-# LANGUAGE TemplateHaskell #-} - -module TH_spliceDecl3 -where - -import Language.Haskell.TH -import TH_spliceDecl3_Lib - -data T = C - -$(do { TyConI d <- reify ''T; rename' d}) - diff --git a/tests/examples/ghc86/TH_spliceE1.hs b/tests/examples/ghc86/TH_spliceE1.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_spliceE1.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -my_id :: a -> a -my_id x = $( [| x |] ) - -main = print (my_id "hello") - diff --git a/tests/examples/ghc86/TH_spliceE3.hs b/tests/examples/ghc86/TH_spliceE3.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_spliceE3.hs +++ /dev/null @@ -1,26 +0,0 @@ --- test the representation of literals and also explicit type annotations -{-# LANGUAGE TemplateHaskell #-} - -module TH_repE1 -where - -import Language.Haskell.TH - -$( do let emptyListExpr :: ExpQ - emptyListExpr = [| [] |] - - singletonListExpr :: ExpQ - singletonListExpr = [| [4] |] - - listExpr :: ExpQ - listExpr = [| [4,5,6] |] - - consExpr :: ExpQ - consExpr = [| 4:5:6:[] |] - - [d| foo = ($emptyListExpr, $singletonListExpr, $listExpr, $consExpr) |] - ) - -bar = $( [| case undefined of - [1] -> 1 |] ) - diff --git a/tests/examples/ghc86/TH_spliceE4.hs b/tests/examples/ghc86/TH_spliceE4.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_spliceE4.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Language.Haskell.TH - -$( do let h x = x - foo = [| \x -> $(h [| x |]) |] - - [d| baz = $foo |] - ) - -main = print (baz "Hello") - diff --git a/tests/examples/ghc86/TH_spliceE5_Lib.hs b/tests/examples/ghc86/TH_spliceE5_Lib.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_spliceE5_Lib.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH_spliceE5_Lib where - -import Language.Haskell.TH - -expandVars :: [String] -> Q Exp -expandVars s = [| concat $(return (ListE (map f s))) |] - where - f x = VarE (mkName x) - diff --git a/tests/examples/ghc86/TH_spliceE5_prof_Lib.hs b/tests/examples/ghc86/TH_spliceE5_prof_Lib.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_spliceE5_prof_Lib.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH_spliceE5_prof_Lib where - -import Language.Haskell.TH - -expandVars :: [String] -> Q Exp -expandVars s = [| concat $(return (ListE (map f s))) |] - where - f x = VarE (mkName x) - diff --git a/tests/examples/ghc86/TH_spliceE5_prof_ext_Lib.hs b/tests/examples/ghc86/TH_spliceE5_prof_ext_Lib.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_spliceE5_prof_ext_Lib.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH_spliceE5_prof_ext_Lib where - -import Language.Haskell.TH - -expandVars :: [String] -> Q Exp -expandVars s = [| concat $(return (ListE (map f s))) |] - where - f x = VarE (mkName x) - diff --git a/tests/examples/ghc86/TH_spliceExpr1.hs b/tests/examples/ghc86/TH_spliceExpr1.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_spliceExpr1.hs +++ /dev/null @@ -1,11 +0,0 @@ --- test representation and splicing of left-parenthesised right infix operators -{-# LANGUAGE TemplateHaskell #-} - -module TH_spliceExpr1 -where - -import Language.Haskell.TH - -foo :: Int -foo = $( [| ((+) $ 2) $ 2 |] ) - diff --git a/tests/examples/ghc86/TH_tf1.hs b/tests/examples/ghc86/TH_tf1.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_tf1.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TemplateHaskell #-} - -module TH_tf1 where - -$( [d| data family T a |] ) -$( [d| data instance T Int = TInt Bool |] ) - -foo :: Bool -> T Int -foo b = TInt (b && b) - -$( [d| type family S a |] ) -$( [d| type instance S Int = Bool |] ) - -bar :: S Int -> Int -bar c = if c then 1 else 2 - -$( [d| type family R (a :: * -> *) :: * -> * |] ) -$( [d| type instance R Maybe = [] |] ) - -baz :: R Maybe Int -> Int -baz = head - diff --git a/tests/examples/ghc86/TH_tf3.hs b/tests/examples/ghc86/TH_tf3.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_tf3.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} - -module TH_tf3 where - -type family T a - -$( [d| foo :: T [a] ~ Bool => a -> a - foo x = x |] ) - -$( [d| class C a - instance a ~ Int => C a |] ) diff --git a/tests/examples/ghc86/TH_unresolvedInfix.hs b/tests/examples/ghc86/TH_unresolvedInfix.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_unresolvedInfix.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} - -module Main where - -import TH_unresolvedInfix_Lib -import Language.Haskell.TH - --------------------------------------------------------------------------------- --- Expressions -- --------------------------------------------------------------------------------- -exprs = [ --------------- Completely-unresolved bindings - $( n +? (n *? n) ), - $( (n +? n) *? n ), - $( n +? (n +? n) ), - $( (n +? n) +? n ), - -- VarE version - $( uInfixE n plus2 (uInfixE n plus2 n) ), - $( uInfixE (uInfixE n plus2 n) plus2 n ), - $( uInfixE n plus3 (uInfixE n plus3 n) ), - $( uInfixE (uInfixE n plus3 n) plus3 n ), - ---------------- Completely-resolved bindings - $( n +! (n *! n) ), - $( (n +! n) *! n ), - $( n +! (n +! n) ), - $( (n +! n) +! n ), - --------------- Mixed resolved/unresolved - $( (n +! n) *? (n +? n) ), - $( (n +? n) *? (n +! n) ), - $( (n +? n) *! (n +! n) ), - $( (n +? n) *! (n +? n) ), - --------------- Parens - $( ((parensE ((n +? n) *? n)) +? n) *? n ), - $( (parensE (n +? n)) *? (parensE (n +? n)) ), - $( parensE ((n +? n) *? (n +? n)) ), - --------------- Sections - $( infixE (Just $ n +? n) plus Nothing ) N, - -- see B.hs for the (non-compiling) other version of the above - $( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N, - --------------- Dropping constructors - $( n *? tupE [n +? n] ) - ] - --------------------------------------------------------------------------------- --- Patterns -- --------------------------------------------------------------------------------- -patterns = [ --------------- Completely-unresolved patterns - case N :+ (N :* N) of - [p1|unused|] -> True, - case N :+ (N :* N) of - [p2|unused|] -> True, - case (N :+ N) :+ N of - [p3|unused|] -> True, - case (N :+ N) :+ N of - [p4|unused|] -> True, --------------- Completely-resolved patterns - case N :+ (N :* N) of - [p5|unused|] -> True, - case (N :+ N) :* N of - [p6|unused|] -> True, - case N :+ (N :+ N) of - [p7|unused|] -> True, - case (N :+ N) :+ N of - [p8|unused|] -> True, --------------- Mixed resolved/unresolved - case ((N :+ N) :* N) :+ N of - [p9|unused|] -> True, - case N :+ (N :* (N :+ N)) of - [p10|unused|] -> True, - case (N :+ N) :* (N :+ N) of - [p11|unused|] -> True, - case (N :+ N) :* (N :+ N) of - [p12|unused|] -> True, --------------- Parens - case (N :+ (N :* N)) :+ (N :* N) of - [p13|unused|] -> True, - case (N :+ N) :* (N :+ N) of - [p14|unused|] -> True, - case (N :+ (N :* N)) :+ N of - [p15|unused|] -> True, --------------- Dropping constructors - case (N :* (N :+ N)) of - [p16|unused|] -> True - ] - --------------------------------------------------------------------------------- --- Types -- --------------------------------------------------------------------------------- - --------------- Completely-unresolved types -_t1 = 1 `Plus` (1 `Times` 1) :: $( int $+? (int $*? int) ) -_t2 = 1 `Plus` (1 `Times` 1) :: $( (int $+? int) $*? int ) -_t3 = (1 `Plus` 1) `Plus` 1 :: $( int $+? (int $+? int) ) -_t4 = (1 `Plus` 1) `Plus` 1 :: $( (int $+? int) $+? int ) --------------- Completely-resolved types -_t5 = 1 `Plus` (1 `Times` 1) :: $( int $+! (int $*! int) ) -_t6 = (1 `Plus` 1) `Times` 1 :: $( (int $+! int) $*! int ) -_t7 = 1 `Plus` (1 `Plus` 1) :: $( int $+! (int $+! int) ) -_t8 = (1 `Plus` 1) `Plus` 1 :: $( (int $+! int) $+! int ) --------------- Mixed resolved/unresolved -_t9 = ((1 `Plus` 1) `Times` 1) `Plus` 1 :: $( (int $+! int) $*? (int $+? int) ) -_t10 = 1 `Plus` (1 `Times` (1 `Plus` 1)) :: $( (int $+? int) $*? (int $+! int) ) -_t11 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+! int) ) -_t12 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+? int) ) --------------- Parens -_t13 = (1 `Plus` (1 `Times` 1)) `Plus` (1 `Times` 1) :: $( ((parensT ((int $+? int) $*? int)) $+? int) $*? int ) -_t14 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (parensT (int $+? int)) $*? (parensT (int $+? int)) ) -_t15 = (1 `Plus` (1 `Times` 1)) `Plus` 1 :: $( parensT ((int $+? int) $*? (int $+? int)) ) - -main = do - mapM_ print exprs - mapM_ print patterns - -- check that there are no Parens or UInfixes in the output - runQ [|N :* N :+ N|] >>= print - runQ [|(N :* N) :+ N|] >>= print - runQ [p|N :* N :+ N|] >>= print - runQ [p|(N :* N) :+ N|] >>= print - runQ [t|Int * Int + Int|] >>= print - runQ [t|(Int * Int) + Int|] >>= print - - -- pretty-printing of unresolved infix expressions - let ne = ConE $ mkName "N" - np = ConP (mkName "N") [] - nt = ConT (mkName "Int") - plusE = ConE (mkName ":+") - plusP = (mkName ":+") - plusT = (mkName "+") - putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UInfixE ne plusE (UInfixE ne plusE ne))) - putStrLn $ pprint (ParensE ne) - putStrLn $ pprint (InfixP np plusP (UInfixP np plusP (UInfixP np plusP np))) - putStrLn $ pprint (ParensP np) - putStrLn $ pprint (InfixT nt plusT (UInfixT nt plusT (UInfixT nt plusT nt))) - putStrLn $ pprint (ParensT nt) - diff --git a/tests/examples/ghc86/TH_unresolvedInfix2.hs b/tests/examples/ghc86/TH_unresolvedInfix2.hs deleted file mode 100644 --- a/tests/examples/ghc86/TH_unresolvedInfix2.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TH_unresolvedInfix2 where - -import Language.Haskell.TH - -infixl 6 :+ - -data Tree = N - | Tree :+ Tree - | Tree :* Tree - -$(return []) - --- Should fail -expr = $( let plus = conE '(:+) - n = conE 'N - in infixE Nothing plus (Just $ uInfixE n plus n) ) - diff --git a/tests/examples/ghc86/TensorTests.hs b/tests/examples/ghc86/TensorTests.hs deleted file mode 100644 --- a/tests/examples/ghc86/TensorTests.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, - RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, - UndecidableInstances #-} - -module TensorTests (tensorTests) where - -import Apply.Cyc -import Tests -import Utils - -import TestTypes - -import Crypto.Lol -import Crypto.Lol.CRTrans -import Crypto.Lol.Cyclotomic.Tensor -import Crypto.Lol.Types - -import Control.Applicative - -import Data.Maybe - -import Data.Singletons -import Data.Promotion.Prelude.Eq -import Data.Singletons.TypeRepStar () - -import qualified Test.Framework as TF - -type TMRParams = ( '(,) <$> Tensors) <*> MRCombos -tmrParams :: Proxy TMRParams -tmrParams = Proxy - ---type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos -type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos -tremParams :: Proxy TrEmParams -tremParams = Proxy - -type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos) - -data Liftable :: TyFun (Factored, Type) Bool -> Type -type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) - diff --git a/tests/examples/ghc86/Test.hs b/tests/examples/ghc86/Test.hs deleted file mode 100644 --- a/tests/examples/ghc86/Test.hs +++ /dev/null @@ -1,410 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------ --- | --- Module : Test --- Copyright : (c) Simon Marlow 2002 --- License : BSD-style --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- This module illustrates & tests most of the features of Haddock. --- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'. --- ------------------------------------------------------------------------------ - --- This is plain comment, ignored by Haddock. - -module Test ( - - -- Section headings are introduced with '-- *': - -- * Type declarations - - -- Subsection headings are introduced with '-- **' and so on. - -- ** Data types - T(..), T2, T3(..), T4(..), T5(..), T6(..), - N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..), - - -- ** Records - R(..), R1(..), - - -- | test that we can export record selectors on their own: - p, q, u, - - -- * Class declarations - C(a,b), D(..), E, F(..), - - -- | Test that we can export a class method on its own: - a, - - -- * Function types - f, g, - - -- * Auxiliary stuff - - -- $aux1 - - -- $aux2 - - -- $aux3 - - -- $aux4 - - -- $aux5 - - -- $aux6 - - -- $aux7 - - -- $aux8 - - -- $aux9 - - -- $aux10 - - -- $aux11 - - -- $aux12 - - -- | This is some inline documentation in the export list - -- - -- > a code block using bird-tracks - -- > each line must begin with > (which isn't significant unless it - -- > is at the beginning of the line). - - -- * A hidden module - module Hidden, - - -- * A visible module - module Visible, - - {-| nested-style doc comments -} - - -- * Existential \/ Universal types - Ex(..), - - -- * Type signatures with argument docs - k, l, m, o, - - -- * A section - -- and without an intervening comma: - -- ** A subsection - -{-| - > a literal line - - $ a non /literal/ line $ --} - - f', - ) where - -import Hidden -import Visible - --- | This comment applies to the /following/ declaration --- and it continues until the next non-comment line -data T a b - = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor - | -- | This comment describes the 'B' constructor - B (T a b, T Int Float) -- ^ - --- | An abstract data declaration -data T2 a b = T2 a b - --- | A data declaration with no documentation annotations on the constructors -data T3 a b = A1 a | B1 b - --- A data declaration with no documentation annotations at all -data T4 a b = A2 a | B2 b - --- A data declaration documentation on the constructors only -data T5 a b - = A3 a -- ^ documents 'A3' - | B3 b -- ^ documents 'B3' - --- | Testing alternative comment styles -data T6 - -- | This is the doc for 'A4' - = A4 - | B4 - | -- ^ This is the doc for 'B4' - - -- | This is the doc for 'C4' - C4 - --- | A newtype -newtype N1 a = N1 a - --- | A newtype with a fieldname -newtype N2 a b = N2 {n :: a b} - --- | A newtype with a fieldname, documentation on the field -newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field - } - --- | An abstract newtype - we show this one as data rather than newtype because --- the difference isn\'t visible to the programmer for an abstract type. -newtype N4 a b = N4 a - -newtype N5 a b = N5 {n5 :: a b -- ^ no docs on the datatype or the constructor - } - -newtype N6 a b = N6 {n6 :: a b - } - -- ^ docs on the constructor only - --- | docs on the newtype and the constructor -newtype N7 a b = N7 {n7 :: a b - } - -- ^ The 'N7' constructor - - -class (D a) => C a where - -- |this is a description of the 'a' method - a :: IO a - b :: [a] - -- ^ this is a description of the 'b' method - c :: a -- c is hidden in the export list - --- ^ This comment applies to the /previous/ declaration (the 'C' class) - -class D a where - d :: T a b - e :: (a,a) --- ^ This is a class declaration with no separate docs for the methods - -instance D Int where - d = undefined - e = undefined - --- instance with a qualified class name -instance Test.D Float where - d = undefined - e = undefined - -class E a where - ee :: a --- ^ This is a class declaration with no methods (or no methods exported) - --- This is a class declaration with no documentation at all -class F a where - ff :: a - --- | This is the documentation for the 'R' record, which has four fields, --- 'p', 'q', 'r', and 's'. -data R = - -- | This is the 'C1' record constructor, with the following fields: - C1 { p :: Int -- ^ This comment applies to the 'p' field - , q :: forall a . a->a -- ^ This comment applies to the 'q' field - , -- | This comment applies to both 'r' and 's' - r,s :: Int - } - | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (), - u,v :: Int - } - -- ^ This is the 'C2' record constructor, also with some fields: - --- | Testing different record commenting styles -data R1 - -- | This is the 'C3' record constructor - = C3 { - -- | The 's1' record selector - s1 :: Int - -- | The 's2' record selector - , s2 :: Int - , s3 :: Int -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here. - -- Since GHC doesn't allow that, I have removed it in this file. - -- ^ The 's3' record selector - } - --- These section headers are only used when there is no export list to --- give the structure of the documentation: - --- * This is a section header (level 1) --- ** This is a section header (level 2) --- *** This is a section header (level 3) - -{-| -In a comment string we can refer to identifiers in scope with -single quotes like this: 'T', and we can refer to modules by -using double quotes: "Foo". We can add emphasis /like this/. - - * This is a bulleted list - - - This is the next item (different kind of bullet) - - (1) This is an ordered list - - 2. This is the next item (different kind of bullet) - -@ - This is a block of code, which can include other markup: 'R' - formatting - is - significant -@ - -> this is another block of code - -We can also include URLs in documentation: . --} - -f :: C a => a -> Int - --- | we can export foreign declarations too -foreign import ccall "header.h" g :: Int -> IO CInt - --- | this doc string has a parse error in it: \' -h :: Int -h = 42 - - --- $aux1 This is some documentation that is attached to a name ($aux1) --- rather than a source declaration. The documentation may be --- referred to in the export list using its name. --- --- @ code block in named doc @ - --- $aux2 This is some documentation that is attached to a name ($aux2) - --- $aux3 --- @ code block on its own in named doc @ - --- $aux4 --- --- @ code block on its own in named doc (after newline) @ - -{- $aux5 a nested, named doc comment - - with a paragraph, - - @ and a code block @ --} - --- some tests for various arrangements of code blocks: - -{- $aux6 ->test ->test1 - -@ test2 - test3 -@ --} - -{- $aux7 -@ -test1 -test2 -@ --} - -{- $aux8 ->test3 ->test4 --} - -{- $aux9 -@ -test1 -test2 -@ - ->test3 ->test4 --} - -{- $aux10 ->test3 ->test4 - -@ -test1 -test2 -@ --} - --- This one is currently wrong (Haddock 0.4). The @...@ part is --- interpreted as part of the bird-tracked code block. -{- $aux11 -aux11: - ->test3 ->test4 - -@ -test1 -test2 -@ --} - --- $aux12 --- > foo --- --- > bar --- - --- | A data-type using existential\/universal types -data Ex a - = forall b . C b => Ex1 b - | forall b . Ex2 b - | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file - | Ex4 (forall a . a -> a) - --- | This is a function with documentation for each argument -k :: T () () -- ^ This argument has type 'T' - -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int' - -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@ - -> T5 () () -- ^ This argument has a very long description that should - -- hopefully cause some wrapping to happen when it is finally - -- rendered by Haddock in the generated HTML page. - -> IO () -- ^ This is the result type - --- This function has arg docs but no docs for the function itself -l :: (Int, Int, Float) -- ^ takes a triple - -> Int -- ^ returns an 'Int' - --- | This function has some arg docs -m :: R - -> N1 () -- ^ one of the arguments - -> IO Int -- ^ and the return value - --- | This function has some arg docs but not a return value doc - --- can't use the original name ('n') with GHC -newn :: R -- ^ one of the arguments, an 'R' - -> N1 () -- ^ one of the arguments - -> IO Int -newn = undefined - - --- | A foreign import with argument docs -foreign import ccall unsafe "header.h" - o :: Float -- ^ The input float - -> IO Float -- ^ The output float - --- | We should be able to escape this: \#\#\# - --- p :: Int --- can't use the above original definition with GHC -newp :: Int -newp = undefined - --- | a function with a prime can be referred to as 'f'' --- but f' doesn't get link'd 'f\'' -f' :: Int - - --- Add some definitions here so that this file can be compiled with GHC - -data T1 -f = undefined -f' = undefined -type CInt = Int -k = undefined -l = undefined -m = undefined - diff --git a/tests/examples/ghc86/Test12417.hs b/tests/examples/ghc86/Test12417.hs deleted file mode 100644 --- a/tests/examples/ghc86/Test12417.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE UnboxedSums, MagicHash #-} - -module Test12417 where - -import GHC.Prim -import GHC.Types - -import System.Mem (performMajorGC) - -type Either1 a b = (# a | b #) - -showEither1 :: (Show a, Show b) => Either1 a b -> String -showEither1 (# left | #) = "Left " ++ show left -showEither1 (# | right #) = "Right " ++ show right - -type T = (# Int | Bool | String | Char | Either Int Bool | Int# | Float# #) - -showEither4 :: T -> String -showEither4 (# | b | | | | | #) = "Alt1: " ++ show b - diff --git a/tests/examples/ghc86/TupleN.hs b/tests/examples/ghc86/TupleN.hs deleted file mode 100644 --- a/tests/examples/ghc86/TupleN.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module TupleN where -import Language.Haskell.TH - -tuple :: Int -> ExpQ -tuple n = [|\list -> $(tupE (exprs [|list|])) |] - where - exprs list = id [infixE (Just (list)) - (varE '(!!)) - (Just (litE $ integerL (toInteger num))) - | num <- [0..(n - 1)]] diff --git a/tests/examples/ghc86/UnicodeSyntax.hs b/tests/examples/ghc86/UnicodeSyntax.hs deleted file mode 100644 --- a/tests/examples/ghc86/UnicodeSyntax.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE Arrows #-} - -module Tutorial where - --- import Abt.Class --- import Abt.Types --- import Abt.Concrete.LocallyNameless - -import Control.Applicative -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Except --- import Data.Vinyl -import Prelude hiding (pi) - --- | We'll start off with a monad in which to manipulate ABTs; we'll need some --- state for fresh variable generation. --- -newtype M α - = M - { _M ∷ State Int α - } deriving (Functor, Applicative, Monad) - --- | We'll run an ABT computation by starting the variable counter at @0@. --- -runM ∷ M α → α -runM (M m) = evalState m 0 - --- | Check out the source to see fresh variable generation. --- -instance MonadVar Var M where - fresh = M $ do - n ← get - let n' = n + 1 - put n' - return $ Var Nothing n' - - named a = do - v ← fresh - return $ v { _varName = Just a } - --- | Next, we'll define the operators for a tiny lambda calculus as a datatype --- indexed by arities. --- -data Lang ns where - LAM ∷ Lang '[S Z] - APP ∷ Lang '[Z, Z] - PI ∷ Lang '[Z, S Z] - UNIT ∷ Lang '[] - AX ∷ Lang '[] - -instance Show1 Lang where - show1 = \case - LAM → "lam" - APP → "ap" - PI → "pi" - UNIT → "unit" - AX → "<>" - -instance HEq1 Lang where - heq1 LAM LAM = Just Refl - heq1 APP APP = Just Refl - heq1 PI PI = Just Refl - heq1 UNIT UNIT = Just Refl - heq1 AX AX = Just Refl - heq1 _ _ = Nothing - -lam ∷ Tm Lang (S Z) → Tm0 Lang -lam e = LAM $$ e :& RNil - -app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang -app m n = APP $$ m :& n :& RNil - -ax ∷ Tm0 Lang -ax = AX $$ RNil - -unit ∷ Tm0 Lang -unit = UNIT $$ RNil - -pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang -pi α xβ = PI $$ α :& xβ :& RNil - --- | A monad transformer for small step operational semantics. --- -newtype StepT m α - = StepT - { runStepT ∷ MaybeT m α - } deriving (Monad, Functor, Applicative, Alternative) - --- | To indicate that a term is in normal form. --- -stepsExhausted - ∷ Applicative m - ⇒ StepT m α -stepsExhausted = StepT . MaybeT $ pure Nothing - -instance MonadVar Var m ⇒ MonadVar Var (StepT m) where - fresh = StepT . MaybeT $ Just <$> fresh - named str = StepT . MaybeT $ Just <$> named str - --- | A single evaluation step. --- -step - ∷ Tm0 Lang - → StepT M (Tm0 Lang) -step tm = - out tm >>= \case - APP :$ m :& n :& RNil → - out m >>= \case - LAM :$ xe :& RNil → xe // n - _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n - PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ - _ → stepsExhausted - --- | The reflexive-transitive closure of a small-step operational semantics. --- -star - ∷ Monad m - ⇒ (α → StepT m α) - → (α → m α) -star f a = - runMaybeT (runStepT $ f a) >>= - return a `maybe` star f - --- | Evaluate a term to normal form --- -eval ∷ Tm0 Lang → Tm0 Lang -eval = runM . star step - -newtype JudgeT m α - = JudgeT - { runJudgeT ∷ ExceptT String m α - } deriving (Monad, Functor, Applicative, Alternative) - -instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where - fresh = JudgeT . ExceptT $ Right <$> fresh - named str = JudgeT . ExceptT $ Right <$> named str - -type Ctx = [(Var, Tm0 Lang)] - -raise ∷ Monad m ⇒ String → JudgeT m α -raise = JudgeT . ExceptT . return . Left - -checkTy - ∷ Ctx - → Tm0 Lang - → Tm0 Lang - → JudgeT M () -checkTy g tm ty = do - let ntm = eval tm - nty = eval ty - (,) <$> out ntm <*> out nty >>= \case - (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do - z ← fresh - ez ← xe // var z - βz ← yβ // var z - checkTy ((z,α):g) ez βz - (AX :$ RNil, UNIT :$ RNil) → return () - _ → do - ty' ← inferTy g tm - if ty' === nty - then return () - else raise "Type error" - -inferTy - ∷ Ctx - → Tm0 Lang - → JudgeT M (Tm0 Lang) -inferTy g tm = do - out (eval tm) >>= \case - V v | Just (eval → ty) ← lookup v g → return ty - | otherwise → raise "Ill-scoped variable" - APP :$ m :& n :& RNil → do - inferTy g m >>= out >>= \case - PI :$ α :& xβ :& RNil → do - checkTy g n α - eval <$> xβ // n - _ → raise "Expected pi type for lambda abstraction" - _ → raise "Only infer neutral terms" - --- | @λx.x@ --- -identityTm ∷ M (Tm0 Lang) -identityTm = do - x ← fresh - return $ lam (x \\ var x) - --- | @(λx.x)(λx.x)@ --- -appTm ∷ M (Tm0 Lang) -appTm = do - tm ← identityTm - return $ app tm tm - --- | A demonstration of evaluating (and pretty-printing). Output: --- --- @ --- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4] --- @ --- -main ∷ IO () -main = do - -- Try out the type checker - either fail print . runM . runExceptT . runJudgeT $ do - x ← fresh - checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit)) - - print . runM $ do - mm ← appTm - mmStr ← toString mm - mmStr' ← toString $ eval mm - return $ mmStr ++ " ~>* " ++ mmStr' - -doMap ∷ FilePath → IOSArrow XmlTree TiledMap -doMap mapPath = proc m → do - mapWidth ← getAttrR "width" ⤙ m - returnA -< baz - --- ^ An opaque ESD handle for recording data from the soundcard via ESD. -data Recorder fr ch (r ∷ ★ → ★) - = Recorder { - reRate ∷ !Int - , reHandle ∷ !Handle - , reCloseH ∷ !(FinalizerHandle r) - } - --- from ghc-prim - --- | A backward-compatible (pre-GHC 8.0) synonym for 'Type' --- type * = TYPE 'PtrRepLifted - --- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type' --- type ★ = TYPE 'PtrRepLifted diff --git a/tests/examples/ghc86/Webhook.hs b/tests/examples/ghc86/Webhook.hs deleted file mode 100644 --- a/tests/examples/ghc86/Webhook.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-| -Module : Servant.GitHub.Webhook -Description : Easily write safe GitHub webhook handlers with Servant -Copyright : (c) Jacob Thomas Errington, 2016 -License : MIT -Maintainer : servant-github-webhook@mail.jerrington.me -Stability : experimental - -The GitHub webhook machinery will attach three headers to the HTTP requests -that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@. -The former two headers correspond with the 'GitHubEvent' and -'GitHubSignedReqBody''' routing combinators. This library ignores the -@X-Github-Delivery@ header; if you would like to access its value, then use the -builtin 'Header' combinator from Servant. - -Usage of the library is straightforward: protect routes with the 'GitHubEvent' -combinator to ensure that the route is only reached for specific -'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write -under that route with 'GitHubSignedReqBody'. It is advised to always include a -'GitHubSignedReqBody''', as this is the only way you can be sure that it is -GitHub who is sending the request, and not a malicious user. If you don't care -about the request body, then simply use Aeson\'s 'Object' type as the -deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and -ignore the @Object@ in the handler. - -The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in -order to extract the signing key. This is the same key that must be entered in -the configuration of the webhook on GitHub. See 'GitHubKey'' for more details. - -In order to support multiple keys on a per-route basis, the basic combinator -@GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this, -create a datatype, e.g. @KeyIndex@ whose constructors identify the different -keys you will be using. Generally, this means one constructor per repository. -Use the @DataKinds@ extension to promote this datatype to a kind, and write an -instance of 'Reflect' for each promoted constructor of your datatype. Finally, -create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is -the datatype you've built up. Thus, your function can determine which key to -retrieve. --} - -{-# LANGUAGE CPP #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - --- GHC 8 seems to have improved its decidability check for type family --- instances and class instances. In particular, without UndecidableInstances --- enabled, the Demote' instance for lists, which we need, will not compile. --- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol, --- won't compile on GHC < 8 because the instance head is no smaller than the --- instance head. -#if __GLASGOW_HASKELL__ < 800 -{-# LANGUAGE UndecidableInstances #-} -#endif - -module Servant.GitHub.Webhook -( -- * Servant combinators - GitHubSignedReqBody'' -, GitHubSignedReqBody' -, GitHubSignedReqBody -, GitHubEvent - - -- ** Security -, GitHubKey'(..) -, GitHubKey -, gitHubKey - - -- * Reexports - -- - -- | We reexport a few datatypes that are typically needed to use the - -- library. -, RepoWebhookEvent(..) -, KProxy(..) - - -- * Implementation details - - -- ** Type-level programming machinery -, Demote -, Demote' -, Reflect(..) - - -- ** Stringy stuff -, parseHeaderMaybe -, matchEvent - - -- * Examples - -- - -- $example1 - -- - -- $example2 -) where - -import Control.Monad.IO.Class ( liftIO ) -import Data.Aeson ( decode', encode ) -import qualified Data.ByteString as BS -import Data.ByteString.Lazy ( fromStrict, toStrict ) -import qualified Data.ByteString.Base16 as B16 -import Data.HMAC ( hmac_sha1 ) -import Data.List ( intercalate ) -import Data.Maybe ( catMaybes, fromMaybe ) -import Data.Monoid ( (<>) ) -import Data.Proxy -import Data.String.Conversions ( cs ) -import qualified Data.Text.Encoding as E -import GHC.TypeLits -import GitHub.Data.Webhooks -import Network.HTTP.Types hiding (Header, ResponseHeaders) -import Network.Wai ( requestHeaders, strictRequestBody ) -import Servant -import Servant.API.ContentTypes ( AllCTUnrender(..) ) -import Servant.Server.Internal - - --- | A clone of Servant's 'ReqBody' combinator, except that it will also --- verify the signature provided by GitHub in the @X-Hub-Signature@ header by --- computing the SHA1 HMAC of the request body and comparing. --- --- The use of this combinator will require that the router context contain an --- appropriate 'GitHubKey'' entry. Specifically, the type parameter of --- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the --- index @key@ used here. Consequently, it will be necessary to use --- 'serveWithContext' instead of 'serve'. --- --- Other routes are not tried upon the failure of this combinator, and a 401 --- response is generated. --- --- Use of this datatype directly is discouraged, since the choice of the index --- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use --- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just --- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for --- the implementation of the 'HasServer' instance for the datatype. -data GitHubSignedReqBody'' - (proxy :: KProxy k) - (key :: k) - (list :: [Type]) - (result :: Type) where - --- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first --- type argument given just the second one. --- --- Use this type synonym if you are creating a webhook server to handle --- webhooks from multiple repositories, with different secret keys. -type GitHubSignedReqBody' (key :: k) - = GitHubSignedReqBody'' ('KProxy :: KProxy k) key - --- | A convenient alias for a trivial key index. --- --- USe this type synonym if you are creating a webhook server to handle only --- webhooks from a single repository, or for mutliple repositories using the --- same secret key. -type GitHubSignedReqBody = GitHubSignedReqBody' '() - --- | A routing combinator that succeeds only for a webhook request that matches --- one of the given 'RepoWebhookEvent' given in the type-level list @events@. --- --- If the list contains 'WebhookWildcardEvent', then all events will be --- matched. --- --- The combinator will require that its associated handler take a --- 'RepoWebhookEvent' parameter, and the matched event will be passed to the --- handler. This allows the handler to determine which event triggered it from --- the list. --- --- Other routes are tried if there is a mismatch. -data GitHubEvent (events :: [RepoWebhookEvent]) where - diff --git a/tests/examples/ghc86/deriving-via-compile.hs b/tests/examples/ghc86/deriving-via-compile.hs deleted file mode 100644 --- a/tests/examples/ghc86/deriving-via-compile.hs +++ /dev/null @@ -1,460 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -module DerivingViaCompile where - -import Data.Void -import Data.Complex -import Data.Functor.Const -import Data.Functor.Identity -import Data.Ratio -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Control.Applicative hiding (WrappedMonad(..)) - -import Data.Bifunctor -import Data.Monoid -import Data.Kind - -type f ~> g = forall xx. f xx -> g xx - ------ --- Simple example ------ - -data Foo a = MkFoo a a - deriving Show - via (Identity (Foo a)) - ------ --- Eta reduction at work ------ - -newtype Flip p a b = Flip { runFlip :: p b a } - -instance Bifunctor p => Bifunctor (Flip p) where - bimap f g = Flip . bimap g f . runFlip - -instance Bifunctor p => Functor (Flip p a) where - fmap f = Flip . first f . runFlip - -newtype Bar a = MkBar (Either a Int) - deriving Functor - via (Flip Either Int) - ------ --- Monad transformers ------ - -type MTrans = (Type -> Type) -> (Type -> Type) - --- From `constraints' -data Dict c where - Dict :: c => Dict c - -newtype a :- b = Sub (a => Dict b) - -infixl 1 \\ -(\\) :: a => (b => r) -> (a :- b) -> r -r \\ Sub Dict = r - --- With `-XQuantifiedConstraints' this just becomes --- --- type Lifting cls trans = forall mm. cls mm => cls (trans mm) --- --- type LiftingMonad trans = Lifting Monad trans --- -class LiftingMonad (trans :: MTrans) where - proof :: Monad m :- Monad (trans m) - -instance LiftingMonad (StateT s :: MTrans) where - proof :: Monad m :- Monad (StateT s m) - proof = Sub Dict - -instance Monoid w => LiftingMonad (WriterT w :: MTrans) where - proof :: Monad m :- Monad (WriterT w m) - proof = Sub Dict - -instance (LiftingMonad trans, LiftingMonad trans') => LiftingMonad (ComposeT trans trans' :: MTrans) where - proof :: forall m. Monad m :- Monad (ComposeT trans trans' m) - proof = Sub (Dict \\ proof @trans @(trans' m) \\ proof @trans' @m) - -newtype Stack :: MTrans where - Stack :: ReaderT Int (StateT Bool (WriterT String m)) a -> Stack m a - deriving newtype - ( Functor - , Applicative - , Monad - , MonadReader Int - , MonadState Bool - , MonadWriter String - ) - deriving (MonadTrans, MFunctor) - via (ReaderT Int `ComposeT` StateT Bool `ComposeT` WriterT String) - -class MFunctor (trans :: MTrans) where - hoist :: Monad m => (m ~> m') -> (trans m ~> trans m') - -instance MFunctor (ReaderT r :: MTrans) where - hoist :: Monad m => (m ~> m') -> (ReaderT r m ~> ReaderT r m') - hoist nat = ReaderT . fmap nat . runReaderT - -instance MFunctor (StateT s :: MTrans) where - hoist :: Monad m => (m ~> m') -> (StateT s m ~> StateT s m') - hoist nat = StateT . fmap nat . runStateT - -instance MFunctor (WriterT w :: MTrans) where - hoist :: Monad m => (m ~> m') -> (WriterT w m ~> WriterT w m') - hoist nat = WriterT . nat . runWriterT - -infixr 9 `ComposeT` -newtype ComposeT :: MTrans -> MTrans -> MTrans where - ComposeT :: { getComposeT :: f (g m) a } -> ComposeT f g m a - deriving newtype (Functor, Applicative, Monad) - -instance (MonadTrans f, MonadTrans g, LiftingMonad g) => MonadTrans (ComposeT f g) where - lift :: forall m. Monad m => m ~> ComposeT f g m - lift = ComposeT . lift . lift - \\ proof @g @m - -instance (MFunctor f, MFunctor g, LiftingMonad g) => MFunctor (ComposeT f g) where - hoist :: forall m m'. Monad m => (m ~> m') -> (ComposeT f g m ~> ComposeT f g m') - hoist f = ComposeT . hoist (hoist f) . getComposeT - \\ proof @g @m - ------ --- Using tuples in a `via` type ------ - -newtype X a = X (a, a) - deriving (Semigroup, Monoid) - via (Product a, Sum a) - - deriving (Show, Eq) - via (a, a) - ------ --- Abstract data types ------ - -class C f where - c :: f a -> Int - -newtype X2 f a = X2 (f a) - -instance C (X2 f) where - c = const 0 - -deriving via (X2 IO) instance C IO - ----- --- Testing parser ----- - -newtype P0 a = P0 a deriving Show via a -newtype P1 a = P1 [a] deriving Show via [a] -newtype P2 a = P2 (a, a) deriving Show via (a, a) -newtype P3 a = P3 (Maybe a) deriving Show via (First a) -newtype P4 a = P4 (Maybe a) deriving Show via (First $ a) -newtype P5 a = P5 a deriving Show via (Identity $ a) -newtype P6 a = P6 [a] deriving Show via ([] $ a) -newtype P7 a = P7 (a, a) deriving Show via (Identity $ (a, a)) -newtype P8 a = P8 (Either () a) deriving Functor via (($) (Either ())) - -newtype f $ a = APP (f a) deriving newtype Show deriving newtype Functor - ----- --- From Baldur's notes ----- - ----- --- 1 ----- -newtype WrapApplicative f a = WrappedApplicative (f a) - deriving (Functor, Applicative) - -instance (Applicative f, Num a) => Num (WrapApplicative f a) where - (+) = liftA2 (+) - (*) = liftA2 (*) - negate = fmap negate - fromInteger = pure . fromInteger - abs = fmap abs - signum = fmap signum - -instance (Applicative f, Fractional a) => Fractional (WrapApplicative f a) where - recip = fmap recip - fromRational = pure . fromRational - -instance (Applicative f, Floating a) => Floating (WrapApplicative f a) where - pi = pure pi - sqrt = fmap sqrt - exp = fmap exp - log = fmap log - sin = fmap sin - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh - -instance (Applicative f, Semigroup s) => Semigroup (WrapApplicative f s) where - (<>) = liftA2 (<>) - -instance (Applicative f, Monoid m) => Monoid (WrapApplicative f m) where - mempty = pure mempty - ----- --- 2 ----- -class Pointed p where - pointed :: a -> p a - -newtype WrapMonad f a = WrappedMonad (f a) - deriving newtype (Pointed, Monad) - -instance (Monad m, Pointed m) => Functor (WrapMonad m) where - fmap = liftM - -instance (Monad m, Pointed m) => Applicative (WrapMonad m) where - pure = pointed - (<*>) = ap - --- data -data Sorted a = Sorted a a a - deriving (Functor, Applicative) - via (WrapMonad Sorted) - deriving (Num, Fractional, Floating, Semigroup, Monoid) - via (WrapApplicative Sorted a) - - -instance Monad Sorted where - (>>=) :: Sorted a -> (a -> Sorted b) -> Sorted b - Sorted a b c >>= f = Sorted a' b' c' where - Sorted a' _ _ = f a - Sorted _ b' _ = f b - Sorted _ _ c' = f c - -instance Pointed Sorted where - pointed :: a -> Sorted a - pointed a = Sorted a a a - ----- --- 3 ----- -class IsZero a where - isZero :: a -> Bool - -newtype WrappedNumEq a = WrappedNumEq a -newtype WrappedShow a = WrappedShow a -newtype WrappedNumEq2 a = WrappedNumEq2 a - -instance (Num a, Eq a) => IsZero (WrappedNumEq a) where - isZero :: WrappedNumEq a -> Bool - isZero (WrappedNumEq a) = 0 == a - -instance Show a => IsZero (WrappedShow a) where - isZero :: WrappedShow a -> Bool - isZero (WrappedShow a) = "0" == show a - -instance (Num a, Eq a) => IsZero (WrappedNumEq2 a) where - isZero :: WrappedNumEq2 a -> Bool - isZero (WrappedNumEq2 a) = a + a == a - -newtype INT = INT Int - deriving newtype Show - deriving IsZero via (WrappedNumEq Int) - -newtype VOID = VOID Void deriving IsZero via (WrappedShow Void) - ----- --- 4 ----- -class Bifunctor p => Biapplicative p where - bipure :: a -> b -> p a b - - biliftA2 - :: (a -> b -> c) - -> (a' -> b' -> c') - -> p a a' - -> p b b' - -> p c c' - -instance Biapplicative (,) where - bipure = (,) - - biliftA2 f f' (a, a') (b, b') = - (f a b, f' a' b') - -newtype WrapBiapp p a b = WrapBiap (p a b) - deriving newtype (Bifunctor, Biapplicative, Eq) - -instance (Biapplicative p, Num a, Num b) => Num (WrapBiapp p a b) where - (+) = biliftA2 (+) (+) - (-) = biliftA2 (*) (*) - (*) = biliftA2 (*) (*) - negate = bimap negate negate - abs = bimap abs abs - signum = bimap signum signum - fromInteger n = fromInteger n `bipure` fromInteger n - -newtype INT2 = INT2 (Int, Int) - deriving IsZero via (WrappedNumEq2 (WrapBiapp (,) Int Int)) - ----- --- 5 ----- -class Monoid a => MonoidNull a where - null :: a -> Bool - -newtype WrpMonNull a = WRM a deriving (Eq, Semigroup, Monoid) - -instance (Eq a, Monoid a) => MonoidNull (WrpMonNull a) where - null :: WrpMonNull a -> Bool - null = (== mempty) - -deriving via (WrpMonNull Any) instance MonoidNull Any -deriving via () instance MonoidNull () -deriving via Ordering instance MonoidNull Ordering - ----- --- 6 ----- --- https://github.com/mikeizbicki/subhask/blob/f53fd8f465747681c88276c7dabe3646fbdf7d50/src/SubHask/Algebra.hs#L635 - -class Lattice a where - sup :: a -> a -> a - (.>=) :: a -> a -> Bool - (.>) :: a -> a -> Bool - -newtype WrapOrd a = WrappedOrd a - deriving newtype (Eq, Ord) - -instance Ord a => Lattice (WrapOrd a) where - sup = max - (.>=) = (>=) - (.>) = (>) - -deriving via [a] instance Ord a => Lattice [a] -deriving via (a, b) instance (Ord a, Ord b) => Lattice (a, b) ---mkLattice_(Bool) -deriving via Bool instance Lattice Bool ---mkLattice_(Char) -deriving via Char instance Lattice Char ---mkLattice_(Int) -deriving via Int instance Lattice Int ---mkLattice_(Integer) -deriving via Integer instance Lattice Integer ---mkLattice_(Float) -deriving via Float instance Lattice Float ---mkLattice_(Double) -deriving via Double instance Lattice Double ---mkLattice_(Rational) -deriving via Rational instance Lattice Rational - ----- --- 7 ----- --- https://hackage.haskell.org/package/linear-1.20.7/docs/src/Linear-Affine.html - -class Functor f => Additive f where - zero :: Num a => f a - (^+^) :: Num a => f a -> f a -> f a - (^+^) = liftU2 (+) - (^-^) :: Num a => f a -> f a -> f a - x ^-^ y = x ^+^ fmap negate y - liftU2 :: (a -> a -> a) -> f a -> f a -> f a - -instance Additive [] where - zero = [] - liftU2 f = go where - go (x:xs) (y:ys) = f x y : go xs ys - go [] ys = ys - go xs [] = xs - -instance Additive Maybe where - zero = Nothing - liftU2 f (Just a) (Just b) = Just (f a b) - liftU2 _ Nothing ys = ys - liftU2 _ xs Nothing = xs - -instance Applicative f => Additive (WrapApplicative f) where - zero = pure 0 - liftU2 = liftA2 - -deriving via (WrapApplicative ((->) a)) instance Additive ((->) a) -deriving via (WrapApplicative Complex) instance Additive Complex -deriving via (WrapApplicative Identity) instance Additive Identity - -instance Additive ZipList where - zero = ZipList [] - liftU2 f (ZipList xs) (ZipList ys) = ZipList (liftU2 f xs ys) - -class Additive (Diff p) => Affine p where - type Diff p :: Type -> Type - - (.-.) :: Num a => p a -> p a -> Diff p a - (.+^) :: Num a => p a -> Diff p a -> p a - (.-^) :: Num a => p a -> Diff p a -> p a - p .-^ v = p .+^ fmap negate v - --- #define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \ --- (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \ --- (.-^) = (^-^) ; {-# INLINE (.-^) #-} --- #define ADDITIVE(T) ADDITIVEC((), T) -newtype WrapAdditive f a = WrappedAdditive (f a) - -instance Additive f => Affine (WrapAdditive f) where - type Diff (WrapAdditive f) = f - - WrappedAdditive a .-. WrappedAdditive b = a ^-^ b - WrappedAdditive a .+^ b = WrappedAdditive (a ^+^ b) - WrappedAdditive a .-^ b = WrappedAdditive (a ^-^ b) - --- ADDITIVE(((->) a)) -deriving via (WrapAdditive ((->) a)) instance Affine ((->) a) --- ADDITIVE([]) -deriving via (WrapAdditive []) instance Affine [] --- ADDITIVE(Complex) -deriving via (WrapAdditive Complex) instance Affine Complex --- ADDITIVE(Maybe) -deriving via (WrapAdditive Maybe) instance Affine Maybe --- ADDITIVE(ZipList) -deriving via (WrapAdditive ZipList) instance Affine ZipList --- ADDITIVE(Identity) -deriving via (WrapAdditive Identity) instance Affine Identity - ----- --- 8 ----- - -class C2 a b c where - c2 :: a -> b -> c - -instance C2 a b (Const a b) where - c2 x _ = Const x - -newtype Fweemp a = Fweemp a - deriving (C2 a b) - via (Const a (b :: Type)) - diff --git a/tests/examples/ghc86/determ004.hs b/tests/examples/ghc86/determ004.hs deleted file mode 100644 --- a/tests/examples/ghc86/determ004.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# LANGUAGE TypeOperators - , DataKinds - , PolyKinds - , TypeFamilies - , GADTs - , UndecidableInstances - , RankNTypes - , ScopedTypeVariables - #-} - -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Werror #-} -{-# OPTIONS_GHC -O1 -fspec-constr #-} - -{- - -With reversed order of allocated uniques the type variables would be in -wrong order: - -*** Core Lint errors : in result of SpecConstr *** -determ004.hs:88:12: warning: - [in body of lambda with binder m_azbFg :: a_afdP_azbON] - @ (a_afdP_azbON :: BOX) is out of scope -*** Offending Program *** - -... - -Rec { -$s$wsFoldr1_szbtK - :: forall (m_azbFg :: a_afdP_azbON) - (x_azbOM :: TyFun - a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> Type) - -> Type) - (a_afdP_azbON :: BOX) - (ipv_szbwN :: a_afdP_azbON) - (ipv_szbwO :: [a_afdP_azbON]). - R:Sing[]z (ipv_szbwN : ipv_szbwO) - ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO) - -> Sing ipv_szbwO - -> Sing ipv_szbwN - -> (forall (t_azbNM :: a_afdP_azbON). - Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) - -> Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) -[LclId, - Arity=4, - Str=DmdType ] -$s$wsFoldr1_szbtK = - \ (@ (m_azbFg :: a_afdP_azbON)) - (@ (x_azbOM :: TyFun - a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> Type) - -> Type)) - (@ (a_afdP_azbON :: BOX)) - (@ (ipv_szbwN :: a_afdP_azbON)) - (@ (ipv_szbwO :: [a_afdP_azbON])) - (sg_szbtL - :: R:Sing[]z (ipv_szbwN : ipv_szbwO) - ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO)) - (sc_szbtM :: Sing ipv_szbwO) - (sc_szbtN :: Sing ipv_szbwN) - (sc_szbtP - :: forall (t_azbNM :: a_afdP_azbON). - Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) -> - case (SCons - @ a_afdP_azbON - @ (ipv_szbwN : ipv_szbwO) - @ ipv_szbwO - @ ipv_szbwN - @~ (_N - :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO)) - sc_szbtN - sc_szbtM) - `cast` (sg_szbtL - ; TFCo:R:Sing[]z[0] _N _N - :: R:Sing[]z (ipv_szbwN : ipv_szbwO) - ~R# R:Sing[]z - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) - of wild_XD { - SNil dt_dzbxX -> - (lvl_szbwi @ a_afdP_azbON) - `cast` ((Sing - (Sym (TFCo:R:Foldr1[2] _N _N) - ; Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N <'[]>_N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) - (Sym dt_dzbxX))_N))_R - :: Sing (Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list") - ~R# Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); - SCons @ n_azbFh @ m_XzbGe dt_dzbxK _sX_azbOH - ds_dzbyu [Dmd=] -> - case ds_dzbyu - `cast` (TFCo:R:Sing[]z[0] _N _N - :: Sing n_azbFh ~R# R:Sing[]z n_azbFh) - of wild_Xo { - SNil dt_dzbxk -> - (lvl_szbw1 @ a_afdP_azbON @ m_XzbGe) - `cast` ((Sing - (Sym (TFCo:R:Foldr1[0] _N _N _N) - ; Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N <'[m_XzbGe]>_N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) - ((_N ': Sym dt_dzbxk)_N ; Sym dt_dzbxK))_N))_R - :: Sing m_XzbGe - ~R# Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); - SCons @ ipv_XzbxR @ ipv_XzbyV ipv_szbwM ipv_szbwL ipv_szbwK -> - case (sc_szbtP @ m_XzbGe _sX_azbOH) - `cast` (TFCo:R:Sing(->)f[0] - _N _N _N - :: Sing (Apply x_azbOM m_XzbGe) - ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe)) - of wild_X3X { SLambda ds_XzbBr [Dmd=] -> - (ds_XzbBr - @ (Foldr1 x_azbOM (ipv_XzbyV : ipv_XzbxR)) - (($wsFoldr1_szbuc - @ a_afdP_azbON - @ x_azbOM - @ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR) - sc_szbtP - ((SCons - @ a_afdP_azbON - @ (ipv_XzbyV : ipv_XzbxR) - @ ipv_XzbxR - @ ipv_XzbyV - @~ (_N - :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR)) - ipv_szbwL - ipv_szbwK) - `cast` (Sym (TFCo:R:Sing[]z[0] _N) (Sym - (TFCo:R:Apply[][]:$$i[0] - _N - _N - _N) - ; (Apply - (Sym - (TFCo:R:Applyk(->):$l[0] - _N - _N)) - _N)_N) - :: R:Sing[]z (ipv_XzbyV : ipv_XzbxR) - ~R# Sing (Apply (Apply (:$) ipv_XzbyV) ipv_XzbxR)))) - `cast` ((Sing - ((Apply - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N) - _N)_N - ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N - ((Apply - (TFCo:R:Applyk(->):$l[0] _N _N) - _N)_N - ; TFCo:R:Apply[][]:$$i[0] - _N _N _N) - _N))_R - :: Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR)) - ~R# Sing (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))))) - `cast` ((Sing - ((Apply - _N - (Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N _N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] - _N _N)) - (Sym - (TFCo:R:Apply[][]:$$i[0] - _N _N _N) - ; (Apply - (Sym - (TFCo:R:Applyk(->):$l[0] _N _N)) - _N)_N))_N))_N - ; Sym - (TFCo:R:Foldr1[1] - _N - _N - _N - _N - _N) - ; Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N _N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) - ((_N ': Sym ipv_szbwM)_N ; Sym dt_dzbxK))_N))_R - :: Sing - (Apply - (Apply x_azbOM m_XzbGe) - (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))) - ~R# Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))) - } - } - } -... --} - -module List (sFoldr1) where - -data Proxy t - -data family Sing (a :: k) - -data TyFun (a :: Type) (b :: Type) - -type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2 - -data instance Sing (f :: TyFun k1 k2 -> Type) = - 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)) -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 -> Type) - -> Type) - (t_afdZ :: [a_afdP]) = - Foldr1 t_afdY t_afdZ -data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) - -> Type) - (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 - -> Type) - -> Type) (TyFun [a_afdP] a_afdP -> Type)) -type instance Apply Foldr1Sym0 l = Foldr1Sym1 l - -type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP - -> Type) - -> Type) - (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 -> Type) -> Type) - (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/ghc86/dynamic-paper.hs b/tests/examples/ghc86/dynamic-paper.hs deleted file mode 100644 --- a/tests/examples/ghc86/dynamic-paper.hs +++ /dev/null @@ -1,341 +0,0 @@ -{- This is the code extracted from "A reflection on types", by Simon PJ, -Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -} - -{-# LANGUAGE RankNTypes, PolyKinds, TypeOperators, - ScopedTypeVariables, GADTs, FlexibleInstances, - UndecidableInstances, RebindableSyntax, - DataKinds, MagicHash, AutoDeriveTypeable, TypeInType #-} -{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-redundant-constraints #-} - -module Dynamic where - -import Data.Map ( Map ) -import qualified Data.Map as Map -import Unsafe.Coerce ( unsafeCoerce ) -import Control.Monad ( (<=<) ) -import Prelude hiding ( lookup, fromInteger, replicate ) -import qualified Prelude -import qualified Data.Typeable -import qualified Data.Data -import Data.Kind - -lookupMap = Map.lookup -insertMap = Map.insert - --- let's ignore overloaded numbers -fromInteger :: Integer -> Int -fromInteger = Prelude.fromInteger - -insertStore = undefined -schema = undefined -withTypeable = undefined -throw# = undefined - -toDynamicST = undefined -fromDynamicST = undefined - -extendStore :: Typeable a => STRef s a -> a -> Store -> Store -lookupStore :: Typeable a => STRef s a -> Store -> Maybe a - -type Key = Int -data STRef s a = STR Key -type Store = Map Key Dynamic - -extendStore (STR k) v s = insertMap k (toDynamicST v) s -lookupStore (STR k) s = case lookupMap k s of - Just d -> fromDynamicST d - Nothing -> Nothing - -toDynamicST :: Typeable a => a -> Dynamic -fromDynamicST :: Typeable a => Dynamic -> Maybe a - -eval = undefined -data Term - -data DynamicSilly = DIntSilly Int - | DBoolSilly Bool - | DCharSilly Char - | DPairSilly DynamicSilly DynamicSilly - - -toDynInt :: Int -> DynamicSilly -toDynInt = DIntSilly - -fromDynInt :: DynamicSilly -> Maybe Int -fromDynInt (DIntSilly n) = Just n -fromDynInt _ = Nothing - -toDynPair :: DynamicSilly -> DynamicSilly -> DynamicSilly -toDynPair = DPairSilly - -dynFstSilly :: DynamicSilly -> Maybe DynamicSilly -dynFstSilly (DPairSilly x1 x2) = Just x1 -dynFstSilly _ = Nothing - -eval :: Term -> DynamicSilly - -eqT = undefined - -instance Typeable (->) -instance Typeable Maybe -instance Typeable Bool -instance Typeable Int -instance (Typeable a, Typeable b) => Typeable (a b) -instance Typeable (,) - -instance Eq TypeRepX - -data Dynamic where - Dyn :: TypeRep a -> a -> Dynamic - -toDynamic :: Typeable a => a -> Dynamic -toDynamic x = Dyn typeRep x - -eqTNoKind = undefined - -eqTNoKind :: TypeRep a -> TypeRep b -> Maybe (a :***: b) - -- Primitive; implemented by compiler - -data a :***: b where - ReflNoKind :: a :***: a - -fromDynamic :: forall d. Typeable d => Dynamic -> Maybe d -fromDynamic (Dyn (ra :: TypeRep a) (x :: a)) - = case eqT ra (typeRep :: TypeRep d) of - Nothing -> Nothing - Just Refl -> Just x - -fromDynamicMonad :: forall d. Typeable d => Dynamic -> Maybe d - -fromDynamicMonad (Dyn ra x) - = do Refl <- eqT ra (typeRep :: TypeRep d) - return x - -cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b -cast x = do Refl <- eqT (typeRep :: TypeRep a) - (typeRep :: TypeRep b) - return x - -gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b) -gcast x = do Refl <- eqT (typeRep :: TypeRep a) - (typeRep :: TypeRep b) - return x - -data SameKind :: k -> k -> Type -type CheckAppResult = SameKind AppResult AppResultNoKind - -- not the most thorough check -foo :: AppResult x -> AppResultNoKind x -foo (App y z) = AppNoKind y z - -splitApp :: TypeRep a -> Maybe (AppResult a) -splitApp = undefined -splitAppNoKind = undefined -splitAppNoKind :: TypeRep a -> Maybe (AppResultNoKind a) - -- Primitive; implemented by compiler - -data AppResultNoKind t where - AppNoKind :: TypeRep a -> TypeRep b -> AppResultNoKind (a b) - -dynFstNoKind :: Dynamic -> Maybe Dynamic -dynFstNoKind (Dyn rpab x) - = do AppNoKind rpa rb <- splitAppNoKind rpab - AppNoKind rp ra <- splitAppNoKind rpa - Refl <- eqT rp (typeRep :: TypeRep (,)) - return (Dyn ra (fst x)) - -dynApply :: Dynamic -> Dynamic -> Maybe Dynamic -dynApply (Dyn rf f) (Dyn rx x) = do - App ra rt2 <- splitApp rf - App rtc rt1 <- splitApp ra - Refl <- eqT rtc (typeRep :: TypeRep (->)) - Refl <- eqT rt1 rx - return (Dyn rt2 (f x)) - -data TypeRepAbstract (a :: k) -- primitive, indexed by type and kind - -class Typeable (a :: k) where - typeRep :: TypeRep a - -data AppResult (t :: k) where - App :: forall k1 k (a :: k1 -> k) (b :: k1). - TypeRep a -> TypeRep b -> AppResult (a b) - -dynFst :: Dynamic -> Maybe Dynamic -dynFst (Dyn (rpab :: TypeRep pab) (x :: pab)) - - = do App (rpa :: TypeRep pa ) (rb :: TypeRep b) <- splitApp rpab - -- introduces kind |k2|, and types |pa :: k2 -> *|, |b :: k2| - - App (rp :: TypeRep p ) (ra :: TypeRep a) <- splitApp rpa - -- introduces kind |k1|, and types |p :: k1 -> k2 -> *|, |a :: k1| - - Refl <- eqT rp (typeRep :: TypeRep (,)) - -- introduces |p ~ (,)| and |(k1 -> k2 -> Type) ~ (Type -> Type -> Type)| - - return (Dyn ra (fst x)) - -eqT :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~: b) - -data (a :: k1) :~: (b :: k2) where - Refl :: forall k (a :: k). a :~: a - -castDance :: (Typeable a, Typeable b) => a -> Maybe b -castDance = castR typeRep typeRep - -withTypeable :: TypeRep a -> (Typeable a => r) -> r - -castR :: TypeRep a -> TypeRep b -> a -> Maybe b -castR ta tb = withTypeable ta (withTypeable tb castDance) - -cmpT = undefined -compareTypeRep = undefined - -data TypeRepX where - TypeRepX :: TypeRep a -> TypeRepX - -type TyMapLessTyped = Map TypeRepX Dynamic - -insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped -insertLessTyped x = Map.insert (TypeRepX (typeRep :: TypeRep a)) (toDynamic x) - -lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a -lookupLessTyped = fromDynamic <=< Map.lookup (TypeRepX (typeRep :: TypeRep a)) - -instance Ord TypeRepX where - compare (TypeRepX tr1) (TypeRepX tr2) = compareTypeRep tr1 tr2 - -compareTypeRep :: TypeRep a -> TypeRep b -> Ordering -- primitive - -data TyMap = Empty | Node Dynamic TyMap TyMap - -lookup :: TypeRep a -> TyMap -> Maybe a -lookup tr1 (Node (Dyn tr2 v) left right) = - case compareTypeRep tr1 tr2 of - LT -> lookup tr1 left - EQ -> castR tr2 tr1 v -- know this cast will succeed - GT -> lookup tr1 right -lookup tr1 Empty = Nothing - -cmpT :: TypeRep a -> TypeRep b -> OrderingT a b - -- definition is primitive - -data OrderingT a b where - LTT :: OrderingT a b - EQT :: OrderingT t t - GTT :: OrderingT a b - -data TypeRep (a :: k) where - TrApp :: TypeRep a -> TypeRep b -> TypeRep (a b) - TrTyCon :: TyCon -> TypeRep k -> TypeRep (a :: k) - -data TyCon = TyCon { tc_module :: Module, tc_name :: String } -data Module = Module { mod_pkg :: String, mod_name :: String } - -tcMaybe :: TyCon -tcMaybe = TyCon { tc_module = Module { mod_pkg = "base" - , mod_name = "Data.Maybe" } - , tc_name = "Maybe" } - -rt = undefined - -delta1 :: Dynamic -> Dynamic -delta1 dn = case fromDynamic dn of - Just f -> f dn - Nothing -> dn -loop1 = delta1 (toDynamic delta1) - -data Rid = MkT (forall a. TypeRep a -> a -> a) -rt :: TypeRep Rid -delta :: forall a. TypeRep a -> a -> a -delta ra x = case (eqT ra rt) of - Just Refl -> case x of MkT y -> y rt x - Nothing -> x -loop = delta rt (MkT delta) - -throw# :: SomeException -> a - -data SomeException where - SomeException :: Exception e => e -> SomeException - -class (Typeable e, Show e) => Exception e where { } - -data Company -data Salary -incS :: Float -> Salary -> Salary -incS = undefined - --- some impedance matching with SYB -instance Data.Data.Data Company -instance {-# INCOHERENT #-} Data.Typeable.Typeable a => Typeable a - -mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a -mkT f x = case (cast f) of - Just g -> g x - Nothing -> x - -data Expr a -frontEnd = undefined - -data DynExp where - DE :: TypeRep a -> Expr a -> DynExp - -frontEnd :: String -> DynExp - -data TyConOld - -typeOf = undefined -eqTOld = undefined -funTcOld = undefined :: TyConOld -splitTyConApp = undefined -mkTyCon3 = undefined -boolTcOld = undefined -tupleTc = undefined -mkTyConApp = undefined -instance Eq TypeRepOld -instance Eq TyConOld - -data TypeRepOld -- Abstract - -class TypeableOld a where - typeRepOld :: proxy a -> TypeRepOld - -data DynamicOld where - DynOld :: TypeRepOld -> a -> DynamicOld - -data Proxy a = Proxy - -fromDynamicOld :: forall d. TypeableOld d => DynamicOld -> Maybe d -fromDynamicOld (DynOld trx x) - | typeRepOld (Proxy :: Proxy d) == trx = Just (unsafeCoerce x) - | otherwise = Nothing - -dynApplyOld :: DynamicOld -> DynamicOld -> Maybe DynamicOld -dynApplyOld (DynOld trf f) (DynOld trx x) = - case splitTyConApp trf of - (tc, [t1,t2]) | tc == funTcOld && t1 == trx -> - Just (DynOld t2 ((unsafeCoerce f) x)) - _ -> Nothing - -data DynamicClosed where - DynClosed :: TypeRepClosed a -> a -> DynamicClosed - -data TypeRepClosed (a :: Type) where - TBool :: TypeRepClosed Bool - TFun :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a -> b) - TProd :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a, b) - - -lookupPil = undefined - -lookupPil :: Typeable a => [Dynamic] -> Maybe a - -data Dyn1 = Dyn1 Int - | DynFun (Dyn1 -> Dyn1) - | DynPair (Dyn1, Dyn1) - -data TypeEnum = IntType | FloatType | BoolType | DateType | StringType -data Schema = Object [Schema] | - Field TypeEnum | - Array Schema - -schema :: Typeable a => a -> Schema diff --git a/tests/examples/ghc86/dynbrk005.hs b/tests/examples/ghc86/dynbrk005.hs deleted file mode 100644 --- a/tests/examples/ghc86/dynbrk005.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -import TupleN - -tuple3 x = $(tuple 3) x - -normal_fn x = tuple3 x diff --git a/tests/examples/ghc86/empty-foralls.hs b/tests/examples/ghc86/empty-foralls.hs deleted file mode 100644 --- a/tests/examples/ghc86/empty-foralls.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} --- Empty foralls are handled correctly in different situations. - -data D = forall. D Int - -data G where - G :: forall. Int -> G diff --git a/tests/examples/ghc86/ffi1.hs b/tests/examples/ghc86/ffi1.hs deleted file mode 100644 --- a/tests/examples/ghc86/ffi1.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-} - -module Lib where - -import GHC.Prim - --- Can't unboxed tuples and sums to FFI, we should fail appropriately. - -foreign import ccall "f1" f1 :: (# Int | Int #) -> IO Int -foreign import ccall "f2" f2 :: (# (# Int, Int #) | (# Float#, Float# #) #) -> IO Int -foreign import ccall "f3" f3 :: (# (# #) | Void# | (# Int# | String #) #) -> IO Int - diff --git a/tests/examples/ghc86/ghci006.hs b/tests/examples/ghc86/ghci006.hs deleted file mode 100644 --- a/tests/examples/ghc86/ghci006.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module Ghci006 where - -data Q = forall x . Show x => Q x -showQ (Q x) = show x - --- associated bug is that at the interpreter command line, --- showQ (Q "foo") crashed the interpreter. - diff --git a/tests/examples/ghc86/haddockA026.hs b/tests/examples/ghc86/haddockA026.hs deleted file mode 100644 --- a/tests/examples/ghc86/haddockA026.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE RankNTypes #-} - -module ShouldCompile where - -test :: (Eq a) => [a] -- ^ doc1 - -> forall b . [b] {-^ doc2 -} - -> [a] -- ^ doc3 -test xs ys = xs - diff --git a/tests/examples/ghc86/haddockA027.hs b/tests/examples/ghc86/haddockA027.hs deleted file mode 100644 --- a/tests/examples/ghc86/haddockA027.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE RankNTypes #-} - -module ShouldCompile where - -test :: [a] -- ^ doc1 - -> forall b. (Ord b) => [b] {-^ doc2 -} - -> forall c. (Num c) => [c] -- ^ doc3 - -> [a] -test xs ys zs = xs - diff --git a/tests/examples/ghc86/haddockA031.hs b/tests/examples/ghc86/haddockA031.hs deleted file mode 100644 --- a/tests/examples/ghc86/haddockA031.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module ShouldCompile where - -data A - = A - | {-| comment for B -} forall a. B a a - | forall a. Num a => C a {-^ comment for C -} - diff --git a/tests/examples/ghc86/haddockC026.hs b/tests/examples/ghc86/haddockC026.hs deleted file mode 100644 --- a/tests/examples/ghc86/haddockC026.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE RankNTypes #-} - -module ShouldCompile where - -test :: (Eq a) => [a] -- ^ doc1 - -> forall b . [b] {-^ doc2 -} - -> [a] -- ^ doc3 -test xs ys = xs - diff --git a/tests/examples/ghc86/haddockC027.hs b/tests/examples/ghc86/haddockC027.hs deleted file mode 100644 --- a/tests/examples/ghc86/haddockC027.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-# LANGUAGE RankNTypes #-} - -module ShouldCompile where - --- I bet this test is a mistake! From the layout it --- looks as if 'test' takes three args, the latter two --- of higher rank. But the parens around these args are --- missing, so it parses as --- test :: [a] --- -> forall a. Ord a --- => [b] --- -> forall c. Num c --- => [c] --- -> [a] --- --- But maybe that what was intended; I'm not sure --- Anyway it should typecheck! - -test :: [a] -- ^ doc1 - -> forall b. (Ord b) => [b] {-^ doc2 -} - -> forall c. (Num c) => [c] -- ^ doc3 - -> [a] -test xs ys zs = xs - diff --git a/tests/examples/ghc86/haddockC031.hs b/tests/examples/ghc86/haddockC031.hs deleted file mode 100644 --- a/tests/examples/ghc86/haddockC031.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -module ShouldCompile where - -data A - = A - | {-| comment for B -} forall a. B a a - | forall a. Num a => C a {-^ comment for C -} - diff --git a/tests/examples/ghc86/mdo.hs b/tests/examples/ghc86/mdo.hs deleted file mode 100644 --- a/tests/examples/ghc86/mdo.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} -import Control.Monad.Fix -import Data.IORef -import Prelude hiding (traverse) - -data N a = N (IORef Bool, N a, a, N a) - -newNode :: N a -> a -> N a -> IO (N a) -newNode b c f = do v <- newIORef False - return (N (v, b, c, f)) - -ll = mdo n0 <- newNode n3 0 n1 - n1 <- newNode n0 1 n2 - n2 <- newNode n1 2 n3 - n3 <- newNode n2 3 n0 - return n0 - -data Dir = F | B deriving Eq - -traverse :: Dir -> N a -> IO [a] -traverse d (N (v, b, i, f)) = - do visited <- readIORef v - if visited - then return [] - else do writeIORef v True - let next = if d == F then f else b - is <- traverse d next - return (i:is) - -l2dll :: [a] -> IO (N a) -l2dll (x:xs) = mdo c <- newNode l x f - (f, l) <- l2dll' c xs - return c - -l2dll' :: N a -> [a] -> IO (N a, N a) -l2dll' p [] = return (p, p) -l2dll' p (x:xs) = mdo c <- newNode p x f - (f, l) <- l2dll' c xs - return (c, l) - diff --git a/tests/examples/ghc86/mkGADTVars.hs b/tests/examples/ghc86/mkGADTVars.hs deleted file mode 100644 --- a/tests/examples/ghc86/mkGADTVars.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE GADTs, TypeInType #-} - -module GADTVars where - -import Data.Kind -import Data.Proxy - -data T (k1 :: Type) (k2 :: Type) (a :: k2) (b :: k2) where - MkT :: T x1 * (Proxy (y :: x1), z) z diff --git a/tests/examples/ghc86/overloadedrecflds_generics.hs b/tests/examples/ghc86/overloadedrecflds_generics.hs deleted file mode 100644 --- a/tests/examples/ghc86/overloadedrecflds_generics.hs +++ /dev/null @@ -1,50 +0,0 @@ --- Test that DuplicateRecordFields doesn't affect the metadata --- generated by GHC.Generics or Data.Data - --- Based on a Stack Overflow post by bennofs --- (http://stackoverflow.com/questions/24474581) --- licensed under cc by-sa 3.0 - -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} - -import GHC.Generics -import Data.Data -import Data.Proxy - -type family FirstSelector (f :: Type -> Type) :: Meta -type instance FirstSelector (M1 D x f) = FirstSelector f -type instance FirstSelector (M1 C x f) = FirstSelector f -type instance FirstSelector (a :*: b) = FirstSelector a -type instance FirstSelector (M1 S s f) = s - -data SelectorProxy (s :: Meta) (f :: Type -> Type) a = SelectorProxy -type SelectorProxy' (s :: Meta) = SelectorProxy s Proxy () - --- Extract the first selector name using GHC.Generics -firstSelectorName :: forall a. Selector (FirstSelector (Rep a)) - => Proxy a -> String -firstSelectorName _ = - selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a))) - --- Extract the list of selector names for a constructor using Data.Data -selectorNames :: Data a => a -> [String] -selectorNames = constrFields . toConstr - -data T = MkT { foo :: Int } deriving (Data, Generic) -data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic) - -main = do -- This should yield "foo", not "$sel:foo:MkT" - print (firstSelectorName (Proxy :: Proxy T)) - -- Similarly this should yield "foo" - print (firstSelectorName (Proxy :: Proxy U)) - -- This should yield ["foo"] - print (selectorNames (MkT 3)) - -- And this should yield ["foo","bar"] - print (selectorNames (MkU 3 True)) diff --git a/tests/examples/ghc88/ClassParens.hs b/tests/examples/ghc88/ClassParens.hs deleted file mode 100644 --- a/tests/examples/ghc88/ClassParens.hs +++ /dev/null @@ -1,11 +0,0 @@ -module ClassParens where - -class LiftingMonad (trans :: MTrans) where - proof :: Monad m :- Monad (trans m) - -class LiftingMonad2 ((trans :: MTrans)) where - proof :: Monad m :- Monad (trans m) - -data Nat (t :: NatKind) where - ZeroNat :: Nat Zero - SuccNat :: Nat t -> Nat (Succ t) diff --git a/tests/examples/ghc88/DumpParsedAst.hs b/tests/examples/ghc88/DumpParsedAst.hs deleted file mode 100644 --- a/tests/examples/ghc88/DumpParsedAst.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies - , TypeApplications, TypeInType #-} - -module DumpParsedAst where -import Data.Kind - -data Peano = Zero | Succ Peano - -type family Length (as :: [k]) :: Peano where - Length (a : as) = Succ (Length as) - Length '[] = Zero - --- vis kind app -data T f (a :: k) = MkT (f a) - -type family F1 (a :: k) (f :: k -> Type) :: Type where - F1 @Peano a f = T @Peano f a - -main = putStrLn "hello" - diff --git a/tests/examples/ghc88/EmptyCase008.hs b/tests/examples/ghc88/EmptyCase008.hs deleted file mode 100644 --- a/tests/examples/ghc88/EmptyCase008.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} -{-# LANGUAGE TypeFamilies, GADTs, EmptyCase, LambdaCase #-} - --- Check interaction between Newtypes and DataFamilies -module EmptyCase008 where - -import Data.Kind (Type) - -data family DA a - -newtype Foo3 a = Foo3 (DA a) - -data instance DA Int = MkDA1 Char | MkDA2 - --- Non-exhaustive. Missing: MkDA1 Char, MkDA2 -f11 :: Foo3 Int -> () -f11 = \case - --- Non-exhaustive. (no info about a) -f12 :: Foo3 a -> () -f12 = \case - -data instance DA () -- Empty data type - --- Exhaustive. -f13 :: Foo3 () -> () -f13 = \case - --- ---------------- -data family DB a :: Type -> Type - -data instance DB Int a where - MkDB1 :: DB Int () - MkDB2 :: DB Int Bool - -newtype Foo4 a b = Foo4 (DB a b) - --- Non-exhaustive. Missing: Foo4 MkDB1 -f14 :: Foo4 Int () -> () -f14 = \case - --- Exhaustive -f15 :: Foo4 Int [a] -> () -f15 = \case - --- Non-exhaustive. Missing: (_ :: Foo4 a b) (no information about a or b) -f16 :: Foo4 a b -> () -f16 = \case - -data instance DB Char Bool -- Empty data type - --- Exhaustive (empty data type) -f17 :: Foo4 Char Bool -> () -f17 = \case - diff --git a/tests/examples/ghc88/Exp.hs b/tests/examples/ghc88/Exp.hs deleted file mode 100644 --- a/tests/examples/ghc88/Exp.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -module Data.Array.Accelerate.Utility.Lift.Exp ( - Unlift, - Unlifted, - Tuple, - unlift, - modify, - modify2, - modify3, - modify4, - Exp(Exp), expr, atom, - unliftPair, - unliftTriple, - unliftQuadruple, - asExp, - mapFst, - mapSnd, - fst3, - snd3, - thd3, - indexCons, - ) where - -import qualified Data.Array.Accelerate.Data.Complex as Complex -import qualified Data.Array.Accelerate as A -import Data.Complex (Complex((:+))) -import Data.Array.Accelerate ((:.)((:.))) - -import qualified Data.Tuple.HT as Tuple -import Data.Tuple.HT (mapTriple) - - -{- | -This class simplifies untupling of expressions. -If you have a function - -> g :: ((Exp a, Exp b), Exp (c,d)) -> (Exp e, Exp f) - -you cannot apply it to an array @arr :: Array sh ((a,b),(c,d))@ using 'A.map'. -Here, the 'modify' function helps: - -> modify ((expr,expr),expr) g :: Exp ((a,b),(c,d)) -> Exp (e,f) - -The 'expr'-pattern tells, how deep the tuple shall be unlifted. -This way you can write: - -> A.map -> (Exp.modify ((expr,expr),expr) $ \((a,b), cd) -> g ((a,b), cd)) -> arr - -'modify' is based on 'unlift'. -In contrast to 'A.unlift' it does not only unlift one level of tupels, -but is guided by an 'expr'-pattern. -In the example I have demonstrated, -how the pair @(a,b)@ is unlifted, but the pair @(c,d)@ is not. -For the result tuple, 'modify' simply calls 'A.lift'. -In contrast to 'A.unlift', -'A.lift' lifts over all tupel levels until it obtains a single 'Exp'. --} -class - (A.Elt (Tuple pattern), A.Plain (Unlifted pattern) ~ Tuple pattern) => - Unlift pattern where - type Unlifted pattern - type Tuple pattern - unlift :: pattern -> A.Exp (Tuple pattern) -> Unlifted pattern - -modify :: - (A.Lift A.Exp a, Unlift pattern) => - pattern -> - (Unlifted pattern -> a) -> - A.Exp (Tuple pattern) -> A.Exp (A.Plain a) -modify p f = A.lift . f . unlift p - -modify2 :: - (A.Lift A.Exp a, Unlift patternA, Unlift patternB) => - patternA -> - patternB -> - (Unlifted patternA -> Unlifted patternB -> a) -> - A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> A.Exp (A.Plain a) -modify2 pa pb f a b = A.lift $ f (unlift pa a) (unlift pb b) - -modify3 :: - (A.Lift A.Exp a, Unlift patternA, Unlift patternB, Unlift patternC) => - patternA -> - patternB -> - patternC -> - (Unlifted patternA -> Unlifted patternB -> Unlifted patternC -> a) -> - A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> - A.Exp (Tuple patternC) -> A.Exp (A.Plain a) -modify3 pa pb pc f a b c = - A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c) - -modify4 :: - (A.Lift A.Exp a, - Unlift patternA, Unlift patternB, Unlift patternC, Unlift patternD) => - patternA -> - patternB -> - patternC -> - patternD -> - (Unlifted patternA -> Unlifted patternB -> - Unlifted patternC -> Unlifted patternD -> a) -> - A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> - A.Exp (Tuple patternC) -> A.Exp (Tuple patternD) -> A.Exp (A.Plain a) -modify4 pa pb pc pd f a b c d = - A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c) (unlift pd d) - - -instance (A.Elt a) => Unlift (Exp a) where - type Unlifted (Exp a) = A.Exp a - type Tuple (Exp a) = a - unlift _ = id - -data Exp e = Exp - -expr :: Exp e -expr = Exp - -{-# DEPRECATED atom "use expr instead" #-} --- | for compatibility with accelerate-utility-0.0 -atom :: Exp e -atom = expr - - -instance (Unlift pa, Unlift pb) => Unlift (pa,pb) where - type Unlifted (pa,pb) = (Unlifted pa, Unlifted pb) - type Tuple (pa,pb) = (Tuple pa, Tuple pb) - unlift (pa,pb) ab = - (unlift pa $ A.fst ab, unlift pb $ A.snd ab) - -instance - (Unlift pa, Unlift pb, Unlift pc) => - Unlift (pa,pb,pc) where - type Unlifted (pa,pb,pc) = (Unlifted pa, Unlifted pb, Unlifted pc) - type Tuple (pa,pb,pc) = (Tuple pa, Tuple pb, Tuple pc) - unlift (pa,pb,pc) = - mapTriple (unlift pa, unlift pb, unlift pc) . A.unlift - - -instance (Unlift pa, A.Slice (Tuple pa), int ~ Exp Int) => Unlift (pa :. int) where - type Unlifted (pa :. int) = Unlifted pa :. A.Exp Int - type Tuple (pa :. int) = Tuple pa :. Int - unlift (pa:.pb) ab = - (unlift pa $ A.indexTail ab) :. (unlift pb $ A.indexHead ab) - - -instance (Unlift p) => Unlift (Complex p) where - type Unlifted (Complex p) = Complex (Unlifted p) - type Tuple (Complex p) = Complex (Tuple p) - unlift (preal:+pimag) z = - unlift preal (Complex.real z) - :+ - unlift pimag (Complex.imag z) - - -unliftPair :: (A.Elt a, A.Elt b) => A.Exp (a,b) -> (A.Exp a, A.Exp b) -unliftPair = A.unlift - -unliftTriple :: - (A.Elt a, A.Elt b, A.Elt c) => A.Exp (a,b,c) -> (A.Exp a, A.Exp b, A.Exp c) -unliftTriple = A.unlift - -unliftQuadruple :: - (A.Elt a, A.Elt b, A.Elt c, A.Elt d) => - A.Exp (a,b,c,d) -> (A.Exp a, A.Exp b, A.Exp c, A.Exp d) -unliftQuadruple = A.unlift - -asExp :: A.Exp a -> A.Exp a -asExp = id - -mapFst :: - (A.Elt a, A.Elt b, A.Elt c) => - (A.Exp a -> A.Exp b) -> A.Exp (a,c) -> A.Exp (b,c) -mapFst f = modify (expr,expr) $ \(a,c) -> (f a, c) - -mapSnd :: - (A.Elt a, A.Elt b, A.Elt c) => - (A.Exp b -> A.Exp c) -> A.Exp (a,b) -> A.Exp (a,c) -mapSnd f = modify (expr,expr) $ \(a,b) -> (a, f b) - - -fst3 :: - (A.Elt a, A.Elt b, A.Elt c) => - A.Exp (a,b,c) -> A.Exp a -fst3 = modify (expr,expr,expr) Tuple.fst3 - -snd3 :: - (A.Elt a, A.Elt b, A.Elt c) => - A.Exp (a,b,c) -> A.Exp b -snd3 = modify (expr,expr,expr) Tuple.snd3 - -thd3 :: - (A.Elt a, A.Elt b, A.Elt c) => - A.Exp (a,b,c) -> A.Exp c -thd3 = modify (expr,expr,expr) Tuple.thd3 - - - -indexCons :: - (A.Slice ix) => A.Exp ix -> A.Exp Int -> A.Exp (ix :. Int) -indexCons ix n = A.lift $ ix:.n - diff --git a/tests/examples/ghc88/ExplicitForAllRules1.hs b/tests/examples/ghc88/ExplicitForAllRules1.hs deleted file mode 100644 --- a/tests/examples/ghc88/ExplicitForAllRules1.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeApplications #-} - -module ExplicitForAllRules1 where - -import Data.Proxy -import Data.Kind - --- From Proposal 0007 (w/ fix to "example") - -{-# RULES -"example" forall a b. forall. map @a @b f = f -"example2" forall a. forall (x :: a). id x = x - #-} - -{-# NOINLINE f #-} -f :: a -> b -f = undefined - --- More tests - -{-# RULES -"example3" forall (a :: Type -> Type) (b :: a Int) c. forall x y. g @(Proxy b) @(Proxy c) x y = () -"example4" forall (a :: Bool) (b :: Proxy a). forall x. g @(Proxy b) @() x = id @() -"example5" forall (a :: Type). forall. h @a = id @a -"example5" forall k (c :: k). forall (x :: Proxy c). id @(Proxy c) x = x - #-} - -{-# NOINLINE g #-} -g :: a -> b -> () -g _ _ = () - -{-# NOINLINE h #-} -h :: a -> a -h x = x - --- Should NOT have a parse error :( -{-# RULES "example6" forall a forall. g a forall = () #-} - --- Should generate a warning -{-# RULES "example7" forall a b. forall (x :: a). id x = x #-} - diff --git a/tests/examples/ghc88/Internal.hs b/tests/examples/ghc88/Internal.hs deleted file mode 100644 --- a/tests/examples/ghc88/Internal.hs +++ /dev/null @@ -1,342 +0,0 @@ -{-# language GADTs, RankNTypes #-} -{-# language FlexibleContexts, DefaultSignatures #-} -{-# language TypeOperators #-} -{-# language LambdaCase #-} -{-# language EmptyCase #-} -module Hedgehog.Function.Internal where - -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Data.Bifunctor (first) -import Data.Functor.Contravariant (Contravariant(..)) -import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable(..)) -import Data.Functor.Identity (Identity(..)) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Maybe (fromJust) -import Data.Void (Void, absurd) -import Data.Word (Word8, Word64) -import Hedgehog.Internal.Gen (GenT(..), Gen, runGenT) -import Hedgehog.Internal.Seed (Seed(..)) -import Hedgehog.Internal.Tree (Tree(..), Node(..)) -import Hedgehog.Internal.Property (PropertyT, forAll) - -import GHC.Generics - -import qualified Hedgehog.Internal.Tree as Tree - -infixr 5 :-> - --- | Shrinkable, showable functions --- --- Claessen, K. (2012, September). Shrinking and showing functions:(functional pearl). --- In ACM SIGPLAN Notices (Vol. 47, No. 12, pp. 73-80). ACM. -data a :-> c where - Unit :: c -> () :-> c - Nil :: a :-> c - Pair :: a :-> b :-> c -> (a, b) :-> c - Sum :: a :-> c -> b :-> c -> Either a b :-> c - Map :: (a -> b) -> (b -> a) -> b :-> c -> a :-> c - -instance Functor ((:->) r) where - fmap f (Unit c) = Unit $ f c - fmap _ Nil = Nil - fmap f (Pair a) = Pair $ fmap (fmap f) a - fmap f (Sum a b) = Sum (fmap f a) (fmap f b) - fmap f (Map a b c) = Map a b (fmap f c) - --- | Tabulate the function -table :: a :-> c -> [(a, c)] -table (Unit c) = [((), c)] -table Nil = [] -table (Pair f) = do - (a, bc) <- table f - (b, c) <- table bc - pure ((a, b), c) -table (Sum a b) = - [(Left x, c) | (x, c) <- table a] ++ - [(Right x, c) | (x, c) <- table b] -table (Map _ g a) = first g <$> table a - -class GArg a where - gbuild' :: (a x -> c) -> a x :-> c - --- | Reify a function whose domain has an instance of 'Generic' -gbuild :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c -gbuild = gvia from to - --- | @instance Arg A where@ allows functions which take @A@s to be reified -class Arg a where - build :: (a -> c) -> a :-> c - default build :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c - build = gbuild - -variant :: Word64 -> GenT m b -> GenT m b -variant n (GenT f) = GenT $ \sz sd -> f sz (sd { seedValue = seedValue sd + n}) - -variant' :: Word64 -> CoGenT m b -> CoGenT m b -variant' n (CoGenT f) = - CoGenT $ \a -> variant n . f a - -class GVary a where - gvary' :: CoGenT m (a x) - -instance GVary V1 where - gvary' = conquer - -instance GVary U1 where - gvary' = conquer - -instance (GVary a, GVary b) => GVary (a :+: b) where - gvary' = - choose - (\case; L1 a -> Left a; R1 a -> Right a) - (variant' 0 gvary') - (variant' 1 gvary') - -instance (GVary a, GVary b) => GVary (a :*: b) where - gvary' = - divide - (\(a :*: b) -> (a, b)) - (variant' 0 gvary') - (variant' 1 gvary') - -instance GVary c => GVary (M1 a b c) where - gvary' = contramap unM1 gvary' - -instance Vary b => GVary (K1 a b) where - gvary' = contramap unK1 vary - --- | Build a co-generator for a type which has a 'Generic' instance -gvary :: (Generic a, GVary (Rep a)) => CoGenT m a -gvary = CoGenT $ \a -> applyCoGenT gvary' (from a) - --- | 'Vary' provides a canonical co-generator for a type. --- --- While technically there are many possible co-generators for a given type, we don't get any --- benefit from caring. -class Vary a where - vary :: CoGenT m a - default vary :: (Generic a, GVary (Rep a)) => CoGenT m a - vary = gvary - --- | Build a co-generator for an 'Integral' type -varyIntegral :: Integral a => CoGenT m a -varyIntegral = CoGenT $ variant . fromIntegral - --- | --- A @'CoGenT' m a@ is used to perturb a @'GenT' m b@ based on the value of the @a@. This way, --- the generated function will have a varying (but still deterministic) right hand side. --- --- Co-generators can be built using 'Divisible' and 'Decidable', but it is recommended to --- derive 'Generic' and use the default instance of the 'Vary' type class. --- --- @'CoGenT' m ~ 'Data.Functor.Contravariabe.Op' ('Data.Monoid.Endo' ('GenT' m b))@ -newtype CoGenT m a = CoGenT { applyCoGenT :: forall b. a -> GenT m b -> GenT m b } -type CoGen = CoGenT Identity - -instance Contravariant (CoGenT m) where - contramap f (CoGenT g) = CoGenT (g . f) - -instance Divisible (CoGenT m) where - divide f (CoGenT gb) (CoGenT gc) = - CoGenT $ \a -> - let (b, c) = f a in gc c . gb b - conquer = CoGenT $ const id - -instance Decidable (CoGenT m) where - choose f (CoGenT gb) (CoGenT gc) = - CoGenT $ \a -> - case f a of - Left b -> gb b . variant 0 - Right c -> gc c . variant 1 - lose f = CoGenT $ \a -> absurd (f a) - -instance (Show a, Show b) => Show (a :-> b) where - show = show . table - --- | Evaluate a possibly partial function -apply' :: a :-> b -> a -> Maybe b -apply' (Unit c) () = Just c -apply' Nil _ = Nothing -apply' (Pair f) (a, b) = do - f' <- apply' f a - apply' f' b -apply' (Sum f _) (Left a) = apply' f a -apply' (Sum _ g) (Right a) = apply' g a -apply' (Map f _ g) a = apply' g (f a) - --- | Evaluate a total function. Unsafe. -unsafeApply :: a :-> b -> a -> b -unsafeApply f = fromJust . apply' f - --- | The type of randomly-generated functions -data Fn a b = Fn b (a :-> Tree (MaybeT Identity) b) - --- | Extract the root value from a 'Tree'. Unsafe. -unsafeFromTree :: Functor m => Tree (MaybeT m) a -> m a -unsafeFromTree = - fmap (maybe (error "empty generator in function") nodeValue) . - runMaybeT . - runTree - -instance (Show a, Show b) => Show (Fn a b) where - show (Fn b a) = - case table a of - [] -> "_ -> " ++ show b - ta -> showTable ta ++ "_ -> " ++ show b - where - showTable :: (Show a, Show b) => [(a, Tree (MaybeT Identity) b)] -> String - showTable [] = "\n" - showTable (x : xs) = unlines (showCase <$> x : xs) - where - showCase (lhs, rhs) = show lhs ++ " -> " ++ show (runIdentity $ unsafeFromTree rhs) - --- | Shrink the function -shrinkFn :: (b -> [b]) -> a :-> b -> [a :-> b] -shrinkFn shr (Unit a) = Unit <$> shr a -shrinkFn _ Nil = [] -shrinkFn shr (Pair f) = - (\case; Nil -> Nil; a -> Pair a) <$> shrinkFn (shrinkFn shr) f -shrinkFn shr (Sum a b) = - fmap (\case; Sum Nil Nil -> Nil; x -> x) $ - [ Sum a Nil | notNil b ] ++ - [ Sum Nil b | notNil a ] ++ - fmap (`Sum` b) (shrinkFn shr a) ++ - fmap (a `Sum`) (shrinkFn shr b) - where - notNil Nil = False - notNil _ = True -shrinkFn shr (Map f g a) = (\case; Nil -> Nil; x -> Map f g x) <$> shrinkFn shr a - -shrinkTree :: Monad m => Tree (MaybeT m) a -> m [Tree (MaybeT m) a] -shrinkTree (Tree m) = do - a <- runMaybeT m - case a of - Nothing -> pure [] - Just (Node _ cs) -> pure cs - --- | Evaluate an 'Fn' -apply :: Fn a b -> a -> b -apply (Fn b f) = maybe b (runIdentity . unsafeFromTree) . apply' f - --- | Generate a function using the user-supplied co-generator -fnWith :: Arg a => CoGen a -> Gen b -> Gen (Fn a b) -fnWith cg gb = - Fn <$> - gb <*> - genFn (\a -> applyCoGenT cg a gb) - where - genFn :: Arg a => (a -> Gen b) -> Gen (a :-> Tree (MaybeT Identity) b) - genFn g = - GenT $ \sz sd -> - Tree.unfold (shrinkFn $ runIdentity . shrinkTree) . - fmap (runGenT sz sd) $ build g - --- | Generate a function -fn :: (Arg a, Vary a) => Gen b -> Gen (Fn a b) -fn = fnWith vary - --- | Run the function generator to retrieve a function -forAllFn :: (Show a, Show b, Monad m) => Gen (Fn a b) -> PropertyT m (a -> b) -forAllFn = fmap apply . forAll - -instance Vary () -instance (Vary a, Vary b) => Vary (Either a b) -instance (Vary a, Vary b) => Vary (a, b) -instance Vary Void -instance Vary Bool -instance Vary Ordering -instance Vary a => Vary (Maybe a) -instance Vary a => Vary [a] -instance Vary Int8 where; vary = varyIntegral -instance Vary Int16 where; vary = varyIntegral -instance Vary Int32 where; vary = varyIntegral -instance Vary Int64 where; vary = varyIntegral -instance Vary Int where; vary = varyIntegral -instance Vary Integer where; vary = varyIntegral -instance Vary Word8 where; vary = varyIntegral - --- | Reify a function via an isomorphism. --- --- If your function's domain has no instance of 'Generic' then you can still reify it using --- an isomorphism to a better domain type. For example, the 'Arg' instance for 'Integral' --- uses an isomorphism from @Integral a => a@ to @(Bool, [Bool])@, where the first element --- is the sign, and the second element is the bit-string. --- --- Note: @via f g@ will only be well-behaved if @g . f = id@ and @f . g = id@ -via :: Arg b => (a -> b) -> (b -> a) -> (a -> c) -> a :-> c -via a b f = Map a b . build $ f . b - -instance Arg Void where - build _ = Nil - -instance Arg () where - build f = Unit $ f () - -instance (Arg a, Arg b) => Arg (a, b) where - build f = Pair . build $ \a -> build $ \b -> f (a, b) - -instance (Arg a, Arg b) => Arg (Either a b) where - build f = Sum (build $ f . Left) (build $ f . Right) - -gvia :: GArg b => (a -> b x) -> (b x -> a) -> (a -> c) -> a :-> c -gvia a b f = Map a b . gbuild' $ f . b - -instance GArg V1 where - gbuild' _ = Nil - -instance GArg U1 where - gbuild' f = Map (\U1 -> ()) (\() -> U1) (Unit $ f U1) - -instance (GArg a, GArg b) => GArg (a :*: b) where - gbuild' f = Map fromPair toPair $ Pair . gbuild' $ \a -> gbuild' $ \b -> f (a :*: b) - where - fromPair (a :*: b) = (a, b) - toPair (a, b) = (a :*: b) - -instance (GArg a, GArg b) => GArg (a :+: b) where - gbuild' f = Map fromSum toSum $ Sum (gbuild' $ f . L1) (gbuild' $ f . R1) - where - fromSum = \case; L1 a -> Left a; R1 a -> Right a - toSum = either L1 R1 - -instance GArg c => GArg (M1 a b c) where - gbuild' = gvia unM1 M1 - -instance Arg b => GArg (K1 a b) where - gbuild' f = Map unK1 K1 . build $ f . K1 - --- | Reify a function on 'Integral's -buildIntegral :: (Arg a, Integral a) => (a -> c) -> (a :-> c) -buildIntegral = via toBits fromBits - where - toBits :: Integral a => a -> (Bool, [Bool]) - toBits n - | n >= 0 = (True, go n) - | otherwise = (False, go $ -n - 1) - where - go 0 = [] - go m = - let - (q, r) = quotRem m 2 - in - (r == 1) : go q - - fromBits :: Integral a => (Bool, [Bool]) -> a - fromBits (pos, bts) - | pos = go bts - | otherwise = negate $ go bts + 1 - where - go [] = 0 - go (x:xs) = (if x then 1 else 0) + 2 * go xs - -instance Arg Bool -instance Arg Ordering -instance Arg a => Arg (Maybe a) -instance Arg a => Arg [a] -instance Arg Int8 where; build = buildIntegral -instance Arg Int16 where; build = buildIntegral -instance Arg Int32 where; build = buildIntegral -instance Arg Int64 where; build = buildIntegral -instance Arg Int where; build = buildIntegral -instance Arg Integer where; build = buildIntegral - diff --git a/tests/examples/ghc88/Issue91.hs b/tests/examples/ghc88/Issue91.hs deleted file mode 100644 --- a/tests/examples/ghc88/Issue91.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Issue91 where - --- Based on https://github.com/alanz/ghc-exactprint/issues/91 - -foo = case hi of - _ -> hi - _ -> hi - _ -> hi diff --git a/tests/examples/ghc88/StarBinder.hs b/tests/examples/ghc88/StarBinder.hs deleted file mode 100644 --- a/tests/examples/ghc88/StarBinder.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeOperators, TypeFamilies #-} -{-# OPTIONS -Wno-star-is-type #-} - -module X (type (X.*)) where - -type family (*) a b where { (*) a b = Either b a } - diff --git a/tests/examples/ghc88/T12045TH1.hs b/tests/examples/ghc88/T12045TH1.hs deleted file mode 100644 --- a/tests/examples/ghc88/T12045TH1.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds - , TypeInType, TypeApplications, TypeFamilies #-} - -module T12045TH1 where -import Data.Kind -import Language.Haskell.TH hiding (Type) - -$([d| type family F (a :: k) :: Type where - F @Type Int = Bool - F @(Type->Type) Maybe = Char |]) - - -$([d| data family D (a :: k) |]) - -$([d| data instance D @Type a = DBool |]) - -$([d| data instance D @(Type -> Type) b = DChar |]) - diff --git a/tests/examples/ghc88/T12045TH2.hs b/tests/examples/ghc88/T12045TH2.hs deleted file mode 100644 --- a/tests/examples/ghc88/T12045TH2.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeApplications, PolyKinds - , TypeFamilies, DataKinds #-} - -module T12045TH2 where - -import Data.Kind -import Language.Haskell.TH hiding (Type) -import System.IO - -type family Foo (a :: k) :: Type where - Foo @Type a = Bool - -type family Baz (a :: k) -type instance Baz @(Type->Type->Type) a = Char - -$( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1) - [TySynEqn (Just bndrs1) (AppT _ lhs1) rhs1]) - [] <- reify ''Foo - FamilyI baz@(OpenTypeFamilyD (TypeFamilyHead _ tvbs2 res2 m_kind2)) - [inst@(TySynInstD (TySynEqn (Just bndrs2) (AppT _ lhs2) rhs2))] <- reify ''Baz - runIO $ putStrLn $ pprint foo - runIO $ putStrLn $ pprint baz - runIO $ putStrLn $ pprint inst - runIO $ hFlush stdout - return [ ClosedTypeFamilyD - (TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1) - [TySynEqn (Just bndrs1) (AppT (ConT (mkName "Foo'")) lhs1) rhs1] - , OpenTypeFamilyD - (TypeFamilyHead (mkName "Baz'") tvbs2 res2 m_kind2) - , TySynInstD (TySynEqn (Just bndrs2) (AppT (ConT (mkName "Baz'")) lhs2) rhs2)] ) - diff --git a/tests/examples/ghc88/T12045a.hs b/tests/examples/ghc88/T12045a.hs deleted file mode 100644 --- a/tests/examples/ghc88/T12045a.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE PolyKinds, GADTs, TypeApplications, TypeInType, DataKinds, - RankNTypes, ConstraintKinds, TypeFamilies #-} - -module T12045a where - -import Data.Kind -import Data.Typeable - -data T (f :: k -> Type) a = MkT (f a) - -newtype TType f a= MkTType (T @Type f a) - -t1 :: TType Maybe Bool -t1 = MkTType (MkT (Just True)) - -t2 :: TType Maybe a -t2 = MkTType (MkT Nothing) - -data Nat = O | S Nat - -data T1 :: forall k1 k2. k1 -> k2 -> Type where - MkT1 :: T1 a b - -x :: T1 @_ @Nat False n -x = MkT1 - --- test from trac 12045 -type Cat k = k -> k -> Type - -data FreeCat :: Cat k -> Cat k where - Nil :: FreeCat f a a - Cons :: f a b -> FreeCat f b c -> FreeCat f a c - -liftCat :: f a b -> FreeCat f a b -liftCat x = Cons x Nil - -data Node = Unit | N - -data NatGraph :: Cat Node where - One :: NatGraph Unit N - Succ :: NatGraph N N - -one :: (FreeCat @Node NatGraph) Unit N -one = liftCat One - -type Typeable1 = Typeable @(Type -> Type) -type Typeable2 = Typeable @(Type -> Type -> Type) -type Typeable3 = Typeable @(Cat Bool) - -type family F a where - F Type = Type -> Type - F (Type -> Type) = Type - F other = other - -data T2 :: F k -> Type - -foo :: T2 @Type Maybe -> T2 @(Type -> Type) Int -> Type -foo a b = undefined - -data family D (a :: k) -data instance D @Type a = DBool -data instance D @(Type -> Type) b = DChar - -class C a where - tc :: (D a) -> Int - -instance C Int where - tc DBool = 5 - -instance C Bool where - tc DBool = 6 - -instance C Maybe where - tc DChar = 7 - --- Tests from D5229 -data P a = MkP -type MkPTrue = MkP @Bool - -type BoolEmpty = '[] @Bool - -type family F1 (a :: k) :: Type -type G2 (a :: Bool) = F1 @Bool a - diff --git a/tests/examples/ghc88/T13087.hs b/tests/examples/ghc88/T13087.hs deleted file mode 100644 --- a/tests/examples/ghc88/T13087.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE AlternativeLayoutRule #-} -{-# LANGUAGE LambdaCase #-} - -isOne :: Int -> Bool -isOne = \case 1 -> True - _ -> False - -main = return () - diff --git a/tests/examples/ghc88/T15365.hs b/tests/examples/ghc88/T15365.hs deleted file mode 100644 --- a/tests/examples/ghc88/T15365.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T15365 where - -$([d| type (|||) = Either - - (&&&) :: Bool -> Bool -> Bool - (&&&) = (&&) - - type role (***) - data (***) - - class (???) - instance (???) - - data family ($$$) - data instance ($$$) - - type family (^^^) - type instance (^^^) = Int - - type family (###) where - (###) = Int - - pattern (:!!!) :: Bool - pattern (:!!!) = True - |]) - diff --git a/tests/examples/ghc88/T4437.hs b/tests/examples/ghc88/T4437.hs deleted file mode 100644 --- a/tests/examples/ghc88/T4437.hs +++ /dev/null @@ -1,57 +0,0 @@ --- | A test for ensuring that GHC's supporting language extensions remains in --- sync with Cabal's own extension list. --- --- If you have ended up here due to a test failure, please see --- Note [Adding a language extension] in compiler/main/DynFlags.hs. - -module Main (main) where - -import Control.Monad -import Data.List -import DynFlags -import Language.Haskell.Extension - -main :: IO () -main = do - let ghcExtensions = map flagSpecName xFlags - cabalExtensions = map show [ toEnum 0 :: KnownExtension .. ] - ghcOnlyExtensions = ghcExtensions \\ cabalExtensions - cabalOnlyExtensions = cabalExtensions \\ ghcExtensions - check "GHC-only flags" expectedGhcOnlyExtensions ghcOnlyExtensions - check "Cabal-only flags" expectedCabalOnlyExtensions cabalOnlyExtensions - -check :: String -> [String] -> [String] -> IO () -check title expected got - = do let unexpected = got \\ expected - missing = expected \\ got - showProblems problemType problems - = unless (null problems) $ - do putStrLn (title ++ ": " ++ problemType) - putStrLn "-----" - mapM_ putStrLn problems - putStrLn "-----" - putStrLn "" - showProblems "Unexpected flags" unexpected - showProblems "Missing flags" missing - --- See Note [Adding a language extension] in compiler/main/DynFlags.hs. -expectedGhcOnlyExtensions :: [String] -expectedGhcOnlyExtensions = ["RelaxedLayout", - "AlternativeLayoutRule", - "AlternativeLayoutRuleTransitional", - "EmptyDataDeriving", - "GeneralisedNewtypeDeriving"] - -expectedCabalOnlyExtensions :: [String] -expectedCabalOnlyExtensions = ["Generics", - "ExtensibleRecords", - "RestrictedTypeSynonyms", - "HereDocuments", - "NewQualifiedOperators", - "XmlSyntax", - "RegularPatterns", - "SafeImports", - "Safe", - "Unsafe", - "Trustworthy"] - diff --git a/tests/examples/ghc88/TH_recover_warns.hs b/tests/examples/ghc88/TH_recover_warns.hs deleted file mode 100644 --- a/tests/examples/ghc88/TH_recover_warns.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wall #-} -module Bug where - -import Language.Haskell.TH - --- Warnings should be preserved through recover -main :: IO () -main = putStrLn $(recover (stringE "splice failed") - [| let x = "a" in let x = "b" in x |]) - diff --git a/tests/examples/ghc88/TH_recursiveDoImport.hs b/tests/examples/ghc88/TH_recursiveDoImport.hs deleted file mode 100644 --- a/tests/examples/ghc88/TH_recursiveDoImport.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TemplateHaskell #-} -module TH_recursiveDoImport where -import Data.IORef -import Language.Haskell.TH - -data SelfRef = SelfRef (IORef (IORef SelfRef)) - -recIO :: ExpQ -recIO = [e| - do rec r1 <- newIORef r2 - r2 <- newIORef (SelfRef r1) - readIORef r2 |] - -mdoIO :: ExpQ -mdoIO = [e| - mdo r1 <- return r2 - r2 <- return (const 1 r1) - return r1 |] - -emptyRecIO :: ExpQ -emptyRecIO = [e| - do rec {} - return () |] - diff --git a/tests/examples/ghc88/TH_reifyDecl1.hs b/tests/examples/ghc88/TH_reifyDecl1.hs deleted file mode 100644 --- a/tests/examples/ghc88/TH_reifyDecl1.hs +++ /dev/null @@ -1,94 +0,0 @@ --- test reification of data declarations - -{-# LANGUAGE TypeFamilies, TypeApplications, PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} -module TH_reifyDecl1 where - -import Data.Kind as K -import System.IO -import Language.Haskell.TH -import Text.PrettyPrint.HughesPJ - -infixl 3 `m1` - --- simple -data T = A | B - --- parametric -data R a = C a | D - --- recursive -data List a = Nil | Cons a (List a) - --- infix operator -data Tree a = Leaf | Tree a :+: Tree a - --- type declaration -type IntList = [Int] - --- newtype declaration -newtype Length = Length Int - --- simple class -class C1 a where - m1 :: a -> Int - --- class with instances -class C2 a where - m2 :: a -> Int -instance C2 Int where - m2 x = x - --- associated types -class C3 a where - type AT1 a - data AT2 a - -instance C3 Int where - type AT1 Int = Bool - data AT2 Int = AT2Int - --- type family -type family TF1 a - --- type family, with instances -type family TF2 a -type instance TF2 Bool = Bool - --- data family -data family DF1 a - --- data family, with instances -data family DF2 a -data instance DF2 Bool = DBool - -data family DF3 (a :: k) -data instance DF3 @K.Type a = DF3Bool -data instance DF3 @(K.Type -> K.Type) b = DF3Char - -$(return []) - -test :: () -test = $(let - display :: Name -> Q () - display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) } - in do { display ''T - ; display ''R - ; display ''List - ; display ''Tree - ; display ''IntList - ; display ''Length - ; display 'Leaf - ; display 'm1 - ; display ''C1 - ; display ''C2 - ; display ''C3 - ; display ''AT1 - ; display ''AT2 - ; display ''TF1 - ; display ''TF2 - ; display ''DF1 - ; display ''DF2 - ; display ''DF3 - ; [| () |] }) - diff --git a/tests/examples/ghc88/Utils.hs b/tests/examples/ghc88/Utils.hs deleted file mode 100644 --- a/tests/examples/ghc88/Utils.hs +++ /dev/null @@ -1,1056 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Utils --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A large and somewhat miscellaneous collection of utility functions used --- throughout the rest of the Cabal lib and in other tools that use the Cabal --- lib like @cabal-install@. It has a very simple set of logging actions. It --- has low level functions for running programs, a bunch of wrappers for --- various directory and file functions that do extra logging. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Utils ( - -- * logging and errors - die, - dieWithLocation, - topHandler, - warn, notice, info, debug, - debugNoWrap, chattyTry, - - -- * running programs - rawSystemExit, - rawSystemExitCode, - rawSystemExitWithEnv, - rawSystemStdout, - rawSystemStdInOut, - rawSystemIOWithEnv, - maybeExit, - xargs, - findProgramLocation, - - -- * copying files - createDirectoryIfMissingVerbose, - copyFileVerbose, - copyDirectoryRecursiveVerbose, - copyFiles, - - -- * installing files - installOrdinaryFile, - installExecutableFile, - installOrdinaryFiles, - installDirectoryContents, - - -- * File permissions - setFileOrdinary, - setFileExecutable, - - -- * file names - currentDir, - - -- * finding files - findFile, - findFirstFile, - findFileWithExtension, - findFileWithExtension', - - -- * environment variables - isInSearchPath, - - -- * simple file globbing - matchFileGlob, - matchDirFileGlob, - parseFileGlob, - FileGlob(..), - - -- * temp files and dirs - withTempFile, - withTempDirectory, - - -- * .cabal and .buildinfo files - defaultPackageDesc, - findPackageDesc, - defaultHookedPackageDesc, - findHookedPackageDesc, - - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - rewriteFile, - - -- * Unicode - fromUTF8, - toUTF8, - readUTF8File, - withUTF8FileContents, - writeUTF8File, - normaliseLineEndings, - - -- * generic utils - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - wrapText, - wrapLine, - ) where - -import Control.Monad - ( when, unless, filterM ) -import Control.Concurrent.MVar - ( newEmptyMVar, putMVar, takeMVar ) -import Data.List - ( nub, unfoldr, isPrefixOf, tails, intercalate ) -import Data.Char as Char - ( toLower, chr, ord ) -import Data.Bits - ( Bits((.|.), (.&.), shiftL, shiftR) ) -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 - -import System.Directory - ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile - , findExecutable ) -import System.Environment - ( getProgName ) -import System.Cmd - ( rawSystem ) -import System.Exit - ( exitWith, ExitCode(..) ) -import System.FilePath - ( normalise, (), (<.>) - , getSearchPath, takeDirectory, splitFileName - , splitExtension, splitExtensions, splitDirectories ) -import System.Directory - ( createDirectory, renameFile, removeDirectoryRecursive ) -import System.IO - ( Handle, openFile, openBinaryFile, openBinaryTempFile - , IOMode(ReadMode), hSetBinaryMode - , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) -import System.IO.Error as IO.Error - ( isDoesNotExistError, isAlreadyExistsError - , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) -import System.IO.Error - ( ioeSetLocation, ioeGetLocation ) -import System.IO.Unsafe - ( unsafeInterleaveIO ) -import qualified Control.Exception as Exception - -import Distribution.Text - ( display ) - -import Control.Exception (evaluate) -import System.Process (runProcess) - -import Control.Concurrent (forkIO) -import System.Process (runInteractiveProcess, waitForProcess) -#if __GLASGOW_HASKELL__ >= 702 -import System.Process (showCommandForUser) -#endif - -import Distribution.Compat.CopyFile - ( copyFile, copyOrdinaryFile, copyExecutableFile - , setFileOrdinary, setFileExecutable, setDirOrdinary ) -import Distribution.Compat.TempFile - ( openTempFile, createTempDirectory ) -import Distribution.Compat.Exception - ( IOException, throwIOIO, tryIO, catchIO, catchExit ) -import Distribution.Verbosity - --- ---------------------------------------------------------------------------- --- Exception and logging utils - -dieWithLocation :: FilePath -> Maybe Int -> String -> IO a -dieWithLocation filename lineno msg = - ioError . setLocation lineno - . flip ioeSetFileName (normalise filename) - $ userError msg - where - setLocation Nothing err = err - setLocation (Just n) err = ioeSetLocation err (show n) - -die :: String -> IO a -die msg = ioError (userError msg) - -topHandler :: IO a -> IO a -topHandler prog = catchIO prog handle - where - handle ioe = do - hFlush stdout - pname <- getProgName - hPutStr stderr (mesage pname) - exitWith (ExitFailure 1) - where - mesage pname = wrapText (pname ++ ": " ++ file ++ detail) - file = case ioeGetFileName ioe of - Nothing -> "" - Just path -> path ++ location ++ ": " - location = case ioeGetLocation ioe of - l@(n:_) | n >= '0' && n <= '9' -> ':' : l - _ -> "" - detail = ioeGetErrorString ioe - --- | Non fatal conditions that may be indicative of an error or problem. --- --- We display these at the 'normal' verbosity level. --- -warn :: Verbosity -> String -> IO () -warn verbosity msg = - when (verbosity >= normal) $ do - hFlush stdout - hPutStr stderr (wrapText ("Warning: " ++ msg)) - --- | Useful status messages. --- --- We display these at the 'normal' verbosity level. --- --- This is for the ordinary helpful status messages that users see. Just --- enough information to know that things are working but not floods of detail. --- -notice :: Verbosity -> String -> IO () -notice verbosity msg = - when (verbosity >= normal) $ - putStr (wrapText msg) - --- | More detail on the operation of some action. --- --- We display these messages when the verbosity level is 'verbose' --- -info :: Verbosity -> String -> IO () -info verbosity msg = - when (verbosity >= verbose) $ - putStr (wrapText msg) - --- | Detailed internal debugging information --- --- We display these messages when the verbosity level is 'deafening' --- -debug :: Verbosity -> String -> IO () -debug verbosity msg = - when (verbosity >= deafening) $ do - putStr (wrapText msg) - hFlush stdout - --- | A variant of 'debug' that doesn't perform the automatic line --- wrapping. Produces better output in some cases. -debugNoWrap :: Verbosity -> String -> IO () -debugNoWrap verbosity msg = - when (verbosity >= deafening) $ do - putStrLn msg - hFlush stdout - --- | Perform an IO action, catching any IO exceptions and printing an error --- if one occurs. -chattyTry :: String -- ^ a description of the action we were attempting - -> IO () -- ^ the action itself - -> IO () -chattyTry desc action = - catchIO action $ \exception -> - putStrLn $ "Error while " ++ desc ++ ": " ++ show exception - --- ----------------------------------------------------------------------------- --- Helper functions - --- | Wraps text to the default line width. Existing newlines are preserved. -wrapText :: String -> String -wrapText = unlines - . map (intercalate "\n" - . map unwords - . wrapLine 79 - . words) - . lines - --- | Wraps a list of words to a list of lines of words of a particular width. -wrapLine :: Int -> [String] -> [[String]] -wrapLine width = wrap 0 [] - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - --- ----------------------------------------------------------------------------- --- rawSystem variants -maybeExit :: IO ExitCode -> IO () -maybeExit cmd = do - res <- cmd - unless (res == ExitSuccess) $ exitWith res - -printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () -printRawCommandAndArgs verbosity path args - | verbosity >= deafening = print (path, args) - | verbosity >= verbose = -#if __GLASGOW_HASKELL__ >= 702 - putStrLn $ showCommandForUser path args -#else - putStrLn $ unwords (path : args) -#endif - | otherwise = return () - -printRawCommandAndArgsAndEnv :: Verbosity - -> FilePath - -> [String] - -> [(String, String)] - -> IO () -printRawCommandAndArgsAndEnv verbosity path args env - | verbosity >= deafening = do putStrLn ("Environment: " ++ show env) - print (path, args) - | verbosity >= verbose = putStrLn $ unwords (path : args) - | otherwise = return () - --- Exit with the same exitcode if the subcommand fails -rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () -rawSystemExit verbosity path args = do - printRawCommandAndArgs verbosity path args - hFlush stdout - exitcode <- rawSystem path args - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - exitWith exitcode - -rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode -rawSystemExitCode verbosity path args = do - printRawCommandAndArgs verbosity path args - hFlush stdout - exitcode <- rawSystem path args - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - return exitcode - -rawSystemExitWithEnv :: Verbosity - -> FilePath - -> [String] - -> [(String, String)] - -> IO () -rawSystemExitWithEnv verbosity path args env = do - printRawCommandAndArgsAndEnv verbosity path args env - hFlush stdout - ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing - exitcode <- waitForProcess ph - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - exitWith exitcode - --- Closes the passed in handles before returning. -rawSystemIOWithEnv :: Verbosity - -> FilePath - -> [String] - -> [(String, String)] - -> Maybe Handle -- ^ stdin - -> Maybe Handle -- ^ stdout - -> Maybe Handle -- ^ stderr - -> IO ExitCode -rawSystemIOWithEnv verbosity path args env inp out err = do - printRawCommandAndArgsAndEnv verbosity path args env - hFlush stdout - ph <- runProcess path args Nothing (Just env) inp out err - exitcode <- waitForProcess ph - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - return exitcode - --- | Run a command and return its output. --- --- The output is assumed to be text in the locale encoding. --- -rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String -rawSystemStdout verbosity path args = do - (output, errors, exitCode) <- rawSystemStdInOut verbosity path args - Nothing False - when (exitCode /= ExitSuccess) $ - die errors - return output - --- | Run a command and return its output, errors and exit status. Optionally --- also supply some input. Also provides control over whether the binary/text --- mode of the input and output. --- -rawSystemStdInOut :: Verbosity - -> FilePath -> [String] - -> Maybe (String, Bool) -- ^ input text and binary mode - -> Bool -- ^ output in binary mode - -> IO (String, String, ExitCode) -- ^ output, errors, exit -rawSystemStdInOut verbosity path args input outputBinary = do - printRawCommandAndArgs verbosity path args - - Exception.bracket - (runInteractiveProcess path args Nothing Nothing) - (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) - $ \(inh,outh,errh,pid) -> do - - -- output mode depends on what the caller wants - hSetBinaryMode outh outputBinary - -- but the errors are always assumed to be text (in the current locale) - hSetBinaryMode errh False - - -- fork off a couple threads to pull on the stderr and stdout - -- so if the process writes to stderr we do not block. - - err <- hGetContents errh - out <- hGetContents outh - - mv <- newEmptyMVar - let force str = (evaluate (length str) >> return ()) - `Exception.finally` putMVar mv () - --TODO: handle exceptions like text decoding. - _ <- forkIO $ force out - _ <- forkIO $ force err - - -- push all the input, if any - case input of - Nothing -> return () - Just (inputStr, inputBinary) -> do - -- input mode depends on what the caller wants - hSetBinaryMode inh inputBinary - hPutStr inh inputStr - hClose inh - --TODO: this probably fails if the process refuses to consume - -- or if it closes stdin (eg if it exits) - - -- wait for both to finish, in either order - takeMVar mv - takeMVar mv - - -- wait for the program to terminate - exitcode <- waitForProcess pid - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - ++ if null err then "" else - " with error message:\n" ++ err - ++ case input of - Nothing -> "" - Just ("", _) -> "" - Just (inp, _) -> "\nstdin input:\n" ++ inp - - return (out, err, exitcode) - - --- | Look for a program on the path. -findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) -findProgramLocation verbosity prog = do - debug verbosity $ "searching for " ++ prog ++ " in path." - res <- findExecutable prog - case res of - Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") - Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) - return res - - --- | Like the unix xargs program. Useful for when we've got very long command --- lines that might overflow an OS limit on command line length and so you --- need to invoke a command multiple times to get all the args in. --- --- Use it with either of the rawSystem variants above. For example: --- --- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs --- -xargs :: Int -> ([String] -> IO ()) - -> [String] -> [String] -> IO () -xargs maxSize rawSystemFun fixedArgs bigArgs = - let fixedArgSize = sum (map length fixedArgs) + length fixedArgs - chunkSize = maxSize - fixedArgSize - in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) - - where chunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk [] len s) - - chunk acc _ [] = (reverse acc,[]) - chunk acc len (s:ss) - | len' < len = chunk (s:acc) (len-len'-1) ss - | otherwise = (reverse acc, s:ss) - where len' = length s - --- ------------------------------------------------------------ --- * File Utilities --- ------------------------------------------------------------ - ----------------- --- Finding files - --- | Find a file by looking in a search path. The file path must match exactly. --- -findFile :: [FilePath] -- ^search locations - -> FilePath -- ^File Name - -> IO FilePath -findFile searchPath fileName = - findFirstFile id - [ path fileName - | path <- nub searchPath] - >>= maybe (die $ fileName ++ " doesn't exist") return - --- | Find a file by looking in a search path with one of a list of possible --- file extensions. The file base name should be given and it will be tried --- with each of the extensions in each element of the search path. --- -findFileWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) -findFileWithExtension extensions searchPath baseName = - findFirstFile id - [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | Like 'findFileWithExtension' but returns which element of the search path --- the file was found in, and the file path relative to that base directory. --- -findFileWithExtension' :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe (FilePath, FilePath)) -findFileWithExtension' extensions searchPath baseName = - findFirstFile (uncurry ()) - [ (path, baseName <.> ext) - | path <- nub searchPath - , ext <- nub extensions ] - -findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) -findFirstFile file = findFirst - where findFirst [] = return Nothing - findFirst (x:xs) = do exists <- doesFileExist (file x) - if exists - then return (Just x) - else findFirst xs - - --- | List all the files in a directory and all subdirectories. --- --- The order places files in sub-directories after all the files in their --- parent directories. The list is generated lazily so is not well defined if --- the source directory structure changes before the list is used. --- -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive topdir = recurseDirectories [""] - where - recurseDirectories :: [FilePath] -> IO [FilePath] - recurseDirectories [] = return [] - recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) - files' <- recurseDirectories (dirs' ++ dirs) - return (files ++ files') - - where - collect files dirs' [] = return (reverse files, reverse dirs') - collect files dirs' (entry:entries) | ignore entry - = collect files dirs' entries - collect files dirs' (entry:entries) = do - let dirEntry = dir entry - isDirectory <- doesDirectoryExist (topdir dirEntry) - if isDirectory - then collect files (dirEntry:dirs') entries - else collect (dirEntry:files) dirs' entries - - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False - ------------------------- --- Environment variables - --- | Is this directory in the system search path? -isInSearchPath :: FilePath -> IO Bool -isInSearchPath path = fmap (elem path) getSearchPath - ----------------- --- File globbing - -data FileGlob - -- | No glob at all, just an ordinary file - = NoGlob FilePath - - -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to - -- @FileGlob \"foo\/bar\" \".baz\"@ - | FileGlob FilePath String - -parseFileGlob :: FilePath -> Maybe FileGlob -parseFileGlob filepath = case splitExtensions filepath of - (filepath', ext) -> case splitFileName filepath' of - (dir, "*") | '*' `elem` dir - || '*' `elem` ext - || null ext -> Nothing - | null dir -> Just (FileGlob "." ext) - | otherwise -> Just (FileGlob dir ext) - _ | '*' `elem` filepath -> Nothing - | otherwise -> Just (NoGlob filepath) - -matchFileGlob :: FilePath -> IO [FilePath] -matchFileGlob = matchDirFileGlob "." - -matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath] -matchDirFileGlob dir filepath = case parseFileGlob filepath of - Nothing -> die $ "invalid file glob '" ++ filepath - ++ "'. Wildcards '*' are only allowed in place of the file" - ++ " name, not in the directory name or file extension." - ++ " If a wildcard is used it must be with an file extension." - Just (NoGlob filepath') -> return [filepath'] - Just (FileGlob dir' ext) -> do - files <- getDirectoryContents (dir dir') - case [ dir' file - | file <- files - , let (name, ext') = splitExtensions file - , not (null name) && ext' == ext ] of - [] -> die $ "filepath wildcard '" ++ filepath - ++ "' does not match any files." - matches -> return matches - ----------------------------------------- --- Copying and installing files and dirs - --- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. --- -createDirectoryIfMissingVerbose :: Verbosity - -> Bool -- ^ Create its parents too? - -> FilePath - -> IO () -createDirectoryIfMissingVerbose verbosity create_parents path0 - | create_parents = createDirs (parents path0) - | otherwise = createDirs (take 1 (parents path0)) - where - parents = reverse . scanl1 () . splitDirectories . normalise - - createDirs [] = return () - createDirs (dir:[]) = createDir dir throwIOIO - createDirs (dir:dirs) = - createDir dir $ \_ -> do - createDirs dirs - createDir dir throwIOIO - - createDir :: FilePath -> (IOException -> IO ()) -> IO () - createDir dir notExistHandler = do - r <- tryIO $ createDirectoryVerbose verbosity dir - case (r :: Either IOException ()) of - Right () -> return () - Left e - | isDoesNotExistError e -> notExistHandler e - -- createDirectory (and indeed POSIX mkdir) does not distinguish - -- between a dir already existing and a file already existing. So we - -- check for it here. Unfortunately there is a slight race condition - -- here, but we think it is benign. It could report an exeption in - -- the case that the dir did exist but another process deletes the - -- directory and creates a file in its place before we can check - -- that the directory did indeed exist. - | isAlreadyExistsError e -> (do - isDir <- doesDirectoryExist dir - if isDir then return () - else throwIOIO e - ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) - | otherwise -> throwIOIO e - -createDirectoryVerbose :: Verbosity -> FilePath -> IO () -createDirectoryVerbose verbosity dir = do - info verbosity $ "creating " ++ dir - createDirectory dir - setDirOrdinary dir - --- | Copies a file without copying file permissions. The target file is created --- with default permissions. Any existing target file is replaced. --- --- At higher verbosity levels it logs an info message. --- -copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () -copyFileVerbose verbosity src dest = do - info verbosity ("copy " ++ src ++ " to " ++ dest) - copyFile src dest - --- | Install an ordinary file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" --- while on Windows it uses the default permissions for the target directory. --- -installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () -installOrdinaryFile verbosity src dest = do - info verbosity ("Installing " ++ src ++ " to " ++ dest) - copyOrdinaryFile src dest - --- | Install an executable file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" --- while on Windows it uses the default permissions for the target directory. --- -installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () -installExecutableFile verbosity src dest = do - info verbosity ("Installing executable " ++ src ++ " to " ++ dest) - copyExecutableFile src dest - --- | Copies a bunch of files to a target directory, preserving the directory --- structure in the target location. The target directories are created if they --- do not exist. --- --- The files are identified by a pair of base directory and a path relative to --- that base. It is only the relative part that is preserved in the --- destination. --- --- For example: --- --- > copyFiles normal "dist/src" --- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] --- --- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and --- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". --- --- This operation is not atomic. Any IO failure during the copy (including any --- missing source files) leaves the target in an unknown state so it is best to --- use it with a freshly created directory so that it can be simply deleted if --- anything goes wrong. --- -copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -copyFiles verbosity targetDir srcFiles = do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles - mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in copyFileVerbose verbosity src dest - | (srcBase, srcFile) <- srcFiles ] - --- | This is like 'copyFiles' but uses 'installOrdinaryFile'. --- -installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -installOrdinaryFiles verbosity targetDir srcFiles = do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles - mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in installOrdinaryFile verbosity src dest - | (srcBase, srcFile) <- srcFiles ] - --- | This installs all the files in a directory to a target location, --- preserving the directory layout. All the files are assumed to be ordinary --- rather than executable files. --- -installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () -installDirectoryContents verbosity srcDir destDir = do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] - ---------------------------------- --- Deprecated file copy functions - -{-# DEPRECATED copyDirectoryRecursiveVerbose - "You probably want installDirectoryContents instead" #-} -copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () -copyDirectoryRecursiveVerbose verbosity srcDir destDir = do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] - ---------------------------- --- Temporary files and dirs - --- | Use a temporary filename that doesn't already exist. --- -withTempFile :: Bool -- ^ Keep temporary files? - -> FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a -withTempFile keepTempFiles tmpDir template action = - Exception.bracket - (openTempFile tmpDir template) - (\(name, handle) -> do hClose handle - unless keepTempFiles $ removeFile name) - (uncurry action) - --- | Create and use a temporary directory. --- --- Creates a new temporary directory inside the given directory, making use --- of the template. The temp directory is deleted after use. For example: --- --- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... --- --- The @tmpDir@ will be a new subdirectory of the given directory, e.g. --- @src/sdist.342@. --- -withTempDirectory :: Verbosity - -> Bool -- ^ Keep temporary files? - -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectory _verbosity keepTempFiles targetDir template = - Exception.bracket - (createTempDirectory targetDir template) - (unless keepTempFiles . removeDirectoryRecursive) - ------------------------------------ --- Safely reading and writing files - --- | Gets the contents of a file, but guarantee that it gets closed. --- --- The file is read lazily but if it is not fully consumed by the action then --- the remaining input is truncated and the file is closed. --- -withFileContents :: FilePath -> (String -> IO a) -> IO a -withFileContents name action = - Exception.bracket (openFile name ReadMode) hClose - (\hnd -> hGetContents hnd >>= action) - --- | Writes a file atomically. --- --- The file is either written sucessfully or an IO exception is raised and --- the original file is left unchanged. --- --- On windows it is not possible to delete a file that is open by a process. --- This case will give an IO exception but the atomic property is not affected. --- -writeFileAtomic :: FilePath -> BS.ByteString -> IO () -writeFileAtomic targetPath content = do - let (targetDir, targetFile) = splitFileName targetPath - Exception.bracketOnError - (openBinaryTempFile targetDir $ targetFile <.> "tmp") - (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) - (\(tmpPath, handle) -> do - BS.hPut handle content - hClose handle - renameFile tmpPath targetPath) - --- | Write a file but only if it would have new content. If we would be writing --- the same as the existing content then leave the file as is so that we do not --- update the file's modification time. --- -rewriteFile :: FilePath -> String -> IO () -rewriteFile path newContent = - flip catchIO mightNotExist $ do - existingContent <- readFile path - _ <- evaluate (length existingContent) - unless (existingContent == newContent) $ - writeFileAtomic path (BS.Char8.pack newContent) - where - mightNotExist e | isDoesNotExistError e = writeFileAtomic path - (BS.Char8.pack newContent) - | otherwise = ioError e - --- | The path name that represents the current directory. --- In Unix, it's @\".\"@, but this is system-specific. --- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) -currentDir :: FilePath -currentDir = "." - --- ------------------------------------------------------------ --- * Finding the description file --- ------------------------------------------------------------ - --- |Package description file (/pkgname/@.cabal@) -defaultPackageDesc :: Verbosity -> IO FilePath -defaultPackageDesc _verbosity = findPackageDesc currentDir - --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. -findPackageDesc :: FilePath -- ^Where to look - -> IO FilePath -- ^.cabal -findPackageDesc dir - = do files <- getDirectoryContents dir - -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal - -- file we filter to exclude dirs and null base file names: - cabalFiles <- filterM doesFileExist - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case cabalFiles of - [] -> noDesc - [cabalFile] -> return cabalFile - multiple -> multiDesc multiple - - where - noDesc :: IO a - noDesc = die $ "No cabal file found.\n" - ++ "Please create a package description file .cabal" - - multiDesc :: [String] -> IO a - multiDesc l = die $ "Multiple cabal files found.\n" - ++ "Please use only one of: " - ++ intercalate ", " l - --- |Optional auxiliary package information file (/pkgname/@.buildinfo@) -defaultHookedPackageDesc :: IO (Maybe FilePath) -defaultHookedPackageDesc = findHookedPackageDesc currentDir - --- |Find auxiliary package information in the given directory. --- Looks for @.buildinfo@ files. -findHookedPackageDesc - :: FilePath -- ^Directory to search - -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present -findHookedPackageDesc dir = do - files <- getDirectoryContents dir - buildInfoFiles <- filterM doesFileExist - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == buildInfoExt ] - case buildInfoFiles of - [] -> return Nothing - [f] -> return (Just f) - _ -> die ("Multiple files with extension " ++ buildInfoExt) - -buildInfoExt :: String -buildInfoExt = ".buildinfo" - --- ------------------------------------------------------------ --- * Unicode stuff --- ------------------------------------------------------------ - --- This is a modification of the UTF8 code from gtk2hs and the --- utf8-string package. - -fromUTF8 :: String -> String -fromUTF8 [] = [] -fromUTF8 (c:cs) - | c <= '\x7F' = c : fromUTF8 cs - | c <= '\xBF' = replacementChar : fromUTF8 cs - | c <= '\xDF' = twoBytes c cs - | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) - | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) - | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) - | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) - | otherwise = replacementChar : fromUTF8 cs - where - twoBytes c0 (c1:cs') - | ord c1 .&. 0xC0 == 0x80 - = let d = ((ord c0 .&. 0x1F) `shiftL` 6) - .|. (ord c1 .&. 0x3F) - in if d >= 0x80 - then chr d : fromUTF8 cs' - else replacementChar : fromUTF8 cs' - twoBytes _ cs' = replacementChar : fromUTF8 cs' - - moreBytes :: Int -> Int -> [Char] -> Int -> [Char] - moreBytes 1 overlong cs' acc - | overlong <= acc && acc <= 0x10FFFF - && (acc < 0xD800 || 0xDFFF < acc) - && (acc < 0xFFFE || 0xFFFF < acc) - = chr acc : fromUTF8 cs' - - | otherwise - = replacementChar : fromUTF8 cs' - - moreBytes byteCount overlong (cn:cs') acc - | ord cn .&. 0xC0 == 0x80 - = moreBytes (byteCount-1) overlong cs' - ((acc `shiftL` 6) .|. ord cn .&. 0x3F) - - moreBytes _ _ cs' _ - = replacementChar : fromUTF8 cs' - - replacementChar = '\xfffd' - -toUTF8 :: String -> String -toUTF8 [] = [] -toUTF8 (c:cs) - | c <= '\x07F' = c - : toUTF8 cs - | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) - : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - | otherwise = chr (0xf0 .|. (w `shiftR` 18)) - : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) - : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - where w = ord c - --- | Ignore a Unicode byte order mark (BOM) at the beginning of the input --- -ignoreBOM :: String -> String -ignoreBOM ('\xFEFF':string) = string -ignoreBOM string = string - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Reads lazily using ordinary 'readFile'. --- -readUTF8File :: FilePath -> IO String -readUTF8File f = fmap (ignoreBOM . fromUTF8) - . hGetContents =<< openBinaryFile f ReadMode - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Same behaviour as 'withFileContents'. --- -withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a -withUTF8FileContents name action = - Exception.bracket - (openBinaryFile name ReadMode) - hClose - (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8) - --- | Writes a Unicode String as a UTF8 encoded text file. --- --- Uses 'writeFileAtomic', so provides the same guarantees. --- -writeUTF8File :: FilePath -> String -> IO () -writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8 - --- | Fix different systems silly line ending conventions -normaliseLineEndings :: String -> String -normaliseLineEndings [] = [] -normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows -normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx -normaliseLineEndings ( c :s) = c : normaliseLineEndings s - --- ------------------------------------------------------------ --- * Common utils --- ------------------------------------------------------------ - -equating :: Eq a => (b -> a) -> b -> b -> Bool -equating p x y = p x == p y - -comparing :: Ord a => (b -> a) -> b -> b -> Ordering -comparing p x y = p x `compare` p y - -isInfixOf :: String -> String -> Bool -isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) - -lowercase :: String -> String -lowercase = map Char.toLower - diff --git a/tests/examples/ghc88/empty-foralls2.hs b/tests/examples/ghc88/empty-foralls2.hs deleted file mode 100644 --- a/tests/examples/ghc88/empty-foralls2.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} --- Empty foralls are handled correctly in different situations. - -data D = forall. D Int - -data G where - G :: forall. Int -> G - -f :: forall. a -> a -f x = x - -type family T x where - forall. T x = x - -{-# RULES - "r" - forall. r a = () -#-} diff --git a/tests/examples/ghc88/hie010.hs b/tests/examples/ghc88/hie010.hs deleted file mode 100644 --- a/tests/examples/ghc88/hie010.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DataKinds #-} -module MoreExplicitForalls where - -import Data.Proxy - -data family F1 a -data instance forall (x :: Bool). F1 (Proxy x) = MkF - -class C a where - type F2 a b - -instance forall a. C [a] where - type forall b. F2 [a] b = Int - - -type family G a b where - forall x y. G [x] (Proxy y) = Double - forall z. G z z = Bool - diff --git a/tests/examples/ghc90/Arity2.hs b/tests/examples/ghc90/Arity2.hs deleted file mode 100644 --- a/tests/examples/ghc90/Arity2.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Arity2 where -{- -inplace/bin/ghc-stage1 -O2 -dcore-lint --} - ---import GHC.Base - -data Id a = Id a - -(<$>) :: (a -> b) -> Id a -> Id b -(<$>) f (Id a) = Id (f a) - -(<*>) :: Id (a -> b) -> Id a -> Id b -(<*>) (Id a) (Id b) = Id (a b) - -data Q = Q () () -data S = S () - --- Q only gets eta-expand once and then trapped -foo = Q <$> Id () <*> Id () - --- This compiles fine -foo2 = S <$> Id () - -{- -[1 of 1] Compiling Arity2 ( linear-tests/Arity2.hs, linear-tests/Arity2.o ) - -linear-tests/Arity2.hs:21:7: error: - • Couldn't match type ‘() ⊸ Q’ with ‘() -> b’ - Expected type: Id (() -> b) - Actual type: Id (() ⊸ Q) - • In the first argument of ‘(<*>)’, namely ‘Q <$> Id ()’ - In the expression: Q <$> Id () <*> Id () - In an equation for ‘foo’: foo = Q <$> Id () <*> Id () - • Relevant bindings include - foo :: Id b (bound at linear-tests/Arity2.hs:21:1) - | -21 | foo = Q <$> Id () <*> Id () - | ^^^^^^^^^^^ --} diff --git a/tests/examples/ghc90/ArrowLambdaCase.hs b/tests/examples/ghc90/ArrowLambdaCase.hs deleted file mode 100644 --- a/tests/examples/ghc90/ArrowLambdaCase.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE Arrows, LambdaCase #-} -module Main (main) where - -import Control.Arrow - -main :: IO () -main = do - putStrLn $ foo (Just 42) - putStrLn $ foo (Just 500) - putStrLn $ foo Nothing - -foo :: ArrowChoice p => p (Maybe Int) String -foo = proc x -> - (| id (\case - Just x | x > 100 -> returnA -< "big " ++ show x - | otherwise -> returnA -< "small " ++ show x - Nothing -> returnA -< "none") - |) x - diff --git a/tests/examples/ghc90/BaseDescriptor.hs b/tests/examples/ghc90/BaseDescriptor.hs deleted file mode 100644 --- a/tests/examples/ghc90/BaseDescriptor.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.ByteString.Mp4.Boxes.BaseDescriptor where - -import Data.ByteString.IsoBaseFileFormat.ReExports -import Data.ByteString.Mp4.Boxes.Expandable - --- * Static base constructor - --- | Abstract class of /descriptors/ as recognized by ISO/IEC 14496-1 (Systems). --- A specifc descriptor is identified by the 'ClassTag'. -data Descriptor :: ClassTag n -> Type where - MkDescriptor ::BitRecord -> Descriptor tag - --- TODO ok... this fixed the current problem in DecoderSpecificInfo .. but remove this instances ... or the above ... or ... I dunno - -data BitRecordOfDescriptor :: Extends (Descriptor c -> BitRecord) - -type instance - Apply BitRecordOfDescriptor ('MkDescriptor body :: Descriptor (tag :: ClassTag tagInd)) = - FieldU8 := tagInd - .+: From (StaticExpandableContent body) - -type family GetClassTag (c :: ClassTag n) :: Nat where - GetClassTag (c :: ClassTag n) = n - --- | Base Descriptor Class Tags TODO rename to xxxTag -data ClassTag (tag :: Nat) where - ObjectDescr ::ClassTag 0x01 - InitialObjectDescr ::ClassTag 0x02 - ES_Descr ::ClassTag 0x03 - DecoderConfigDescr ::ClassTag 0x04 - DecSpecificInfo ::ClassTag 0x05 - SLConfigDescr ::ClassTag 0x06 - ContentIdentDescr ::ClassTag 0x07 - SupplContentIdentDescr ::ClassTag 0x08 - IPI_DescrPointer ::ClassTag 0x09 - IPMP_DescrPointer ::ClassTag 0x0A - IPMP_Descr ::ClassTag 0x0B - QoS_Descr ::ClassTag 0x0C - RegistrationDescr ::ClassTag 0x0D - ES_ID_Ref ::ClassTag 0x0F - MP4_IOD_ ::ClassTag 0x10 - MP4_OD_ ::ClassTag 0x11 - IPL_DescrPointerRef ::ClassTag 0x12 - ExtensionProfileLevelDescr ::ClassTag 0x13 - ProfileLevelIndicationIndexDescr ::ClassTag 0x14 - ContentClassificationDescr ::ClassTag 0x40 - KeyWordDescr ::ClassTag 0x41 - RatingDescr ::ClassTag 0x42 - LanguageDescr ::ClassTag 0x43 - ShortTextualDescr ::ClassTag 0x44 - ExpandedTextualDescr ::ClassTag 0x45 - ContentCreatorNameDescr ::ClassTag 0x46 - ContentCreationDateDescr ::ClassTag 0x47 - OCICreatorNameDescr ::ClassTag 0x48 - OCICreationDateDescr ::ClassTag 0x49 - SmpteCameraPositionDescr ::ClassTag 0x4A - SegmentDescr ::ClassTag 0x4B - MediaTimeDescr ::ClassTag 0x4C - IPMP_ToolsListDescr ::ClassTag 0x60 - IPMP_Tool ::ClassTag 0x61 - M4MuxTimingDescr ::ClassTag 0x62 - M4MuxCodeTableDescr ::ClassTag 0x63 - ExtSLConfigDescr ::ClassTag 0x64 - M4MuxBufferSizeDescr ::ClassTag 0x65 - M4MuxIdentDescr ::ClassTag 0x66 - DependencyPointer ::ClassTag 0x67 - DependencyMarker ::ClassTag 0x68 - M4MuxChannelDescr ::ClassTag 0x69 - ExtDescrTag :: (forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n) - OCIDescrTag :: (forall (n :: Nat) . (0x40 <= n, n <= 0x5F) => ClassTag n) diff --git a/tests/examples/ghc90/BaseDescriptor2.hs b/tests/examples/ghc90/BaseDescriptor2.hs deleted file mode 100644 --- a/tests/examples/ghc90/BaseDescriptor2.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -module BaseDescriptors2 where - -data ClassTag (tag :: Nat) where - ExtDescrTag :: (forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n) - -data ClassTag2 (tag :: Nat) where - ExtDescrTag2 :: forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n diff --git a/tests/examples/ghc90/Branches.hs b/tests/examples/ghc90/Branches.hs deleted file mode 100644 --- a/tests/examples/ghc90/Branches.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -module GuardTup where - -data Q = Q () - -mkQ :: () -> Q -mkQ = Q - -foo smart - | smart = mkQ - | otherwise = Q - -fooIf smart = if smart then mkQ else Q diff --git a/tests/examples/ghc90/CSETest.hs b/tests/examples/ghc90/CSETest.hs deleted file mode 100644 --- a/tests/examples/ghc90/CSETest.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE UnicodeSyntax #-} -{- This test makes sure that if two expressions with conflicting types are - CSEd then appropiate things happen. -} -module CSETest where - -minimal :: a ⊸ a -minimal x = x - -maximal :: a -> a -maximal x = x - diff --git a/tests/examples/ghc90/Dollar2.hs b/tests/examples/ghc90/Dollar2.hs deleted file mode 100644 --- a/tests/examples/ghc90/Dollar2.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Dollar2 where -{- -inplace/bin/ghc-stage1 -O2 -dcore-lint --} - - -import GHC.Base - -data AB = A () | B () - -qux :: Bool -qux = True -{-# NOINLINE qux #-} - -foo = id $ ((if qux then A else B) $ ()) - -{- - --} diff --git a/tests/examples/ghc90/DollarDefault.hs b/tests/examples/ghc90/DollarDefault.hs deleted file mode 100644 --- a/tests/examples/ghc90/DollarDefault.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -module DollarDefault where - -class C p where - cid :: p a a -> p a a - -instance C (->) where - cid = id - -foo = (cid $ id) $ () diff --git a/tests/examples/ghc90/DollarTest.hs b/tests/examples/ghc90/DollarTest.hs deleted file mode 100644 --- a/tests/examples/ghc90/DollarTest.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE UnicodeSyntax #-} -module Dollar where -{- -Check $ interacting with multiplicity polymorphism. -This caused Core Lint error previously. --} - -import GHC.Base - -data Q a = Q a - -data QU = QU () - -test = QU $ () - -qux = Q $ () diff --git a/tests/examples/ghc90/ExplicitSpecificity4.hs b/tests/examples/ghc90/ExplicitSpecificity4.hs deleted file mode 100644 --- a/tests/examples/ghc90/ExplicitSpecificity4.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module ExplicitSpecificity4 where - -class C a where - f :: forall {z}. z -> a -> a - default f :: forall {z}. z -> a -> a - f _ x = x - - g :: forall z. z -> a -> a - g _ x = x diff --git a/tests/examples/ghc90/ExplicitSpecificityA1.hs b/tests/examples/ghc90/ExplicitSpecificityA1.hs deleted file mode 100644 --- a/tests/examples/ghc90/ExplicitSpecificityA1.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE RankNTypes - , PolyKinds - , GADTs - , TypeApplications - , PatternSynonyms - , ExistentialQuantification - , StandaloneKindSignatures - , DataKinds - , ExistentialQuantification -#-} - -module ExplicitSpecificityA1 where - -import Data.Proxy -import Data.Kind - --- Type variables bound in RULES -{-# RULES "parametricity" forall (f :: forall {a}. a -> a). map f = id #-} - --- Type signatures -foo1 :: a -> a -foo1 x = x - -foo2 :: forall a. a -> a -foo2 x = x - -foo3 :: forall {a}. a -> a -foo3 x = x - -foo4 :: forall a {b}. a -> b -> b -foo4 _ x = x - -foo5 :: forall {a} b. a -> b -> b -foo5 _ x = x - -bar1 :: () -bar1 = let { x1 = foo1 42 - ; x2 = foo2 @Int 42 - ; x3 = foo3 42 - ; x4 = foo4 @Bool True 42 - ; x5 = foo5 @Int True 42 - } - in () - --- Data declarations -data T1 a = C1 a - -data T2 (a :: k) = C2 { f2 :: Proxy a } - -data T3 a where C3 :: forall k (a::k). Proxy a -> T3 a - -data T4 a where C4 :: forall {k} (a::k). Proxy a -> T4 a - -data T5 k (a :: k) where C5 :: forall k (a::k). Proxy a -> T5 k a - -data T6 k a where C6 :: forall {k} (a::k). Proxy a -> T6 k a - -bar2 :: () -bar2 = let { x1 = C1 @Int 42 - ; x2 = C2 @Type @Int Proxy - ; x3 = C3 @Type @Int Proxy - ; x4 = C4 @Int Proxy - ; x5 = C5 @Type @Int Proxy - ; x6 = C6 @Int Proxy - } - in () - --- Pattern synonyms -data T7 a where C7 :: forall a b. a -> b -> T7 a - -data T8 a where C8 :: forall a {b}. a -> b -> T8 a - -pattern Pat1 :: forall a. () => forall b. a -> b -> T7 a -pattern Pat1 x y = C7 x y - -pattern Pat2 :: forall {a}. () => forall b. a -> b -> T7 a -pattern Pat2 x y = C7 x y - -pattern Pat3 :: forall a. () => forall b. a -> b -> T8 a -pattern Pat3 x y = C8 x y - -pattern Pat4 :: forall {a}. () => forall b. a -> b -> T8 a -pattern Pat4 x y = C8 x y - -pattern Pat5 :: forall {a}. () => forall {b}. a -> b -> T7 a -pattern Pat5 x y = C7 x y - -bar3 :: (T7 a) -> () -bar3 (Pat1 x y) = () -bar3 (Pat2 x y) = () - -bar4 :: (T8 a) -> () -bar4 (Pat3 x y) = () -bar4 (Pat4 x y) = () - --- Existential variable quantification -data HList = HNil - | forall {a}. HCons a HList - --- Type synonyms -type TySy = forall a {b}. Either a b - --- Standalone kind signatures -type Foo :: forall a {b}. a -> b -> b -type Foo x y = y - -type Bar = Foo @Bool True 42 - diff --git a/tests/examples/ghc90/FromManual.hs b/tests/examples/ghc90/FromManual.hs deleted file mode 100644 --- a/tests/examples/ghc90/FromManual.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE UnicodeSyntax #-} - -module FromManual where - -data T1 a = MkT1 a - -construct :: a %1 -> MkT1 a -construct x = MkT1 x - -deconstruct :: MkT1 a %1 -> a -deconstruct (MkT1 x) = x -- must consume `x` exactly once - -data T2 a b c where - MkT2 :: a -> b %1 -> c %1 -> T2 a b -- Note unrestricted arrow in the first argument - -data T3 a b c where - MkT3 :: a -> b ⊸ c ⊸ T2 a b -- Note unrestricted arrow in the first argument - -g :: A %1 -> (A, B) -h :: A %1 -> B %1 -> C - -f :: A %1 -> C -f x = f' (g x) - where - f' :: (A, B) %1 -> C - f' (y, z) = h y z diff --git a/tests/examples/ghc90/Linear.hs b/tests/examples/ghc90/Linear.hs deleted file mode 100644 --- a/tests/examples/ghc90/Linear.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LinearTypes #-} -module Monad.Linear where - -import Prelude(Int, (+)) - -data T where T :: Int -> T -data TM a = TM a - -class Monad m where - return :: a #-> m a - (>>=) :: m a #-> (a #-> m b) #-> m b - -(>>) :: Monad m => m () #-> m b #-> m b -m1 >> m2 = m1 >>= \() -> m2 - -instance Monad TM where - return = TM - TM a >>= f = f a - -data Unrestricted a where - Unrestricted :: a -> Unrestricted a - -runTM :: TM (Unrestricted a) -> a -runTM (TM (Unrestricted a)) = a - -newT :: TM T -newT = return (T 0) - -increaseT :: T #-> TM T -increaseT (T i) = return (T (i+1)) - -extractT :: T #-> TM (T, Unrestricted Int) -extractT (T i) = return (T i, Unrestricted i) - -deleteT :: T #-> TM () -deleteT (T _) = return () - diff --git a/tests/examples/ghc90/Linear10.hs b/tests/examples/ghc90/Linear10.hs deleted file mode 100644 --- a/tests/examples/ghc90/Linear10.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE GADTs #-} -module Linear10 where - -data Unrestricted a where Unrestricted :: a -> Unrestricted a - -unrestrictedDup :: Unrestricted a ⊸ (a, a) -unrestrictedDup (Unrestricted a) = (a,a) - diff --git a/tests/examples/ghc90/Linear12.hs b/tests/examples/ghc90/Linear12.hs deleted file mode 100644 --- a/tests/examples/ghc90/Linear12.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE GADTs #-} -module Linear12 where - -type N a = a ⊸ () - -consume :: a ⊸ N a ⊸ () -consume x k = k x - -data N' a where N :: N a ⊸ N' a - -data M' a where M :: M a -> M' a - -consume' :: a ⊸ N' a ⊸ () -consume' x (N k) = k x - -data W = W (W ⊸ ()) - -wPlusTwo :: W ⊸ W -wPlusTwo n = W (\(W k) -> k n) - -data Nat = S Nat - -natPlusOne :: Nat ⊸ Nat -natPlusOne n = S n - -data D = D () - -mkD :: () ⊸ D -mkD x = D x - -data Odd = E Even -data Even = O Odd - -evenPlusOne :: Even ⊸ Odd -evenPlusOne e = E e - diff --git a/tests/examples/ghc90/Linear14.hs b/tests/examples/ghc90/Linear14.hs deleted file mode 100644 --- a/tests/examples/ghc90/Linear14.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -module Linear14 where - --- Inference-related behaviour. Slightly sub-optimal still. - -bind1 :: (d ⊸ (a ⊸ b) ⊸ c) ⊸ d ⊸ (a⊸b) ⊸ c -bind1 b x f = b x (\a -> f a) - -newtype I a = I a - -bind2 :: (d ⊸ (a ⊸ b) ⊸ c) ⊸ d ⊸ (I a⊸b) ⊸ c -bind2 b x f = b x (\a -> f (I a)) - -bind3 :: (d ⊸ I (a ⊸ b) ⊸ c) ⊸ d ⊸ (a⊸b) ⊸ c -bind3 b x f = b x (I (\a -> f a)) - -bind4 :: (d ⊸ I ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c -bind4 b x f = b x (I (\g -> f g)) - -bind5 :: (d ⊸ ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c -bind5 b x f = b x (\g -> f (\a -> g a)) - -bind6 :: (d ⊸ I ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c -bind6 b x f = b x (I (\g -> f (\a -> g a))) - diff --git a/tests/examples/ghc90/Linear15.hs b/tests/examples/ghc90/Linear15.hs deleted file mode 100644 --- a/tests/examples/ghc90/Linear15.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -module Linear15 where - -correctWhere :: Int ⊸ Int -correctWhere a = g a - where - f :: Int ⊸ Int - f x = x - - g :: Int ⊸ Int - g x = f x - diff --git a/tests/examples/ghc90/Linear16.hs b/tests/examples/ghc90/Linear16.hs deleted file mode 100644 --- a/tests/examples/ghc90/Linear16.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE RebindableSyntax #-} -module Linear16 where - --- Rebindable do notation - -(>>=) :: a ⊸ (a ⊸ b) ⊸ b -(>>=) x f = f x - --- `fail` is needed due to pattern matching on (); --- ideally, it shouldn't be there. -fail :: a -fail = fail - -correctDo = do - x <- () - (y,z) <- ((),x) - () <- y - () <- z - () - diff --git a/tests/examples/ghc90/Linear1Rule.hs b/tests/examples/ghc90/Linear1Rule.hs deleted file mode 100644 --- a/tests/examples/ghc90/Linear1Rule.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -module Linear1Rule where - --- Test the 1 <= p rule -f :: a %1 -> b -f = f - --- f1 :: a %001 -> b --- f1 = f1 - -g :: a %p -> b -g x = f x - diff --git a/tests/examples/ghc90/Linear3.hs b/tests/examples/ghc90/Linear3.hs deleted file mode 100644 --- a/tests/examples/ghc90/Linear3.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -module Linear3 where - -correctApp1 :: (a⊸b) ⊸ a ⊸ b -correctApp1 f a = f a - -correctApp2 :: (a⊸a) -> a ⊸ a -correctApp2 f a = f (f a) - -correctApp3 :: Int ⊸ Int -correctApp3 x = f x - where - f :: Int ⊸ Int - f y = y - -correctApp4 :: Int ⊸ Int -correctApp4 x = f (f x) - where - f :: Int ⊸ Int - f y = y - -correctIf :: Bool ⊸ a ⊸ a -correctIf x n = - if x then n else n - diff --git a/tests/examples/ghc90/Linear4.hs b/tests/examples/ghc90/Linear4.hs deleted file mode 100644 --- a/tests/examples/ghc90/Linear4.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE LambdaCase, GADTs #-} -module Linear4 where - -correctCase :: Bool ⊸ a ⊸ a -correctCase x n = - case x of - True -> n - False -> n - diff --git a/tests/examples/ghc90/Linear6.hs b/tests/examples/ghc90/Linear6.hs deleted file mode 100644 --- a/tests/examples/ghc90/Linear6.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -module Linear6 where - -correctEqn :: Bool ⊸ Int ⊸ Int -correctEqn True n = n -correctEqn False n = n - diff --git a/tests/examples/ghc90/Linear8.hs b/tests/examples/ghc90/Linear8.hs deleted file mode 100644 --- a/tests/examples/ghc90/Linear8.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE LambdaCase #-} -module Linear8 where - -correctLCase :: Int ⊸ Bool -> Int -correctLCase n = \case - True -> n - False -> n - diff --git a/tests/examples/ghc90/LinearConstructors.hs b/tests/examples/ghc90/LinearConstructors.hs deleted file mode 100644 --- a/tests/examples/ghc90/LinearConstructors.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE TupleSections #-} -module LinearConstructors where - -data T a b = MkT a b - -f1 :: a %1 -> b %1 -> T a b -f1 = MkT - -f2 :: a %1 -> b -> T a b -f2 = MkT - -f3 :: a -> b %1 -> T a b -f3 = MkT - -f4 :: a -> b -> T a b -f4 = MkT - --- tuple sections -g1 :: a %1 -> b %1 -> (a, b, Int) -g1 = (,,0) - -g2 :: a %1 -> b -> (a, b, Int) -g2 = (,,0) - -g3 :: a -> b %1 -> (a, b, Int) -g3 = (,,0) - -g4 :: a -> b -> (a, b, Int) -g4 = (,,0) - diff --git a/tests/examples/ghc90/LinearEmptyCase.hs b/tests/examples/ghc90/LinearEmptyCase.hs deleted file mode 100644 --- a/tests/examples/ghc90/LinearEmptyCase.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE EmptyCase, LinearTypes #-} - -module LinearEmptyCase where - -data Void - -f :: a %1 -> Void -> b -f x y = case y of {} - diff --git a/tests/examples/ghc90/LinearGuards.hs b/tests/examples/ghc90/LinearGuards.hs deleted file mode 100644 --- a/tests/examples/ghc90/LinearGuards.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -module LinearGuards where - -f :: Bool -> a %1 -> a -f b a | b = a - | True = a - diff --git a/tests/examples/ghc90/LinearTH1.hs b/tests/examples/ghc90/LinearTH1.hs deleted file mode 100644 --- a/tests/examples/ghc90/LinearTH1.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE LinearTypes, TemplateHaskell #-} -{-# LANGUAGE NoMonomorphismRestriction #-} - -module LinearTH1 where - -x1 = [t|Int -> Int|] diff --git a/tests/examples/ghc90/LinearTH2.hs b/tests/examples/ghc90/LinearTH2.hs deleted file mode 100644 --- a/tests/examples/ghc90/LinearTH2.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE LinearTypes, TemplateHaskell, RankNTypes, NoMonomorphismRestriction #-} -module LinearTH2 where - -x1 = [t|forall p. Int %p -> Int|] diff --git a/tests/examples/ghc90/LinearTypeable.hs b/tests/examples/ghc90/LinearTypeable.hs deleted file mode 100644 --- a/tests/examples/ghc90/LinearTypeable.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE LinearTypes, TypeOperators #-} -module Main (main) where - -import Data.Typeable -import Data.Maybe - -x :: Maybe ((Int -> Int) :~: (Int #-> Int)) -x = eqT - -main = print (isJust x) - diff --git a/tests/examples/ghc90/Memoize.hs b/tests/examples/ghc90/Memoize.hs deleted file mode 100644 --- a/tests/examples/ghc90/Memoize.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Feldspar.Memoize where - -import qualified Prelude - -import Feldspar - --- | Accelerate the function @f@ using a lookup table. --- The table will span all possible input values. -tabulate :: (Bits i, Integral i, Syntax a) - => (Data i -> a) -> Data i -> a -tabulate f i = tabulateLen (2 ^ bitSize i) f i - --- | Accelerate the function @f@ by creating a lookup table of the results for the --- @len@ first argument values --- --- Note. To really get a table the function must be closed after the --- application to @i@ --- -tabulateLen :: (Integral i, Syntax a) - => Data Length -> (Data i -> a) -> Data i -> a --- tabulateLen len f i = sugar $ share (parallel len (desugar.f.i2n)) (!i2n i) -tabulateLen len f i = sugar $ share (parallel len (desugar.f.i2n)) (! i2n i) - diff --git a/tests/examples/ghc90/MultConstructor.hs b/tests/examples/ghc90/MultConstructor.hs deleted file mode 100644 --- a/tests/examples/ghc90/MultConstructor.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE GADTSyntax, DataKinds, LinearTypes, KindSignatures, ExplicitForAll #-} -module MultConstructor where - -import GHC.Types - -data T p a where - MkT :: a %p -> T p a - -{- -this currently fails -g :: forall (b :: Type). T 'Many b %1 -> (b,b) -g (MkT x) = (x,x) --} diff --git a/tests/examples/ghc90/OldList.hs b/tests/examples/ghc90/OldList.hs deleted file mode 100644 --- a/tests/examples/ghc90/OldList.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables, BangPatterns, RankNTypes #-} - -{- -This is a simplified version of Data.OldList module from base. -This caused an assertion failure in earlier version of linear -types implementation. --} - -module Data.OldList where - -import GHC.Base - -sortBy :: forall a . (a -> a -> Ordering) -> [a] -sortBy cmp = [] - where - sequences (a:b:xs) - | a `cmp` b == GT = descending b [a] xs - | otherwise = ascending b (a:) xs - sequences xs = [xs] - --- descending :: a -> [a] -> [a] -> [[a]] - descending a as (b:bs) - | a `cmp` b == GT = descending b (a:as) bs - descending a as bs = (a:as): sequences bs - - ascending :: a -> (forall i . [a] %i -> [a]) -> [a] -> [[a]] - ascending a as (b:bs) - | a `cmp` b /= GT = ascending b foo bs - where - foo :: [a] %k -> [a] - foo ys = as (a:ys) - ascending a as bs = let !x = as [a] - in x : sequences bs diff --git a/tests/examples/ghc90/Op.hs b/tests/examples/ghc90/Op.hs deleted file mode 100644 --- a/tests/examples/ghc90/Op.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE NoImplicitPrelude #-} -module Op where -{- -See Control.Arrow and Data.Functor.Contravariant --} - -import GHC.Base - -class Or p where - or :: p a b -> p a b -> p a b - -instance Or (->) where - or x _ = x - - -foo = or Just (\x -> Just x) - -{- -This caused an error in the earlier version of linear types: - -linear-tests/Op.hs:18:16: error: - • Couldn't match expected type ‘a ⊸ Maybe a’ - with actual type ‘a0 -> Maybe a0’ - • The lambda expression ‘\ x -> Just x’ has one argument, - its type is ‘p0 a b0’, - it is specialized to ‘a ⊸ Maybe a’ - In the second argument of ‘or’, namely ‘(\ x -> Just x)’ - In the expression: or Just (\ x -> Just x) - • Relevant bindings include - foo :: a ⊸ Maybe a (bound at linear-tests/Op.hs:18:1) - | -18 | foo = or Just (\x -> Just x) - | ^^^^^^^^^^^^ --} diff --git a/tests/examples/ghc90/ParserArrowLambdaCase.hs b/tests/examples/ghc90/ParserArrowLambdaCase.hs deleted file mode 100644 --- a/tests/examples/ghc90/ParserArrowLambdaCase.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE Arrows, LambdaCase #-} -module ParserArrowLambdaCase where - -import Control.Arrow - -foo :: () -> () -foo = proc () -> (| id (\case - () -> () >- returnA) |) () - diff --git a/tests/examples/ghc90/Pr110.hs b/tests/examples/ghc90/Pr110.hs deleted file mode 100644 --- a/tests/examples/ghc90/Pr110.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -module Pr110 where - -data Bloop = Bloop Bool - -g :: Bloop %1 -> Bool -g (Bloop x) = x - -h :: Bool %1 -> Bloop -h x = Bloop x - diff --git a/tests/examples/ghc90/T18023.hs b/tests/examples/ghc90/T18023.hs deleted file mode 100644 --- a/tests/examples/ghc90/T18023.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneKindSignatures #-} -module T18023 where - -import Data.Kind -import Data.Proxy - -newtype N :: Type -> Type -> Type where - MkN :: forall b a. { unN :: Either a b } -> N a b - -toN :: Either Int Bool -> N Int Bool -toN = MkN @Bool @Int - -fromN :: N Int Bool -> Either Int Bool -fromN = unN @Bool @Int - -newtype P a = MkP { unP :: Proxy a } - -toPTrue :: Proxy True -> P True -toPTrue = MkP @True - -fromPTrue :: P True -> Proxy True -fromPTrue = unP @True - -newtype P2 a b = MkP2 { unP2 :: (Proxy a, Proxy b) } - -toP2True :: (Proxy True, Proxy True) -> P2 True True -toP2True = MkP2 @True @True - -fromP2True :: P2 True True -> (Proxy True, Proxy True) -fromP2True = unP2 @True @True - -type P3 :: forall {k}. k -> Type -newtype P3 a = MkP3 { unP3 :: Proxy a } - -toP3True :: Proxy True -> P3 True -toP3True = MkP3 @True - -fromP3True :: P3 True -> Proxy True -fromP3True = unP3 @True - diff --git a/tests/examples/ghc90/T18432.hs b/tests/examples/ghc90/T18432.hs deleted file mode 100644 --- a/tests/examples/ghc90/T18432.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE QuantifiedConstraints #-} -module Bug where - -import Data.Proxy - -class C a where - m :: Proxy a - -f :: (forall {a}. C a) => Proxy Int -f = m - diff --git a/tests/examples/ghc90/T18522-dbg-ppr.hs b/tests/examples/ghc90/T18522-dbg-ppr.hs deleted file mode 100644 --- a/tests/examples/ghc90/T18522-dbg-ppr.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE TemplateHaskell, ExplicitForAll, PolyKinds #-} -{-# LANGUAGE QuasiQuotes #-} - -module Main where - -import Language.Haskell.TH (runQ) -import GHC.Types.Basic -import GHC.ThToHs -import GHC.Driver.Session -import GHC.Core.TyCo.Ppr -import GHC.Utils.Outputable -import GHC.Tc.Module -import GHC.Tc.Utils.Zonk -import GHC.Utils.Error -import GHC.Driver.Types -import GHC -import qualified GHC.LanguageExtensions as LangExt - -import Data.Either (fromRight) -import Control.Monad.IO.Class (liftIO) -import System.Environment (getArgs) - -main :: IO () -main = do - [libdir] <- getArgs - runGhc (Just libdir) $ do - initial_dflags <- getSessionDynFlags - setSessionDynFlags $ initial_dflags - `dopt_set` Opt_D_ppr_debug - `gopt_set` Opt_SuppressUniques - `gopt_set` Opt_SuppressModulePrefixes - `gopt_set` Opt_SuppressVarKinds - `xopt_set` LangExt.KindSignatures - `xopt_set` LangExt.PolyKinds - `xopt_set` LangExt.RankNTypes - hsc_env <- getSession - let dflags = hsc_dflags hsc_env - liftIO $ do - th_t <- runQ [t| forall k {j}. - forall (a :: k) (b :: j) -> - () |] - let hs_t = fromRight (error "convertToHsType") $ - convertToHsType Generated noSrcSpan th_t - ((warnings, errors), mres) <- - tcRnType hsc_env SkolemiseFlexi True hs_t - case mres of - Nothing -> do - printBagOfErrors dflags warnings - printBagOfErrors dflags errors - Just (t, _) -> do - putStrLn $ showSDoc dflags (debugPprType t) - diff --git a/tests/examples/ghc90/TH_reifyLinear.hs b/tests/examples/ghc90/TH_reifyLinear.hs deleted file mode 100644 --- a/tests/examples/ghc90/TH_reifyLinear.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE TemplateHaskell #-} -module TH_reifyLinear where - -import Language.Haskell.TH -import System.IO - -type T = Int #-> Int - -$( - do x <- reify ''T - runIO $ hPutStrLn stderr $ pprint x - return [] - ) - diff --git a/tests/examples/ghc90/TupSection.hs b/tests/examples/ghc90/TupSection.hs deleted file mode 100644 --- a/tests/examples/ghc90/TupSection.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE LinearTypes #-} -{-# LANGUAGE TupleSections #-} -module TupSection where -{- -inplace/bin/ghc-stage1 -O2 -dcore-lint --} - -myAp :: (a -> b) -> a -> b -myAp f x = f x - -foo = myAp (,()) () - -qux = ("go2",) $ () diff --git a/tests/examples/ghc90/anf.hs b/tests/examples/ghc90/anf.hs deleted file mode 100644 --- a/tests/examples/ghc90/anf.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE LinearTypes #-} --- !! Data constructors with strict fields --- This test should use -funbox-strict-fields - -module Main ( main ) where - -main = print (g (f t)) - -t = MkT 1 2 (3,4) (MkS 5 6) - -g (MkT x _ _ _) = x - -data T = MkT Int !Int !(Int,Int) !(S Int) - -data S a = MkS a a - - -{-# NOINLINE f #-} -f :: T -> T -- Takes apart the thing and puts it - -- back together differently -f (MkT x y (a,b) (MkS p q)) = MkT a b (p,q) (MkS x y) diff --git a/tests/examples/ghc90/qdocompile001.hs b/tests/examples/ghc90/qdocompile001.hs deleted file mode 100644 --- a/tests/examples/ghc90/qdocompile001.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE QualifiedDo #-} - -import Prelude as P - --- Test that the context of the do shows well in the renamer --- output. --- --- The nested do in the renamer output must be qualified the --- same as the outer P.do written in the source program. --- --- > ==================== Renamer ==================== --- > Main.main --- > = print --- > $ P.do (x <- [1, 2] | --- > y <- P.do y@1 <- [1, 2] -- qualified! --- > [1, 2] --- > y) --- > return y --- -main = - print $ P.do - x <- [1, 2] - y@1 <- [1, 2] - [1, 2] - P.return y - diff --git a/tests/examples/ghc90/qdocompile002.hs b/tests/examples/ghc90/qdocompile002.hs deleted file mode 100644 --- a/tests/examples/ghc90/qdocompile002.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE QualifiedDo #-} - -import Prelude as P hiding (fail) - - --- Tests that fail is not required with irrefutable patterns -main = - print $ P.do - x <- [1, 2] - (_, y) <- [(1, "a"), (2, "b")] - P.return (x, y) - diff --git a/tests/examples/ghc90/qdorun001.hs b/tests/examples/ghc90/qdorun001.hs deleted file mode 100644 --- a/tests/examples/ghc90/qdorun001.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE QualifiedDo #-} - -import qualified Monad.Graded as Graded -import Vector as Graded - - -main = do - putStrLn "The unqualified do still works." - print $ toList $ Graded.do - x <- VCons 1 (VCons 2 VNil) - y <- VCons 1 (VCons 2 VNil) - Graded.return (x, y) - -- test Graded.fail - print $ toList $ Graded.do - 1 <- VCons 1 VNil - Graded.return 1 - diff --git a/tests/examples/ghc90/qdorun002.hs b/tests/examples/ghc90/qdorun002.hs deleted file mode 100644 --- a/tests/examples/ghc90/qdorun002.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE QualifiedDo #-} -{-# LANGUAGE RecursiveDo #-} - -import qualified Monad.Graded as Graded -import Vector as Graded - - -main = do - print $ take 6 $ concat $ toList $ Graded.do - rec - VCons (take 6 y) VNil - y <- VCons (1 : zipWith (+) y (0 : y)) VNil - Graded.return y - diff --git a/tests/examples/ghc90/qdorun003.hs b/tests/examples/ghc90/qdorun003.hs deleted file mode 100644 --- a/tests/examples/ghc90/qdorun003.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE QualifiedDo #-} - -import qualified Monad.Graded as Graded -import Vector as Graded - - -main = do - print $ toList $ Graded.do - x <- VCons 1 (VCons 2 VNil) - y <- VCons 1 (VCons 2 VNil) - Graded.return (x, y) - -- Test Graded.join - print $ toList $ Graded.do - x <- VCons 1 (VCons 2 VNil) - y <- VCons 1 (VCons 2 VNil) - VCons (y, x) VNil - diff --git a/tests/examples/ghc90/qdorun004.hs b/tests/examples/ghc90/qdorun004.hs deleted file mode 100644 --- a/tests/examples/ghc90/qdorun004.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE QualifiedDo #-} -{-# LANGUAGE RecursiveDo #-} -import qualified Control.Monad.Fix as P -import Prelude (print, ($)) -import qualified Prelude as P - -return :: a -> [a] -return x = [x, x] - --- Tests that QualifiedDo doesn't affect return -main = do - print $ P.do - x <- [1, 2] - return x - print $ P.mdo - x <- [1, 2] - return x - diff --git a/tests/examples/ghc90/qdorun005.hs b/tests/examples/ghc90/qdorun005.hs deleted file mode 100644 --- a/tests/examples/ghc90/qdorun005.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE QualifiedDo #-} -{-# LANGUAGE RebindableSyntax #-} -import qualified Monad.Graded as Graded -import Vector -import Prelude (print, ($)) -import qualified Prelude as P - -xs >>= f = 'c' : P.concatMap f xs -(>>) = (P.>>) - -main = do - print $ toList $ Graded.do - x <- VCons 'a' (VCons 'b' VNil) - Graded.return x - print $ do - a <- ['a', 'b'] - P.return a - diff --git a/tests/examples/ghc90/qdorun006.hs b/tests/examples/ghc90/qdorun006.hs deleted file mode 100644 --- a/tests/examples/ghc90/qdorun006.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE QualifiedDo #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TemplateHaskell #-} - -import qualified Monad.Graded as Graded -import Vector as Graded - - -main = do - print $ toList $([| Graded.do - x <- VCons 1 (VCons 2 VNil) - y <- VCons 1 (VCons 2 VNil) - Graded.return (x, y) |]) - print $ toList $([| Graded.mdo - z <- VCons (take 8 y) VNil - y <- VCons (1 : zipWith (+) y (0 : y)) VNil - Graded.return z |]) - diff --git a/tests/examples/ghc90/qdorun007.hs b/tests/examples/ghc90/qdorun007.hs deleted file mode 100644 --- a/tests/examples/ghc90/qdorun007.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE QualifiedDo #-} --- Tests that QualfiedDo works for a linear monad. - -import Monad.Linear as Linear - - -main = do - let r = runTM (Linear.do - t0 <- newT - t1 <- increaseT t0 - (t2, ur) <- extractT t1 - deleteT t2 - Linear.return ur) - print r - print r - diff --git a/tests/examples/ghc910/AnnotationNoListTuplePuns.hs b/tests/examples/ghc910/AnnotationNoListTuplePuns.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/AnnotationNoListTuplePuns.hs @@ -0,0 +1,18 @@ +{-# language NoListTuplePuns #-} +module AnnotationNoListTuplePuns where + +type A = + -- comment pre + [ + -- comment inside + ] + -- comment post + +type B = + -- comment pre + [ + -- comment inside + Bool + ] + -- comment post + diff --git a/tests/examples/ghc910/ByHand.hs b/tests/examples/ghc910/ByHand.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/ByHand.hs @@ -0,0 +1,5 @@ +module ByHand where + +instance SDecide Nat where + SZero %~ (SSucc _) = Disproved (\case) + diff --git a/tests/examples/ghc910/Cfipu.hs b/tests/examples/ghc910/Cfipu.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Cfipu.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} + +module Main where + +instructions = + [ ('2', \m r -> do + r m + ; `catch` get m r) + ] + diff --git a/tests/examples/ghc910/Class.hs b/tests/examples/ghc910/Class.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Class.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE CPP #-} +module Distribution.Compat.Binary.Class where + +x = 1 + +-- c1 + +#if 1 + +y = 1 +#endif + diff --git a/tests/examples/ghc910/ConPat.hs b/tests/examples/ghc910/ConPat.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/ConPat.hs @@ -0,0 +1,17 @@ +module ConPat where + + + + + + + + + + + + + + +yyy = let snd:fst:xs = flipFirst global + in f fst snd diff --git a/tests/examples/ghc910/ConstructorArgs.hs b/tests/examples/ghc910/ConstructorArgs.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/ConstructorArgs.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +module ConstructorArgs where + +class + a -- c1 + :+ -- c2 + b -- c3 + +data Foo + = Int -- c4 + :* -- c5 + String -- c6 diff --git a/tests/examples/ghc910/Disambiguate.hs b/tests/examples/ghc910/Disambiguate.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Disambiguate.hs @@ -0,0 +1,10 @@ +module Disambiguate where + +instance Disambiguatable P_ObjDef where + disambInfo (P_Obj a b c -- c1 + v -- c2 + d -- c3 + f) -- c4 + env -- c5 + = (P_Obj a b c' v d' f, Cnstr (sourceConstraintsOf env2) [] -- c6 + ) diff --git a/tests/examples/ghc910/Domino.hs b/tests/examples/ghc910/Domino.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Domino.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} +module Domino where + +-- c0 +pattern (:|) :: + -- c1 + a -> + -- c2 + a -> + -- c3 + Domino a diff --git a/tests/examples/ghc910/ErrorSpec.hs b/tests/examples/ghc910/ErrorSpec.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/ErrorSpec.hs @@ -0,0 +1,9 @@ +module ErrorSpec where + +type ErrorChoiceApi + = "path0" :> Get '[JSON] Int -- c0 + :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- c4 + :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- c5 + :<|> "path5" :> (ReqBody '[JSON] Int :> Post '[PlainText] Int -- c6 + :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- c7 + diff --git a/tests/examples/ghc910/Expression.hs b/tests/examples/ghc910/Expression.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Expression.hs @@ -0,0 +1,4 @@ +module Expression where + +eh1 = try (do return r;) <|> (do + return r) diff --git a/tests/examples/ghc910/Generate.hs b/tests/examples/ghc910/Generate.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Generate.hs @@ -0,0 +1,1003 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} -- For NFData instances +{-# LANGUAGE DeriveGeneric #-} -- For NFData instances +{-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp) +{-# LANGUAGE ConstraintKinds #-} -- For Dict +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} -- For nextInput +{-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp) +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Symantic.Parser.Machine.Generate where + +import Control.DeepSeq (NFData(..)) +import Control.Monad (Monad(..)) +import Control.Monad.ST (ST, runST) +import Data.Bool (Bool(..), otherwise) +import Data.Char (Char) +import Data.Either (Either(..)) +import Data.Eq (Eq(..)) +import Data.Foldable (foldr, toList, null) +import Data.Function (($), (.), on) +import Data.Functor ((<$>)) +import Data.Int (Int) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Map (Map) +import Data.Maybe (Maybe(..)) +import Data.Ord (Ord(..), Ordering(..)) +import Data.Proxy (Proxy(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Set (Set) +import Data.String (String) +import Data.Traversable (Traversable(..)) +import Data.Tuple (snd) +import Data.Typeable (Typeable) +import Data.Word (Word8) +import GHC.Generics (Generic) +import GHC.Show (showCommaSpace) +import Language.Haskell.TH (CodeQ) +import Prelude ((+), (-), error) +import Text.Show (Show(..), showParen, showString) +import qualified Data.HashMap.Strict as HM +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Internal as Map_ +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Set.Internal as Set_ +import qualified Data.STRef as ST +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH + +import qualified Symantic.Data as Sym +import Symantic.Derive +import Symantic.ObserveSharing +import qualified Symantic.Parser.Grammar as Gram +import Symantic.Parser.Grammar.Combinators + ( UnscopedRegister(..) + , Exception(..) + , Failure(..) + , SomeFailure(..) + , unSomeFailure + , inputTokenProxy + ) +import Symantic.Parser.Machine.Input +import Symantic.Parser.Machine.Instructions +import qualified Language.Haskell.TH.HideName as TH +import qualified Symantic.Lang as Prod +import qualified Symantic.Optimize as Prod + +--import Debug.Trace + +-- | Convenient utility to generate some final 'TH.CodeQ'. +genCode :: Splice a -> CodeQ a +genCode = derive . Prod.normalOrderReduction + +-- * Type 'Gen' +-- | Generate the 'CodeQ' parsing the input. +data Gen inp vs a = Gen + { genAnalysisByLet :: OpenRecs TH.Name GenAnalysis + -- ^ 'genAnalysis' for each 'defLet' and 'defJoin' of the 'Machine'. + , genAnalysis :: OpenRec TH.Name GenAnalysis + -- ^ Synthetized (bottom-up) static genAnalysis of the 'Machine'. + , unGen :: forall st. + GenCtx st inp vs a -> + CodeQ (ST st (Either (ParsingError inp) a)) + } + +{-# INLINE returnST #-} +returnST :: forall s a. a -> ST s a +returnST = return @(ST s) + +-- | @('generateCode' input mach)@ generates @TemplateHaskell@ code +-- parsing the given 'input' according to the given 'Machine'. +generateCode :: + -- Not really used constraints, + -- just to please 'checkHorizon'. + Ord (InputToken inp) => + Show (InputToken inp) => + TH.Lift (InputToken inp) => + NFData (InputToken inp) => + Typeable (InputToken inp) => + Inputable inp => + Show (Cursor inp) => + Gen inp '[] a -> + CodeQ (inp -> Either (ParsingError inp) a) +generateCode gen = + let Gen{unGen=k, ..} = checkHorizon gen in + [|| \(input :: inp) -> + -- Pattern bindings containing unlifted types + -- should use an outermost bang pattern. + let !(# init, readMore, readNext #) = $$(cursorOf [||input||]) + finalRet = \_farInp _farExp v _inp -> returnST $ Right v + finalRaise :: forall st b. (OnException st inp b) + = \ !exn _failInp !farInp !farExp -> + returnST $ Left ParsingError + { parsingErrorOffset = offset farInp + , parsingErrorException = exn + , parsingErrorUnexpected = + if readMore farInp + then Just (let (# c, _ #) = readNext farInp in c) + else Nothing + , parsingErrorExpecting = + let (minHoriz, res) = + Set.foldr (\f (minH, acc) -> + case unSomeFailure f of + Just (FailureHorizon h :: Failure (Gram.CombSatisfiable (InputToken inp))) + | Just old <- minH -> (Just (min old h), acc) + | otherwise -> (Just h, acc) + _ -> (minH, f:acc) + ) (Nothing, []) farExp in + Set.fromList $ case minHoriz of + Just h -> SomeFailure (FailureHorizon @(InputToken inp) h) : res + Nothing -> res + } + in runST $$( + let + -- | Defines 'inputTokenProxy' so that the TemplateHaskell code + -- can refer to @(InputToken inp)@ through it. + defInputTokenProxy :: TH.CodeQ a -> TH.CodeQ a + defInputTokenProxy exprCode = + TH.unsafeCodeCoerce [| + let $(return (TH.VarP inputTokenProxy)) = Proxy :: Proxy (InputToken inp) in + $(TH.unTypeQ (TH.examineCode exprCode)) + |] + in + defInputTokenProxy $ + k GenCtx + { valueStack = ValueStackEmpty + , onExceptionStackByLabel = Map.empty :: Map Exception (NonEmpty (TH.CodeQ (OnException s inp a))) + , defaultCatch = [||finalRaise||] + , onReturn = [||finalRet||] :: CodeQ (OnReturn s inp a a) + , input = [||init||] + , nextInput = [||readNext||] + , moreInput = [||readMore||] + -- , farthestError = [||Nothing||] + , farthestInput = [||init||] + , farthestExpecting = [||Set.empty||] + , checkedHorizon = 0 + , analysisByLet = mutualFix genAnalysisByLet + } + ) + ||] + +-- ** Type 'ParsingError' +data ParsingError inp + = ParsingError + { parsingErrorOffset :: Offset + , parsingErrorException :: Exception + -- | Note: if a 'FailureHorizon' greater than 1 + -- is amongst the 'parsingErrorExpecting' + -- then 'parsingErrorUnexpected' is only the 'InputToken' + -- at the begining of the expected 'Horizon'. + , parsingErrorUnexpected :: Maybe (InputToken inp) + , parsingErrorExpecting :: Set SomeFailure + } deriving (Generic) +deriving instance NFData (InputToken inp) => NFData (ParsingError inp) +--deriving instance Show (InputToken inp) => Show (ParsingError inp) +instance Show (InputToken inp) => Show (ParsingError inp) where + showsPrec p ParsingError{..} = + showParen (p >= 11) $ + showString "ParsingErrorStandard {" . + showString "parsingErrorOffset = " . + showsPrec 0 parsingErrorOffset . + showCommaSpace . + showString "parsingErrorException = " . + showsPrec 0 parsingErrorException . + showCommaSpace . + showString "parsingErrorUnexpected = " . + showsPrec 0 parsingErrorUnexpected . + showCommaSpace . + showString "parsingErrorExpecting = fromList " . + showsPrec 0 ( + -- Sort on the string representation + -- because the 'Ord' of the 'SomeFailure' + -- is based upon hashes ('typeRepFingerprint') + -- depending on packages' ABI and whether + -- cabal-install's setup is --inplace or not, + -- and that would be too unstable for golden tests. + List.sortBy (compare `on` show) $ + Set.toList parsingErrorExpecting + ) . + showString "}" + +-- ** Type 'ErrorLabel' +type ErrorLabel = String + +-- * Type 'GenAnalysis' +data GenAnalysis = GenAnalysis + { minReads :: Horizon + -- ^ The minimun number of input tokens to read + -- on the current 'input' to reach a success. + , mayRaise :: Map Exception () + -- ^ The 'Exception's that may be raised depending on the 'input'. + , alwaysRaise :: Set Exception + -- ^ The 'Exception's raised whatever is or happen to the 'input'. + , freeRegs :: Set TH.Name + -- ^ The free registers that are used. + } deriving (Show) + +-- ** Type 'Offset' +type Offset = Int +-- ** Type 'Horizon' +-- | Minimal input length required for a successful parsing. +type Horizon = Offset + +-- | Merge given 'GenAnalysis' as sequences. +seqGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis +seqGenAnalysis aas@(a:|as) = GenAnalysis + { minReads = List.foldl' (\acc -> (acc +) . minReads) (minReads a) as + , mayRaise = sconcat (mayRaise <$> aas) + , alwaysRaise = sconcat (alwaysRaise <$> aas) + , freeRegs = sconcat (freeRegs <$> aas) + } +-- | Merge given 'GenAnalysis' as alternatives. +altGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis +altGenAnalysis aas = GenAnalysis + { minReads = + case + (`NE.filter` aas) $ \a -> + -- If an alternative 'alwaysRaise's 'ExceptionFailure' whatever its 'input' is, + -- it __should__ remain semantically the same (up to the exact 'Failure's) + -- to raise an 'ExceptionFailure' even before knowing + -- whether that alternative branch will be taken or not, + -- hence an upstream 'checkHorizon' is allowed to raise an 'ExceptionFailure' + -- based only upon the 'minReads' of such alternatives: + Set.toList (alwaysRaise a) /= [ExceptionFailure] + of + [] -> 0 + a:as -> List.foldl' (\acc -> min acc . minReads) (minReads a) as + , mayRaise = sconcat (mayRaise <$> aas) + , alwaysRaise = foldr Set.intersection Set.empty (alwaysRaise <$> aas) + , freeRegs = sconcat (freeRegs <$> aas) + } + + + +{- +-- *** Type 'FarthestError' +data FarthestError inp = FarthestError + { farthestInput :: Cursor inp + , farthestExpecting :: [Failure (InputToken inp)] + } +-} + +-- ** Type 'GenCtx' +-- | This is an inherited (top-down) context +-- only present at compile-time, to build TemplateHaskell splices. +data GenCtx st inp vs a = + ( Cursorable (Cursor inp) + -- For checkHorizon + , TH.Lift (InputToken inp) + , Show (InputToken inp) + , Eq (InputToken inp) + , Ord (InputToken inp) + , Typeable (InputToken inp) + , NFData (InputToken inp) + ) => GenCtx + { valueStack :: ValueStack vs + , onExceptionStackByLabel :: Map Exception (NonEmpty (CodeQ (OnException st inp a))) + -- | Default 'OnException' defined at the begining of the generated 'CodeQ', + -- hence a constant within the 'Gen'eration. + , defaultCatch :: forall b. CodeQ (OnException st inp b) + , onReturn :: CodeQ (OnReturn st inp a a) + , input :: CodeQ (Cursor inp) + , moreInput :: CodeQ (Cursor inp -> Bool) + , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #)) + , farthestInput :: CodeQ (Cursor inp) + , farthestExpecting :: CodeQ (Set SomeFailure) + -- | Remaining horizon already checked. + -- Use to factorize 'input' length checks, + -- instead of checking the 'input' length + -- one 'InputToken' at a time at each 'read'. + -- Updated by 'checkHorizon' + -- and reset elsewhere when needed. + , checkedHorizon :: Horizon + -- | Output of 'mutualFix'. + , analysisByLet :: LetRecs TH.Name GenAnalysis + } + +-- ** Type 'ValueStack' +data ValueStack vs where + ValueStackEmpty :: ValueStack '[] + ValueStackCons :: + { valueStackHead :: Splice v + , valueStackTail :: ValueStack vs + } -> ValueStack (v ': vs) + +instance InstrComment Gen where + comment msg k = k + { unGen = \ctx -> {-trace "unGen.comment" $-} + [|| + let _ = $$(liftTypedString $ "comment: "<>msg) in + $$(unGen k ctx) + ||] + } +instance InstrValuable Gen where + pushValue x k = k + { unGen = \ctx -> {-trace "unGen.pushValue" $-} + [|| + let _ = "pushValue" in + $$(unGen k ctx + { valueStack = ValueStackCons x (valueStack ctx) }) + ||] + } + popValue k = k + { unGen = \ctx -> {-trace "unGen.popValue" $-} + [|| + let _ = "popValue" in + $$(unGen k ctx + { valueStack = valueStackTail (valueStack ctx) }) + ||] + } + lift2Value f k = k + { unGen = \ctx -> {-trace "unGen.lift2Value" $-} + [|| + let _ = $$(liftTypedString ("lift2Value checkedHorizon="<>show (checkedHorizon ctx))) in + $$(unGen k ctx + { valueStack = + let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in + ValueStackCons (f Prod..@ x Prod..@ y) vs + }) + ||] + } + swapValue k = k + { unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx + { valueStack = + let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in + ValueStackCons x (ValueStackCons y vs) + } + } +instance InstrBranchable Gen where + caseBranch kx ky = Gen + { genAnalysisByLet = genAnalysisByLet kx <> genAnalysisByLet ky + , genAnalysis = \final -> altGenAnalysis $ + genAnalysis kx final :| + [genAnalysis ky final] + , unGen = \ctx -> {-trace "unGen.caseBranch" $-} + let ValueStackCons v vs = valueStack ctx in + [|| + case $$(genCode v) of + Left x -> $$(unGen kx ctx{ valueStack = ValueStackCons (splice [||x||]) vs }) + Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (splice [||y||]) vs }) + ||] + } + choicesBranch bs default_ = Gen + { genAnalysisByLet = sconcat $ genAnalysisByLet default_ :| (genAnalysisByLet . snd <$> bs) + , genAnalysis = \final -> altGenAnalysis $ + (\k -> genAnalysis k final) + <$> (default_:|(snd <$> bs)) + , unGen = \ctx0 -> {-trace "unGen.choicesBranch" $-} + let ValueStackCons v vs = valueStack ctx0 in + let ctx = ctx0{valueStack = vs} in + let + go x ((p,b):bs') = [|| + if $$(genCode (p Prod..@ x)) + then + let _ = $$(liftTypedString ("choicesBranch checkedHorizon="<>show (checkedHorizon ctx))) in + $$({-trace "unGen.choicesBranch.b" $-} unGen b ctx) + else + let _ = "choicesBranch.else" in + $$(go x bs') + ||] + go _ _ = unGen default_ ctx + in go v bs + } +instance InstrExceptionable Gen where + raise exn = Gen + { genAnalysisByLet = HM.empty + , genAnalysis = \_final -> GenAnalysis + { minReads = 0 + , mayRaise = Map.singleton (ExceptionLabel exn) () + , alwaysRaise = Set.singleton (ExceptionLabel exn) + , freeRegs = Set.empty + } + , unGen = \ctx@GenCtx{} -> {-trace ("unGen.raise: "<>show exn) $-} [|| + $$(raiseException ctx (ExceptionLabel exn)) + (ExceptionLabel $$(TH.liftTyped exn)) + {-failInp-}$$(input ctx) + {-farInp-}$$(input ctx) + $$(farthestExpecting ctx) + ||] + } + fail fs = Gen + { genAnalysisByLet = HM.empty + , genAnalysis = \_final -> GenAnalysis + { minReads = 0 + , mayRaise = Map.singleton ExceptionFailure () + , alwaysRaise = Set.singleton ExceptionFailure + , freeRegs = Set.empty + } + , unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-} + if null fs + then [|| -- Raise without updating the farthest error. + $$(raiseException ctx ExceptionFailure) + ExceptionFailure + {-failInp-}$$(input ctx) + $$(farthestInput ctx) + $$(farthestExpecting ctx) + ||] + else raiseFailure ctx [||fs||] + } + commit exn k = k + { unGen = \ctx -> {-trace ("unGen.commit: "<>show exn) $-} + [|| + let _ = "commit" in + $$(unGen k ctx{onExceptionStackByLabel = + Map.update (\case + _r0:|(r1:rs) -> Just (r1:|rs) + _ -> Nothing + ) + exn (onExceptionStackByLabel ctx) + }) + ||] + } + catch exn k onExn = Gen + { genAnalysisByLet = genAnalysisByLet k <> genAnalysisByLet onExn + , genAnalysis = \final -> + let kAnalysis = genAnalysis k final in + let onExnAnalysis = genAnalysis onExn final in + altGenAnalysis $ + kAnalysis + { mayRaise = Map.delete exn (mayRaise kAnalysis) + , alwaysRaise = Set.delete exn (alwaysRaise kAnalysis) + } :| + [ onExnAnalysis ] + , unGen = \ctx@GenCtx{} -> {-trace ("unGen.catch: "<>show exn) $-} [|| + let _ = $$(liftTypedString ("catch "<>show exn<>" checkedHorizon="<>show (checkedHorizon ctx))) in + let onException = $$(onExceptionCode (input ctx) (checkedHorizon ctx) onExn ctx) in + $$(unGen k ctx + { onExceptionStackByLabel = + Map.insertWith (<>) exn + (NE.singleton [||onException||]) + (onExceptionStackByLabel ctx) + } + ) ||] + } +-- ** Class 'SpliceInputable' +-- | Record an 'input' and a 'checkedHorizon' together +-- to be able to put both of them on the 'valueStack', +-- and having them moved together by operations +-- on the 'valueStack' (eg. 'lift2Value'). +-- Used by 'saveInput' and 'loadInput'. +class SpliceInputable repr where + inputSave :: CodeQ inp -> Horizon -> repr inp +data instance Sym.Data SpliceInputable repr a where + InputSave :: CodeQ inp -> Horizon -> Sym.Data SpliceInputable repr inp +instance SpliceInputable (Sym.Data SpliceInputable repr) where + inputSave = InputSave +instance SpliceInputable repr => SpliceInputable (Sym.SomeData repr) where + inputSave inp = Sym.SomeData . InputSave inp +instance SpliceInputable TH.CodeQ where + inputSave inp _hor = inp +instance SpliceInputable repr => Derivable (Sym.Data SpliceInputable repr) where + derive = \case + InputSave inp hor -> inputSave inp hor +instance InstrInputable Gen where + saveInput k = k + { unGen = \ctx -> + {-trace "unGen.saveInput" $-} + [|| + let _ = $$(liftTypedString $ "saveInput checkedHorizon="<>show (checkedHorizon ctx)) in + $$(unGen k ctx + { valueStack = inputSave (input ctx) (checkedHorizon ctx) `ValueStackCons` valueStack ctx + }) + ||] + } + loadInput k = k + { unGen = \ctx@GenCtx{} -> + {-trace "unGen.loadInput" $-} + let ValueStackCons v vs = valueStack ctx in + let (input, checkedHorizon) = case v of + Sym.Data (InputSave i h) -> (i, h) + -- This case should never happen if 'saveInput' is used. + i -> (genCode i, 0) in + [|| + let _ = $$(liftTypedString $ "loadInput checkedHorizon="<>show checkedHorizon) in + $$(unGen (checkHorizon k) ctx + { valueStack = vs + , input + , checkedHorizon + }) + ||] + , genAnalysis = \final -> + let analysis = genAnalysis k final in + -- The input is reset and thus any previous 'checkHorizon' + -- cannot check after this 'loadInput'. + analysis{minReads = 0} + } +instance InstrCallable Gen where + defLet defs k = k + { unGen = \ctx@GenCtx{} -> + {-trace ("unGen.defLet: defs="<>show (HM.keys defs)) $-} + TH.unsafeCodeCoerce $ do + decls <- traverse (makeDecl ctx) (HM.toList defs) + body <- TH.unTypeQ $ TH.examineCode $ + {-trace "unGen.defLet.body" $-} + unGen k ctx + return $ TH.LetE ( + -- | Use 'List.sortBy' to output more deterministic code + -- to be able to golden test it, at the cost of more computations + -- (at compile-time only though). + List.sortBy (compare `on` TH.hideName) $ + toList decls + ) body + , genAnalysisByLet = + HM.unions + $ genAnalysisByLet k + : ((\(SomeLet sub) -> genAnalysis sub) <$> defs) + : ((\(SomeLet sub) -> genAnalysisByLet sub) <$> HM.elems defs) + } + where + makeDecl ctx (subName, SomeLet sub) = do + let subAnalysis = analysisByLet ctx HM.! subName + body <- takeFreeRegs (freeRegs subAnalysis) $ + TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley + -- Called by 'call' or 'jump'. + \ !callerOnReturn{-from onReturnCode-} + !callerInput + !callerOnExceptionStackByLabel{- 'onExceptionStackByLabel' from the 'call'-site -} -> + $$({-trace ("unGen.defLet.sub: "<>show subName) $-} unGen sub ctx + { valueStack = ValueStackEmpty + -- Build a 'onExceptionStackByLabel' for the 'mayRaise' of the subroutine, + -- where each 'OnException' calls the one passed by the 'call'-site (in 'callerOnExceptionStackByLabel'). + -- Note that currently the 'call'-site can supply in 'callerOnExceptionStackByLabel' + -- a subset of the 'mayRaise' needed by this subroutine, + -- because 'Map.findWithDefault' is used instead of 'Map.!'. + , onExceptionStackByLabel = Map.mapWithKey + (\lbl () -> NE.singleton [||Map.findWithDefault $$(defaultCatch ctx) lbl callerOnExceptionStackByLabel||]) + ({-trace ("mayRaise: "<>show subName) $-} + mayRaise subAnalysis) + , input = [||callerInput||] + , onReturn = {-trace ("unGen.defLet.sub.onReturn: "<>show subName) $-} [||callerOnReturn||] + + -- These are passed by the caller via 'callerOnReturn' or 'ko' + -- , farthestInput = + -- , farthestExpecting = + + -- Some callers can call this declaration + -- with zero 'checkedHorizon', hence use this minimum. + -- TODO: maybe it could be improved a bit + -- by taking the minimum of the checked horizons + -- before all the 'call's and 'jump's to this declaration. + , checkedHorizon = 0 + }) + ||] + let decl = TH.FunD subName [TH.Clause [] (TH.NormalB body) []] + return decl + jump isRec (LetName subName) = Gen + { genAnalysisByLet = HM.empty + , genAnalysis = \final -> + if isRec + then GenAnalysis + { minReads = 0 + , mayRaise = Map.empty + , alwaysRaise = Set.empty + , freeRegs = Set.empty + } + else final HM.! subName + , unGen = \ctx -> {-trace ("unGen.jump: "<>show subName) $-} + let subAnalysis = analysisByLet ctx HM.! subName in + [|| + let _ = "jump" in + $$(TH.unsafeCodeCoerce $ + giveFreeRegs (freeRegs subAnalysis) $ + return (TH.VarE subName)) + {-ok-}$$(onReturn ctx) + $$(input ctx) + $$(liftTypedRaiseByLabel $ + onExceptionStackByLabel ctx + -- Pass only the labels raised by the 'defLet'. + `Map.intersection` + (mayRaise subAnalysis) + ) + ||] + } + call isRec (LetName subName) k = k + { genAnalysis = \final -> + if isRec + then GenAnalysis + { minReads = 0 + , mayRaise = Map.empty + , alwaysRaise = Set.empty + , freeRegs = Set.empty + } + else seqGenAnalysis $ (final HM.! subName) :| [ genAnalysis k final ] + , unGen = {-trace ("unGen.call: "<>show subName) $-} \ctx -> + -- let ks = (Map.keys (onExceptionStackByLabel ctx)) in + let subAnalysis = analysisByLet ctx HM.! subName in + [|| + -- let _ = $$(liftTypedString $ "call exceptByLet("<>show subName<>")="<>show (Map.keys (Map.findWithDefault Map.empty subName (exceptByLet ctx))) <> " onExceptionStackByLabel(ctx)="<> show ks) in + $$(TH.unsafeCodeCoerce $ + giveFreeRegs (freeRegs subAnalysis) $ + return (TH.VarE subName)) + {-ok-}$$(onReturnCode k ctx) + $$(input ctx) + $$(liftTypedRaiseByLabel $ + -- FIXME: maybe it should rather pass all the 'mayRaise' of 'subName' + -- and 'defaultCatch' be removed from 'makeDecl''s 'onExceptionStackByLabel'. + onExceptionStackByLabel ctx + -- Pass only the labels raised by the 'defLet'. + `Map.intersection` + (mayRaise subAnalysis) + ) + ||] + } + ret = Gen + { genAnalysisByLet = HM.empty + , genAnalysis = \_final -> GenAnalysis + { minReads = 0 + , mayRaise = Map.empty + , alwaysRaise = Set.empty + , freeRegs = Set.empty + } + , unGen = \ctx -> {-trace "unGen.ret" $-} + {-trace "unGen.ret.returnCode" $-} + returnCode ({-trace "unGen.ret.onReturn" $-} onReturn ctx) ctx + } + +takeFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp +takeFreeRegs frs k = go (Set.toList frs) + where + go [] = k + go (r:rs) = [| \ $(return (TH.VarP r)) -> $(go rs) |] + +giveFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp +giveFreeRegs frs k = go (Set.toList frs) + where + go [] = k + go (r:rs) = [| $(go rs) $(return (TH.VarE r)) |] + +-- | Like 'TH.liftString' but on 'TH.Code'. +-- Useful to get a 'TH.StringL' instead of a 'TH.ListE'. +liftTypedString :: String -> TH.Code TH.Q a +liftTypedString = TH.unsafeCodeCoerce . TH.liftString + +-- | Like 'TH.liftTyped' but adjusted to work on 'onExceptionStackByLabel' +-- which already contains 'CodeQ' terms. +-- Moreover, only the 'OnException' at the top of the stack +-- is needed and thus generated in the resulting 'CodeQ'. +-- +-- TODO: Use an 'Array' instead of a 'Map'? +liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a) +liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||] +liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) = + [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||] + +instance TH.Lift a => TH.Lift (Set a) where + liftTyped Set_.Tip = [|| Set_.Tip ||] + liftTyped (Set_.Bin s a l r) = [|| Set_.Bin $$(TH.liftTyped s) $$(TH.liftTyped a) $$(TH.liftTyped l) $$(TH.liftTyped r) ||] + +-- ** Type 'OnReturn' +-- | A continuation generated by 'onReturnCode' and later called by 'returnCode'. +type OnReturn st inp v a = + {-farthestInput-}Cursor inp -> + {-farthestExpecting-}Set SomeFailure -> + v -> + Cursor inp -> + ST st (Either (ParsingError inp) a) + +-- | Generate an 'OnReturn' continuation to be called with 'returnCode'. +-- Used when 'call' 'ret'urns. +-- The return 'v'alue is 'pushValue'-ed on the 'valueStack'. +onReturnCode :: + {-k-}Gen inp (v ': vs) a -> + GenCtx st inp vs a -> + CodeQ (OnReturn st inp v a) +onReturnCode k ctx = [|| + let _ = $$(liftTypedString $ "onReturn") in + \farInp farExp v !inp -> + $$({-trace "unGen.onReturnCode" $-} unGen k ctx + { valueStack = ValueStackCons ({-trace "unGen.onReturnCode.value" $-} splice [||v||]) (valueStack ctx) + , input = [||inp||] + , farthestInput = [||farInp||] + , farthestExpecting = [||farExp||] + , checkedHorizon = 0 + } + ) + ||] + +-- | Generate a call to the 'onReturnCode' continuation. +-- Used when 'call' 'ret'urns. +returnCode :: + CodeQ (OnReturn st inp v a) -> + GenCtx st inp (v ': vs) a -> + CodeQ (ST st (Either (ParsingError inp) a)) +returnCode k = \ctx -> {-trace "returnCode" $-} [|| + let _ = "resume" in + $$k + $$(farthestInput ctx) + $$(farthestExpecting ctx) + (let _ = "resume.genCode" in $$({-trace "returnCode.genCode" $-} + genCode $ valueStackHead $ valueStack ctx)) + $$(input ctx) + ||] + +-- ** Type 'OnException' +-- | A continuation generated by 'catch' and later called by 'raise' or 'fail'. +type OnException st inp a = + Exception -> + {-failInp-}Cursor inp -> + {-farInp-}Cursor inp -> + {-farExp-}Set SomeFailure -> + ST st (Either (ParsingError inp) a) + +-- TODO: some static infos should be attached to 'OnException' +-- to avoid comparing inputs when they're the same +-- and to improve 'checkedHorizon'. +onExceptionCode :: + CodeQ (Cursor inp) -> Horizon -> + Gen inp (Cursor inp : vs) a -> + GenCtx st inp vs a -> TH.CodeQ (OnException st inp a) +onExceptionCode resetInput resetCheckedHorizon k ctx = [|| + let _ = $$(liftTypedString $ "onException") in + \ !_exn !failInp !farInp !farExp -> + $$(unGen k ctx + -- Push 'input' and 'checkedHorizon' + -- as they were when entering the 'catch' or 'iter', + -- they will be available to 'loadInput', if any. + { valueStack = inputSave resetInput resetCheckedHorizon + `ValueStackCons` valueStack ctx + -- Note that 'onExceptionStackByLabel' is reset. + -- Move the input to the failing position. + , input = [||failInp||] + -- The 'checkedHorizon' at the 'raise's are not known here. + -- Nor whether 'failInp' is after 'checkedHorizon' or not. + -- Hence fallback to a safe value. + , checkedHorizon = 0 + -- Set those to the farthest error computed in 'raiseFailure'. + , farthestInput = [||farInp||] + , farthestExpecting = [||farExp||] + }) + ||] + +instance InstrJoinable Gen where + defJoin (LetName n) sub k = k + { unGen = \ctx -> + {-trace ("unGen.defJoin: "<>show n) $-} + TH.unsafeCodeCoerce [| + let $(return (TH.VarP n)) = $(TH.unTypeQ $ TH.examineCode [|| + -- Called by 'returnCode'. + \farInp farExp v !inp -> + $$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx + { valueStack = ValueStackCons (splice [||v||]) (valueStack ctx) + , input = [||inp||] + , farthestInput = [||farInp||] + , farthestExpecting = [||farExp||] + , checkedHorizon = 0 + {- FIXME: + , onExceptionStackByLabel = Map.mapWithKey + (\lbl () -> NE.singleton [||koByLabel Map.! lbl||]) + (mayRaise sub raiseLabelsByLetButSub) + -} + }) + ||]) + in $(TH.unTypeQ $ TH.examineCode $ + {-trace ("unGen.defJoin.expr: "<>show n) $-} + unGen k ctx) + |] + , genAnalysisByLet = + (genAnalysisByLet sub <>) $ + HM.insert n (genAnalysis sub) $ + genAnalysisByLet k + } + refJoin (LetName n) = Gen + { unGen = \ctx -> + {-trace ("unGen.refJoin: "<>show n) $-} + returnCode + (TH.unsafeCodeCoerce (return (TH.VarE n))) ctx + , genAnalysisByLet = HM.empty + , genAnalysis = \final -> + HM.findWithDefault + (error (show (n,HM.keys final))) + n final + } +instance InstrReadable Char Gen where + read fs p = checkHorizon . checkToken fs p +instance InstrReadable Word8 Gen where + read fs p = checkHorizon . checkToken fs p +instance InstrIterable Gen where + iter (LetName loopJump) loop done = Gen + { genAnalysisByLet = HM.unions + [ -- No need to give 'freeRegs' when 'call'ing 'loopJump' + -- because they're passed when 'call'ing 'iter'. + -- This avoids to passing those registers around. + HM.singleton loopJump (\final -> (genAnalysis loop final){freeRegs = Set.empty}) + , genAnalysisByLet loop + , genAnalysisByLet done + ] + , genAnalysis = \final -> + let loopAnalysis = genAnalysis loop final in + let doneAnalysis = genAnalysis done final in + GenAnalysis + { minReads = minReads doneAnalysis + , mayRaise = + Map.delete ExceptionFailure (mayRaise loopAnalysis) <> + mayRaise doneAnalysis + , alwaysRaise = + Set.delete ExceptionFailure (alwaysRaise loopAnalysis) <> + alwaysRaise doneAnalysis + , freeRegs = freeRegs loopAnalysis <> freeRegs doneAnalysis + } + , unGen = \ctx -> TH.unsafeCodeCoerce [| + let _ = "iter" in + let + onException loopInput = $(TH.unTypeCode $ onExceptionCode + (TH.unsafeCodeCoerce [|loopInput|]) 0 done ctx) + $(return $ TH.VarP loopJump) = \_callerOnReturn callerInput callerOnExceptionStackByLabel -> + $(TH.unTypeCode $ unGen loop ctx + { valueStack = ValueStackEmpty + , onExceptionStackByLabel = + Map.insertWith (<>) ExceptionFailure + (NE.singleton $ TH.unsafeCodeCoerce [|onException callerInput|]) + (onExceptionStackByLabel ctx) + , input = TH.unsafeCodeCoerce [|callerInput|] + -- FIXME: promote to compile time error? + , onReturn = TH.unsafeCodeCoerce [|error "invalid onReturn"|] + , checkedHorizon = 0 + }) + in $(TH.unTypeCode $ unGen (jump True (LetName loopJump)) ctx{valueStack=ValueStackEmpty}) + |] + } +instance InstrRegisterable Gen where + newRegister (UnscopedRegister r) k = k + { genAnalysis = \final -> + let analysis = genAnalysis k final in + analysis{freeRegs = Set.delete r $ freeRegs analysis} + , unGen = \ctx -> + let ValueStackCons v vs = valueStack ctx in + TH.unsafeCodeCoerce [| + do + let dupv = $(TH.unTypeCode $ genCode v) + $(return (TH.VarP r)) <- ST.newSTRef dupv + $(TH.unTypeCode $ unGen k ctx{valueStack=vs}) + |] + } + readRegister (UnscopedRegister r) k = k + { genAnalysis = \final -> + let analysis = genAnalysis k final in + analysis{freeRegs = Set.insert r $ freeRegs analysis} + , unGen = \ctx -> [|| do + sr <- ST.readSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r))) + $$(unGen k ctx{valueStack=ValueStackCons (splice [||sr||]) (valueStack ctx)}) + ||] + } + writeRegister (UnscopedRegister r) k = k + { genAnalysis = \final -> + let analysis = genAnalysis k final in + analysis{freeRegs = Set.insert r $ freeRegs analysis} + , unGen = \ctx -> + let ValueStackCons v vs = valueStack ctx in + [|| do + let dupv = $$(genCode v) + ST.writeSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r))) dupv + $$(unGen k ctx{valueStack=vs}) + ||] + } + +checkHorizon :: + forall inp vs a. + -- Those constraints are not used anyway + -- because (TH.Lift SomeFailure) uses 'inputTokenProxy'. + Ord (InputToken inp) => + Show (InputToken inp) => + TH.Lift (InputToken inp) => + NFData (InputToken inp) => + Typeable (InputToken inp) => + {-ok-}Gen inp vs a -> + Gen inp vs a +checkHorizon ok = ok + { genAnalysis = \final -> seqGenAnalysis $ + GenAnalysis { minReads = 0 + , mayRaise = Map.singleton ExceptionFailure () + , alwaysRaise = Set.empty + , freeRegs = Set.empty + } :| + [ genAnalysis ok final ] + , unGen = \ctx0@GenCtx{} -> + if checkedHorizon ctx0 >= 1 + then + [|| + let _ = $$(liftTypedString $ "checkHorizon.oldCheck: checkedHorizon="<>show (checkedHorizon ctx0)) in + $$(unGen ok ctx0{checkedHorizon = checkedHorizon ctx0 - 1}) + ||] + else + let minHoriz = minReads $ genAnalysis ok $ analysisByLet ctx0 in + if minHoriz == 0 + then + [|| + let _ = "checkHorizon.noCheck" in + $$(unGen ok ctx0) + ||] + else + [|| + let inp = $$(input ctx0) in + --let partialCont inp = + -- Factorize generated code for raising the "fail". + let readFail = $$(raiseException ctx0{input=[||inp||]} ExceptionFailure) in + $$( + let ctx = ctx0 + { onExceptionStackByLabel = + Map.adjust (\(_r:|rs) -> [||readFail||] :| rs) + ExceptionFailure (onExceptionStackByLabel ctx0) + , input = [||inp||] + } in + [|| + let _ = $$(liftTypedString $ "checkHorizon.newCheck: checkedHorizon="<>show (checkedHorizon ctx)<>" minHoriz="<>show minHoriz) in + if $$(moreInput ctx) + $$(if minHoriz > 1 + then [||$$shiftRight $$(TH.liftTyped (minHoriz - 1)) inp||] + else [||inp||]) + then $$(unGen ok ctx{checkedHorizon = minHoriz}) + else + let _ = $$(liftTypedString $ "checkHorizon.newCheck.fail") in + -- TODO: return a resuming continuation (like attoparsec's Partial) + -- This could be done with a Buffer for efficient backtracking: + -- http://www.serpentine.com/blog/2014/05/31/attoparsec/ + $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) minHoriz)) ctx) + ||] + ) + --in partialCont $$(input ctx0) + ||] + } + +-- | @('raiseFailure' ctx fs)@ raises 'ExceptionFailure' +-- with farthest parameters set to or updated with @(fs)@ +-- according to the relative position of 'input' wrt. 'farthestInput'. +raiseFailure :: + Cursorable (Cursor inp) => + GenCtx st inp cs a -> + TH.CodeQ (Set SomeFailure) -> + TH.CodeQ (ST st (Either (ParsingError inp) a)) +raiseFailure ctx fs = [|| + let failExp = $$fs in + let (# farInp, farExp #) = + case $$compareOffset $$(farthestInput ctx) $$(input ctx) of + LT -> (# $$(input ctx), failExp #) + EQ -> (# $$(farthestInput ctx), failExp <> $$(farthestExpecting ctx) #) + GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) + in $$(raiseException ctx ExceptionFailure) + ExceptionFailure + {-failInp-}$$(input ctx) farInp farExp + ||] +-- | @('raiseException' ctx exn)@ raises exception @(exn)@ +-- using any entry in 'onExceptionStackByLabel', or 'defaultCatch' if none. +raiseException :: + GenCtx st inp vs a -> Exception -> + CodeQ (Exception -> Cursor inp -> Cursor inp -> Set SomeFailure -> ST st (Either (ParsingError inp) a)) +raiseException ctx exn = + NE.head $ Map.findWithDefault + (NE.singleton (defaultCatch ctx)) + exn (onExceptionStackByLabel ctx) + +checkToken :: + Set SomeFailure -> + {-predicate-}Splice (InputToken inp -> Bool) -> + {-ok-}Gen inp (InputToken inp ': vs) a -> + Gen inp vs a +checkToken fs p ok = ok + { genAnalysis = \final -> seqGenAnalysis $ + GenAnalysis { minReads = 1 + , mayRaise = Map.singleton ExceptionFailure () + , alwaysRaise = Set.empty + , freeRegs = Set.empty + } :| + [ genAnalysis ok final ] + , unGen = \ctx -> {-trace "unGen.read" $-} [|| + let _ = "checkToken" in + let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in + $$(genCode $ + Prod.ifThenElse + (p Prod..@ splice [||c||]) + (splice $ unGen ok ctx + { valueStack = ValueStackCons (splice [||c||]) (valueStack ctx) + , input = [||cs||] + }) + (splice [|| + let _ = "checkToken.fail" in + $$(unGen (fail fs) ctx) + ||]) + )||] + } + diff --git a/tests/examples/ghc910/GenerateBug.hs b/tests/examples/ghc910/GenerateBug.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/GenerateBug.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +module Generate where + +onReturnCode = [|| + $$( + {- c1 -} unGen + ) + ||] + + +foo = + ( + {- c2 -} blah + ) diff --git a/tests/examples/ghc910/Generic.hs b/tests/examples/ghc910/Generic.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Generic.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Aeson.Deriving.Internal.Generic where + + +------------------------------------------------------------------------------------------ +-- A Single type for all Options fields +------------------------------------------------------------------------------------------ + +-- | Type-level representation of the Aeson Generic deriving 'Options'. +-- This representation is useful for explicitly setting all options. +data GenericOptions + :: fieldLabelModifier + -> tagSingleConstructors + -> Type + +instance + ( All StringFunction [fieldLabelModifier, constructorTagModifier] + , ToSumEncoding sumEncoding + , All KnownBool + [ allNullaryToStringTag + , tagSingleConstructors + ] + ) => ToAesonOptions + (GenericOptions + (FieldLabelModifier := fieldLabelModifier) + (ConstructorTagModifier := constructorTagModifier) + (TagSingleConstructors := tagSingleConstructors)) where + toAesonOptions _ = defaultOptions + { fieldLabelModifier = stringFunction $ Proxy @fieldLabelModifier + , tagSingleConstructors = boolVal $ Proxy @tagSingleConstructors + } + + + diff --git a/tests/examples/ghc910/Lexing.hs b/tests/examples/ghc910/Lexing.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Lexing.hs @@ -0,0 +1,7 @@ +module TuplePat where + +next + ( steps -- c1 + , ys -- c2 + ) x -- c3 + = (steps, x, ys) diff --git a/tests/examples/ghc910/LinearLet.hs b/tests/examples/ghc910/LinearLet.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/LinearLet.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE LinearTypes #-} + +module LinearLet where + +import GHC.Types + +f :: a -> a +f x = let %1 y = x in y + +f' :: a %1 -> a +f' x = let %1 y = x in y + +f'' :: a %1 -> a +f'' x = let y = x in y + +g :: a -> (a, a, a) +g x = let %'Many y = x in (x, x, x) + +h :: a %1 -> a +h x = y + where %1 y = x + +h' :: a %1 -> a +h' x = y + where y = x + +i :: Maybe a %1 -> a +i x = let %1 !(Just y) = x in y + +j :: (a, b) %1 -> (b, a) +j x = let !(y, z) = x in (z, y) + +-- The non-variable pattern let binding cannot be linear because it's inferred as +-- polymorphic. See Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind +-- +-- The local let binding is inferred as polymorphic despite MonoLocalBinds +-- because it is closed. This behaviour is not very problematic (this will never +-- need to be linear), but can be a little surprising. +k :: a -> (a, Bool) +k x = let !(f, b) = ((\y -> y), b) in (f x, b) + +-- let !y = (without a multiplicity annotation) uses the same code path as let y = +-- (FunBind) not that of pattern bindings (PatBind). The desugaring of a strict +-- pattern involves `seq`, with which we need to be careful when dealing with +-- linear types. +l :: a %1 -> a +l x = let !y = x in y + diff --git a/tests/examples/ghc910/Manager.hs b/tests/examples/ghc910/Manager.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Manager.hs @@ -0,0 +1,6 @@ +module Manager where + +expandProcess + outCHAs -- comment + locationDescr = + blah diff --git a/tests/examples/ghc910/MonoBacktrackPrio.hs b/tests/examples/ghc910/MonoBacktrackPrio.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/MonoBacktrackPrio.hs @@ -0,0 +1,4 @@ +module CHR.Solve.MonoBacktrackPrio where + +fun (Con {- c1 -} a b) + = undefined diff --git a/tests/examples/ghc910/Normalform.hs b/tests/examples/ghc910/Normalform.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Normalform.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternGuards #-} +module Normalform where + +nfCom = case expr of + x :*: y -- comment + | x' <= y' -> x' :*: y' + _ -> blah + diff --git a/tests/examples/ghc910/Operator1.hs b/tests/examples/ghc910/Operator1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Operator1.hs @@ -0,0 +1,7 @@ +module Operator1 where + +main :: IO () +main = do + putStrLn $ show {- c3 -} $ {- c4 -} foo {- c1 -} || {- c2 -} bar + +{-# RULES "print" forall x. putStrLn $ show $ x = print $ x #-} diff --git a/tests/examples/ghc910/P_IO_data.hs b/tests/examples/ghc910/P_IO_data.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/P_IO_data.hs @@ -0,0 +1,1 @@ +module P_IO_data {- c1 -} where diff --git a/tests/examples/ghc910/PostProcess.hs b/tests/examples/ghc910/PostProcess.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/PostProcess.hs @@ -0,0 +1,6 @@ +module PostProcess where + +fromDecl (PatBind + -- comment + pat + rhs) = undefined diff --git a/tests/examples/ghc910/PrettyPrinter.hs b/tests/examples/ghc910/PrettyPrinter.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/PrettyPrinter.hs @@ -0,0 +1,5 @@ +module PrettyPrinter where + +prPrintData True {- use STL -} _ = + render + diff --git a/tests/examples/ghc910/ProjectionLike.hs b/tests/examples/ghc910/ProjectionLike.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/ProjectionLike.hs @@ -0,0 +1,6 @@ +module Agda.TypeChecking.ProjectionLike where + +makeProjection = + case defn of + Function{funMutual = VV, -- comment + funAbstr = ConcreteDef} -> undefined diff --git a/tests/examples/ghc910/ScriptSyntax.hs b/tests/examples/ghc910/ScriptSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/ScriptSyntax.hs @@ -0,0 +1,3 @@ +module ScriptSyntax where + +scriptLink = manyTill anyChar (try $ do char ':'; char ']';) diff --git a/tests/examples/ghc910/Sum.hs b/tests/examples/ghc910/Sum.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Sum.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Sum where + +-- base +import GHC.Generics +import Data.Typeable +-- aeson +import Data.Aeson (FromJSON, ToJSON) + +-- containers +import qualified Data.Map as Map + +-- hspec +import Test.Hspec + +-- QuickCheck +import Test.QuickCheck hiding (Result, Success) + +-- quickcheck-arbitrary-adt +import Test.QuickCheck.Arbitrary.ADT +import Test.Aeson.Internal.ADT.GoldenSpecs + +-- servant +import Servant.API + +-- ocaml-export +import OCaml.Export hiding (mkGoldenFiles) +import Util + + +type SumPackage + = OCamlPackage "sum" NoDependency :> + (OCamlModule '["OnOrOff"] :> OnOrOff + :<|> OCamlModule '["NameOrIdNumber"] :> NameOrIdNumber + :<|> OCamlModule '["SumVariant"] :> SumVariant + :<|> OCamlModule '["WithTuple"] :> WithTuple + :<|> OCamlModule '["SumWithRecord"] :> SumWithRecord -- :> SumWithRecordMixed + :<|> OCamlModule '["Result"] :> Result TypeParameterRef0 TypeParameterRef1 -- :> ComplexResult TypeParameterRef0 TypeParameterRef1 TypeParameterRef2 + :<|> OCamlModule '["NewType"] :> NewType) + +compareInterfaceFiles :: FilePath -> SpecWith () +compareInterfaceFiles = compareFiles "test/interface" "sum" True + +mkGolden :: forall a. (ToADTArbitrary a, ToJSON a) => Proxy a -> IO () +mkGolden Proxy = mkGoldenFileForType 10 (Proxy :: Proxy a) "test/interface/golden/golden/sum" + +mkGoldenFiles :: IO () +mkGoldenFiles = do + mkGolden (Proxy :: Proxy OnOrOff) + mkGolden (Proxy :: Proxy NameOrIdNumber) + mkGolden (Proxy :: Proxy SumVariant) + mkGolden (Proxy :: Proxy WithTuple) + mkGolden (Proxy :: Proxy SumWithRecord) + mkGolden (Proxy :: Proxy (Result TypeParameterRef0 TypeParameterRef1)) + mkGolden (Proxy :: Proxy NewType) + +spec :: Spec +spec = do + runIO mkGoldenFiles + runGoldenSpec (Proxy :: Proxy SumPackage) 10 "test/interface/golden/golden/sum" + + let dir = "test/interface/temp" + + -- create spec to be tested against servant + runIO $ + mkPackage + (Proxy :: Proxy SumPackage) + (PackageOptions dir "sum" Map.empty True $ + Just $ SpecOptions + "__tests__/sum-servant" + "golden/sum" + (Just "http://localhost:8082")) + + -- create spec to be tested against files only + runIO $ + mkPackage + (Proxy :: Proxy SumPackage) + (PackageOptions dir "sum" Map.empty True $ + Just $ SpecOptions + "__tests__/sum" + "golden/sum" + Nothing) + + describe "OCaml Declaration with Interface: Sum Types" $ do + compareInterfaceFiles "OnOrOff" + compareInterfaceFiles "NameOrIdNumber" + compareInterfaceFiles "SumVariant" + compareInterfaceFiles "WithTuple" + compareInterfaceFiles "SumWithRecord" + compareInterfaceFiles "Result" + compareInterfaceFiles "NewType" + +data OnOrOff = On | Off + deriving (Show,Eq,Generic,OCamlType,ToJSON,FromJSON) + +instance Arbitrary OnOrOff where + arbitrary = elements [On, Off] + +instance ToADTArbitrary OnOrOff + +data NameOrIdNumber = Name String | IdNumber Int + deriving (Show, Eq, Generic, OCamlType,ToJSON,FromJSON) + +instance Arbitrary NameOrIdNumber where + arbitrary = oneof [Name <$> arbitrary, IdNumber <$> arbitrary] + +instance ToADTArbitrary NameOrIdNumber + +data Result a b + = Success a + | Error b + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +instance Arbitrary (Result TypeParameterRef0 TypeParameterRef1) where + arbitrary = oneof [Success <$> arbitrary, Error <$> arbitrary] + +instance ToADTArbitrary (Result TypeParameterRef0 TypeParameterRef1) + +instance (Typeable a, OCamlType a, Typeable b, OCamlType b) => (OCamlType (Result a b)) + +data ComplexResult a b c + = CR0 a + | CR1 a b + | CR2 b (c,a) + | CR3 String b Int a + | CR4 { cr4b :: b, cr4ac :: (a,c) } + | CR5 + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +instance Arbitrary (ComplexResult TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) where + arbitrary = + oneof + [ CR0 <$> arbitrary + , CR1 <$> arbitrary <*> arbitrary + , CR2 <$> arbitrary <*> arbitrary + , CR3 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , CR4 <$> arbitrary <*> arbitrary + , pure CR5 + ] + +instance ToADTArbitrary (ComplexResult TypeParameterRef0 TypeParameterRef1 TypeParameterRef2) + +instance (Typeable a, OCamlType a, Typeable b, OCamlType b, Typeable c, OCamlType c) => (OCamlType (ComplexResult a b c)) + +data SumVariant + = HasNothing + | HasSingleInt Int + | HasSingleTuple (Int,Int) + | HasMultipleInts Int Int + | HasMultipleTuples (Int,Int) (Int,Int) + | HasMixed Int String Double + | HasNameOrIdNumber NameOrIdNumber Int + deriving (Show,Eq,Generic, OCamlType, ToJSON, FromJSON) + +instance Arbitrary SumVariant where + arbitrary = + oneof + [ pure HasNothing + , HasSingleInt <$> arbitrary + , HasSingleTuple <$> arbitrary + , HasMultipleInts <$> arbitrary <*> arbitrary + , HasMultipleTuples <$> arbitrary <*> arbitrary + , HasMixed <$> arbitrary <*> arbitrary <*> arbitrary + , HasNameOrIdNumber <$> arbitrary <*> arbitrary + ] + +instance ToADTArbitrary SumVariant + + +type Tuple + = (Int,Int) + +data WithTuple = WithTuple Tuple + deriving (Show,Eq,Generic, OCamlType, ToJSON, FromJSON) + +instance Arbitrary WithTuple where + arbitrary = WithTuple <$> arbitrary + +instance ToADTArbitrary WithTuple + +data SumWithRecord + = A1 {a1 :: Int} + | B2 {b2 :: String, b3 :: Int} + deriving (Show,Eq,Generic, OCamlType, ToJSON, FromJSON) + +instance Arbitrary SumWithRecord where + arbitrary = + oneof + [ A1 <$> arbitrary + , B2 <$> arbitrary <*> arbitrary + ] + +instance ToADTArbitrary SumWithRecord + +data SumWithRecordMixed + = SRM1 {srm1 :: Int} + | SRM2 + | SRM3 {srm2 :: String, srm3 :: Float} + | SRM4 Int (String, Double) + deriving (Show,Eq,Generic, OCamlType, ToJSON, FromJSON) + +instance Arbitrary SumWithRecordMixed where + arbitrary = + oneof + [ SRM1 <$> arbitrary + , pure SRM2 + , SRM3 <$> arbitrary <*> arbitrary + , SRM4 <$> arbitrary <*> arbitrary + ] + +instance ToADTArbitrary SumWithRecordMixed + + +newtype NewType + = NewType Int + deriving (Show,Eq,Generic,OCamlType, ToJSON, FromJSON) + +instance Arbitrary NewType where + arbitrary = NewType <$> arbitrary + +instance ToADTArbitrary NewType + + +{- +introduce Enumerator +extra type is made +but anything coming after the enumerator is broken + + + + +λ> toOCamlType (Proxy :: Proxy (ComplexResult TypeParameterRef0 TypeParameterRef1 TypeParameterRef2)) + +OCamlDatatype (HaskellTypeMetaData "ComplexResult" "Sum" "main") "ComplexResult" (OCamlValueConstructor (MultipleConstructors [MultipleConstructors [NamedConstructor "CR0" (OCamlTypeParameterRef "a0"),MultipleConstructors [NamedConstructor "CR1" (Values (OCamlTypeParameterRef "a0") (OCamlTypeParameterRef "a1")),NamedConstructor "CR2" (Values (OCamlTypeParameterRef "a1") (OCamlPrimitiveRef (OTuple2 (OCamlDatatype (HaskellTypeMetaData "a2" "OCaml.BuckleScript.Types" "ocaml-export") "a2" (OCamlValueConstructor (NamedConstructor "a2" (OCamlTypeParameterRef "a2")))) (OCamlDatatype (HaskellTypeMetaData "a0" "OCaml.BuckleScript.Types" "ocaml-export") "a0" (OCamlValueConstructor (NamedConstructor "a0" (OCamlTypeParameterRef "a0")))))))]],MultipleConstructors [NamedConstructor "CR3" (Values (Values (OCamlPrimitiveRef (OList (OCamlPrimitive OChar))) (OCamlTypeParameterRef "a1")) (Values (OCamlPrimitiveRef OInt) (OCamlTypeParameterRef "a0"))),MultipleConstructors [RecordConstructor "CR4" (Values (OCamlField "cr4b" (OCamlTypeParameterRef "a1")) (OCamlField "cr4ac" (OCamlPrimitiveRef (OTuple2 (OCamlDatatype (HaskellTypeMetaData "a0" "OCaml.BuckleScript.Types" "ocaml-export") "a0" (OCamlValueConstructor (NamedConstructor "a0" (OCamlTypeParameterRef "a0")))) (OCamlDatatype (HaskellTypeMetaData "a2" "OCaml.BuckleScript.Types" "ocaml-export") "a2" (OCamlValueConstructor (NamedConstructor "a2" (OCamlTypeParameterRef "a2")))))))),NamedConstructor "CR5" OCamlEmpty]]])) + +λ> toOCamlType (Proxy :: Proxy SumWithRecord) + +OCamlDatatype (HaskellTypeMetaData "SumWithRecord" "Sum" "main") "SumWithRecord" (OCamlSumOfRecordConstructor "SumWithRecord" (MultipleConstructors [RecordConstructor "A1" (OCamlField "a1" (OCamlPrimitiveRef OInt)),RecordConstructor "B2" (Values (OCamlField "b2" (OCamlPrimitiveRef (OList (OCamlPrimitive OChar)))) (OCamlField "b3" (OCamlPrimitiveRef OInt)))])) + +-} + diff --git a/tests/examples/ghc910/T14032a.hs b/tests/examples/ghc910/T14032a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/T14032a.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell, ExplicitNamespaces #-} +module T14032a where + +$([d| + infix 4 type :*: + infix 4 data :*: + data a :*: b = a :*: b + |]) + diff --git a/tests/examples/ghc910/T17594a.hs b/tests/examples/ghc910/T17594a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/T17594a.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ScopedTypeVariables, ImpredicativeTypes, TemplateHaskell, LambdaCase, TypeAbstractions, BlockArguments #-} +module T17594a where + +import qualified Language.Haskell.TH as TH + +id1 :: forall a. a -> a +id1 @t x = x + +id2 :: forall a. Bool -> a -> a +id2 @t False x = x :: t +id2 True x = x + +id3 :: a -> a +id3 @t x = x :: t + +id4 :: forall a b c. a -> b -> c -> forall d e f. d -> e -> f -> (a, b, c, d, e, f) +id4 @t1 @t2 @t3 x1 x2 x3 @t4 @t5 @t6 x4 x5 x6 = (x1 :: t1, x2 :: t2, x3 :: t3, x4 :: t4, x5 :: t5, x6 :: t6) + +id5 :: (forall a. a -> a, forall a. a -> a) +id5 = (\ @t x -> x, id1) + +id6 :: [forall a. a -> a] +id6 = [\ @t x -> x, id1, id3, fst id5, snd id5, id8] + +id7 :: a -> a +id7 @($(TH.varT (TH.mkName "t"))) x = x :: t + +id_r_N_t :: (forall a. Bool -> a -> a) -> a -> a +id_r_N_t @t f = f @t False + +id8 = id_r_N_t (\ @t _ x -> x :: t) + +id9 :: forall a. a -> a +id9 = id_r_N_t \cases + @t True x -> x :: t + False x -> x + diff --git a/tests/examples/ghc910/T23927.hs b/tests/examples/ghc910/T23927.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/T23927.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE GADTs, TemplateHaskell, TypeFamilies #-} + +import Language.Haskell.TH (runQ) +import Language.Haskell.TH.Ppr (pprint) + +main = + runQ [d| + class C a where {data D a; f :: a -> D a}; + instance C Int where {data D Int where {C1 :: Int -> D Int; C2 :: D Int}; f = C1} + |] + >>= putStrLn . pprint + diff --git a/tests/examples/ghc910/T8761.hs b/tests/examples/ghc910/T8761.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/T8761.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE TemplateHaskell, RankNTypes, GADTs, PatternSynonyms #-} + +module T8761 where + +{- Testsuite for pattern synonyms as implemented by ticket #8761 -} + +import Control.Monad +import Language.Haskell.TH +import System.IO + +data Ex where MkEx :: forall a. a -> Ex +data ExProv where MkExProv :: forall a. (Show a) => a -> ExProv +data UnivProv a where MkUnivProv :: forall a. (Show a) => a -> UnivProv a + +{- Test manual construction and pretty printing of pattern synonyms -} +do + [qx1,qy1,qz1] <- mapM (\i -> newName $ "x" ++ show i) [1,2,3] + let nm1 = mkName "Q1" + prefixPat = patSynD nm1 (prefixPatSyn [qx1,qy1,qz1]) unidir + (tupP [tupP [varP qx1, varP qy1], listP [varP qz1], wildP, wildP]) + + [qx2,qy2] <- mapM (\i -> newName $ "x" ++ show i) [1,2] + let nm2 = mkName "Q2" + infixPat = patSynD nm2 (infixPatSyn qx2 qy2) implBidir + (tupP [tupP [varP qx2, varP qy2]]) + + let nm3 = mkName "Q3" + [qx3,qy3,qz3] = map mkName ["qx3", "qy3", "qz3"] + patP = tupP [tupP [varP qx3, varP qy3], listP [varP qz3]] + patE = tupE [tupE [varE qx3, varE qy3], listE [varE qz3]] + cls = clause ([varP qx3, varP qy3, varP qz3]) (normalB patE) [] + recordPat = patSynD nm3 (recordPatSyn [qx3,qy3,qz3]) + (explBidir [cls]) patP + + pats <- sequence [prefixPat, infixPat, recordPat] + -- pretty print the pattern synonyms: + mapM_ (runIO . hPutStrLn stderr . pprint) pats + -- splice in the pattern synonyms + return pats + +{- Test prefix pattern synonyms -} +[d| + pattern P1 x y z <- ((x,y), [z], _, _) -- unidirectional pattern + pattern P2 x y z = ((x,y), [z]) -- implicit bidirectional pattern + pattern P3 x y z <- ((x,y), [z]) where -- explicit bidirectional pattern + P3 x y z = ((x,y), [z]) |] + +{- Test infix pattern synonyms -} +[d| + pattern x :*: y <- ((x,_), [y]) + pattern x :+: y = (x,y) + pattern x :~: y <- (x,y) where + x :~: y = (x,y) |] + +{- Test record pattern synonyms -} +[d| + pattern R1 {x1, y1} <- ((x1,_), [y1]) + getX1 = x1 ((1, 2), [3]) -- should yield 1 + getY1 = y1 ((1, 2), [3]) -- should yield 3 + pattern R2 {x2, y2} = (x2, [y2]) + pattern R3 {x3, y3} <- (x3, [y3]) where + R3 x y = (x, [y]) |] + +--x1 = "no, no, no" +--y1 = "no, no, no" + +getX1' = x1 ((1, 2), [3]) -- should yield 1 +getY1' = y1 ((1, 2), [3]) -- should yield 3 + +{- Test splicing unidirectional pattern synonyms with different types -} +[d| + pattern P :: Bool + pattern P <- True + + pattern Pe :: () => forall a. a -> Ex + pattern Pe x <- MkEx x + + pattern Pu :: forall a. a -> a + pattern Pu x <- x + + pattern Pue :: forall a. () => forall b. a -> b -> (a, Ex) + pattern Pue x y <- (x, MkEx y) + + pattern Pur :: forall a. (Num a, Eq a) => a -> [a] + pattern Pur x <- [x, 1] + + pattern Purp :: forall a b. (Num a, Eq a) => + Show b => a -> b -> ([a], UnivProv b) + pattern Purp x y <- ([x, 1], MkUnivProv y) + + pattern Pure :: forall a. (Num a, Eq a) => forall b. a -> b -> ([a], Ex) + pattern Pure x y <- ([x, 1], MkEx y) + + pattern Purep :: forall a. (Num a, Eq a) => + forall b. Show b => a -> b -> ([a], ExProv) + pattern Purep x y <- ([x, 1], MkExProv y) + + pattern Pep :: () => forall a. Show a => a -> ExProv + pattern Pep x <- MkExProv x + + pattern Pup :: forall a. () => Show a => a -> UnivProv a + pattern Pup x <- MkUnivProv x + + pattern Puep :: forall a. () => forall b. (Show b) => a -> b -> (ExProv, a) + pattern Puep x y <- (MkExProv y, x) |] + +{- Test reification of different pattern synonyms and their types -} +do + infos <- mapM reify [ 'P, 'Pe, 'Pu, 'Pue, 'Pur, 'Purp + , 'Pure, 'Purep, 'Pep, 'Pup, 'Puep ] + mapM_ (runIO . hPutStrLn stderr . pprint) infos + -- NB. use stderr rather than stdout, because GHC does not + -- guarantee to flush stdout after TH code. In particular when + -- the output is going to a file, and we're using GHC with the + -- runtime linker or with -fexternal-interpreter, stdout will not + -- get flushed. + [d| theAnswerIs = 42 |] + diff --git a/tests/examples/ghc910/Test138.hs b/tests/examples/ghc910/Test138.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/Test138.hs @@ -0,0 +1,6 @@ +-- c1 +module Main + ( Test(Test, a, b) + , foo -- c2 + ) -- c3 + where diff --git a/tests/examples/ghc910/type-operators1-four-out.hs b/tests/examples/ghc910/type-operators1-four-out.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc910/type-operators1-four-out.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} + +class + a -- Before operator + :+ + b -- After operator diff --git a/tests/examples/ghc912/Fff.hs b/tests/examples/ghc912/Fff.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc912/Fff.hs @@ -0,0 +1,8 @@ +yes p1 p2 + | g1 = e1 + + +foo = 3 + where + yes p1 p2 + | g1 = e1 diff --git a/tests/examples/ghc912/Module.hs b/tests/examples/ghc912/Module.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc912/Module.hs @@ -0,0 +1,7 @@ +module Module where + +fff = do + let { + ; (a, b) = foo + } + pure () diff --git a/tests/examples/ghc912/Operator.hs b/tests/examples/ghc912/Operator.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc912/Operator.hs @@ -0,0 +1,54 @@ +module Operator where + +main :: IO () +main = do + print $ 3 + 4 + -- lets make sure + print $ foo || + -- that comments end up in the right place + bar || + baz && + -- even this one + quux + + -- lets also make sure + print $ foo + -- that these comments end up in the right place + || bar + || baz + -- even when the operator is leading + && quux + + return ({- comment -} x >= 1 || y >= 2) + + print $ foo || bar + print $ foo || bar + print $ foo || bar + print $ {- comment here -} foo || bar + print $ foo {- comment here -} || bar + print $ foo || {- comment here -} bar + print $ foo || bar {- comment here -} + + print $ foo || bar + print $ foo || bar + +{-# RULES "print" forall x. putStrLn $ show $ x = print $ x #-} + +f :: Int -> Bool +f x = x == 2 + +g :: Int -> Bool +g y = (y == 2) /= False + +roundtrip :: IO [a] +roundtrip = return $ mconcat + [ timeToText $ time_enrolled - mod time_enrolled t + , ":" + ] + +-- Ensure local fixity declarations are handled properly +(.@@@) :: (a -> b) -> a -> b +f .@@@ x = f x + +infixr 0 .@@@ +{-# RULES "printAt" forall x. putStrLn .@@@ show .@@@ x = print $ x #-} diff --git a/tests/examples/ghc912/T23501a.hs b/tests/examples/ghc912/T23501a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc912/T23501a.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds, NoListTuplePuns #-} + +module T23501a where + +import Prelude.Experimental (List, Unit) +import Data.Kind (Type, Constraint) + +---------------------------- +-- Class declarations -- +---------------------------- + +class C1 (_ :: k) _ -- no SAKS + where f1 :: k -> Unit + +f1' :: C1 @k a b => k -> Unit +f1' @_ @a @b = f1 @_ @a @b + +type C2 :: k1 -> k2 -> Constraint +class C2 (_ :: k) _ where + f2 :: k -> Unit + +f2' :: C2 @k1 @k2 a b => k1 -> Unit +f2' @_ @_ @a @b = f2 @_ @_ @a @b + +type C3 :: k1 -> k2 -> Constraint +class C3 @k @_ _ _ where + f3 :: k -> Unit + +f3' :: C3 @k1 @k2 a b => k1 -> Unit +f3' @_ @_ @a @b = f3 @_ @_ @a @b + +--------------------------- +-- Data declarations -- +--------------------------- + +data D1 k (_ :: k) _ -- no SAKS + where MkD1 :: k -> D1 k a b + +mkD1 :: k -> D1 k a b +mkD1 = MkD1 + +type D2 :: forall (k1 :: Type) -> k1 -> k2 -> Type +data D2 k (_ :: k) _ where + MkD2 :: k -> D2 k a b + +mkD2 :: k -> D2 k a b +mkD2 = MkD2 + +type D3 :: k1 -> k2 -> Type +data D3 @k @_ _ _ = MkD3 k + +data MProxy (_ :: Type) = MPrx +data CProxy (_ :: k -> Constraint) = CPrx + +type Rec :: (k -> Type) -> List k -> Type +data Rec _ _ where + RNil :: Rec f [] + (:&) :: f x -> Rec f xs -> Rec f (x:xs) + +------------------ +-- Newtypes -- +------------------ + +newtype N1 k (_ :: k) _ -- no SAKS + = MkN1 k + +mkN1 :: k -> N1 k a b +mkN1 = MkN1 + +type N2 :: forall (k1 :: Type) -> k1 -> k2 -> Type +newtype N2 k (_ :: k) _ = MkN2 k + +mkN2 :: k -> N2 k a b +mkN2 = MkN2 + +---------------------------- +-- Open type families -- +---------------------------- + +type family OTF1 (_ :: Type -> Type) _ -- no SAKS + +type instance OTF1 f x = f x + +otf1 :: OTF1 Maybe Int -> Int +otf1 Nothing = 0 +otf1 (Just x) = x + +type OTF2 :: (Type -> Type) -> Type -> Type +type family OTF2 (_ :: Type -> Type) _ + +type instance OTF2 f x = f x + +otf2 :: OTF2 Maybe Int -> Int +otf2 Nothing = 0 +otf2 (Just x) = x + +------------------------------ +-- Closed type families -- +------------------------------ + +type family CTF1 (_ :: Type -> Type) _ -- no SAKS + where CTF1 f x = f x + +ctf1 :: CTF1 Maybe Int -> Int +ctf1 Nothing = 0 +ctf1 (Just x) = x + +type CTF2 :: (Type -> Type) -> Type -> Type +type family CTF2 (_ :: Type -> Type) _ where + CTF2 f x = f x + +ctf2 :: CTF2 Maybe Int -> Int +ctf2 Nothing = 0 +ctf2 (Just x) = x + +type CTF3 :: k1 -> k2 -> Type +type family CTF3 @_ @k _ _ + where CTF3 @_ @k _ _ = k + +ctf3 :: CTF3 a True -> Bool +ctf3 = id + +----------------------- +-- Type synonyms -- +----------------------- + +type T1 (_ :: Type -> Type) _ = () -- no SAKS + +type T2 :: (Type -> Type) -> k -> Type +type T2 (_ :: Type -> Type) _ = Unit + +type T3 :: k1 -> k2 -> Type +type T3 @_ @k _ _ = k + +type FConst _ = () + diff --git a/tests/examples/ghc914/A.8.hs b/tests/examples/ghc914/A.8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc914/A.8.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE NamedDefaults #-} +module A ( + Stringify(..), + default Stringify, + Bingify(..), + default Bingify + ) where + +class Stringify a where + stringify :: a -> String + +instance Stringify Int where + stringify n = "Int" + +instance Stringify Bool where + stringify b = "Bool" + +instance Stringify [Char] where + stringify s = "String" + +class Bingify a where + bingify :: a -> String + +instance Bingify Int where + bingify n = "Int" + +instance Bingify Bool where + bingify b = "Bool" + +instance Bingify [Char] where + bingify s = "String" + +default Stringify (Int) +default Bingify (Int) + diff --git a/tests/examples/ghc914/SI01.hs b/tests/examples/ghc914/SI01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc914/SI01.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI01 where + +-- Using a splice imported thing, inside an untyped and typed splice works +import splice SI01A + +main :: IO () +main = $( sid [| pure () |]) >> $$( sid [|| pure () ||]) + diff --git a/tests/examples/ghc914/SI26.hs b/tests/examples/ghc914/SI26.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc914/SI26.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module SI26 where + +-- Test using 'quote' as a post-qualifier in imports +import Prelude quote +import Prelude quote qualified as P +import quote Prelude qualified as P2 + +-- Test using 'splice' as a post-qualifier in imports +import Language.Haskell.TH.Syntax splice + +import splice Language.Haskell.TH.Syntax qualified as TH +import Language.Haskell.TH.Syntax splice qualified as TH2 + +-- Use the imported modules +testQuote = [| id |] +testQuote2 = [| P.id |] +testQuote3 = [| P2.id |] + +testSplice = $(lift "Hello from splice") +testSplice2 = $(TH.lift "Hello from splice2") +testSplice3 = $(TH2.lift "Hello from splice3") + diff --git a/tests/examples/ghc92/AdhocRule.hs b/tests/examples/ghc92/AdhocRule.hs deleted file mode 100644 --- a/tests/examples/ghc92/AdhocRule.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# RULES "adhoc1" forall r i. r { rOne = i } = r { rOne = i + 12 } #-} -{-# RULES "adhoc2" forall s. Record { rTwo = s } = Record { rTwo = s ++ s } #-} - diff --git a/tests/examples/ghc92/Async.hs b/tests/examples/ghc92/Async.hs deleted file mode 100644 --- a/tests/examples/ghc92/Async.hs +++ /dev/null @@ -1,11 +0,0 @@ - -asyncUsing :: (IO () -> IO ThreadId) - -> IO a -> IO (Async a) -asyncUsing doFork = \action -> do - var <- newEmptyTMVarIO - -- t <- forkFinally action (\r -> atomically $ putTMVar var r) - -- slightly faster: - t <- mask $ \restore -> - doFork $ try (restore action) >>= atomically . putTMVar var - return (Async t (readTMVar var)) - diff --git a/tests/examples/ghc92/BalanceComments1.hs b/tests/examples/ghc92/BalanceComments1.hs deleted file mode 100644 --- a/tests/examples/ghc92/BalanceComments1.hs +++ /dev/null @@ -1,11 +0,0 @@ -module BalanceComments1 where - --- Captured in https://gitlab.haskell.org/ghc/ghc/-/issues/20297 --- The '-- do stuff' comment is attached to the wrong annotation - --- Chris done comment attachment problem -foo = x - where -- do stuff - doStuff = do stuff -x = 1 -stuff = 4 diff --git a/tests/examples/ghc92/Binary.hs b/tests/examples/ghc92/Binary.hs deleted file mode 100644 --- a/tests/examples/ghc92/Binary.hs +++ /dev/null @@ -1,259 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} - -module Data.Curve.Binary - ( module Data.Curve - , Point(..) - -- * Binary curves - , BCurve(..) - , BPoint - -- ** Binary affine curves - , BACurve(..) - , BAPoint - -- ** Binary projective curves - , BPCurve(..) - , BPPoint - ) where - -import Protolude - -import Data.Field.Galois as F (GaloisField, PrimeField, frob, quad) -import GHC.Natural (Natural) -import Text.PrettyPrint.Leijen.Text (Pretty(..)) - -import Data.Curve - -------------------------------------------------------------------------------- --- Binary form -------------------------------------------------------------------------------- - --- | Binary points. -type BPoint = Point 'Binary - --- | Binary curves. -class (GaloisField q, PrimeField r, Curve 'Binary c e q r) => BCurve c e q r where - {-# MINIMAL a_, b_, h_, p_, r_ #-} - a_ :: BPoint c e q r -> q -- ^ Coefficient @A@. - b_ :: BPoint c e q r -> q -- ^ Coefficient @B@. - h_ :: BPoint c e q r -> Natural -- ^ Curve cofactor. - p_ :: BPoint c e q r -> Natural -- ^ Curve polynomial. - r_ :: BPoint c e q r -> Natural -- ^ Curve order. - -------------------------------------------------------------------------------- --- Affine coordinates -------------------------------------------------------------------------------- - --- | Binary affine points. -type BAPoint = BPoint 'Affine - --- | Binary affine curves @y^2 + xy = x^3 + Ax^2 + B@. -class BCurve 'Affine e q r => BACurve e q r where - {-# MINIMAL gA_ #-} - gA_ :: BAPoint e q r -- ^ Curve generator. - --- Binary affine curves are elliptic curves. -instance BACurve e q r => Curve 'Binary 'Affine e q r where - - data instance Point 'Binary 'Affine e q r = A q q -- ^ Affine point. - | O -- ^ Infinite point. - deriving (Eq, Generic, NFData, Read, Show) - - add p O = p - add O q = q - add (A x1 y1) (A x2 y2) - | xx == 0 = O - | otherwise = A x3 y3 - where - a = a_ (witness :: BAPoint e q r) - xx = x1 + x2 - yy = y1 + y2 - l = yy / xx - x3 = l * (l + 1) + xx + a - y3 = l * (x1 + x3) + x3 + y1 - {-# INLINABLE add #-} - - char = const 2 - {-# INLINABLE char #-} - - cof = h_ - {-# INLINABLE cof #-} - - dbl O = O - dbl (A x y) - | x == 0 = O - | otherwise = A x' y' - where - a = a_ (witness :: BAPoint e q r) - l = x + y / x - l' = l + 1 - x' = l * l' + a - y' = x * x + l' * x' - {-# INLINABLE dbl #-} - - def O = True - def (A x y) = ((x + a) * x + y) * x + b + y * y == 0 - where - a = a_ (witness :: BAPoint e q r) - b = b_ (witness :: BAPoint e q r) - {-# INLINABLE def #-} - - disc _ = b_ (witness :: BAPoint e q r) - {-# INLINABLE disc #-} - - frob O = O - frob (A x y) = A (F.frob x) (F.frob y) - {-# INLINABLE frob #-} - - fromA = identity - {-# INLINABLE fromA #-} - - gen = gA_ - {-# INLINABLE gen #-} - - id = O - {-# INLINABLE id #-} - - inv O = O - inv (A x y) = A x (x + y) - {-# INLINABLE inv #-} - - order = r_ - {-# INLINABLE order #-} - - point x y = let p = A x y in if def p then Just p else Nothing - {-# INLINABLE point #-} - - pointX x = A x <$> yX (witness :: BAPoint e q r) x - {-# INLINABLE pointX #-} - - toA = identity - {-# INLINABLE toA #-} - - yX _ x = quad 1 x ((x + a) * x * x + b) - where - a = a_ (witness :: BAPoint e q r) - b = b_ (witness :: BAPoint e q r) - {-# INLINABLE yX #-} - --- Binary affine points are pretty. -instance BACurve e q r => Pretty (BAPoint e q r) where - - pretty (A x y) = pretty (x, y) - pretty O = "O" - -------------------------------------------------------------------------------- --- Projective coordinates -------------------------------------------------------------------------------- - --- | Binary projective points. -type BPPoint = BPoint 'Projective - --- | Binary projective curves @y^2z + xyz = x^3 + Ax^2z + Bz@. -class BCurve 'Projective e q r => BPCurve e q r where - {-# MINIMAL gP_ #-} - gP_ :: BPPoint e q r -- ^ Curve generator. - --- Binary projective curves are elliptic curves. -instance BPCurve e q r => Curve 'Binary 'Projective e q r where - - data instance Point 'Binary 'Projective e q r = P q q q -- ^ Projective point. - deriving (Generic, NFData, Read, Show) - - -- Addition formula add-2008-bl - add p (P _ _ 0) = p - add (P _ _ 0) q = q - add (P x1 y1 z1) (P x2 y2 z2) = P x3 y3 z3 - where - a' = a_ (witness :: BPPoint e q r) - y1z2 = y1 * z2 - x1z2 = x1 * z2 - a = y1z2 + z1 * y2 - b = x1z2 + z1 * x2 - ab = a + b - c = b * b - d = z1 * z2 - e = b * c - f = (a * ab + a' * c) * d + e - x3 = b * f - y3 = c * (a * x1z2 + b * y1z2) + ab * f - z3 = e * d - {-# INLINABLE add #-} - - char = const 2 - {-# INLINABLE char #-} - - cof = h_ - {-# INLINABLE cof #-} - - -- Doubling formula dbl-2008-bl - dbl (P _ _ 0) = P 0 1 0 - dbl (P x1 y1 z1) = P x3 y3 z3 - where - a' = a_ (witness :: BPPoint e q r) - a = x1 * x1 - b = a + y1 * z1 - c = x1 * z1 - bc = b + c - d = c * c - e = b * bc + a' * d - x3 = c * e - y3 = bc * e + a * a * c - z3 = c * d - {-# INLINABLE dbl #-} - - def (P x y z) = ((x + a * z) * x + yz) * x + y * yz + b * z * z * z == 0 - where - a = a_ (witness :: BPPoint e q r) - b = b_ (witness :: BPPoint e q r) - yz = y * z - {-# INLINABLE def #-} - - disc _ = b_ (witness :: BPPoint e q r) - {-# INLINABLE disc #-} - - frob (P x y z) = P (F.frob x) (F.frob y) (F.frob z) - {-# INLINABLE frob #-} - - fromA (A x y) = P x y 1 - fromA _ = P 0 1 0 - {-# INLINABLE fromA #-} - - gen = gP_ - {-# INLINABLE gen #-} - - id = P 0 1 0 - {-# INLINABLE id #-} - - inv (P x y z) = P x (x + y) z - {-# INLINABLE inv #-} - - order = r_ - {-# INLINABLE order #-} - - point x y = let p = P x y 1 in if def p then Just p else Nothing - {-# INLINABLE point #-} - - pointX x = flip (P x) 1 <$> yX (witness :: BPPoint e q r) x - {-# INLINABLE pointX #-} - - toA (P _ _ 0) = O - toA (P x y z) = A (x / z) (y / z) - {-# INLINABLE toA #-} - - yX _ x = quad 1 x ((x + a) * x * x + b) - where - a = a_ (witness :: BPPoint e q r) - b = b_ (witness :: BPPoint e q r) - {-# INLINABLE yX #-} - --- Binary projective points are equatable. -instance BPCurve e q r => Eq (BPPoint e q r) where - - P x1 y1 z1 == P x2 y2 z2 = z1 == 0 && z2 == 0 - || x1 * z2 == x2 * z1 && y1 * z2 == y2 * z1 - {-# INLINABLE (==) #-} - --- Binary projective points are pretty. -instance BPCurve e q r => Pretty (BPPoint e q r) where - - pretty (P x y z) = pretty (x, y, z) - diff --git a/tests/examples/ghc92/BlockComment.hs b/tests/examples/ghc92/BlockComment.hs deleted file mode 100644 --- a/tests/examples/ghc92/BlockComment.hs +++ /dev/null @@ -1,7 +0,0 @@ -module BlockComment where - -foo x = do - blah - where - {- a comment -} - blah = 3 diff --git a/tests/examples/ghc92/Character.hs b/tests/examples/ghc92/Character.hs deleted file mode 100644 --- a/tests/examples/ghc92/Character.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -module Atomo.Kernel.Character where - -import Data.Char - -import Atomo - - -load :: VM () -load = do - [p|(c: Character) control?|] =: liftM Boolean (onCharacter isControl) - [p|(c: Character) space?|] =: liftM Boolean (onCharacter isSpace) - [p|(c: Character) lower?|] =: liftM Boolean (onCharacter isLower) - [p|(c: Character) upper?|] =: liftM Boolean (onCharacter isUpper) - [p|(c: Character) alpha?|] =: liftM Boolean (onCharacter isAlpha) - [p|(c: Character) alphanum?|] =: liftM Boolean (onCharacter isAlphaNum) - [p|(c: Character) print?|] =: liftM Boolean (onCharacter isPrint) - [p|(c: Character) digit?|] =: liftM Boolean (onCharacter isDigit) - [p|(c: Character) oct-digit?|] =: liftM Boolean (onCharacter isOctDigit) - [p|(c: Character) hex-digit?|] =: liftM Boolean (onCharacter isHexDigit) - [p|(c: Character) letter?|] =: liftM Boolean (onCharacter isLetter) - [p|(c: Character) mark?|] =: liftM Boolean (onCharacter isMark) - [p|(c: Character) number?|] =: liftM Boolean (onCharacter isNumber) - [p|(c: Character) punctuation?|] =: liftM Boolean (onCharacter isPunctuation) - [p|(c: Character) symbol?|] =: liftM Boolean (onCharacter isSymbol) - [p|(c: Character) separator?|] =: liftM Boolean (onCharacter isSeparator) - [p|(c: Character) ascii?|] =: liftM Boolean (onCharacter isAscii) - [p|(c: Character) latin1?|] =: liftM Boolean (onCharacter isLatin1) - [p|(c: Character) ascii-upper?|] =: liftM Boolean (onCharacter isAsciiLower) - [p|(c: Character) ascii-lower?|] =: liftM Boolean (onCharacter isAsciiUpper) - - [p|(c: Character) uppercase|] =: liftM Character (onCharacter toUpper) - [p|(c: Character) lowercase|] =: liftM Character (onCharacter toLower) - [p|(c: Character) titlecase|] =: liftM Character (onCharacter toTitle) - - [p|(c: Character) from-digit|] =: liftM (Integer . fromIntegral) (onCharacter digitToInt) - [p|(i: Integer) to-digit|] =: liftM Character (onInteger (intToDigit . fromIntegral)) - - [p|(c: Character) ord|] =: liftM (Integer . fromIntegral) (onCharacter ord) - [p|(i: Integer) chr|] =: liftM Character (onInteger (chr . fromIntegral)) - - [p|(c: Character) category|] =: liftM c (onCharacter generalCategory) - where - onCharacter :: (Char -> a) -> VM a - onCharacter f = here "c" >>= liftM (f . fromCharacter) . findCharacter - - onInteger :: (Integer -> a) -> VM a - onInteger f = here "i" >>= liftM (f . Atomo.fromInteger) . findInteger - - c UppercaseLetter = keyParticleN ["letter"] [particle "uppercase"] - c LowercaseLetter = keyParticleN ["letter"] [particle "lowercase"] - c TitlecaseLetter = keyParticleN ["letter"] [particle "titlecase"] - c ModifierLetter = keyParticleN ["letter"] [particle "modified"] - c OtherLetter = keyParticleN ["letter"] [particle "other"] - c NonSpacingMark = keyParticleN ["mark"] [particle "non-spacing"] - c SpacingCombiningMark = keyParticleN ["mark"] [particle "space-combining"] - c EnclosingMark = keyParticleN ["mark"] [particle "enclosing"] - c DecimalNumber = keyParticleN ["number"] [particle "decimal"] - c LetterNumber = keyParticleN ["number"] [particle "letter"] - c OtherNumber = keyParticleN ["number"] [particle "other"] - c ConnectorPunctuation = keyParticleN ["punctuation"] [particle "connector"] - c DashPunctuation = keyParticleN ["punctuation"] [particle "dash"] - c OpenPunctuation = keyParticleN ["punctuation"] [particle "open"] - c ClosePunctuation = keyParticleN ["punctuation"] [particle "close"] - c InitialQuote = keyParticleN ["quote"] [particle "initial"] - c FinalQuote = keyParticleN ["quote"] [particle "final"] - c OtherPunctuation = keyParticleN ["punctuation"] [particle "other"] - c MathSymbol = keyParticleN ["symbol"] [particle "math"] - c CurrencySymbol = keyParticleN ["symbol"] [particle "currency"] - c ModifierSymbol = keyParticleN ["symbol"] [particle "modifier"] - c OtherSymbol = keyParticleN ["symbol"] [particle "other"] - c Space = particle "space" - c LineSeparator = keyParticleN ["separator"] [particle "line"] - c ParagraphSeparator = keyParticleN ["separator"] [particle "paragraph"] - c Control = particle "control" - c Format = particle "format" - c Surrogate = particle "surrogate" - c PrivateUse = particle "private-use" - c NotAssigned = particle "not-assigned" diff --git a/tests/examples/ghc92/Checkpoint.hs b/tests/examples/ghc92/Checkpoint.hs deleted file mode 100644 --- a/tests/examples/ghc92/Checkpoint.hs +++ /dev/null @@ -1,45 +0,0 @@ --- | Checkpoints in the blockchain (every 1000th blocks) - -{-# LANGUAGE CPP #-} -module Bitcoin.BlockChain.Checkpoint where - ---6----------------------------------------------------------------------------- - -import Bitcoin.Protocol.Hash - ---10---------------------------------------------------------------------------- - -#ifndef WITH_TESTNET - ---14---------------------------------------------------------------------------- --- * the real network - -theGenesisBlock :: Hash256 -theGenesisBlock = hash256FromTextBE "000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f" - -theCheckpoints :: [(Int,Hash256)] -theCheckpoints = - [ (0 , hash256FromTextBE "000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f" ) - , (248000 , hash256FromTextBE "000000000000004d945017c14b75a3a58a2aa6772cacbfcaf907b3bee6d7f344" ) - ] - ---273--------------------------------------------------------------------------- - -#else - ---277--------------------------------------------------------------------------- --- * testnet3 - -theGenesisBlock :: Hash256 -theGenesisBlock = hash256FromTextBE "000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943" - -theCheckpoints :: [(Int,Hash256)] -theCheckpoints = - [ (0 , hash256FromTextBE "000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943" ) - , (97000 , hash256FromTextBE "0000000000096581c7c0fe4d15ea0212f1087fc79f3735a892ee262c384b3741" ) - ] - -#endif - ---387--------------------------------------------------------------------------- - diff --git a/tests/examples/ghc92/CommentOrder.hs b/tests/examples/ghc92/CommentOrder.hs deleted file mode 100644 --- a/tests/examples/ghc92/CommentOrder.hs +++ /dev/null @@ -1,7 +0,0 @@ -module CommentOrder where - -x = 1 - --- First --- Second --- Third diff --git a/tests/examples/ghc92/CommentPlacement.hs b/tests/examples/ghc92/CommentPlacement.hs deleted file mode 100644 --- a/tests/examples/ghc92/CommentPlacement.hs +++ /dev/null @@ -1,17 +0,0 @@ -module CommentPlacement where - -liftToTopLevel' modName pn@(L _ n) = do - liftToMod - --step0: comment - liftToMod - where - --step1: comment - liftToMod = return () - -c04 r@Resource{..} = do - let result = do - acceptStr <- lookup HTTP.hAccept reqHeaders - where - -- this is so that in addition to getting back the resource - provided' = map dupContentType provided - dupContentType (a, b) = (a, (a, b)) diff --git a/tests/examples/ghc92/CommentPlacement2.hs b/tests/examples/ghc92/CommentPlacement2.hs deleted file mode 100644 --- a/tests/examples/ghc92/CommentPlacement2.hs +++ /dev/null @@ -1,8 +0,0 @@ -module CommentPlacement2 where - -c04 = do - let result = do - acceptStr <- y - where - --COMMENT - aa = bb diff --git a/tests/examples/ghc92/CommentPlacement3.hs b/tests/examples/ghc92/CommentPlacement3.hs deleted file mode 100644 --- a/tests/examples/ghc92/CommentPlacement3.hs +++ /dev/null @@ -1,7 +0,0 @@ -module CommentPlacement where - ---a comment -x = y1 ---b comment -y = x1 ---c comment diff --git a/tests/examples/ghc92/CommentPlacement4.hs b/tests/examples/ghc92/CommentPlacement4.hs deleted file mode 100644 --- a/tests/examples/ghc92/CommentPlacement4.hs +++ /dev/null @@ -1,9 +0,0 @@ -module CommentPlacement4 where - -data family GMap k :: * -> * - -data family Array e - --- data GMap () v = GMapUnit (Maybe v) --- deriving Show - diff --git a/tests/examples/ghc92/CommentPlacement5.hs b/tests/examples/ghc92/CommentPlacement5.hs deleted file mode 100644 --- a/tests/examples/ghc92/CommentPlacement5.hs +++ /dev/null @@ -1,9 +0,0 @@ -module CommentPlacement5 where - -bar :: Foo -> () -bar a = - case a of - GInt -> () - -- GBool -> () -bar _ = () - diff --git a/tests/examples/ghc92/CommentPlacement6.hs b/tests/examples/ghc92/CommentPlacement6.hs deleted file mode 100644 --- a/tests/examples/ghc92/CommentPlacement6.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | Checkpoints in the blockchain (every 1000th blocks) - -{-# LANGUAGE CPP #-} -module CommentPlacement6 where - -#ifndef WITH_TESTNET - ---8----------------------------------------------------------------------------- --- * the real network - -theGenesisBlock :: Hash256 -theGenesisBlock = 1 - ---14---------------------------------------------------------------------------- - -#else - ---18---------------------------------------------------------------------------- --- * testnet3 - -theGenesisBlock :: Hash256 -theGenesisBlock = 2 - -#endif - ---26---------------------------------------------------------------------------- - diff --git a/tests/examples/ghc92/CommonUI.hs b/tests/examples/ghc92/CommonUI.hs deleted file mode 100644 --- a/tests/examples/ghc92/CommonUI.hs +++ /dev/null @@ -1,11 +0,0 @@ -module CommonUI where - --- | Prints a document in a none XMl format - -createRuleItem frame state g n e = - do - when (isJust maybeRes) $ - do{ - ;let ;palette = getPalette doc - } - diff --git a/tests/examples/ghc92/ConPat.hs b/tests/examples/ghc92/ConPat.hs deleted file mode 100644 --- a/tests/examples/ghc92/ConPat.hs +++ /dev/null @@ -1,5 +0,0 @@ -module ConPat where - -{-# RULES -"infix" forall a. let x1:x2:xs = flipFirst a in f x2 x1 = let x1:x2:xs = a in f x1 x2 - #-} diff --git a/tests/examples/ghc92/ConstructorComment.hs b/tests/examples/ghc92/ConstructorComment.hs deleted file mode 100644 --- a/tests/examples/ghc92/ConstructorComment.hs +++ /dev/null @@ -1,7 +0,0 @@ -module ConstructorComment where - - -data instance Method PGMigration = MigrationQuery Query - -- ^ Run a query against the database - | MigrationCode (Connection -> IO (Either String ())) - -- ^ Run any arbitrary IO code diff --git a/tests/examples/ghc92/DataDecl.hs b/tests/examples/ghc92/DataDecl.hs deleted file mode 100644 --- a/tests/examples/ghc92/DataDecl.hs +++ /dev/null @@ -1,9 +0,0 @@ -module DataDecl where - -data FileGlob - -- | No glob at all, just an ordinary file - = NoGlob FilePath - - -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to - -- @FileGlob \"foo\/bar\" \".baz\"@ - | FileGlob FilePath String diff --git a/tests/examples/ghc92/DependentStmt.hs b/tests/examples/ghc92/DependentStmt.hs deleted file mode 100644 --- a/tests/examples/ghc92/DependentStmt.hs +++ /dev/null @@ -1,10 +0,0 @@ -module DependentStmt where - --- This test rewrites foo to baz, but only in scope of 'y'. - -main :: IO () -main = do - x <- bar 7 - foo x - y <- bar 54 - baz y diff --git a/tests/examples/ghc92/ExperimIOP.hs b/tests/examples/ghc92/ExperimIOP.hs deleted file mode 100644 --- a/tests/examples/ghc92/ExperimIOP.hs +++ /dev/null @@ -1,24 +0,0 @@ --- --- (C) Susumu Katayama --- --- (Typed)IOPairs¾å¤Ç¥Ç¡¼¥¿¤ò¤È¤ë¡¥ghci¾å¤Ç :cmd ¤ò»È¤¤¤Þ¤¯¤ë´¶¤¸¡¥ -{-# LANGUAGE RankNTypes, CPP, TemplateHaskell #-} -module ExperimIOP(module ExperimIOP, module MagicHaskeller.RunAnalytical) where - -import MagicHaskeller.Analytical -#ifdef DEBUG - hiding (rev) -#endif -import MagicHaskeller.Classification(Filtrable) -import MagicHaskeller.RunAnalytical -#ifdef DEBUG - hiding (main) -#endif -import MagicHaskeller.GetTime(batchWrite) - -main = do iop <- runQ andL - let e = getOne iop [] - putStrLn $ pprint e - -emptyBK = [d| {} |] - diff --git a/tests/examples/ghc92/FOL.hs b/tests/examples/ghc92/FOL.hs deleted file mode 100644 --- a/tests/examples/ghc92/FOL.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, - TypeFamilies, TypeSynonymInstances #-} -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -module Data.Logic.Types.Harrison.FOL - ( TermType(..) - , FOL(..) - , Function(..) - ) where - --- Baz -import qualified Data.Logic.Types.Common ({- instance Variable String -}) --- Bar - diff --git a/tests/examples/ghc92/Field.hs b/tests/examples/ghc92/Field.hs deleted file mode 100644 --- a/tests/examples/ghc92/Field.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} -{-| - Module : AERN2.MP.Ball.Field - Description : Field operations on arbitrary precision dyadic balls - Copyright : (c) Michal Konecny - License : BSD3 - - Maintainer : mikkonecny@gmail.com - Stability : experimental - Portability : portable - - Field operations on arbitrary precision dyadic balls --} -module AERN2.MP.Ball.Field -(mulBalls, mulByEndpoints) -where - -import MixedTypesNumPrelude --- import qualified Prelude as P - -import qualified Numeric.CollectErrors as CN - -import AERN2.Normalize - - -mulByEndpoints :: MPBall -> MPBall -> MPBall -mulByEndpoints b1 b2 = - fromEndpoints l r - where - (l,r) - | 0 <= l1 && 0 <= l2 = (l1*.l2, r1*^r2) -- 0 <= l1 <= r1, 0 <= l2 <= r2 - | r1 <= 0 && r2 <= 0 = (r1*.r2, l1*^l2) -- l1 <= r1 <= 0, l2 <= r2 <= 0 - | 0 <= l1 && r2 <= 0 = (r1*.l2, l1*^r2) -- l2 <= r2 <= 0 <= l1 <= r1 - | r1 <= 0 && 0 <= l2 = (l1*.r2, r1*^l2) -- l1 <= r1 <= 0 <= l2 <= r2 - | l1 < 0 && 0 < r1 && 0 <= l2 = (l1*.r2, r1*^r2) -- l1 < 0 < r1, 0 <= l2 <= r2 - | l1 < 0 && 0 < r1 && r2 <= 0 = (r1*.l2, l1*^l2) -- l1 < 0 < r1, l2 <= r2 <= 0 - | l2 < 0 && 0 < r2 && 0 <= l1 = (l2*.r1, r2*^r1) -- l2 < 0 < r2, 0 <= l1 <= r1 - | l2 < 0 && 0 < r2 && r1 <= 0 = (r2*.l1, l2*^l1) -- l2 < 0 < r2, l1 <= r1 <= 0 - | otherwise = -- l1 < 0 < r1, l2 < 0 < r2 - ((l1 *. r2) `min` (r1 *. l2) - ,(l1 *^ l2) `max` (r1 *^ r2)) - (l1,r1) = endpoints b1 - (l2,r2) = endpoints b2 - - diff --git a/tests/examples/ghc92/Group.hs b/tests/examples/ghc92/Group.hs deleted file mode 100644 --- a/tests/examples/ghc92/Group.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE RebindableSyntax,QuasiQuotes #-} - --- | This module contains most of the math types not directly related to linear algebra --- --- FIXME: there is probably a better name for this -module SubHask.Algebra.Group - where - -import Control.Monad -import qualified Prelude as P - -import SubHask.Algebra -import SubHask.Category -import SubHask.Mutable -import SubHask.SubType -import SubHask.Internal.Prelude -import SubHask.TemplateHaskell.Deriving - -------------------------------------------------------------------------------- --- non-negative objects - -newtype NonNegative t = NonNegative { unNonNegative :: t } - -deriveHierarchy ''NonNegative [ ''Enum, ''Boolean, ''Rig, ''Metric ] - -instance (Ord t, Group t) => Cancellative (NonNegative t) where - (NonNegative t1)-(NonNegative t2) = if diff>zero - then NonNegative diff - else NonNegative zero - where - diff=t1-t2 - -------------------- - -{- -newtype a +> b = HomHask { unHomHask :: a -> b } -infixr +> - -unsafeHomHask2 :: (a -> b -> c) -> (a +> b +> c) -unsafeHomHask2 f = HomHask (\a -> HomHask $ \b -> f a b) - -instance Category (+>) where - type ValidCategory (+>) a = () - id = HomHask id - (HomHask a).(HomHask b) = HomHask $ a.b - -instance Sup (+>) (->) (->) -instance Sup (->) (+>) (->) -instance (+>) <: (->) where - embedType_ = Embed2 unHomHask - -instance Monoidal (+>) where - type Tensor (+>) = (,) - tensor = unsafeHomHask2 $ \a b -> (a,b) - -instance Braided (+>) where - braid = HomHask $ \(a,b) -> (b,a) - unbraid = braid - -instance Closed (+>) where - curry (HomHask f) = HomHask $ \ a -> HomHask $ \b -> f (a,b) - uncurry (HomHask f) = HomHask $ \ (a,b) -> unHomHask (f a) b - -mkSubtype [t|Int|] [t|Integer|] 'toInteger - -[subhask| -poop :: (Semigroup' g, Ring g) => g +> g -poop = (+:1) -|] - -class Semigroup' a where - (+:) :: a +> a +> a - -instance Semigroup' Int where (+:) = unsafeHomHask2 (+) - -instance Semigroup' [a] where (+:) = unsafeHomHask2 (+) - -f :: Integer +> Integer -f = HomHask $ \i -> i+1 - -n1 = NonNegative 5 :: NonNegative Int -n2 = NonNegative 3 :: NonNegative Int -i1 = 5 :: Int -i2 = 3 :: Int -j1 = 5 :: Integer -j2 = 3 :: Integer --} - -------------------------------------------------------------------------------- --- integers modulo n - --- | Maps members of an equivalence class into the "canonical" element. -class Quotient a (b::k) where - mkQuotient :: a -> a/b - --- | The type of equivalence classes created by a mod b. -newtype (/) (a :: *) (b :: k) = Mod a - --- mkDefaultMutable [t| forall a b. a/b |] - --- newtype instance Mutable m (a/b) = Mutable_Mod (Mutable m a) - -instance (Quotient a b, Arbitrary a) => Arbitrary (a/b) where - arbitrary = liftM mkQuotient arbitrary - -deriveHierarchyFiltered ''(/) [ ''Eq_, ''P.Ord ] [''Arbitrary] - -instance (Semigroup a, Quotient a b) => Semigroup (a/b) where - (Mod z1) + (Mod z2) = mkQuotient $ z1 + z2 - -instance (Abelian a, Quotient a b) => Abelian (a/b) - -instance (Monoid a, Quotient a b) => Monoid (a/b) - where zero = Mod zero - -instance (Cancellative a, Quotient a b) => Cancellative (a/b) where - (Mod i1)-(Mod i2) = mkQuotient $ i1-i2 - -instance (Group a, Quotient a b) => Group (a/b) where - negate (Mod i) = mkQuotient $ negate i - -instance (Rg a, Quotient a b) => Rg (a/b) where - (Mod z1)*(Mod z2) = mkQuotient $ z1 * z2 - -instance (Rig a, Quotient a b) => Rig (a/b) where - one = Mod one - -instance (Ring a, Quotient a b) => Ring (a/b) where - fromInteger i = mkQuotient $ fromInteger i - -type instance ((a/b)> Module (a/b) where - (Mod a) .* r = mkQuotient $ a .* r - --- | The type of integers modulo n -type Z (n::Nat) = Integer/n - -instance KnownNat n => Quotient Int n - where - mkQuotient i = Mod $ i `P.mod` (fromIntegral $ natVal (Proxy::Proxy n)) - -instance KnownNat n => Quotient Integer n - where - mkQuotient i = Mod $ i `P.mod` (natVal (Proxy::Proxy n)) - --- | Extended Euclid's algorithm is used to calculate inverses in modular arithmetic -extendedEuclid :: (Eq t, Integral t) => t -> t -> (t,t,t,t,t,t) -extendedEuclid a b = go zero one one zero b a - where - go s1 s0 t1 t0 r1 r0 = if r1==zero - then (s1,s0,t1,t0,undefined,r0) - else go s1' s0' t1' t0' r1' r0' - where - q = r0 `div` r1 - (r0', r1') = (r1,r0-q*r1) - (s0', s1') = (s1,s0-q*s1) - (t0', t1') = (t1,t0-q*t1) - -------------------------------------------------------------------------------- --- example: Galois field - --- | @Galois p k@ is the type of integers modulo p^k, where p is prime. --- All finite fields have this form. --- --- See wikipedia for more details. --- --- FIXME: Many arithmetic operations over Galois Fields can be implemented more efficiently than the standard operations. --- See . -newtype Galois (p::Nat) (k::Nat) = Galois (Z (p^k)) - -type instance Galois p k >< Integer = Galois p k - -deriveHierarchy ''Galois [''Eq_,''Ring] - -instance KnownNat (p^k) => Module (Galois p k) where - z .* i = Galois (Mod i) * z - -instance (Prime p, KnownNat (p^k)) => Field (Galois p k) where - reciprocal (Galois (Mod i)) = Galois $ mkQuotient $ t - where - (_,_,_,t,_,_) = extendedEuclid n i - n = natVal (Proxy::Proxy (p^k)) - -------------------- - -class Prime (n::Nat) -instance Prime 1 -instance Prime 2 -instance Prime 3 -instance Prime 5 -instance Prime 7 -instance Prime 11 -instance Prime 13 -instance Prime 17 -instance Prime 19 -instance Prime 23 - -------------------------------------------------------------------------------- --- the symmetric group - --- | The symmetric group is one of the simplest and best studied finite groups. --- It is efficiently implemented as a "BijectiveT SparseFunction (Z n) (Z n)". --- See - --- newtype Sym (n::Nat) = Sym (BijectiveT SparseFunction (Z n) (Z n)) --- --- instance KnownNat n => Monoid (Sym n) where --- zero = Sym id --- (Sym s1)+(Sym s2) = Sym $ s1.s2 --- --- instance KnownNat n => Group (Sym n) where --- negate (Sym s) = Sym $ inverse s - -------------------------------------------------------------------------------- --- | The GrothendieckGroup is a general way to construct groups from cancellative semigroups. --- --- FIXME: How should this be related to the Ratio type? --- --- See for more details. -data GrothendieckGroup g where - GrotheindieckGroup :: Cancellative g => g -> GrothendieckGroup g - -------------------------------------------------------------------------------- --- the vedic square - --- | The Vedic Square always forms a monoid, --- and sometimes forms a group depending on the value of "n". --- (The type system isn't powerful enough to encode these special cases.) --- --- See for more detail. -newtype VedicSquare (n::Nat) = VedicSquare (Z n) - -deriveHierarchy ''VedicSquare [''Eq_] - -instance KnownNat n => Semigroup (VedicSquare n) where - (VedicSquare v1)+(VedicSquare v2) = VedicSquare $ v1*v2 - -instance KnownNat n => Monoid (VedicSquare n) where - zero = VedicSquare one - ------------------------------------------------------------------------------- --- Minkowski addition - --- | TODO: implement --- More details available at . - diff --git a/tests/examples/ghc92/Import.hs b/tests/examples/ghc92/Import.hs deleted file mode 100644 --- a/tests/examples/ghc92/Import.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ImportQualifiedPost #-} -module Import where - -import safe A -import qualified B as B -import B qualified as B -import C hiding (a,b) -import D (x,y) -import Data.List as L ( intersperse ) -import "base" Prelude hiding (String) diff --git a/tests/examples/ghc92/IndentedComments.hs b/tests/examples/ghc92/IndentedComments.hs deleted file mode 100644 --- a/tests/examples/ghc92/IndentedComments.hs +++ /dev/null @@ -1,12 +0,0 @@ -module IndentedComments where - --- | 'ls_get strsMany n' ls_get strs 'n' elements in order, without blowing the stack. -ls_getMany strs n = go [] n - where - go xs 0 = return $! reverse xs - go xs i = do x <- ls_get strs - -- indented comment - x `seq` go (x:xs) (i-1) - --- compat newtype for deserialization of v2-v4 CaptureData -newtype IntLen a = IntLen { fromIntLen :: a } diff --git a/tests/examples/ghc92/LinePragmas.hs b/tests/examples/ghc92/LinePragmas.hs deleted file mode 100644 --- a/tests/examples/ghc92/LinePragmas.hs +++ /dev/null @@ -1,7 +0,0 @@ -module LinePragmas where - -x = 1 --- Comment 1 -{-# LINE 93 "Foo.chs" #-} --- Comment 2 -y = 2 diff --git a/tests/examples/ghc92/LinearArrow.hs b/tests/examples/ghc92/LinearArrow.hs deleted file mode 100644 --- a/tests/examples/ghc92/LinearArrow.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE LinearTypes, DataKinds, UnicodeSyntax #-} - -module LinearArrow where - -import GHC.Types (Multiplicity(One, Many)) - -n1 :: a %1 -> b -n1 = undefined - -u1 :: a %1 → b -u1 = undefined - -n2 :: a %(Many) -> b -n2 = undefined - -u2 :: a %(Many) → b -u2 = undefined - -m3 :: a ⊸ b -m3 = undefined - -n4 :: a %p -> b -n4 = undefined - -u4 :: a %p → b -u4 = undefined diff --git a/tests/examples/ghc92/ListComments.hs b/tests/examples/ghc92/ListComments.hs deleted file mode 100644 --- a/tests/examples/ghc92/ListComments.hs +++ /dev/null @@ -1,5 +0,0 @@ -module ListComments where - -foo :: Int -- nonterm - -> IO Int -foo = undefined diff --git a/tests/examples/ghc92/MatchSemis.hs b/tests/examples/ghc92/MatchSemis.hs deleted file mode 100644 --- a/tests/examples/ghc92/MatchSemis.hs +++ /dev/null @@ -1,5 +0,0 @@ -module MatchSemis where -{ -a 0 = 1; -a _ = 2; -} diff --git a/tests/examples/ghc92/Observer.hs b/tests/examples/ghc92/Observer.hs deleted file mode 100644 --- a/tests/examples/ghc92/Observer.hs +++ /dev/null @@ -1,325 +0,0 @@ --- | Observer Effects --- --- This module supports the implementation of observerRegistry and observables. Expected use --- case is event propagation. --- --- The observable event sources and the observers are usually server processes for a --- protocol that embeds the 'ObserverRegistry' and 'Observer' 'Pdu's respectively. --- --- A generic FIFO queue based observer can be found in "Control.Eff.Concurrent.Protocol.Observer.Queue". --- --- @since 0.16.0 -module Control.Eff.Concurrent.Protocol.Observer - ( Observer (..), - ObservationSink (), - IsObservable, - CanObserve, - Pdu (RegisterObserver, ForgetObserver, Observed), - registerObserver, - forgetObserver, - forgetObserverUnsafe, - ObserverRegistry (..), - ObserverRegistryState, - observerRegistryNotify, - evalObserverRegistryState, - emptyObserverRegistry, - observerRegistryHandlePdu, - observerRegistryRemoveProcess, - ) -where - -import Control.DeepSeq (NFData (rnf)) -import Control.Eff -import Control.Eff.Concurrent.Process -import Control.Eff.Concurrent.Protocol -import Control.Eff.Concurrent.Protocol.Client -import Control.Eff.Concurrent.Protocol.Wrapper (Request (Cast)) -import Control.Eff.Log -import Control.Eff.State.Strict -import Control.Lens -import Control.Monad -import Data.Dynamic -import Data.Kind -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Proxy -import Data.Semigroup -import GHC.Generics -import GHC.Stack - --- * Observers - --- ** Observables - --- | A /protocol/ to communicate 'Observed' events from a sources to many sinks. --- --- A sink is any process that serves a protocol with a 'Pdu' instance that embeds --- the 'Observer' Pdu via an 'HasPduPrism' instance. --- --- This type has /dual use/, for one it serves as type-index for 'Pdu', i.e. --- 'HasPdu' respectively, and secondly it contains an 'ObservationSink' and --- a 'MonitorReference'. --- --- The 'ObservationSink' is used to serialize and send the 'Observed' events, --- while the 'ProcessId' serves as key for internal maps. --- --- @since 0.28.0 -newtype Observer event - = MkObserver (Arg ProcessId (ObservationSink event)) - deriving (Eq, Ord, Typeable) - -instance ToTypeLogMsg event => ToLogMsg (Observer event) where - toLogMsg (MkObserver (Arg t _)) = toTypeLogMsg (Proxy @(Observer event)) <> toLogMsg t - -instance ToTypeLogMsg event => ToTypeLogMsg (Observer event) where - toTypeLogMsg _ = toTypeLogMsg (Proxy @event) <> packLogMsg "_observer" - -instance NFData (Observer event) where - rnf (MkObserver (Arg x y)) = rnf x `seq` rnf y - -instance (Tangible event) => HasPdu (Observer event) where - data Pdu (Observer event) r where - Observed :: event -> Pdu (Observer event) 'Asynchronous - deriving (Typeable) - -instance NFData event => NFData (Pdu (Observer event) r) where - rnf (Observed event) = rnf event - -instance ToLogMsg event => ToLogMsg (Pdu (Observer event) r) where - toLogMsg (Observed event) = - packLogMsg "observed: " <> toLogMsg event - --- | The Information necessary to wrap an 'Observed' event to a process specific --- message, e.g. the embedded 'Observer' 'Pdu' instance, and the 'MonitorReference' of --- the destination process. --- --- @since 0.28.0 -data ObservationSink event = MkObservationSink - { _observerSerializer :: Serializer (Pdu (Observer event) 'Asynchronous), - _observerMonitorReference :: MonitorReference - } - deriving (Generic, Typeable) - -instance NFData (ObservationSink event) where - rnf (MkObservationSink s p) = s `seq` rnf p - --- | Convenience type alias. --- --- @since 0.28.0 -type IsObservable eventSource event = - ( Tangible event, - Embeds eventSource (ObserverRegistry event), - HasPdu eventSource, - ToTypeLogMsg event, - ToLogMsg event - ) - --- | Convenience type alias. --- --- @since 0.28.0 -type CanObserve eventSink event = - ( Tangible event, - Embeds eventSink (Observer event), - HasPdu eventSink - ) - --- | And an 'Observer' to the set of recipients for all observations reported by 'observerRegistryNotify'. --- Note that the observerRegistry are keyed by the observing process, i.e. a previous entry for the process --- contained in the 'Observer' is overwritten. If you want multiple entries for a single process, just --- combine several filter functions. --- --- @since 0.16.0 -registerObserver :: - forall event eventSink eventSource r q. - ( HasProcesses r q, - TangiblePdu eventSource 'Asynchronous, - IsObservable eventSource event, - TangiblePdu eventSink 'Asynchronous, - CanObserve eventSink event - ) => - Endpoint eventSource -> - Endpoint eventSink -> - Eff r () -registerObserver eventSource eventSink = - cast eventSource (RegisterObserver serializer (eventSink ^. fromEndpoint)) - where - serializer = - MkSerializer - ( toMessage - . Cast - . embedPdu @eventSink @(Observer event) @('Asynchronous) - ) - --- | Send the 'ForgetObserver' message --- --- @since 0.16.0 -forgetObserver :: - forall event eventSink eventSource r q. - ( HasProcesses r q, - TangiblePdu eventSource 'Asynchronous, - IsObservable eventSource event - ) => - Endpoint eventSource -> - Endpoint eventSink -> - Eff r () -forgetObserver eventSource eventSink = - forgetObserverUnsafe @event @eventSource eventSource (eventSink ^. fromEndpoint) - --- | Send the 'ForgetObserver' message, use a raw 'ProcessId' as parameter. --- --- @since 0.28.0 -forgetObserverUnsafe :: - forall event eventSource r q. - ( HasProcesses r q, - TangiblePdu eventSource 'Asynchronous, - IsObservable eventSource event - ) => - Endpoint eventSource -> - ProcessId -> - Eff r () -forgetObserverUnsafe eventSource eventSink = - cast eventSource (ForgetObserver @event eventSink) - --- ** Observer Support Functions - --- * Managing Observers - --- | A protocol for managing 'Observer's, encompassing registration and de-registration of --- 'Observer's. --- --- @since 0.28.0 -data ObserverRegistry (event :: Type) = MkObserverRegistry - {_observerRegistry :: Map ProcessId (ObservationSink event)} - deriving (Typeable) - -instance ToTypeLogMsg event => ToTypeLogMsg (ObserverRegistry event) where - toTypeLogMsg _ = toTypeLogMsg (Proxy @event) <> packLogMsg "_observer_registry_event" - -instance (Tangible event) => HasPdu (ObserverRegistry event) where - data Pdu (ObserverRegistry event) r where - -- | This message denotes that the given 'Observer' should receive observations until 'ForgetObserver' is - -- received. - -- - -- @since 0.28.0 - RegisterObserver :: Serializer (Pdu (Observer event) 'Asynchronous) -> ProcessId -> Pdu (ObserverRegistry event) 'Asynchronous - -- | This message denotes that the given 'Observer' should not receive observations anymore. - -- - -- @since 0.16.1 - ForgetObserver :: ProcessId -> Pdu (ObserverRegistry event) 'Asynchronous - -- -- | This message denotes that a monitored process died - -- -- - -- -- @since 0.28.0 - -- ObserverMightBeDown :: MonitorReference -> Pdu (ObserverRegistry event) ( 'Synchronous Bool) - deriving (Typeable) - -instance NFData (Pdu (ObserverRegistry event) r) where - rnf (RegisterObserver ser pid) = rnf ser `seq` rnf pid - rnf (ForgetObserver pid) = rnf pid - -instance ToTypeLogMsg event => ToLogMsg (Pdu (ObserverRegistry event) r) where - toLogMsg (RegisterObserver _ser pid) = packLogMsg "register " <> toTypeLogMsg (Proxy @event) <> packLogMsg " observer " <> toLogMsg pid - toLogMsg (ForgetObserver pid) = packLogMsg "forget " <> toTypeLogMsg (Proxy @event) <> packLogMsg " observer " <> toLogMsg pid - --- ** Protocol for integrating 'ObserverRegistry' into processes. - --- | Provide the implementation for the 'ObserverRegistry' Protocol, this handled 'RegisterObserver' and 'ForgetObserver' --- messages. It also adds the 'ObserverRegistryState' constraint to the effect list. --- --- @since 0.28.0 -observerRegistryHandlePdu :: - forall event q r. - ( HasCallStack, - ToTypeLogMsg event, - HasProcesses r q, - Member (ObserverRegistryState event) r, - Member Logs r - ) => - Pdu (ObserverRegistry event) 'Asynchronous -> - Eff r () -observerRegistryHandlePdu = \case - RegisterObserver ser pid -> do - monRef <- monitor pid - let sink = MkObservationSink ser monRef - observer = MkObserver (Arg pid sink) - modify @(ObserverRegistry event) (over observerRegistry (Map.insert pid sink)) - os <- get @(ObserverRegistry event) - logDebug - (LABEL "registered" observer) - ( LABEL - "current number of observers" -- TODO put this info into the process details - (Map.size (view observerRegistry os)) - ) - ForgetObserver ob -> do - wasRemoved <- observerRegistryRemoveProcess @event ob - unless wasRemoved $ - logDebug (LABEL "unknown observer " ob) - --- | Remove the entry in the 'ObserverRegistry' for the 'ProcessId' --- and return 'True' if there was an entry, 'False' otherwise. --- --- @since 0.28.0 -observerRegistryRemoveProcess :: - forall event q r. - ( HasCallStack, - ToTypeLogMsg event, - HasProcesses r q, - Member (ObserverRegistryState event) r, - Member Logs r - ) => - ProcessId -> - Eff r Bool -observerRegistryRemoveProcess ob = do - mSink <- view (observerRegistry . at ob) <$> get @(ObserverRegistry event) - modify @(ObserverRegistry event) (observerRegistry . at ob .~ Nothing) - os <- get @(ObserverRegistry event) - maybe - (pure False) - (foundIt os) - mSink - where - foundIt os sink@(MkObservationSink _ monRef) = do - demonitor monRef - logDebug - (LABEL "removed" (MkObserver $ Arg ob sink)) - (LABEL "current number of observers" (Map.size (view observerRegistry os))) - pure True - --- | Keep track of registered 'Observer's. --- --- Handle the 'ObserverRegistryState' effect, i.e. run 'evalState' on an 'emptyObserverRegistry'. --- --- @since 0.28.0 -evalObserverRegistryState :: Eff (ObserverRegistryState event ': r) a -> Eff r a -evalObserverRegistryState = evalState emptyObserverRegistry - --- | The empty 'ObserverRegistryState' --- --- @since 0.28.0 -emptyObserverRegistry :: ObserverRegistry event -emptyObserverRegistry = MkObserverRegistry Map.empty - --- | Alias for the effect that contains the observers managed by 'evalObserverRegistryState' -type ObserverRegistryState event = State (ObserverRegistry event) - --- | An 'Iso' for the 'Map' used internally. -observerRegistry :: Iso' (ObserverRegistry event) (Map ProcessId (ObservationSink event)) -observerRegistry = iso _observerRegistry MkObserverRegistry - --- | Report an observation to all observers. --- The process needs to 'evalObserverRegistryState' and to 'observerRegistryHandlePdu'. --- --- @since 0.28.0 -observerRegistryNotify :: - forall event r q. - ( HasProcesses r q, - Member (ObserverRegistryState event) r - ) => - event -> - Eff r () -observerRegistryNotify observation = do - os <- view observerRegistry <$> get - mapM_ notifySomeObserver (Map.assocs os) - where - notifySomeObserver (destination, (MkObservationSink serializer _)) = - sendAnyMessage destination (runSerializer serializer (Observed observation)) - diff --git a/tests/examples/ghc92/Observer1.hs b/tests/examples/ghc92/Observer1.hs deleted file mode 100644 --- a/tests/examples/ghc92/Observer1.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Observer1 where - -instance HasPdu Int where - data Pdu Int r where - --a comment - RegisterObserver :: Int - --b comment - ForgetObserver :: Int - --c comment - deriving (Typeable) diff --git a/tests/examples/ghc92/ParensGADT.hs b/tests/examples/ghc92/ParensGADT.hs deleted file mode 100644 --- a/tests/examples/ghc92/ParensGADT.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -module ParensGADT where - --- | Base Descriptor Class Tags TODO rename to xxxTag -data ClassTag (tag :: Nat) where - M4MuxChannelDescr ::ClassTag 0x69 - ExtDescrTag :: ( forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n) - OCIDescrTag :: ((forall (n :: Nat) . (0x40 <= n, n <= 0x5F) => ClassTag n)) - --- End of file comment diff --git a/tests/examples/ghc92/Parse.hs b/tests/examples/ghc92/Parse.hs deleted file mode 100644 --- a/tests/examples/ghc92/Parse.hs +++ /dev/null @@ -1,5 +0,0 @@ - -module Language.Python.Internal.Parse where - -compoundStatement pIndent indentBefore = - do; a <- doAsync; fundef diff --git a/tests/examples/ghc92/PostgreSQL.hs b/tests/examples/ghc92/PostgreSQL.hs deleted file mode 100644 --- a/tests/examples/ghc92/PostgreSQL.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module Drifter.PostgreSQL - ( PGMigration - , Method(..) - , DBConnection(..) - , ChangeHistory(..) - , runMigrations - , getChangeHistory - , getChangeNameHistory - ) where - -------------------------------------------------------------------------------- -import Control.Applicative as A -import Control.Exception -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Trans.Except -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Time -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.FromRow -import Database.PostgreSQL.Simple.SqlQQ -import Drifter -------------------------------------------------------------------------------- - - -data PGMigration - - -data instance Method PGMigration = MigrationQuery Query - -- ^ Run a query against the database - | MigrationCode (Connection -> IO (Either String ())) - -- ^ Run any arbitrary IO code - - -data instance DBConnection PGMigration = DBConnection PGMigrationConnection - - -data PGMigrationConnection = PGMigrationConnection (Set ChangeName) Connection - - -instance Drifter PGMigration where - migrateSingle (DBConnection migrationConn) change = do - runExceptT $ migrateChange migrationConn change - - -------------------------------------------------------------------------------- --- Change History Tracking -------------------------------------------------------------------------------- -newtype ChangeId = ChangeId Int deriving (Eq, Ord, Show, FromField) - - -data ChangeHistory = ChangeHistory { - histId :: ChangeId - , histName :: ChangeName - , histDescription :: Maybe Description - , histTime :: UTCTime - } deriving (Show) - - -instance Eq ChangeHistory where - a == b = (histName a) == (histName b) - - -instance Ord ChangeHistory where - compare a b = compare (histId a) (histId b) - - -instance FromRow ChangeHistory where - fromRow = ChangeHistory <$> field - <*> (ChangeName <$> field) - <*> field - <*> field - - -------------------------------------------------------------------------------- --- Queries -------------------------------------------------------------------------------- -bootstrapQ :: Query -bootstrapQ = [sql| -CREATE TABLE IF NOT EXISTS schema_migrations ( - id serial NOT NULL, - name text NOT NULL, - description text, - time timestamptz NOT NULL DEFAULT now(), - - PRIMARY KEY (id), - UNIQUE (name) -); -|] - - -------------------------------------------------------------------------------- -changeHistoryQ :: Query -changeHistoryQ = - "SELECT id, name, description, time FROM schema_migrations ORDER BY id;" - - -------------------------------------------------------------------------------- -changeNameHistoryQ :: Query -changeNameHistoryQ = - "SELECT name FROM schema_migrations ORDER BY id;" - - -------------------------------------------------------------------------------- -insertLogQ :: Query -insertLogQ = - "INSERT INTO schema_migrations (name, description, time) VALUES (?, ?, ?);" - - -------------------------------------------------------------------------------- -migrateChange :: PGMigrationConnection -> Change PGMigration -> ExceptT String IO () -migrateChange (PGMigrationConnection hist c) ch@Change{..} = do - if Set.member changeName hist - then lift $ putStrLn $ "Skipping: " ++ show (changeNameText changeName) - else do - runMethod c changeMethod - logChange c ch - lift $ putStrLn $ "Committed: " ++ show changeName - - -------------------------------------------------------------------------------- -runMethod :: Connection -> Method PGMigration -> ExceptT String IO () -runMethod c (MigrationQuery q) = - void $ ExceptT $ (Right <$> execute_ c q) `catches` errorHandlers -runMethod c (MigrationCode f) = - ExceptT $ f c `catches` errorHandlers - - - ------------------------------------------------------------------------------- -logChange :: Connection -> Change PGMigration -> ExceptT String IO () -logChange c Change{..} = do - now <- lift getCurrentTime - void $ ExceptT $ (Right <$> go now) `catches` errorHandlers - where - go now = execute c insertLogQ (changeNameText changeName, changeDescription, now) - - -------------------------------------------------------------------------------- -errorHandlers :: [Handler (Either String b)] -errorHandlers = [ Handler (\(ex::SqlError) -> return $ Left $ show ex) - , Handler (\(ex::FormatError) -> return $ Left $ show ex) - , Handler (\(ex::ResultError) -> return $ Left $ show ex) - , Handler (\(ex::QueryError) -> return $ Left $ show ex) - ] - - -------------------------------------------------------------------------------- --- | Takes a connection and builds the state to thread throughout the migration. --- This includes bootstrapping the migration tables and collecting all the --- migrations that have already been committed. -makePGMigrationConnection :: Connection -> IO PGMigrationConnection -makePGMigrationConnection conn = do - void $ execute_ conn bootstrapQ - hist <- getChangeNameHistory conn - return $ PGMigrationConnection (Set.fromList hist) conn - - -------------------------------------------------------------------------------- --- | Takes the list of all migrations, removes the ones that have --- already run and runs them. Use this instead of 'migrate'. -runMigrations :: Connection -> [Change PGMigration] -> IO (Either String ()) -runMigrations conn changes = do - begin conn - migrationConn <- makePGMigrationConnection conn - res <- migrate (DBConnection migrationConn) changes `onException` rollback conn - case res of - Right _ -> commit conn - Left _ -> rollback conn - return res - - -------------------------------------------------------------------------------- --- | Get all changes from schema_migrations table for all the migrations that --- have previously run. -getChangeHistory :: Connection -> IO [ChangeHistory] -getChangeHistory conn = query_ conn changeHistoryQ - - -------------------------------------------------------------------------------- --- | Get just the names of all changes from schema_migrations for migrations --- that have previously run. -getChangeNameHistory :: Connection -> IO [ChangeName] -getChangeNameHistory conn = fmap (\(Only nm) -> ChangeName nm) - A.<$> query_ conn changeNameHistoryQ - diff --git a/tests/examples/ghc92/PragmaSpans.hs b/tests/examples/ghc92/PragmaSpans.hs deleted file mode 100644 --- a/tests/examples/ghc92/PragmaSpans.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE GADTs #-} -module PragmaSpans where - --- The following pragma gets the wrong previous span. --- See https://gitlab.haskell.org/ghc/ghc/-/issues/20720 -{-# LANGUAGE TypeFamilies #-} diff --git a/tests/examples/ghc92/RList.hs b/tests/examples/ghc92/RList.hs deleted file mode 100644 --- a/tests/examples/ghc92/RList.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE TypeOperators, EmptyDataDecls, RankNTypes #-} -{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds, KindSignatures #-} -{-# LANGUAGE GADTs, TypeInType, PatternGuards #-} - --- | --- Module : Data.Type.RList --- Copyright : (c) 2016 Edwin Westbrook --- --- License : BSD3 --- --- Maintainer : westbrook@galois.com --- Stability : experimental --- Portability : GHC --- --- A /right list/, or 'RList', is a list where cons adds to the end, or the --- right-hand side, of a list. This is useful conceptually for contexts of --- name-bindings, where the most recent name-binding is intuitively at the end --- of the context. - -module Data.Type.RList where - -import Prelude hiding (map, foldr) -import Data.Kind -import Data.Type.Equality -import Data.Proxy (Proxy(..)) -import Data.Functor.Constant -import Data.Typeable - -------------------------------------------------------------------------------- --- * Right-lists as a datatype -------------------------------------------------------------------------------- - --- | A form of lists where elements are added to the right instead of the left -data RList a - = RNil - | (RList a) :> a - --- | Append two 'RList's at the type level -type family ((r1 :: RList k) :++: (r2 :: RList k)) :: RList k -infixr 5 :++: -type instance (r :++: 'RNil) = r -type instance (r1 :++: (r2 ':> a)) = (r1 :++: r2) ':> a - -------------------------------------------------------------------------------- --- * Proofs of membership in a type-level list -------------------------------------------------------------------------------- - -{-| - A @Member ctx a@ is a \"proof\" that the type @a@ is in the type - list @ctx@, meaning that @ctx@ equals - -> t0 ':>' a ':>' t1 ':>' ... ':>' tn - - for some types @t0,t1,...,tn@. --} -data Member (ctx :: RList k1) (a :: k2) where - Member_Base :: Member (ctx :> a) a - Member_Step :: Member ctx a -> Member (ctx :> b) a - deriving Typeable - -instance Show (Member r a) where - showsPrec p = showsPrecMember (p > 10) where - showsPrecMember :: Bool -> Member ctx a -> ShowS - showsPrecMember _ Member_Base = showString "Member_Base" - showsPrecMember p (Member_Step prf) = showParen p $ - showString "Member_Step" . showsPrec 10 prf - -instance TestEquality (Member ctx) where - testEquality Member_Base Member_Base = Just Refl - testEquality (Member_Step memb1) (Member_Step memb2) - | Just Refl <- testEquality memb1 memb2 - = Just Refl - testEquality _ _ = Nothing - -instance Eq (Member ctx a) where - Member_Base == Member_Base = True - (Member_Step memb1) == (Member_Step memb2) = memb1 == memb2 - _ == _ = False - ---toEq :: Member (Nil :> a) b -> b :~: a ---toEq Member_Base = Refl ---toEq _ = error "Should not happen! (toEq)" - --- | Weaken a 'Member' proof by prepending another context to the context it --- proves membership in -weakenMemberL :: Proxy r1 -> Member r2 a -> Member (r1 :++: r2) a -weakenMemberL _ Member_Base = Member_Base -weakenMemberL tag (Member_Step mem) = Member_Step (weakenMemberL tag mem) - - ------------------------------------------------------------- --- * Proofs that one list equals the append of two others ------------------------------------------------------------- - -{-| - An @Append ctx1 ctx2 ctx@ is a \"proof\" that @ctx = ctx1 ':++:' ctx2@. --} -data Append ctx1 ctx2 ctx where - Append_Base :: Append ctx RNil ctx - Append_Step :: Append ctx1 ctx2 ctx -> Append ctx1 (ctx2 :> a) (ctx :> a) - --- | Make an 'Append' proof from any 'RAssign' vector for the second --- argument of the append. -mkAppend :: RAssign f c2 -> Append c1 c2 (c1 :++: c2) -mkAppend MNil = Append_Base -mkAppend (c :>: _) = Append_Step (mkAppend c) - --- | A version of 'mkAppend' that takes in a 'Proxy' argument. -mkMonoAppend :: Proxy c1 -> RAssign f c2 -> Append c1 c2 (c1 :++: c2) -mkMonoAppend _ = mkAppend - --- | The inverse of 'mkAppend', that builds an 'RAssign' from an 'Append' -proxiesFromAppend :: Append c1 c2 c -> RAssign Proxy c2 -proxiesFromAppend Append_Base = MNil -proxiesFromAppend (Append_Step a) = proxiesFromAppend a :>: Proxy - - -------------------------------------------------------------------------------- --- * Contexts -------------------------------------------------------------------------------- - -{-| - An @RAssign f r@ an assignment of an @f a@ for each @a@ in the 'RList' @r@ --} -data RAssign (f :: k -> *) (c :: RList k) where - MNil :: RAssign f RNil - (:>:) :: RAssign f c -> f a -> RAssign f (c :> a) - --- | Create an empty 'RAssign' vector. -empty :: RAssign f RNil -empty = MNil - --- | Create a singleton 'RAssign' vector. -singleton :: f a -> RAssign f (RNil :> a) -singleton x = MNil :>: x - --- | Look up an element of an 'RAssign' vector using a 'Member' proof -get :: Member c a -> RAssign f c -> f a -get Member_Base (_ :>: x) = x -get (Member_Step mem') (mc :>: _) = get mem' mc - --- | Heterogeneous type application, including a proof that the input kind of --- the function equals the kind of the type argument -data HApply (f :: k1 -> Type) (a :: k2) where - HApply :: forall k (f :: k -> Type) (a :: k). f a -> HApply f a - --- | Look up an element of an 'RAssign' vector using a 'Member' proof at what --- GHC thinks might be a different kind, i.e., heterogeneously -hget :: forall k1 k2 (f :: k1 -> Type) (c :: RList k1) (a :: k2). - Member c a -> RAssign f c -> HApply f a -hget Member_Base (_ :>: x) = HApply x -hget (Member_Step mem') (mc :>: _) = hget mem' mc - --- | Modify an element of an 'RAssign' vector using a 'Member' proof. -modify :: Member c a -> (f a -> f a) -> RAssign f c -> RAssign f c -modify Member_Base f (xs :>: x) = xs :>: f x -modify (Member_Step mem') f (xs :>: x) = modify mem' f xs :>: x - --- | Set an element of an 'RAssign' vector using a 'Member' proof. -set :: Member c a -> f a -> RAssign f c -> RAssign f c -set memb x = modify memb (const x) - --- | Test if an object is in an 'RAssign', returning a 'Member' proof if it is -memberElem :: TestEquality f => f a -> RAssign f ctx -> Maybe (Member ctx a) -memberElem _ MNil = Nothing -memberElem x (_ :>: y) | Just Refl <- testEquality x y = Just Member_Base -memberElem x (xs :>: _) = fmap Member_Step $ memberElem x xs - --- | Map a function on all elements of an 'RAssign' vector. -map :: (forall x. f x -> g x) -> RAssign f c -> RAssign g c -map _ MNil = MNil -map f (mc :>: x) = map f mc :>: f x - --- | An alternate name for 'map' that does not clash with the prelude -mapRAssign :: (forall x. f x -> g x) -> RAssign f c -> RAssign g c -mapRAssign = map - --- | Map a binary function on all pairs of elements of two 'RAssign' vectors. -map2 :: (forall x. f x -> g x -> h x) -> - RAssign f c -> RAssign g c -> RAssign h c -map2 _ MNil MNil = MNil -map2 f (xs :>: x) (ys :>: y) = map2 f xs ys :>: f x y - --- | Take the tail of an 'RAssign' -tail :: RAssign f (ctx :> a) -> RAssign f ctx -tail (xs :>: _) = xs - --- | Convert a monomorphic 'RAssign' to a list -toList :: RAssign (Constant a) c -> [a] -toList = mapToList getConstant - --- | Map a function with monomorphic output type across an 'RAssign' to create a --- standard list: --- --- > mapToList f = toList . map (Constant . f) -mapToList :: (forall a. f a -> b) -> RAssign f ctx -> [b] -mapToList _ MNil = [] -mapToList f (xs :>: x) = mapToList f xs ++ [f x] - --- | Append two 'RAssign' vectors. -append :: RAssign f c1 -> RAssign f c2 -> RAssign f (c1 :++: c2) -append mc MNil = mc -append mc1 (mc2 :>: x) = append mc1 mc2 :>: x - --- | Perform a right fold across an 'RAssign' -foldr :: (forall a. f a -> r -> r) -> r -> RAssign f ctx -> r -foldr _ r MNil = r -foldr f r (xs :>: x) = f x $ foldr f r xs - --- | Split an 'RAssign' vector into two pieces. The first argument is a --- phantom argument that gives the form of the first list piece. -split :: (c ~ (c1 :++: c2)) => prx c1 -> - RAssign any c2 -> RAssign f c -> (RAssign f c1, RAssign f c2) -split _ MNil mc = (mc, MNil) -split _ (any :>: _) (mc :>: x) = (mc1, mc2 :>: x) - where (mc1, mc2) = split Proxy any mc - --- | Create a vector of proofs that each type in @c@ is a 'Member' of @c@. -members :: RAssign f c -> RAssign (Member c) c -members MNil = MNil -members (c :>: _) = map Member_Step (members c) :>: Member_Base - --- | A type-class which ensures that ctx is a valid context, i.e., has --- | the form (RNil :> t1 :> ... :> tn) for some types t1 through tn -class TypeCtx ctx where - typeCtxProxies :: RAssign Proxy ctx - -instance TypeCtx RNil where - typeCtxProxies = MNil - -instance TypeCtx ctx => TypeCtx (ctx :> a) where - typeCtxProxies = typeCtxProxies :>: Proxy - diff --git a/tests/examples/ghc92/Records.hs b/tests/examples/ghc92/Records.hs deleted file mode 100644 --- a/tests/examples/ghc92/Records.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Records where - -data Record = Record - { rOne :: Int - , rTwo :: String - } - -defR :: Record -defR = Record 1 "record" - -main :: IO () -main = do - print $ defR { rOne = 42 } - print $ Record { rTwo = "foo" } diff --git a/tests/examples/ghc92/Records2.hs b/tests/examples/ghc92/Records2.hs deleted file mode 100644 --- a/tests/examples/ghc92/Records2.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Records where - -data Record = Record - { rOne :: Int - , rTwo :: String - } - -defR :: Record -defR = Record 1 "record" - -main :: IO () -main = do - print $ defR { rOne = 42 + 12 } - print $ Record { rTwo = "foo" ++ "foo" } diff --git a/tests/examples/ghc92/Retrie.hs b/tests/examples/ghc92/Retrie.hs deleted file mode 100644 --- a/tests/examples/ghc92/Retrie.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedSums #-} -module Types4a where - -import Data.Maybe hiding (f1,f2,n1,n2) - -type Foo5 = forall r (a :: Type) (b :: TYPE r). (a -> b) -> a -> b - -foo5 :: forall s (c :: Type) (d :: TYPE s). (c -> d) -> c -> d -foo5 = ($) diff --git a/tests/examples/ghc92/RmDecl4.hs b/tests/examples/ghc92/RmDecl4.hs deleted file mode 100644 --- a/tests/examples/ghc92/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 -- comment - xx = 2 - --- EOF diff --git a/tests/examples/ghc92/ScopesBug.hs b/tests/examples/ghc92/ScopesBug.hs deleted file mode 100644 --- a/tests/examples/ghc92/ScopesBug.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE PatternSynonyms, ViewPatterns #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeApplications #-} - -module ScopesBug where - -data Proxy (a :: k) = Proxy -data Con k (a :: k) = Con (Proxy a) - -tyApp :: Con k a -> Proxy a -tyApp (Con @kx @ax (x :: Proxy ax)) = x :: Proxy (ax :: kx) - diff --git a/tests/examples/ghc92/StringRef.hs b/tests/examples/ghc92/StringRef.hs deleted file mode 100644 --- a/tests/examples/ghc92/StringRef.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances, TypeSynonymInstances #-} -{-# LANGUAGE LambdaCase #-} - -module Data.Binary.StringRef - ( ListOfStringable(..) - , StringReferencingBinary(..) - , IntLen(..) - , ls_encode - , ls_decode - ) where - -import Data.Binary -import Data.Binary.Put -import Data.Binary.Get -import Control.Monad -import Control.Applicative ((<$>)) -import Data.List -import Data.ByteString.Lazy (ByteString) -import qualified Data.MyText as T -import Data.MyText (Text, decodeUtf8, encodeUtf8) -import Debug.Trace - -class StringReferencingBinary a => ListOfStringable a where - listOfStrings :: a -> [Text] - --- | An extended version of Binary that passes the list of strings of the --- previous sample -class StringReferencingBinary a where - ls_put :: [Text] -> a -> Put - ls_get :: [Text] -> Get a - ------------------------------------------------------------------------- --- Instances for the first few tuples - -instance (StringReferencingBinary a, StringReferencingBinary b) => StringReferencingBinary (a,b) where - ls_put strs (a,b) = ls_put strs a >> ls_put strs b - ls_get strs = liftM2 (,) (ls_get strs) (ls_get strs) - -instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c) => StringReferencingBinary (a,b,c) where - ls_put strs (a,b,c) = ls_put strs a >> ls_put strs b >> ls_put strs c - ls_get strs = liftM3 (,,) (ls_get strs) (ls_get strs) (ls_get strs) - -instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c, StringReferencingBinary d) => StringReferencingBinary (a,b,c,d) where - ls_put strs (a,b,c,d) = ls_put strs a >> ls_put strs b >> ls_put strs c >> ls_put strs d - ls_get strs = liftM4 (,,,) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs) - -instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c, StringReferencingBinary d, StringReferencingBinary e) => StringReferencingBinary (a,b,c,d,e) where - ls_put strs (a,b,c,d,e) = ls_put strs a >> ls_put strs b >> ls_put strs c >> ls_put strs d >> ls_put strs e - ls_get strs = liftM5 (,,,,) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs) - - -newtype CompactNum a = CompactNum { fromCompactNum :: a } - -instance (Integral a, Num a, Binary a) => StringReferencingBinary (CompactNum a) where - ls_put _ (CompactNum i) - | 0 <= i && i < 255 = putWord8 (fromIntegral i) - | otherwise = putWord8 255 >> put i - ls_get _ = fmap CompactNum $ getWord8 >>= \case - i | 0 <= i && i < 255 -> return (fromIntegral i) - | otherwise -> get - -instance StringReferencingBinary a => StringReferencingBinary [a] where - ls_put strs l = ls_put strs (CompactNum (length l)) >> mapM_ (ls_put strs) l - ls_get strs = ls_getMany strs . fromCompactNum =<< ls_get strs - -instance StringReferencingBinary Text where - ls_put strs s = case elemIndex s strs of - Just i | 0 <= i && i < 255 -> - putWord8 (fromIntegral (succ i)) - _ -> putWord8 0 >> ls_put strs (T.unpack s) - ls_get strs = getWord8 >>= \case - 0 -> T.pack <$> ls_get strs - i -> return $! strs !! fromIntegral (pred i) - --- | 'ls_get strsMany n' ls_get strs 'n' elements in order, without blowing the stack. -ls_getMany :: StringReferencingBinary a => [Text] -> Int -> Get [a] -ls_getMany strs n = go [] n - where - go xs 0 = return $! reverse xs - go xs i = do x <- ls_get strs - -- we must seq x to avoid stack overflows due to laziness in - -- (>>=) - x `seq` go (x:xs) (i-1) -{-# INLINE ls_getMany #-} - - --- compat newtype for deserialization of v2-v4 CaptureData -newtype IntLen a = IntLen { fromIntLen :: a } - --- compat instance for deserialization of v1 CaptureData -instance Binary a => Binary (IntLen a) where - put = put . fromIntLen - get = IntLen <$> get - --- compat instance for deserialization of v2-v4 CaptureData -instance StringReferencingBinary a => StringReferencingBinary (IntLen [a]) where - ls_put strs (IntLen l) = ls_put strs (length l) >> mapM_ (ls_put strs) l - ls_get strs = fmap IntLen $ ls_getMany strs =<< ls_get strs - --- compat instance for deserialization of v2-v4 CaptureData -instance StringReferencingBinary (IntLen Text) where - ls_put strs (IntLen s) = case elemIndex s strs of - Just i | 0 <= i && i < 255 -> - putWord8 (fromIntegral (succ i)) - _ -> putWord8 0 >> ls_put strs (IntLen (T.unpack s)) - ls_get strs = fmap IntLen $ getWord8 >>= \case - 0 -> T.pack . fromIntLen <$> ls_get strs - i -> return $! strs !! fromIntegral (pred i) - -{- -instance Binary a => StringReferencingBinary a where - ls_put _ = put - ls_get _ = get --} - -instance StringReferencingBinary Char where { ls_put _ = put; ls_get _ = get } -instance StringReferencingBinary Int where { ls_put _ = put; ls_get _ = get } -instance StringReferencingBinary Integer where { ls_put _ = put; ls_get _ = get } -instance StringReferencingBinary Bool where { ls_put _ = put; ls_get _ = get } - -ls_encode :: StringReferencingBinary a => [Text] -> a -> ByteString -ls_encode strs = runPut . ls_put strs -{-# INLINE ls_encode #-} - --- | Decode a value from a lazy ByteString, reconstructing the original structure. --- -ls_decode :: StringReferencingBinary a => [Text] -> ByteString -> a -ls_decode strs = runGet (ls_get strs) - diff --git a/tests/examples/ghc92/T17544_kw.hs b/tests/examples/ghc92/T17544_kw.hs deleted file mode 100644 --- a/tests/examples/ghc92/T17544_kw.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE GADTs #-} - --- Haddock comments in this test case should all be rejected, but they are not. --- --- This is a known issue. Users should avoid writing comments in such --- positions, as a future fix will disallow them. --- --- See Note [Register keyword location] in GHC.Parser.PostProcess.Haddock - -module - -- | Bad comment for the module - T17544_kw where - -data Foo -- | Bad comment for MkFoo - where MkFoo :: Foo - -newtype Bar -- | Bad comment for MkBar - where MkBar :: () -> Bar - -class Cls a - -- | Bad comment for clsmethod - where - clsmethod :: a - diff --git a/tests/examples/ghc92/TH.hs b/tests/examples/ghc92/TH.hs deleted file mode 100644 --- a/tests/examples/ghc92/TH.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-| -Module : Language.Grammars.AspectAG.TH -Description : Boilerplate generation -Copyright : (c) Juan García Garland -License : GPL -Maintainer : jpgarcia@fing.edu.uy -Stability : experimental -Portability : POSIX --} - -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TemplateHaskell #-} - -module Language.Grammars.AspectAG.TH where - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (showName) -import Data.Proxy -import Data.Either -import GHC.TypeLits -import Data.List -import Data.Set (Set) -import qualified Data.Set as S - -import Control.Monad - -import Data.GenRec.Label -import Data.GenRec -import Language.Grammars.AspectAG -import Language.Grammars.AspectAG.RecordInstances -import qualified Data.Kind as DK - - --- * Attribute labels - --- | makes a type level lit (Symbol) from a String -str2Sym s = litT$ strTyLit s -- th provides nametoSymbol, btw - - --- | TH function to define a typed attribute label given a name --- and a quoted type -attLabel :: String -> Name -> DecsQ -attLabel s t - = [d| $(varP (mkName s)) = Label :: Label ( 'Att $(str2Sym s) - $(conT t)) |] - --- | for completness, to have a name as the next one -attMono = attLabel - --- | TH function to define a polymorphic attribute -attPoly :: String -> DecsQ -attPoly s - = [d| $(varP (mkName s)) = Label :: forall a . Label ( 'Att $(str2Sym s) a) |] - --- | multiple monomorphic attributes at once -attLabels :: [(String,Name)] -> Q [Dec] -attLabels xs = liftM concat . sequence $ [attLabel att ty | (att,ty) <- xs ] - --- * Non terminals - --- | add a non terminal symbol -addNont :: String -> Q [Dec] -addNont s - = liftM concat . sequence $ [addNTLabel s, addNTType s] - -addNTLabel :: String -> Q [Dec] -addNTLabel s - = [d| $(varP (mkName ("nt_" ++ s))) = Label :: Label ('NT $(str2Sym s)) |] - -addNTType :: String -> Q [Dec] -addNTType s - = return [TySynD (mkName ("Nt_"++ s)) [] (AppT (PromotedT 'NT) (LitT (StrTyLit s)))] - - --- * Productions ---data Symbol = N String | Te Name -type family Terminal s :: Either NT T where - Terminal s = 'Right ('T s) - -type family NonTerminal s where - NonTerminal s = 'Left s - - -data SymTH = Ter Name | NonTer Name | Poly - - -addChi :: String -- chi name - -> Name -- prd - -> SymTH -- symbol type - -> Q [Dec] -addChi chi prd (Ter typ) - = [d| $(varP (mkName ("ch_" ++chi))) - = Label :: Label ( 'Chi $(str2Sym chi) - $(conT prd) - (Terminal $(conT typ)))|] -addChi chi prd (NonTer typ) - = [d| $(varP (mkName ("ch_" ++chi))) - = Label :: Label ( 'Chi $(str2Sym chi) - $(conT prd) - (NonTerminal $(conT typ)))|] -addChi chi prd poly - = [d| $(varP (mkName ("ch_" ++chi))) - = Label :: forall a . Label ( 'Chi $(str2Sym chi) - $(conT prd) - ('Right ('T a)))|] - --- | only prod symbol -addPrd :: String --name - -> Name --nonterm - -> Q [Dec] -addPrd prd nt = liftM concat . sequence - $ [addPrdType prd nt, addPrdLabel prd nt] - -addPrdLabel prd nt - = [d| $(varP (mkName ("p_" ++ prd))) - = Label :: Label ('Prd $(str2Sym prd) $(conT nt))|] - -addPrdType prd nt - = return [TySynD (mkName ("P_"++ prd)) [] - (AppT (AppT (PromotedT 'Prd) (LitT (StrTyLit prd))) (ConT nt))] - - --- | Productions -addProd :: String -- name - -> Name -- nt - -> [(String, SymTH)] -- chiLst - -> Q [Dec] -addProd prd nt xs - = liftM concat . sequence $ - addPrd prd nt - : addInstance nt prd (map preProc xs) - : [addChi chi (mkName ("P_" ++ prd)) sym | (chi, sym) <- xs] - where preProc (n, Ter a) = (mkName n, a) - preProc (n, NonTer a) = (mkName n, a) - preProc (n, Poly) = (mkName n, mkName "a") - --- | class -class Prods (lhs :: NT) (name :: Symbol) (rhs :: [(Symbol, Symbol)]) where {} - --- get a list of instances -getInstances :: Q [InstanceDec] -getInstances = do - ClassI _ instances <- reify ''Prods - return instances - --- convert the list of instances into an Exp so they can be displayed in GHCi -showInstances :: Q Exp -showInstances = do - ins <- getInstances - return . LitE . stringL $ show $ head ins - -addInstance :: Name -> String -> [(Name, Name)] -> Q [Dec] -addInstance nt name rhs - = [d| instance Prods $(conT nt) $(str2Sym name) $(typeList rhs) where {} |] - -typeList :: [(Name, Name)] -> Q Type -typeList = foldr f promotedNilT - -- where f = \x xs -> appT (appT promotedConsT (nameToSymbolBase x)) xs - where f = \(n,t) xs - -> appT (appT promotedConsT (appT (appT (promotedTupleT 2) - (nameToSymbol n)) - (nameToSymbolBase t))) xs - -nameToSymbol = litT . strTyLit . show -nameToSymbolBase = litT . strTyLit . nameBase - -isNTName :: Name -> Bool -isNTName n - = "Nt_" `isPrefixOf` nameBase n - -closeNT :: Name -> Q [Dec] -closeNT nt - = do decs <- getInstances - let consts = map mkCon $ filter (isInstanceOf nt) decs - return [ DataD [] - (mkName $ drop 3 $ nameBase nt) [] Nothing - consts [DerivClause Nothing [ConT ''Show, ConT ''Eq, ConT ''Read]]] - -isInstanceOf nt (InstanceD _ _ (AppT (AppT (AppT (ConT prods) (ConT nt')) _ ) _) _) - = nameBase nt == nameBase nt' -isInstanceOf _ _ = False - -mkCon :: InstanceDec -> Con -mkCon i - = case i of - InstanceD _ [] (AppT (AppT (AppT (ConT _prods) (ConT nt)) (LitT (StrTyLit prdname))) tlist) _ - -> RecC (mkName prdname) (map mkBangPR $ getTList tlist) - -mkBangP (_, a) = (Bang NoSourceUnpackedness NoSourceStrictness, ConT a) -mkBangPR (n, a) = (n, Bang NoSourceUnpackedness NoSourceStrictness, ConT a) - -getTList :: Type -> [(Name, Name)] -getTList (SigT _ _) = [] -getTList (AppT (AppT (PromotedConsT) - (AppT (AppT (PromotedTupleT 2) - (LitT (StrTyLit n))) - (LitT (StrTyLit pos)))) - ts) - = (mkName n, - if "Nt_" `isPrefixOf` pos then mkName $ drop 3 pos else mkName pos) - : getTList ts -getTList _ = [] - --- | keeps nt info -getTListNT :: Type -> [(Name, Name)] -getTListNT (SigT _ _) = [] -getTListNT (AppT (AppT (PromotedConsT) - (AppT (AppT (PromotedTupleT 2) - (LitT (StrTyLit n))) - (LitT (StrTyLit pos)))) - ts) - = (mkName n, mkName pos) : getTListNT ts -getTListNT _ = [] - --- | like |mkCon| in semantic functions, builds a case -mkClause :: InstanceDec -> Clause -mkClause i - = case i of - InstanceD _ [] (AppT (AppT (AppT (ConT _prods) - (ConT nt)) - (LitT (StrTyLit prdname))) - tlist) _ - -> Clause [VarP (mkName "asp"), - ConP (mkName $ prdname) [ VarP a | a <- map fst (getTList tlist)]] - (NormalB ((AppE (AppE (AppE (VarE $ mkName "knitAspect") - (VarE $ mkName $ "p_"++ prdname)) - (VarE $ mkName "asp")) - (toSemRec (getTListNT tlist))))) - [] - -toSemRec :: [(Name, Name)] -> Exp -toSemRec - = foldr mkChSem (VarE (mkName "emptyGenRec")) - where mkChSem (n,pos) xs - | "Nt_" `isPrefixOf` nameBase pos = - (AppE (AppE (VarE $ mkName ".*.") - (AppE (AppE (VarE $ mkName ".=.") - (VarE $ mkName $ "ch_" ++ nameBase n)) - (AppE (AppE (VarE $ mkName $ "sem_" ++ (drop 3 $ nameBase pos)) - (VarE $ mkName "asp")) - (VarE $ n)))) - xs) - | otherwise = - (AppE (AppE (VarE $ mkName ".*.") - (AppE (AppE (VarE $ mkName ".=.") - (VarE $ mkName $ "ch_" ++ nameBase n)) - (AppE (VarE $ mkName "sem_Lit") - (VarE $ n)))) - xs) -closeNTs :: [Name] -> Q [Dec] -closeNTs = liftM concat . sequence . map (closeNT) - -mkSemFunc :: Name -- nonterm - -> Q [Dec] -mkSemFunc nt = - do decs <- getInstances - let clauses = map mkClause $ filter (isInstanceOf nt) decs - return [FunD (mkName $ "sem_" ++ drop 3 (nameBase nt)) clauses ] - -mkSemFuncs :: [Name] -> Q [Dec] -mkSemFuncs - = liftM concat . sequence . map (mkSemFunc) - diff --git a/tests/examples/ghc92/TH2.hs b/tests/examples/ghc92/TH2.hs deleted file mode 100644 --- a/tests/examples/ghc92/TH2.hs +++ /dev/null @@ -1,8 +0,0 @@ -{- Bloc comment --} - -{-# LANGUAGE PolyKinds #-} - -module Language.Grammars.AspectAG.TH where - -import Data.GenRec diff --git a/tests/examples/ghc92/TH_reifyDecl1a.hs b/tests/examples/ghc92/TH_reifyDecl1a.hs deleted file mode 100644 --- a/tests/examples/ghc92/TH_reifyDecl1a.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TypeFamilies, TypeApplications, PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} -module TH_reifyDecl1 where - -test :: () -test = $(let - display :: Name -> Q () - display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) } - in do { display ''T - ; display ''DF3 - ; [| () |] }) - diff --git a/tests/examples/ghc92/TopLevelSemis.hs b/tests/examples/ghc92/TopLevelSemis.hs deleted file mode 100644 --- a/tests/examples/ghc92/TopLevelSemis.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -module Network.MoHWS.HTTP.Header where - -x = 1 - --- Comment -; - -data Foo = Foo - --- After TyClD -; - -instance Monoid CIRB where - mempty = CIRB mempty mempty mempty mempty - --- After InstD -; - -deriving instance Eq (GenTickish 'TickishPassCore) - --- After DerivD -; - -transferCodingStr DeflateTransferCoding = "deflate" - --- After ValD -; - -getContentType :: Int - --- After SigD -; - -type MyMaybe :: Type -> Type - --- After KindSigD -; - -default (Integer) - --- After DefD -; - -foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int - --- After ForD -; - -{-# DEPRECATED foo2 [] #-} - --- After WarningD -; - -{-# ANN module FromA #-} - --- After AnnD -; - -{-# RULES "myrule2" id f = f #-} - --- After RuleD -; - -$foo - --- After SpliceD -; - -type role Representational representational - --- After RoleAnnotD -; - -getContentType = 1 - --- Note: skipping DocD, only generated in haddock mode - diff --git a/tests/examples/ghc92/TopLevelSemis1.hs b/tests/examples/ghc92/TopLevelSemis1.hs deleted file mode 100644 --- a/tests/examples/ghc92/TopLevelSemis1.hs +++ /dev/null @@ -1,14 +0,0 @@ -module TopLevelSemis1 where - -x = 1 - --- C1 --- C2 -; --- C3 -; --- C4 - -data Foo = Foo - --- After TyClD diff --git a/tests/examples/ghc92/TopLevelSemis2.hs b/tests/examples/ghc92/TopLevelSemis2.hs deleted file mode 100644 --- a/tests/examples/ghc92/TopLevelSemis2.hs +++ /dev/null @@ -1,25 +0,0 @@ -module TopLevelSemis2 where - -x = 1 -; - --- foo: two matches, with params -foo [] = [] --- After foo1 -; - -foo x = x --- After foo2 -; - --- bar: one match, with params -bar a = a --- after bar -; - --- baz: one match, no params -baz = 2 --- after baz -; - -y = 3 diff --git a/tests/examples/ghc92/TopLevelSemis3.hs b/tests/examples/ghc92/TopLevelSemis3.hs deleted file mode 100644 --- a/tests/examples/ghc92/TopLevelSemis3.hs +++ /dev/null @@ -1,7 +0,0 @@ -module TopLevelSemis3 where - { - x = 1; - -- Comment - class Foo a where { - }; -} diff --git a/tests/examples/ghc92/TypeFamilies.hs b/tests/examples/ghc92/TypeFamilies.hs deleted file mode 100644 --- a/tests/examples/ghc92/TypeFamilies.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds, UndecidableInstances #-} - -module TypeFamilies where - -type family F a b = r | r -> a b where - F a IO = IO a -- (1) - F Char b = b Int -- (2) diff --git a/tests/examples/ghc92/n-plus-k-patterns.hs b/tests/examples/ghc92/n-plus-k-patterns.hs deleted file mode 100644 --- a/tests/examples/ghc92/n-plus-k-patterns.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE NPlusKPatterns #-} -singleline :: Int -singleline (n + 1) = n - -multiline :: Int -multiline(n - + 1) = n - -n :: Int -(n + 1) = 3 - diff --git a/tests/examples/ghc92/proc-do-complex-four-out.hs b/tests/examples/ghc92/proc-do-complex-four-out.hs deleted file mode 100644 --- a/tests/examples/ghc92/proc-do-complex-four-out.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE Arrows #-} - -foo - f - g - h - ma = - proc - ( (a, b) - , (c, d) - , (e, f) - ) - -> do - -- Begin do - (x, y) <- -- GHC parser fails if layed out over multiple lines - f -- Call into f - ( a - , c -- Tuple together arguments - ) - ( b - , d - ) - -< - ( b + 1 -- Funnel into arrow - , d * b - ) - if x `mod` y == 0 -- Basic condition - then case e of -- Only left case is relevant - Left - ( z - , w - ) -> \u -> -- Procs can have lambdas - let v = - u -- Actually never used - ^ 2 - in ( returnA - -< - -- Just do the calculation - (x + y * z) - ) - else do - let u = x -- Let bindings bind expressions, not commands - -- Could pattern match directly on x - i <- case u of - 0 -> (g . h -< u) - n -> - ( ( h . g - -< - y -- First actual use of y - ) - ) - returnA -< () - -- Sometimes execute effects - if i > 0 - then ma -< () - else returnA -< () - returnA - -< - ( i - + x - * y -- Just do the calculation - ) - diff --git a/tests/examples/ghc92/proc-do-complex-out.hs b/tests/examples/ghc92/proc-do-complex-out.hs deleted file mode 100644 --- a/tests/examples/ghc92/proc-do-complex-out.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE Arrows #-} - -foo - f - g - h - ma = - proc - ( (a, b), - (c, d), - (e, f) - ) - -> do - -- Begin do - (x, y) <- -- GHC parser fails if layed out over multiple lines - f -- Call into f - ( a, - c -- Tuple together arguments - ) - ( b, - d - ) - -< - ( b + 1, -- Funnel into arrow - d * b - ) - if x `mod` y == 0 -- Basic condition - then case e of -- Only left case is relevant - Left - ( z, - w - ) -> \u -> -- Procs can have lambdas - let v = - u -- Actually never used - ^ 2 - in ( returnA - -< - -- Just do the calculation - (x + y * z) - ) - else do - let u = x -- Let bindings bind expressions, not commands - -- Could pattern match directly on x - i <- case u of - 0 -> (g . h -< u) - n -> - ( ( h . g - -< - y -- First actual use of y - ) - ) - returnA -< () - -- Sometimes execute effects - if i > 0 - then ma -< () - else returnA -< () - returnA - -< - ( i - + x - * y -- Just do the calculation - ) - diff --git a/tests/examples/ghc92/proc-do-complex.hs b/tests/examples/ghc92/proc-do-complex.hs deleted file mode 100644 --- a/tests/examples/ghc92/proc-do-complex.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE Arrows #-} -foo - f - g - h - ma = proc ( - (a, b), - (c, d), - (e, f) - ) -> - do -- Begin do - (x,y) -- GHC parser fails if layed out over multiple lines - <- f -- Call into f - (a, - c) -- Tuple together arguments - (b, - d) - -< (b + 1, -- Funnel into arrow - d * b) - if - x `mod` y == 0 -- Basic condition - then case e -- Only left case is relevant - of Left (z, - w) -> \u -> -- Procs can have lambdas - let - v - = u -- Actually never used - ^ 2 - in - (returnA - -< -- Just do the calculation - (x + y * z)) - else do - let u = x -- Let bindings bind expressions, not commands - -- Could pattern match directly on x - i <- case u of - 0 -> (g . h -< u) - n -> ( - (h . g - -< y) -- First actual use of y - ) - returnA -< () - -- Sometimes execute effects - if i > 0 - then ma -< () - else returnA -< () - returnA -< (i + - x * - y) -- Just do the calculation - diff --git a/tests/examples/ghc92/proc-lets-out.hs b/tests/examples/ghc92/proc-lets-out.hs deleted file mode 100644 --- a/tests/examples/ghc92/proc-lets-out.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE Arrows #-} - -foo f = proc a -> let b = a in f -< b - -bar f g = proc a -> - let h = - f - . g a - j = - g - . h - in id -< (h, j) - diff --git a/tests/examples/ghc92/proc-lets.hs b/tests/examples/ghc92/proc-lets.hs deleted file mode 100644 --- a/tests/examples/ghc92/proc-lets.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE Arrows #-} - -foo f = proc a -> let b = a in f -< b - -bar f g = proc a -> - let - h - = f - . g a - j = g - . - h - in - id -< (h, j) - diff --git a/tests/examples/ghc94/Haddock.hs b/tests/examples/ghc94/Haddock.hs deleted file mode 100644 --- a/tests/examples/ghc94/Haddock.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-} ------------------------------------------------------------------------------ --- | --- Module : Test --- Copyright : (c) Simon Marlow 2002 --- License : BSD-style --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- This module illustrates & tests most of the features of Haddock. --- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'. --- ------------------------------------------------------------------------------ - --- This is plain comment, ignored by Haddock. - -module Haddock ( - - -- Section headings are introduced with '-- *': - -- * Type declarations - - -- Subsection headings are introduced with '-- **' and so on. - -- ** Data types - T(..), T2, T3(..), T4(..), T5(..), T6(..), - N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..), - - -- ** Records - R(..), R1(..), - - -- | test that we can export record selectors on their own: - p, q, u, - - -- * Class declarations - C(a,b), D(..), E, F(..), - - -- | Test that we can export a class method on its own: - a, - - -- * Function types - f, g, - - -- * Auxiliary stuff - - -- $aux1 - - -- $aux2 - - -- $aux3 - - -- $aux4 - - -- $aux5 - - -- $aux6 - - -- $aux7 - - -- $aux8 - - -- $aux9 - - -- $aux10 - - -- $aux11 - - -- $aux12 - - -- | This is some inline documentation in the export list - -- - -- > a code block using bird-tracks - -- > each line must begin with > (which isn't significant unless it - -- > is at the beginning of the line). - - -- * A hidden module - module Hidden, - - -- * A visible module - module Visible, - - {-| nested-style doc comments -} - - -- * Existential \/ Universal types - Ex(..), - - -- * Type signatures with argument docs - k, l, m, o, - - -- * A section - -- and without an intervening comma: - -- ** A subsection - -{-| - > a literal line - - $ a non /literal/ line $ --} - - f', - ) where - -import Hidden -import Visible - --- | This comment applies to the /following/ declaration --- and it continues until the next non-comment line -data T a b - = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor - | -- | This comment describes the 'B' constructor - B (T a b, T Int Float) -- ^ - --- | An abstract data declaration -data T2 a b = T2 a b - --- | A data declaration with no documentation annotations on the constructors -data T3 a b = A1 a | B1 b - --- A data declaration with no documentation annotations at all -data T4 a b = A2 a | B2 b - --- A data declaration documentation on the constructors only -data T5 a b - = A3 a -- ^ documents 'A3' - | B3 b -- ^ documents 'B3' - --- | Testing alternative comment styles -data T6 - -- | This is the doc for 'A4' - = A4 - | B4 - | -- ^ This is the doc for 'B4' - - -- | This is the doc for 'C4' - C4 - --- | A newtype -newtype N1 a = N1 a - --- | A newtype with a fieldname -newtype N2 a b = N2 {n :: a b} - --- | A newtype with a fieldname, documentation on the field -newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field - } - --- | An abstract newtype - we show this one as data rather than newtype because --- the difference isn\'t visible to the programmer for an abstract type. -newtype N4 a b = N4 a - -newtype N5 a b = N5 {n5 :: a b -- ^ no docs on the datatype or the constructor - } - -newtype N6 a b = N6 {n6 :: a b - } - -- ^ docs on the constructor only - --- | docs on the newtype and the constructor -newtype N7 a b = N7 {n7 :: a b - } - -- ^ The 'N7' constructor - - -class (D a) => C a where - -- |this is a description of the 'a' method - a :: IO a - b :: [a] - -- ^ this is a description of the 'b' method - c :: a -- c is hidden in the export list - --- ^ This comment applies to the /previous/ declaration (the 'C' class) - -class D a where - d :: T a b - e :: (a,a) --- ^ This is a class declaration with no separate docs for the methods - -instance D Int where - d = undefined - e = undefined - --- instance with a qualified class name -instance Test.D Float where - d = undefined - e = undefined - -class E a where - ee :: a --- ^ This is a class declaration with no methods (or no methods exported) - --- This is a class declaration with no documentation at all -class F a where - ff :: a - --- | This is the documentation for the 'R' record, which has four fields, --- 'p', 'q', 'r', and 's'. -data R = - -- | This is the 'C1' record constructor, with the following fields: - C1 { p :: Int -- ^ This comment applies to the 'p' field - , q :: forall a . a->a -- ^ This comment applies to the 'q' field - , -- | This comment applies to both 'r' and 's' - r,s :: Int - } - | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (), - u,v :: Int - } - -- ^ This is the 'C2' record constructor, also with some fields: - --- | Testing different record commenting styles -data R1 - -- | This is the 'C3' record constructor - = C3 { - -- | The 's1' record selector - s1 :: Int - -- | The 's2' record selector - , s2 :: Int - , s3 :: Int -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here. - -- Since GHC doesn't allow that, I have removed it in this file. - -- ^ The 's3' record selector - } - --- These section headers are only used when there is no export list to --- give the structure of the documentation: - --- * This is a section header (level 1) --- ** This is a section header (level 2) --- *** This is a section header (level 3) - -{-| -In a comment string we can refer to identifiers in scope with -single quotes like this: 'T', and we can refer to modules by -using double quotes: "Foo". We can add emphasis /like this/. - - * This is a bulleted list - - - This is the next item (different kind of bullet) - - (1) This is an ordered list - - 2. This is the next item (different kind of bullet) - -@ - This is a block of code, which can include other markup: 'R' - formatting - is - significant -@ - -> this is another block of code - -We can also include URLs in documentation: . --} - -f :: C a => a -> Int - --- | we can export foreign declarations too -foreign import ccall "header.h" g :: Int -> IO CInt - --- | this doc string has a parse error in it: \' -h :: Int -h = 42 - - --- $aux1 This is some documentation that is attached to a name ($aux1) --- rather than a source declaration. The documentation may be --- referred to in the export list using its name. --- --- @ code block in named doc @ - --- $aux2 This is some documentation that is attached to a name ($aux2) - --- $aux3 --- @ code block on its own in named doc @ - --- $aux4 --- --- @ code block on its own in named doc (after newline) @ - -{- $aux5 a nested, named doc comment - - with a paragraph, - - @ and a code block @ --} - --- some tests for various arrangements of code blocks: - -{- $aux6 ->test ->test1 - -@ test2 - test3 -@ --} - -{- $aux7 -@ -test1 -test2 -@ --} - -{- $aux8 ->test3 ->test4 --} - -{- $aux9 -@ -test1 -test2 -@ - ->test3 ->test4 --} - -{- $aux10 ->test3 ->test4 - -@ -test1 -test2 -@ --} - --- This one is currently wrong (Haddock 0.4). The @...@ part is --- interpreted as part of the bird-tracked code block. -{- $aux11 -aux11: - ->test3 ->test4 - -@ -test1 -test2 -@ --} - --- $aux12 --- > foo --- --- > bar --- - --- | A data-type using existential\/universal types -data Ex a - = forall b . C b => Ex1 b - | forall b . Ex2 b - | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file - | Ex4 (forall a . a -> a) - --- | This is a function with documentation for each argument -k :: T () () -- ^ This argument has type 'T' - -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int' - -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@ - -> T5 () () -- ^ This argument has a very long description that should - -- hopefully cause some wrapping to happen when it is finally - -- rendered by Haddock in the generated HTML page. - -> IO () -- ^ This is the result type - --- This function has arg docs but no docs for the function itself -l :: (Int, Int, Float) -- ^ takes a triple - -> Int -- ^ returns an 'Int' - --- | This function has some arg docs -m :: R - -> N1 () -- ^ one of the arguments - -> IO Int -- ^ and the return value - --- | This function has some arg docs but not a return value doc - --- can't use the original name ('n') with GHC -newn :: R -- ^ one of the arguments, an 'R' - -> N1 () -- ^ one of the arguments - -> IO Int -newn = undefined - - --- | A foreign import with argument docs -foreign import ccall unsafe "header.h" - o :: Float -- ^ The input float - -> IO Float -- ^ The output float - --- | We should be able to escape this: \#\#\# - --- p :: Int --- can't use the above original definition with GHC -newp :: Int -newp = undefined - --- | a function with a prime can be referred to as 'f'' --- but f' doesn't get link'd 'f\'' -f' :: Int - - --- Add some definitions here so that this file can be compiled with GHC - -data T1 -f = undefined -f' = undefined -type CInt = Int -k = undefined -l = undefined -m = undefined diff --git a/tests/examples/ghc94/Haddock1.hs b/tests/examples/ghc94/Haddock1.hs deleted file mode 100644 --- a/tests/examples/ghc94/Haddock1.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-} --- | Haddock comment, --- coming before the module -module Haddock1 ( - - -- | This is some inline documentation in the export list - -- - -- > a code block using bird-tracks - -- > each line must begin with > (which isn't significant unless it - -- > is at the beginning of the line). - f - - {-| nested-style doc comments -} - , g - - -- * A section - -- and without an intervening comma: - -- ** A subsection - ) where - --- | Haddock before imports -import Data.List - --- | Haddock before decl -f = undefined -g = undefined - --- | This comment applies to the /following/ declaration --- and it continues until the next non-comment line -data T a b - = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor - | -- | This comment describes the 'B' constructor - B (T a b, T Int Float) -- ^ abcd - --- | An abstract data declaration -data T2 a b = T2 a b diff --git a/tests/examples/ghc94/Haddock2.hs b/tests/examples/ghc94/Haddock2.hs deleted file mode 100644 --- a/tests/examples/ghc94/Haddock2.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock -ddump-parsed -dkeep-comments #-} -module Haddock2 where - -data T - = B -- ^ abcd - --- | An abstract data declaration -data T2 = T2 diff --git a/tests/examples/ghc94/HsDocTy.hs b/tests/examples/ghc94/HsDocTy.hs deleted file mode 100644 --- a/tests/examples/ghc94/HsDocTy.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# OPTIONS_GHC -haddock #-} -module HsDocTy where - -class C1 a where - f1 :: a -> Int - -- ^ comment on Int diff --git a/tests/examples/ghc94/record-dot-four-out.hs b/tests/examples/ghc94/record-dot-four-out.hs deleted file mode 100644 --- a/tests/examples/ghc94/record-dot-four-out.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedRecordUpdate #-} -{-# LANGUAGE RebindableSyntax #-} - -data Foo = Foo {bar :: Foo} - -mfoo = fmap (.bar) $ Nothing - -baz = (Foo 1).bar - -fooplus f n = f{foo = f.bar + n} - -nestedFoo f = f.bar.bar.bar.bar.bar - -nestedFooUpdate f = f{bar.bar = f.bar} <> f{bar.bar.bar.bar} diff --git a/tests/examples/ghc96/ContinuationIO.hs b/tests/examples/ghc96/ContinuationIO.hs deleted file mode 100644 --- a/tests/examples/ghc96/ContinuationIO.hs +++ /dev/null @@ -1,3 +0,0 @@ -module ContinuationIO{-(module ContinuationIO, module DialogueIO)-} where - -stdin = "stdin" diff --git a/tests/examples/ghc96/Lib.hs b/tests/examples/ghc96/Lib.hs deleted file mode 100644 --- a/tests/examples/ghc96/Lib.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE DataKinds, TypeData #-} -module T22315a.Lib where - -data TermLevel = Mk -type data TypeLevel = Mk - -class C (a :: TypeLevel) -instance C Mk where - -foo :: C a => proxy a -> () -foo _ = () - diff --git a/tests/examples/ghc96/Main.hs b/tests/examples/ghc96/Main.hs deleted file mode 100644 --- a/tests/examples/ghc96/Main.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE OverloadedLabels, FlexibleContexts, OverloadedStrings, RecursiveDo, TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -module Main where - - -main :: IO () -main = do - Gtk.applicationNew (Just "de.weltraumschlangen.reflex-test") [] - >>= maybe - (die "Failed to initialize GTK") - ( \application -> do - ret <- runReflexGtk application (Just argv) $ do - runGtk $ do - #add mainWindow - #packStart outerBox - - ) - - - -- #add mainWindow - -- #packStart outerBox diff --git a/tests/examples/ghc96/T11671_run.hs b/tests/examples/ghc96/T11671_run.hs deleted file mode 100644 --- a/tests/examples/ghc96/T11671_run.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE MagicHash #-} - -import Data.Foldable (traverse_) -import Data.Proxy (Proxy(..)) -import GHC.OverloadedLabels (IsLabel(..)) -import GHC.TypeLits (KnownSymbol, symbolVal) -import GHC.Prim (Addr#) - -instance KnownSymbol symbol => IsLabel symbol String where - fromLabel = symbolVal (Proxy :: Proxy symbol) - -(#), (#.) :: String -> Int -> String -(#) _ i = show i -_ #. i = show i - -f :: Addr# -> Int -> String -f _ i = show i - -main :: IO () -main = traverse_ putStrLn - [ #a - , #number17 - , #do - , #type - , #Foo - , #3 - , #"199.4" - , #17a23b - , #f'a' - , #'a' - , #' - , #''notTHSplice - , #"..." - , #привет - , #こんにちは - , #"3" - , #":" - , #"Foo" - , #"The quick brown fox" - , #"\"" - , (++) #hello#world - , (++) #"hello"#"world" - , #"hello"# 1 -- equivalent to `(fromLabel @"hello") # 1` - , f "hello"#2 -- equivalent to `f ("hello"# :: Addr#) 2` - ] diff --git a/tests/examples/ghc96/T22315b.hs b/tests/examples/ghc96/T22315b.hs deleted file mode 100644 --- a/tests/examples/ghc96/T22315b.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeData #-} -module T22315b where - -data TermLevel = Mk -type data TypeLevel = Mk - -mk = Mk - -type Mk2 = Mk - diff --git a/tests/examples/ghc96/T22332a.hs b/tests/examples/ghc96/T22332a.hs deleted file mode 100644 --- a/tests/examples/ghc96/T22332a.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TypeData, DataKinds, TypeFamilies #-} -module Main where - -import Type.Reflection -import Data.Type.Equality - -data Proxy a -type data X1 = T -- defines type constructor T -data X2 = T -- defines type constructor 'T - -data family F p - -newtype instance F (Proxy T) = ID (forall a. a -> a) -newtype instance F (Proxy 'T) = UC (forall a b. a -> b) - --- This should fail at runtime because these are different types -eq :: T :~~: 'T -Just eq = eqTypeRep typeRep typeRep - -p :: a :~~: b -> F (Proxy a) :~: F (Proxy b) -p HRefl = Refl - -uc :: a -> b -uc = case castWith (p eq) (ID id) of UC a -> a - -main :: IO () -main = print (uc 'a' :: Int) - diff --git a/tests/examples/ghc96/T22500.hs b/tests/examples/ghc96/T22500.hs deleted file mode 100644 --- a/tests/examples/ghc96/T22500.hs +++ /dev/null @@ -1,10 +0,0 @@ --- Check that a quoted data type declaration is printed correctly -{-# LANGUAGE TemplateHaskellQuotes, TypeData #-} - -module Main where - -import Language.Haskell.TH -import Language.Haskell.TH.Ppr - -main = putStrLn . pprint =<< runQ [d| type data Nat = Zero | Succ Nat |] - diff --git a/tests/examples/ghc96/TDDataConstructor.hs b/tests/examples/ghc96/TDDataConstructor.hs deleted file mode 100644 --- a/tests/examples/ghc96/TDDataConstructor.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE TypeData #-} -module TDDataConstructor where - -type data P = MkP -data Prom = P - diff --git a/tests/examples/ghc96/TDExistential.hs b/tests/examples/ghc96/TDExistential.hs deleted file mode 100644 --- a/tests/examples/ghc96/TDExistential.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TypeData #-} -{-# LANGUAGE TypeFamilies #-} -module TDExistential where - -import Data.Kind (Type) - --- example from GHC User's Guide 6.4.10.6 - -type data Ex :: Type where - MkEx :: forall a. a -> Ex - -type family UnEx (ex :: Ex) :: k -type instance UnEx (MkEx x) = x - diff --git a/tests/examples/ghc96/TDGADT.hs b/tests/examples/ghc96/TDGADT.hs deleted file mode 100644 --- a/tests/examples/ghc96/TDGADT.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TypeData #-} -module TDGADT where - -import Data.Kind (Type) - -type data Nat = Zero | Succ Nat - --- type level GADT -type data Vec :: Nat -> Type -> Type where - VNil :: Vec Zero a - VCons :: a -> Vec n a -> Vec (Succ n) a - -type X = VCons Bool (VCons Int VNil) - diff --git a/tests/examples/ghc96/TDGoodConsConstraints.hs b/tests/examples/ghc96/TDGoodConsConstraints.hs deleted file mode 100644 --- a/tests/examples/ghc96/TDGoodConsConstraints.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeData #-} -{-# LANGUAGE GADTs #-} -module TDGoodConsConstraints where - -import Data.Kind (Type) -import Data.Type.Equality - -type data Foo :: Type -> Type where - MkFoo1 :: a ~ Int => Foo a - MkFoo2 :: a ~~ Int => Foo a - diff --git a/tests/examples/ghc96/TDVector.hs b/tests/examples/ghc96/TDVector.hs deleted file mode 100644 --- a/tests/examples/ghc96/TDVector.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE TypeData #-} -{-# LANGUAGE MonoLocalBinds #-} -module TDVector where - -import Data.Kind (Type) - -type data Nat = Zero | Succ Nat - -type data List a = Nil | Cons a (List a) - -type data Pair a b = MkPair a b - -type data Sum a b = L a | R b - -data Vec :: Nat -> Type -> Type where - VNil :: Vec Zero a - VCons :: a -> Vec n a -> Vec (Succ n) a - -instance Functor (Vec n) where - fmap _ VNil = VNil - fmap f (VCons x xs) = VCons (f x) (fmap f xs) - diff --git a/tests/examples/ghc96/TD_TH_splice.hs b/tests/examples/ghc96/TD_TH_splice.hs deleted file mode 100644 --- a/tests/examples/ghc96/TD_TH_splice.hs +++ /dev/null @@ -1,19 +0,0 @@ --- Check that splicing in a quoted declaration has the same effect as --- giving the declaration directly. -{-# LANGUAGE TemplateHaskell, TypeData, GADTs #-} - -module TD_TH_splice where - -import Data.Kind (Type) - --- splice should be equivalent to giving the declaration directly -$( [d| type data Nat = Zero | Succ Nat |] ) - -data Vec :: Nat -> Type -> Type where - VNil :: Vec Zero a - VCons :: a -> Vec n a -> Vec (Succ n) a - -instance Functor (Vec n) where - fmap _ VNil = VNil - fmap f (VCons x xs) = VCons (f x) (fmap f xs) - diff --git a/tests/examples/ghc98/ExportWarnings_aux.hs b/tests/examples/ghc98/ExportWarnings_aux.hs deleted file mode 100644 --- a/tests/examples/ghc98/ExportWarnings_aux.hs +++ /dev/null @@ -1,7 +0,0 @@ -module ExportWarnings_aux ( - {-# WARNING "warn" #-} x, - {-# WARNING in "x-custom-\72" [ "is" , "deprecated"] #-} S(S1), - ) where -import ExportWarnings_base (x) - -data S = S1 | S2 diff --git a/tests/examples/ghc98/IndentedModule2.hs b/tests/examples/ghc98/IndentedModule2.hs deleted file mode 100644 --- a/tests/examples/ghc98/IndentedModule2.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{- -} module Main where -main = putStr "foo" - diff --git a/tests/examples/ghc98/LexerM2.hs b/tests/examples/ghc98/LexerM2.hs deleted file mode 100644 --- a/tests/examples/ghc98/LexerM2.hs +++ /dev/null @@ -1,215 +0,0 @@ ----------------------------------------------------------------------------- --- | --- Module : FastTags.LexerM --- Copyright : (c) Sergey Vinokurov 2019 --- --- All the types and functions needed to make lexer run: --- - 'AlexInput' - primary workhorse, an optimized representation of input --- stream as a pointer to utf8 bytes and our position within it. --- - Lexer monad 'AlexM' - a monad (self-explanatory) with state that describes --- current lexing context. --- - 'AlexState' - state of the lexing monad, maintains current Alex code, --- comment depth, quasiquoter depth, indentation size, whether we're in --- a literate mode (and in which one) or vanilla mode and whether there --- are any TH quasiquotes present till the end of file. --- --- All the functions are to do with ----------------------------------------------------------------------------- - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} - -module FastTags.LexerM - ( AlexState(..) - , mkAlexState - , alexEnterBirdLiterateEnv - , alexEnterLiterateLatexEnv - , alexExitLiterateEnv - , pushContext - , modifyCommentDepth - , modifyQuasiquoterDepth - , modifyPreprocessorDepth - , addIndentationSize - , checkQuasiQuoteEndPresent - - , AlexM - , runAlexM - , alexSetInput - , alexSetNextCode - - , AlexInput(..) - , aiLineL - , takeText - , countInputSpace - , extractDefineOrLetName - , dropUntilNL - , dropUntilUnescapedNL - , dropUntilNLOr - , dropUntilNLOrEither - , unsafeTextHeadAscii - , unsafeTextHeadOfTailAscii - , unsafeTextHead - , utf8BS - - , asCodeL - , asCommentDepthL - , asQuasiquoterDepthL - , asIndentationSizeL - , asPreprocessorDepthL - , asLiterateLocL - , asHaveQQEndL - - -- * Alex interface - , alexInputPrevChar - , alexGetByte - ) where - -import Control.Applicative as A -import Control.DeepSeq -import Control.Exception -import Control.Monad.ST -import Control.Monad.State.Strict -import Control.Monad.Writer.Strict - -import Data.Char -import Data.Int -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Void (Void, vacuous) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Internal as BSI -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Mutable as UM - -import Foreign.ForeignPtr -import Foreign.Ptr -import GHC.Base -import GHC.Ptr -import GHC.Word -import Text.Printf - -import FastTags.LensBlaze -import FastTags.LexerTypes -import FastTags.Token - -import GHC.Exts (word8ToWord#, wordToWord8#) - - -data AlexState = AlexState - { asInput :: {-# UNPACK #-} !AlexInput - , asIntStore :: {-# UNPACK #-} !Word64 - -- ^ Integer field that stores all the other useful fields for lexing. - , asContextStack :: [Context] - } deriving (Show, Eq, Ord) - - -checkQuasiQuoteEndPresent :: Ptr Word8 -> Bool -checkQuasiQuoteEndPresent - = (\x -> isTrue# (qqessPresent x)) - . utf8Foldl' combine (QQEndsState 0# '\n'#) - where - combine :: QQEndsState -> Char# -> QQEndsState - combine QQEndsState{qqessPresent, qqessPrevChar} c# = QQEndsState - { qqessPresent = - qqessPresent `orI#` - case (# qqessPrevChar, c# #) of - (# '|'#, ']'# #) -> 1# - (# _, '⟧'# #) -> 1# - _ -> 0# - , qqessPrevChar = c# - } - -countInputSpace :: AlexInput -> Int -> Int -countInputSpace AlexInput{aiPtr} len = - utf8FoldlBounded len inc 0 aiPtr - where - inc !acc ' '# = acc + 1 - inc !acc '\t'# = acc + 8 - inc !acc c# = case fixChar c# of - 1## -> acc + 1 - _ -> acc - --- Translate unicode character into special symbol we teached Alex to recognize. -{-# INLINE fixChar #-} -fixChar :: Char# -> Word# -fixChar = \case - -- These should not be translated since Alex knows about them - '→'# -> reservedSym - '∷'# -> reservedSym - '⇒'# -> reservedSym - '∀'# -> reservedSym - '⦇'# -> reservedSym - '⦈'# -> reservedSym - '⟦'# -> reservedSym - '⟧'# -> reservedSym - '\x00'# -> fullStop - '\x01'# -> fullStop - '\x02'# -> fullStop - '\x03'# -> fullStop - '\x04'# -> fullStop - '\x05'# -> fullStop - '\x06'# -> fullStop - '\x07'# -> fullStop - '\x08'# -> other - c# -> case ord# c# of - c2# | isTrue# (c2# <=# 0x7f#) -> - int2Word# c2# -- Plain ascii needs no fixing. - | otherwise -> - case generalCategory (C# c#) of - UppercaseLetter -> upper - LowercaseLetter -> lower - TitlecaseLetter -> upper - ModifierLetter -> suffix - OtherLetter -> lower - NonSpacingMark -> suffix - DecimalNumber -> digit - OtherNumber -> digit - Space -> space - ConnectorPunctuation -> symbol - DashPunctuation -> symbol - OtherPunctuation -> symbol - MathSymbol -> symbol - CurrencySymbol -> symbol - ModifierSymbol -> symbol - OtherSymbol -> symbol - - SpacingCombiningMark -> space - EnclosingMark -> other - LetterNumber -> symbol - OpenPunctuation -> symbol - ClosePunctuation -> symbol - InitialQuote -> symbol - FinalQuote -> symbol - LineSeparator -> space - ParagraphSeparator -> space - Control -> other - Format -> other - Surrogate -> other - PrivateUse -> other - NotAssigned -> other - where - fullStop, space, upper, lower, symbol :: Word# - digit, suffix, reservedSym, other :: Word# - fullStop = 0x00## -- Don't care about these - space = 0x01## - upper = 0x02## - lower = 0x03## - symbol = 0x04## - digit = 0x05## - suffix = 0x06## - reservedSym = 0x07## - other = 0x08## - diff --git a/tests/examples/ghc98/ModuleComments.hs b/tests/examples/ghc98/ModuleComments.hs deleted file mode 100644 --- a/tests/examples/ghc98/ModuleComments.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -x = 1 diff --git a/tests/examples/ghc98/MonoidsFD.hs b/tests/examples/ghc98/MonoidsFD.hs deleted file mode 100644 --- a/tests/examples/ghc98/MonoidsFD.hs +++ /dev/null @@ -1,112 +0,0 @@ --- From a blog post: http://www.jonmsterling.com/posts/2012-01-12-unifying-monoids-and-monads-with-polymorphic-kinds.html - --------------------- FUNCTIONAL DEPENDENCY VERSION ---------------- - -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE UnicodeSyntax #-} - -module Main where -import Control.Monad (Monad(..), join, ap) -import Data.Monoid (Monoid(..)) -import Data.Semigroup (Semigroup(..)) - --- First we define the type class Monoidy: - -class Monoidy to comp id m | m to → comp id where - munit :: id `to` m - mjoin :: (m `comp` m) `to` m - --- We use functional dependencies to help the typechecker understand that --- m and ~> uniquely determine comp (times) and id. --- --- This kind of type class would not have been possible in previous --- versions of GHC; with the new kind system, however, we can abstract --- over kinds!2 Now, let’s create types for the additive and --- multiplicative monoids over the natural numbers: - -newtype Sum a = Sum a deriving Show -newtype Product a = Product a deriving Show -instance Num a ⇒ Monoidy (→) (,) () (Sum a) where - munit _ = Sum 0 - mjoin (Sum x, Sum y) = Sum $ x + y -instance Num a ⇒ Monoidy (→) (,) () (Product a) where - munit _ = Product 1 - mjoin (Product x, Product y) = Product $ x * y - --- It will be slightly more complicated to make a monadic instance with --- Monoidy. First, we need to define the identity functor, a type for --- natural transformations, and a type for functor composition: - -data Id α = Id { runId :: α } deriving Functor - --- A natural transformation (Λ f g α. (f α) → (g α)) may be encoded in Haskell as follows: - -data NT f g = NT { runNT :: ∀ α. f α → g α } - --- Functor composition (Λ f g α. f (g α)) is encoded as follows: - -data FC f g α = FC { runFC :: f (g α) } - --- Now, let us define some type T which should be a monad: - -data Wrapper a = Wrapper { runWrapper :: a } deriving (Show, Functor) -instance Monoidy NT FC Id Wrapper where - munit = NT $ Wrapper . runId - mjoin = NT $ runWrapper . runFC - --- With these defined, we can use them as follows: - -test1 = do { print (mjoin (munit (), Sum 2)) - -- Sum 2 - ; print (mjoin (Product 2, Product 3)) - -- Product 6 - ; print (runNT mjoin $ FC $ Wrapper (Wrapper "hello, world")) - -- Wrapper {runWrapper = "hello, world" } - } - --- We can even provide a special binary operator for the appropriate monoids as follows: - -(<+>) :: Monoidy (→) (,) () m ⇒ m → m → m -(<+>) = curry mjoin - -test2 = print (Sum 1 <+> Sum 2 <+> Sum 4) -- Sum 7 - --- Now, all the extra wrapping that Haskell requires for encoding this is --- rather cumbersome in actual use. So, we can give traditional Monad and --- Monoid instances for instances of Monoidy: - -instance Monoidy (→) (,) () m ⇒ Semigroup m where - (<>) = curry mjoin - -instance Monoidy (→) (,) () m ⇒ Monoid m where - mempty = munit () - -instance Applicative Wrapper where - pure x = runNT munit $ Id x - (<*>) = ap - --- instance (Functor m, Monoidy NT FC Id m) ⇒ Monad m where -instance Monad Wrapper where - x >>= f = runNT mjoin $ FC (f `fmap` x) - --- And so the following works: - -test3 - = do { print (mappend mempty (Sum 2)) - -- Sum 2 - ; print (mappend (Product 2) (Product 3)) - -- Product 6 - ; print (join $ Wrapper $ Wrapper "hello") - -- Wrapper {runWrapper = "hello" } - ; print (Wrapper "hello, world" >>= return) - -- Wrapper {runWrapper = "hello, world" } - } - -main = test1 >> test2 >> test3 diff --git a/tests/examples/ghc98/T13343.hs b/tests/examples/ghc98/T13343.hs deleted file mode 100644 --- a/tests/examples/ghc98/T13343.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE PolyKinds #-} -module Bug where - -import GHC.Exts - -type Bad :: forall v . TYPE v -type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v - --- Note v /= v1. - diff --git a/tests/examples/ghc98/T23465.hs b/tests/examples/ghc98/T23465.hs deleted file mode 100644 --- a/tests/examples/ghc98/T23465.hs +++ /dev/null @@ -1,14 +0,0 @@ -module T23465 {-# WaRNING in "x-a" "b" #-} where - -{-# WARNInG in "x-c" e "d" #-} -e = e - -{-# WARNInG - in "x-f" f "fw" ; - in "x-f" g "gw" -#-} -f = f -g = g - -{-# WARNinG h "hw" #-} -h = h diff --git a/tests/examples/ghc98/Token.hs b/tests/examples/ghc98/Token.hs deleted file mode 100644 --- a/tests/examples/ghc98/Token.hs +++ /dev/null @@ -1,261 +0,0 @@ -{-# language BangPatterns #-} -{-# language BinaryLiterals #-} -{-# language DerivingStrategies #-} -{-# language DuplicateRecordFields #-} -{-# language LambdaCase #-} -{-# language MagicHash #-} -{-# language PolyKinds #-} -{-# language RankNTypes #-} -{-# language StandaloneDeriving #-} -{-# language TypeApplications #-} -{-# language UnboxedTuples #-} - -module Json.Token - ( Token(..) - , TokenException(..) - , decode - ) where - -import Control.Monad.ST (ST,runST) -import Data.Bits ((.&.),(.|.),unsafeShiftR) -import Data.Builder.ST (Builder) -import Data.Bytes.Parser (Parser) -import Data.Bytes.Types (Bytes(..)) -import Data.Char (ord) -import Data.Primitive (MutableByteArray,ByteArray) -import Data.Primitive (SmallArray) -import Data.Text.Short (ShortText) -import Data.Word (Word8,Word16) -import GHC.Exts (Int(I#),Char(C#)) -import GHC.Exts (word2Int#,chr#,gtWord#,ltWord#) -import GHC.Word (Word16(W16#),Word8(W8#)) -import Data.Number.Scientific (Scientific) - -import qualified Data.ByteString.Short.Internal as BSS -import qualified Data.Bytes.Parser as P -import qualified Data.Bytes.Parser.Utf8 as Utf8 -import qualified Data.Bytes.Parser.Latin as Latin -import qualified Data.Bytes.Parser.Unsafe as Unsafe -import qualified Data.Builder.ST as B -import qualified Data.Chunks as C -import qualified Data.Primitive as PM -import qualified Data.Text.Short.Unsafe as TS -import qualified Data.Number.Scientific as SCI - --- | A token in a JSON document. -data Token - = LeftBrace - | RightBrace - | LeftBracket - | RightBracket - | Comma - | Colon - | BooleanTrue - | BooleanFalse - | Null - | String {-# UNPACK #-} !ShortText - | Number {-# UNPACK #-} !Scientific - deriving stock (Eq,Show) - --- | An exception encountered while tokenizing a JSON document. -data TokenException - = InvalidNumber - | InvalidLeader - | ExpectedTrue - | ExpectedFalse - | ExpectedNull - | LeadingZero - | InvalidEscapeSequence - | IncompleteString - | IncompleteEscapeSequence - deriving stock (Eq,Show) - -isSpace :: Word8 -> Bool -isSpace w = - w == c2w ' ' - || w == c2w '\t' - || w == c2w '\r' - || w == c2w '\n' - --- | Decode a sequence as JSON tokens. This allows token --- sequences that would be rejected by the ABNF given in --- : --- --- >>> decode (Bytes.fromAsciiString "[ , true }") --- Right [ LeftBracket, Comma, BooleanTrue, RightBrace ] --- --- It is up to the user to reject such malformed JSON when --- they parse the token sequence. More surprisingly, this --- tokenizer accepts some unnatural juxtapositions of token --- sequences without whitespace. For example: --- --- >>> decode (Bytes.fromAsciiString "55truefalse") --- Right [ Number 55, BooleanTrue, BooleanFalse ] --- >>> decode (Bytes.fromAsciiString "null\"hello\"") --- Right [ Null, String "hello" ] --- --- Acceptance of such samples simplifies the implementation --- of this tokenizer. These unnatural juxtapositions always --- result in token sequences that should be rejected anyway in --- the subsequent parsing done by the user. Consequently, their --- acceptance is not considered harmful. -decode :: Bytes -> Either TokenException (SmallArray Token) -decode !bs = runST $ do - !b <- B.new - P.parseBytesEffectfully (P.skipWhile isSpace *> manyTokens b) bs >>= \case - P.Failure err -> pure (Left err) - -- Since manyTokens only completes once the end of the input - -- has been reached, we do not need to check the length here. - P.Success (P.Slice _ _ cs) -> pure (Right cs) - -manyTokens :: - Builder s Token - -> Parser TokenException s (SmallArray Token) -manyTokens !b0 = do - t <- oneToken - !b1 <- P.effect (B.push t b0) - P.skipWhile isSpace - done <- P.isEndOfInput - if done - then P.effect $ do - cs <- B.freeze b1 - pure $! C.concat cs - else manyTokens b1 - --- TODO: oneToken is only called in contexts where the initial --- call to Latin.any cannot fail. Consider refactoring to make --- this more explicit. -oneToken :: Parser TokenException s Token -oneToken = Latin.any InvalidLeader >>= \case - '{' -> pure LeftBrace - '}' -> pure RightBrace - '[' -> pure LeftBracket - ']' -> pure RightBracket - ',' -> pure Comma - ':' -> pure Colon - 't' -> do - Latin.char3 ExpectedTrue 'r' 'u' 'e' - pure BooleanTrue - 'f' -> do - Latin.char4 ExpectedFalse 'a' 'l' 's' 'e' - pure BooleanFalse - 'n' -> do - Latin.char3 ExpectedNull 'u' 'l' 'l' - pure Null - '"' -> do - start <- Unsafe.cursor - string start - '-' -> fmap Number (SCI.parserNegatedUtf8Bytes InvalidNumber) - '0' -> Latin.trySatisfy (\c -> c >= '0' && c <= '9') >>= \case - True -> P.fail LeadingZero - False -> fmap Number (SCI.parserTrailingUtf8Bytes InvalidNumber 0) - c | c >= '1' && c <= '9' -> - fmap Number (SCI.parserTrailingUtf8Bytes InvalidNumber (ord c - 48)) - _ -> P.fail InvalidLeader - -copyAndEscape :: Int -> Parser TokenException s Token -copyAndEscape !maxLen = do - !dst <- P.effect (PM.newByteArray maxLen) - let go !ix = Utf8.any# IncompleteString `P.bindFromCharToLifted` \c -> case c of - '\\'# -> Latin.any IncompleteEscapeSequence >>= \case - '"' -> do - P.effect (PM.writeByteArray dst ix (c2w '"')) - go (ix + 1) - '\\' -> do - P.effect (PM.writeByteArray dst ix (c2w '\\')) - go (ix + 1) - 't' -> do - P.effect (PM.writeByteArray dst ix (c2w '\t')) - go (ix + 1) - 'n' -> do - P.effect (PM.writeByteArray dst ix (c2w '\n')) - go (ix + 1) - 'r' -> do - P.effect (PM.writeByteArray dst ix (c2w '\r')) - go (ix + 1) - '/' -> do - P.effect (PM.writeByteArray dst ix (c2w '/')) - go (ix + 1) - 'b' -> do - P.effect (PM.writeByteArray dst ix (c2w '\b')) - go (ix + 1) - 'f' -> do - P.effect (PM.writeByteArray dst ix (c2w '\f')) - go (ix + 1) - 'u' -> do - w <- Latin.hexFixedWord16 InvalidEscapeSequence - if w >= 0xD800 && w < 0xDFFF - then go =<< P.effect (encodeUtf8Char dst ix '\xFFFD') - else go =<< P.effect (encodeUtf8Char dst ix (w16ToChar w)) - _ -> P.fail InvalidEscapeSequence - '"'# -> do - str <- P.effect - (PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray dst ix) - pure (String (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str))) - _ -> go =<< P.effect (encodeUtf8Char dst ix (C# c)) - go 0 - -encodeUtf8Char :: MutableByteArray s -> Int -> Char -> ST s Int -encodeUtf8Char !marr !ix !c - | c < '\128' = do - PM.writeByteArray marr ix (c2w c) - pure (ix + 1) - | c < '\x0800' = do - PM.writeByteArray marr ix - (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6 .|. 0b11000000)) - PM.writeByteArray marr (ix + 1) - (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c)))) - pure (ix + 2) - | c <= '\xffff' = do - PM.writeByteArray marr ix - (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 12 .|. 0b11100000)) - PM.writeByteArray marr (ix + 1) - (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6)))) - PM.writeByteArray marr (ix + 2) - (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c)))) - pure (ix + 3) - | otherwise = error "encodeUtf8Char: write this" - - --- Compute the maximum number of bytes that could possibly --- be required to house the UTF-8-encoded string once any --- JSON escape sequences have been resolved. --- The correctness of this hinges on the assumption that --- the UTF-8 encoding of a character never takes up more --- bytes than its escape sequence. --- TODO: Something fishy is going on with escape sequences --- in this function. Look over this again. -string :: Int -> Parser TokenException s Token -string !start = go 1 where - go !canMemcpy = do - P.any IncompleteString >>= \case - 92 -> P.any InvalidEscapeSequence *> go 0 -- backslash - 34 -> do -- double quote - !pos <- Unsafe.cursor - case canMemcpy of - 1 -> do - src <- Unsafe.expose - str <- P.effect $ do - let end = pos - 1 - let len = end - start - dst <- PM.newByteArray len - PM.copyByteArray dst 0 src start len - PM.unsafeFreezeByteArray dst - pure (String (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str))) - _ -> do - Unsafe.unconsume (pos - start) - let end = pos - 1 - let maxLen = end - start - copyAndEscape maxLen - W8# w -> go (canMemcpy .&. I# (ltWord# w 128##) .&. I# (gtWord# w 31##)) - -byteArrayToShortByteString :: ByteArray -> BSS.ShortByteString -byteArrayToShortByteString (PM.ByteArray x) = BSS.SBS x - -c2w :: Char -> Word8 -c2w = fromIntegral . ord - --- Precondition: Not in the range [U+D800 .. U+DFFF] -w16ToChar :: Word16 -> Char -w16ToChar (W16# w) = C# (chr# (word2Int# w)) - diff --git a/tests/examples/pre-ghc810/arrowfail003.hs b/tests/examples/pre-ghc810/arrowfail003.hs deleted file mode 100644 --- a/tests/examples/pre-ghc810/arrowfail003.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE Arrows #-} --- Arrow commands where an expression is expected - -module ShouldFail where - -import Control.Arrow - -foo = returnA -< [] -bar = (|zeroArrow|) - diff --git a/tests/examples/pre-ghc86/BadTelescope.hs b/tests/examples/pre-ghc86/BadTelescope.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/BadTelescope.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module BadTelescope where - -import Data.Kind - -data SameKind :: k -> k -> * - -data X a k (b :: k) (c :: SameKind a b) diff --git a/tests/examples/pre-ghc86/BadTelescope2.hs b/tests/examples/pre-ghc86/BadTelescope2.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/BadTelescope2.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE TypeInType, ExplicitForAll #-} - -module BadTelescope2 where - -import Data.Kind -import Data.Proxy - -data SameKind :: k -> k -> * - -foo :: forall a k (b :: k). SameKind a b -foo = undefined - -bar :: forall a (c :: Proxy b) (d :: Proxy a). Proxy c -> SameKind b d -bar = undefined diff --git a/tests/examples/pre-ghc86/BadTelescope3.hs b/tests/examples/pre-ghc86/BadTelescope3.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/BadTelescope3.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeInType, ExplicitForAll #-} - -module BadTelescope3 where - -import Data.Kind - -data SameKind :: k -> k -> * - -type S a k (b :: k) = SameKind a b diff --git a/tests/examples/pre-ghc86/BadTelescope4.hs b/tests/examples/pre-ghc86/BadTelescope4.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/BadTelescope4.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, TypeInType #-} -module BadTelescope4 where - -import Data.Proxy -import Data.Kind - -data SameKind :: k -> k -> * - -data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - -data Borked a (b :: k) = forall (c :: k). B (Proxy c) - -- this last one is OK. But there was a bug involving renaming - -- that failed here, so the test case remains. diff --git a/tests/examples/pre-ghc86/Dep3.hs b/tests/examples/pre-ghc86/Dep3.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/Dep3.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-} - -module Dep3 where - -import Data.Kind -import GHC.Exts ( Constraint ) - -type Star1 = * - -data Id1 (a :: Star1) where - Id1 :: a -> Id1 a - -data Id1' :: Star1 -> * where - Id1' :: a -> Id1' a - -type family Star2 x where - Star2 x = * - -data Id2a (a :: Star2 Constraint) = Id2a a - - -data Id2 (a :: Star2 Constraint) where - Id2 :: a -> Id2 a - -data Id2' :: Star2 Constraint -> * where - Id2' :: a -> Id2' a diff --git a/tests/examples/pre-ghc86/KindEqualities2.hs b/tests/examples/pre-ghc86/KindEqualities2.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/KindEqualities2.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll, - TemplateHaskell, UndecidableInstances, ScopedTypeVariables, - TypeInType #-} - -module KindEqualities2 where - -import Data.Kind -import GHC.Exts ( Any ) - -data Kind = Star | Arr Kind Kind - -data Ty :: Kind -> * where - TInt :: Ty Star - TBool :: Ty Star - TMaybe :: Ty (Arr Star Star) - TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2 - - -data TyRep (k :: Kind) (t :: Ty k) where - TyInt :: TyRep Star TInt - TyBool :: TyRep Star TBool - TyMaybe :: TyRep (Arr Star Star) TMaybe - TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b) - -type family IK (k :: Kind) -type instance IK Star = * -type instance IK (Arr k1 k2) = IK k1 -> IK k2 - -$(return []) -- necessary because the following instances depend on the - -- previous ones. - -type family I (t :: Ty k) :: IK k -type instance I TInt = Int -type instance I TBool = Bool -type instance I TMaybe = Maybe -type instance I (TApp a b) = (I a) (I b) - -zero :: forall (a :: Ty 'Star). TyRep Star a -> I a -zero TyInt = 0 -zero TyBool = False -zero (TyApp TyMaybe TyInt) = Nothing - -main = print $ zero (TyApp TyMaybe TyInt) diff --git a/tests/examples/pre-ghc86/LiftedConstructors.hs b/tests/examples/pre-ghc86/LiftedConstructors.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/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/pre-ghc86/RAE_T32a.hs b/tests/examples/pre-ghc86/RAE_T32a.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/RAE_T32a.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds, - PolyKinds, TypeFamilies, GADTs, TypeInType #-} - -module RAE_T32a where - -import Data.Kind - -data family Sing (k :: *) :: k -> * - -data TyArr' (a :: *) (b :: *) :: * -type TyArr (a :: *) (b :: *) = TyArr' a b -> * -type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2 -data TyPi' (a :: *) (b :: TyArr a *) :: * -type TyPi (a :: *) (b :: TyArr a *) = TyPi' a b -> * -type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b -$(return []) - -data MkStar (p :: *) (x :: TyArr' p *) -type instance MkStar p @@ x = * -$(return []) - -data Sigma (p :: *) (r :: TyPi p (MkStar p)) :: * where - Sigma :: - forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a). - Sing * p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b -> Sigma p r -$(return []) - -data instance Sing Sigma (Sigma p r) x where - SSigma :: - forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a) - (sp :: Sing * p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) (sb :: Sing (r @@@ a) b). - Sing (Sing (r @@@ a) b) sb -> - Sing (Sigma p r) ('Sigma sp sr sa sb) - --- I (RAE) believe this last definition is ill-typed. diff --git a/tests/examples/pre-ghc86/RAE_T32b.hs b/tests/examples/pre-ghc86/RAE_T32b.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/RAE_T32b.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, DataKinds, PolyKinds, - RankNTypes, TypeOperators, TypeInType #-} - -module RAE_T32b where - -import Data.Kind - -data family Sing (k :: *) :: k -> * - -data TyArr (a :: *) (b :: *) :: * -type family (a :: TyArr k1 k2 -> *) @@ (b :: k1) :: k2 -$(return []) - -data Sigma (p :: *) (r :: TyArr p * -> *) :: * where - Sigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a). - Sing * p -> Sing (TyArr p * -> *) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r -$(return []) - -data instance Sing (Sigma p r) (x :: Sigma p r) :: * where - SSigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a) - (sp :: Sing * p) (sr :: Sing (TyArr p * -> *) r) (sa :: Sing p a) (sb :: Sing (r @@ a) b). - Sing (Sing (r @@ a) b) sb -> - Sing (Sigma p r) ('Sigma sp sr sa sb) diff --git a/tests/examples/pre-ghc86/Rae31.hs b/tests/examples/pre-ghc86/Rae31.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/Rae31.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds, - TypeFamilies, TypeInType #-} - -module A where - -import Data.Kind - -data family Sing (k :: *) :: k -> * -type Sing' (x :: k) = Sing k x -data TyFun' (a :: *) (b :: *) :: * -type TyFun (a :: *) (b :: *) = TyFun' a b -> * -type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2 -data TyPi' (a :: *) (b :: TyFun a *) :: * -type TyPi (a :: *) (b :: TyFun a *) = TyPi' a b -> * -type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b -$(return []) - -data A (a :: *) (b :: a) (c :: TyFun' a *) -- A :: forall a -> a -> a ~> * -type instance (@@) (A a b) c = * -$(return []) -data B (a :: *) (b :: TyFun' a *) -- B :: forall a -> a ~> * -type instance (@@) (B a) b = TyPi a (A a b) -$(return []) -data C (a :: *) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) *) diff --git a/tests/examples/pre-ghc86/RaeBlogPost.hs b/tests/examples/pre-ghc86/RaeBlogPost.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/RaeBlogPost.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies, - TypeInType #-} -{-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-} - -module RaeBlogPost where - -import Data.Kind - --- a Proxy type with an explicit kind -data Proxy k (a :: k) = P -prox :: Proxy * Bool -prox = P - -prox2 :: Proxy Bool 'True -prox2 = P - --- implicit kinds still work -data A -data B :: A -> * -data C :: B a -> * -data D :: C b -> * -data E :: D c -> * --- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> * - --- a kind-indexed GADT -data TypeRep (a :: k) where - TInt :: TypeRep Int - TMaybe :: TypeRep Maybe - TApp :: TypeRep a -> TypeRep b -> TypeRep (a b) - -zero :: TypeRep a -> a -zero TInt = 0 -zero (TApp TMaybe _) = Nothing - -data Nat = Zero | Succ Nat -type family a + b where - 'Zero + b = b - ('Succ a) + b = 'Succ (a + b) - -data Vec :: * -> Nat -> * where - Nil :: Vec a 'Zero - (:>) :: a -> Vec a n -> Vec a ('Succ n) -infixr 5 :> - --- promoted GADT, and using + as a "kind family": -type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where - 'Nil ++ y = y - (h ':> t) ++ y = h ':> (t ++ y) - --- datatype that mentions * -data U = Star (*) - | Bool Bool - --- kind synonym -type Monadish = * -> * -class MonadTrans (t :: Monadish -> Monadish) where - lift :: Monad m => m a -> t m a -data Free :: Monadish where - Return :: a -> Free a - Bind :: Free a -> (a -> Free b) -> Free b - --- yes, * really does have type *. -type Star = (* :: (* :: (* :: *))) diff --git a/tests/examples/pre-ghc86/RenamingStar.hs b/tests/examples/pre-ghc86/RenamingStar.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/RenamingStar.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module RenamingStar where - -data Foo :: * diff --git a/tests/examples/pre-ghc86/SlidingTypeSyn.hs b/tests/examples/pre-ghc86/SlidingTypeSyn.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/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/pre-ghc86/T10134a.hs b/tests/examples/pre-ghc86/T10134a.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/T10134a.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -module T10134a where - -import GHC.TypeLits - -data Vec :: Nat -> * -> * where - Nil :: Vec 0 a - (:>) :: a -> Vec n a -> Vec (n + 1) a diff --git a/tests/examples/pre-ghc86/T10321.hs b/tests/examples/pre-ghc86/T10321.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/T10321.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - -module T10321 where - -import GHC.TypeLits - -data Vec :: Nat -> * -> * where - Nil :: Vec 0 a - (:>) :: a -> Vec n a -> Vec (n + 1) a - -infixr 5 :> diff --git a/tests/examples/pre-ghc86/T10689a.hs b/tests/examples/pre-ghc86/T10689a.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/T10689a.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE TypeOperators - , DataKinds - , PolyKinds - , TypeFamilies - , GADTs - , UndecidableInstances - , RankNTypes - , ScopedTypeVariables - #-} - -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Werror #-} -{-# OPTIONS_GHC -O1 -fspec-constr #-} - -{- -ghc-stage2: panic! (the 'impossible' happened) - (GHC version 7.11.20150723 for x86_64-unknown-linux): - Template variable unbound in rewrite rule --} - -module List (sFoldr1) where - -data Proxy t - -data family Sing (a :: k) - -data TyFun (a :: *) (b :: *) - -type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2 - -data instance Sing (f :: TyFun k1 k2 -> *) = - SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } - -type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) - -type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) -singFun2 :: Proxy f -> SingFunction2 f -> Sing f -singFun2 _ f = SLambda (\x -> SLambda (f x)) - -data (:$$) (j :: a) (i :: TyFun [a] [a]) -type instance Apply ((:$$) j) i = (:) j i - -data (:$) (l :: TyFun a (TyFun [a] [a] -> *)) -type instance Apply (:$) l = (:$$) l -data instance Sing (z :: [a]) - = z ~ '[] => - SNil - | forall (m :: a) - (n :: [a]). z ~ (:) m n => - SCons (Sing m) (Sing n) - -data ErrorSym0 (t1 :: TyFun k1 k2) - -type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh - -type Let1627448493Xs f_afe9 - x_afea - wild_1627448474_afeb - wild_1627448476_afec = - Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec -type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) - -> *) - (t_afdZ :: [a_afdP]) = - Foldr1 t_afdY t_afdZ -data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) - -> *) - (l_afe2 :: TyFun [a_afdP] a_afdP) -type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 - -data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP - -> *) - -> *) (TyFun [a_afdP] a_afdP -> *)) -type instance Apply Foldr1Sym0 l = Foldr1Sym1 l - -type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP - -> *) - -> *) - (a_afe6 :: [a_afdP]) :: a_afdP where - Foldr1 z_afe7 '[x_afe8] = x_afe8 - Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) - Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" - -sFoldr1 :: - forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) - (y :: [a_afdP]). - Sing x - -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) -sFoldr1 _ (SCons _sX SNil) = undefined -sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) - = let - lambda_afeC :: - forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. - Sing f_afe9 - -> Sing x_afea - -> Sing wild_1627448474_afeb - -> Sing wild_1627448476_afec - -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) - lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG - = let - sXs :: - Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) - sXs - = applySing - (applySing - (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) - wild_1627448476_afeG - in - applySing - (applySing f_afeD x_afeE) - (applySing - (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) - sXs) - in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 -sFoldr1 _ SNil = undefined diff --git a/tests/examples/pre-ghc86/T10934.hs b/tests/examples/pre-ghc86/T10934.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/T10934.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE - ScopedTypeVariables - , DataKinds - , GADTs - , RankNTypes - , TypeOperators - , PolyKinds -- Comment out PolyKinds and the bug goes away. - #-} -{-# OPTIONS_GHC -O #-} - -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it - -module KeyValue where - -data AccValidation err a = AccFailure err | AccSuccess a - -data KeyValueError = MissingValue - -type WithKeyValueError = AccValidation [KeyValueError] - -missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs -missing = rpure missingField - where - missingField :: forall x. (WithKeyValueError :. f) x - missingField = Compose $ AccFailure [MissingValue] - -data Rec :: (u -> *) -> [u] -> * where - RNil :: Rec f '[] - (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) - -newtype Compose (f :: l -> *) (g :: k -> l) (x :: k) - = Compose { getCompose :: f (g x) } - -type (:.) f g = Compose f g - -class RecApplicative rs where - rpure - :: (forall x. f x) - -> Rec f rs diff --git a/tests/examples/pre-ghc86/T11142.hs b/tests/examples/pre-ghc86/T11142.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/T11142.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE TypeInType, RankNTypes #-} - -module T11142 where - -import Data.Kind - -data SameKind :: k -> k -> * - -foo :: forall b. (forall k (a :: k). SameKind a b) -> () -foo = undefined diff --git a/tests/examples/pre-ghc86/T3927b.hs b/tests/examples/pre-ghc86/T3927b.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/T3927b.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} - -module T3927b where - -import Data.Proxy -import GHC.Exts - -data Message - -data SocketType = Dealer | Push | Pull - -data SocketOperation = Read | Write - -type family Restrict (a :: SocketOperation) (as :: [SocketOperation]) :: Constraint where - Restrict a (a ': as) = () - Restrict x (a ': as) = Restrict x as - Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!") - -type family Implements (t :: SocketType) :: [SocketOperation] where - Implements Dealer = ['Read, Write] - Implements Push = '[Write] - Implements Pull = '[ 'Read] - -data SockOp :: SocketType -> SocketOperation -> * where - SRead :: SockOp sock 'Read - SWrite :: SockOp sock Write - -data Socket :: SocketType -> * where - Socket :: proxy sock - -> (forall op . Restrict op (Implements sock) => SockOp sock op -> Operation op) - -> Socket sock - -type family Operation (op :: SocketOperation) :: * where - Operation 'Read = IO Message - Operation Write = Message -> IO () - -class Restrict 'Read (Implements t) => Readable t where - readSocket :: Socket t -> Operation 'Read - readSocket (Socket _ f) = f (SRead :: SockOp t 'Read) - -instance Readable Dealer - -type family Writable (t :: SocketType) :: Constraint where - Writable Dealer = () - Writable Push = () - -dealer :: Socket Dealer -dealer = Socket (Proxy :: Proxy Dealer) f - where - f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op - f SRead = undefined - f SWrite = undefined - -push :: Socket Push -push = Socket (Proxy :: Proxy Push) f - where - f :: Restrict op (Implements Push) => SockOp Push op -> Operation op - f SWrite = undefined - -pull :: Socket Pull -pull = Socket (Proxy :: Proxy Pull) f - where - f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op - f SRead = undefined - -foo :: IO Message -foo = readSocket dealer diff --git a/tests/examples/pre-ghc86/T9632.hs b/tests/examples/pre-ghc86/T9632.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/T9632.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module T9632 where - -import Data.Kind - -data B = T | F -data P :: B -> * - -type B' = B -data P' :: B' -> * diff --git a/tests/examples/pre-ghc86/TensorTests.hs b/tests/examples/pre-ghc86/TensorTests.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/TensorTests.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, - RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, - UndecidableInstances #-} - -module TensorTests (tensorTests) where - -import Apply.Cyc -import Tests -import Utils - -import TestTypes - -import Crypto.Lol -import Crypto.Lol.CRTrans -import Crypto.Lol.Cyclotomic.Tensor -import Crypto.Lol.Types - -import Control.Applicative - -import Data.Maybe - -import Data.Singletons -import Data.Promotion.Prelude.Eq -import Data.Singletons.TypeRepStar () - -import qualified Test.Framework as TF - -type TMRParams = ( '( , ,) <$> Tensors <*> Tensors) <*> MRCombos - -type TMRParams = ( '(,) <$> Tensors) <*> MRCombos -tmrParams :: Proxy TMRParams -tmrParams = Proxy - ---type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos -type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos -tremParams :: Proxy TrEmParams -tremParams = Proxy - -type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos) - -data Liftable :: TyFun (Factored, *) Bool -> * -type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) - diff --git a/tests/examples/pre-ghc86/UnicodeSyntax.hs b/tests/examples/pre-ghc86/UnicodeSyntax.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/UnicodeSyntax.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnicodeSyntax #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE Arrows #-} - -module Tutorial where - --- import Abt.Class --- import Abt.Types --- import Abt.Concrete.LocallyNameless - -import Control.Applicative -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Except --- import Data.Vinyl -import Prelude hiding (pi) - --- | We'll start off with a monad in which to manipulate ABTs; we'll need some --- state for fresh variable generation. --- -newtype M α - = M - { _M ∷ State Int α - } deriving (Functor, Applicative, Monad) - --- | We'll run an ABT computation by starting the variable counter at @0@. --- -runM ∷ M α → α -runM (M m) = evalState m 0 - --- | Check out the source to see fresh variable generation. --- -instance MonadVar Var M where - fresh = M $ do - n ← get - let n' = n + 1 - put n' - return $ Var Nothing n' - - named a = do - v ← fresh - return $ v { _varName = Just a } - --- | Next, we'll define the operators for a tiny lambda calculus as a datatype --- indexed by arities. --- -data Lang ns where - LAM ∷ Lang '[S Z] - APP ∷ Lang '[Z, Z] - PI ∷ Lang '[Z, S Z] - UNIT ∷ Lang '[] - AX ∷ Lang '[] - -instance Show1 Lang where - show1 = \case - LAM → "lam" - APP → "ap" - PI → "pi" - UNIT → "unit" - AX → "<>" - -instance HEq1 Lang where - heq1 LAM LAM = Just Refl - heq1 APP APP = Just Refl - heq1 PI PI = Just Refl - heq1 UNIT UNIT = Just Refl - heq1 AX AX = Just Refl - heq1 _ _ = Nothing - -lam ∷ Tm Lang (S Z) → Tm0 Lang -lam e = LAM $$ e :& RNil - -app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang -app m n = APP $$ m :& n :& RNil - -ax ∷ Tm0 Lang -ax = AX $$ RNil - -unit ∷ Tm0 Lang -unit = UNIT $$ RNil - -pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang -pi α xβ = PI $$ α :& xβ :& RNil - --- | A monad transformer for small step operational semantics. --- -newtype StepT m α - = StepT - { runStepT ∷ MaybeT m α - } deriving (Monad, Functor, Applicative, Alternative) - --- | To indicate that a term is in normal form. --- -stepsExhausted - ∷ Applicative m - ⇒ StepT m α -stepsExhausted = StepT . MaybeT $ pure Nothing - -instance MonadVar Var m ⇒ MonadVar Var (StepT m) where - fresh = StepT . MaybeT $ Just <$> fresh - named str = StepT . MaybeT $ Just <$> named str - --- | A single evaluation step. --- -step - ∷ Tm0 Lang - → StepT M (Tm0 Lang) -step tm = - out tm >>= \case - APP :$ m :& n :& RNil → - out m >>= \case - LAM :$ xe :& RNil → xe // n - _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n - PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ - _ → stepsExhausted - --- | The reflexive-transitive closure of a small-step operational semantics. --- -star - ∷ Monad m - ⇒ (α → StepT m α) - → (α → m α) -star f a = - runMaybeT (runStepT $ f a) >>= - return a `maybe` star f - --- | Evaluate a term to normal form --- -eval ∷ Tm0 Lang → Tm0 Lang -eval = runM . star step - -newtype JudgeT m α - = JudgeT - { runJudgeT ∷ ExceptT String m α - } deriving (Monad, Functor, Applicative, Alternative) - -instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where - fresh = JudgeT . ExceptT $ Right <$> fresh - named str = JudgeT . ExceptT $ Right <$> named str - -type Ctx = [(Var, Tm0 Lang)] - -raise ∷ Monad m ⇒ String → JudgeT m α -raise = JudgeT . ExceptT . return . Left - -checkTy - ∷ Ctx - → Tm0 Lang - → Tm0 Lang - → JudgeT M () -checkTy g tm ty = do - let ntm = eval tm - nty = eval ty - (,) <$> out ntm <*> out nty >>= \case - (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do - z ← fresh - ez ← xe // var z - βz ← yβ // var z - checkTy ((z,α):g) ez βz - (AX :$ RNil, UNIT :$ RNil) → return () - _ → do - ty' ← inferTy g tm - if ty' === nty - then return () - else raise "Type error" - -inferTy - ∷ Ctx - → Tm0 Lang - → JudgeT M (Tm0 Lang) -inferTy g tm = do - out (eval tm) >>= \case - V v | Just (eval → ty) ← lookup v g → return ty - | otherwise → raise "Ill-scoped variable" - APP :$ m :& n :& RNil → do - inferTy g m >>= out >>= \case - PI :$ α :& xβ :& RNil → do - checkTy g n α - eval <$> xβ // n - _ → raise "Expected pi type for lambda abstraction" - _ → raise "Only infer neutral terms" - --- | @λx.x@ --- -identityTm ∷ M (Tm0 Lang) -identityTm = do - x ← fresh - return $ lam (x \\ var x) - --- | @(λx.x)(λx.x)@ --- -appTm ∷ M (Tm0 Lang) -appTm = do - tm ← identityTm - return $ app tm tm - --- | A demonstration of evaluating (and pretty-printing). Output: --- --- @ --- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4] --- @ --- -main ∷ IO () -main = do - -- Try out the type checker - either fail print . runM . runExceptT . runJudgeT $ do - x ← fresh - checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit)) - - print . runM $ do - mm ← appTm - mmStr ← toString mm - mmStr' ← toString $ eval mm - return $ mmStr ++ " ~>* " ++ mmStr' - -doMap ∷ FilePath → IOSArrow XmlTree TiledMap -doMap mapPath = proc m → do - mapWidth ← getAttrR "width" ⤙ m - returnA -< baz - --- ^ An opaque ESD handle for recording data from the soundcard via ESD. -data Recorder fr ch (r ∷ ★ → ★) - = Recorder { - reRate ∷ !Int - , reHandle ∷ !Handle - , reCloseH ∷ !(FinalizerHandle r) - } - --- from ghc-prim - --- | A backward-compatible (pre-GHC 8.0) synonym for 'Type' -type * = TYPE 'PtrRepLifted - --- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type' -type ★ = TYPE 'PtrRepLifted diff --git a/tests/examples/pre-ghc86/Vect.hs b/tests/examples/pre-ghc86/Vect.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/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/pre-ghc86/Webhook.hs b/tests/examples/pre-ghc86/Webhook.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/Webhook.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-| -Module : Servant.GitHub.Webhook -Description : Easily write safe GitHub webhook handlers with Servant -Copyright : (c) Jacob Thomas Errington, 2016 -License : MIT -Maintainer : servant-github-webhook@mail.jerrington.me -Stability : experimental - -The GitHub webhook machinery will attach three headers to the HTTP requests -that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@. -The former two headers correspond with the 'GitHubEvent' and -'GitHubSignedReqBody''' routing combinators. This library ignores the -@X-Github-Delivery@ header; if you would like to access its value, then use the -builtin 'Header' combinator from Servant. - -Usage of the library is straightforward: protect routes with the 'GitHubEvent' -combinator to ensure that the route is only reached for specific -'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write -under that route with 'GitHubSignedReqBody'. It is advised to always include a -'GitHubSignedReqBody''', as this is the only way you can be sure that it is -GitHub who is sending the request, and not a malicious user. If you don't care -about the request body, then simply use Aeson\'s 'Object' type as the -deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and -ignore the @Object@ in the handler. - -The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in -order to extract the signing key. This is the same key that must be entered in -the configuration of the webhook on GitHub. See 'GitHubKey'' for more details. - -In order to support multiple keys on a per-route basis, the basic combinator -@GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this, -create a datatype, e.g. @KeyIndex@ whose constructors identify the different -keys you will be using. Generally, this means one constructor per repository. -Use the @DataKinds@ extension to promote this datatype to a kind, and write an -instance of 'Reflect' for each promoted constructor of your datatype. Finally, -create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is -the datatype you've built up. Thus, your function can determine which key to -retrieve. --} - -{-# LANGUAGE CPP #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - --- GHC 8 seems to have improved its decidability check for type family --- instances and class instances. In particular, without UndecidableInstances --- enabled, the Demote' instance for lists, which we need, will not compile. --- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol, --- won't compile on GHC < 8 because the instance head is no smaller than the --- instance head. -#if __GLASGOW_HASKELL__ < 800 -{-# LANGUAGE UndecidableInstances #-} -#endif - -module Servant.GitHub.Webhook -( -- * Servant combinators - GitHubSignedReqBody'' -, GitHubSignedReqBody' -, GitHubSignedReqBody -, GitHubEvent - - -- ** Security -, GitHubKey'(..) -, GitHubKey -, gitHubKey - - -- * Reexports - -- - -- | We reexport a few datatypes that are typically needed to use the - -- library. -, RepoWebhookEvent(..) -, KProxy(..) - - -- * Implementation details - - -- ** Type-level programming machinery -, Demote -, Demote' -, Reflect(..) - - -- ** Stringy stuff -, parseHeaderMaybe -, matchEvent - - -- * Examples - -- - -- $example1 - -- - -- $example2 -) where - -import Control.Monad.IO.Class ( liftIO ) -import Data.Aeson ( decode', encode ) -import qualified Data.ByteString as BS -import Data.ByteString.Lazy ( fromStrict, toStrict ) -import qualified Data.ByteString.Base16 as B16 -import Data.HMAC ( hmac_sha1 ) -import Data.List ( intercalate ) -import Data.Maybe ( catMaybes, fromMaybe ) -import Data.Monoid ( (<>) ) -import Data.Proxy -import Data.String.Conversions ( cs ) -import qualified Data.Text.Encoding as E -import GHC.TypeLits -import GitHub.Data.Webhooks -import Network.HTTP.Types hiding (Header, ResponseHeaders) -import Network.Wai ( requestHeaders, strictRequestBody ) -import Servant -import Servant.API.ContentTypes ( AllCTUnrender(..) ) -import Servant.Server.Internal - - --- | A clone of Servant's 'ReqBody' combinator, except that it will also --- verify the signature provided by GitHub in the @X-Hub-Signature@ header by --- computing the SHA1 HMAC of the request body and comparing. --- --- The use of this combinator will require that the router context contain an --- appropriate 'GitHubKey'' entry. Specifically, the type parameter of --- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the --- index @key@ used here. Consequently, it will be necessary to use --- 'serveWithContext' instead of 'serve'. --- --- Other routes are not tried upon the failure of this combinator, and a 401 --- response is generated. --- --- Use of this datatype directly is discouraged, since the choice of the index --- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use --- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just --- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for --- the implementation of the 'HasServer' instance for the datatype. -data GitHubSignedReqBody'' - (proxy :: KProxy k) - (key :: k) - (list :: [*]) - (result :: *) where - --- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first --- type argument given just the second one. --- --- Use this type synonym if you are creating a webhook server to handle --- webhooks from multiple repositories, with different secret keys. -type GitHubSignedReqBody' (key :: k) - = GitHubSignedReqBody'' ('KProxy :: KProxy k) key - --- | A convenient alias for a trivial key index. --- --- USe this type synonym if you are creating a webhook server to handle only --- webhooks from a single repository, or for mutliple repositories using the --- same secret key. -type GitHubSignedReqBody = GitHubSignedReqBody' '() - --- | A routing combinator that succeeds only for a webhook request that matches --- one of the given 'RepoWebhookEvent' given in the type-level list @events@. --- --- If the list contains 'WebhookWildcardEvent', then all events will be --- matched. --- --- The combinator will require that its associated handler take a --- 'RepoWebhookEvent' parameter, and the matched event will be passed to the --- handler. This allows the handler to determine which event triggered it from --- the list. --- --- Other routes are tried if there is a mismatch. -data GitHubEvent (events :: [RepoWebhookEvent]) where - diff --git a/tests/examples/pre-ghc86/determ004.hs b/tests/examples/pre-ghc86/determ004.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/determ004.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# LANGUAGE TypeOperators - , DataKinds - , PolyKinds - , TypeFamilies - , GADTs - , UndecidableInstances - , RankNTypes - , ScopedTypeVariables - #-} - -{-# OPTIONS_GHC -Wall #-} -{-# OPTIONS_GHC -Werror #-} -{-# OPTIONS_GHC -O1 -fspec-constr #-} - -{- - -With reversed order of allocated uniques the type variables would be in -wrong order: - -*** Core Lint errors : in result of SpecConstr *** -determ004.hs:88:12: warning: - [in body of lambda with binder m_azbFg :: a_afdP_azbON] - @ (a_afdP_azbON :: BOX) is out of scope -*** Offending Program *** - -... - -Rec { -$s$wsFoldr1_szbtK - :: forall (m_azbFg :: a_afdP_azbON) - (x_azbOM :: TyFun - a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *) - -> *) - (a_afdP_azbON :: BOX) - (ipv_szbwN :: a_afdP_azbON) - (ipv_szbwO :: [a_afdP_azbON]). - R:Sing[]z (ipv_szbwN : ipv_szbwO) - ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO) - -> Sing ipv_szbwO - -> Sing ipv_szbwN - -> (forall (t_azbNM :: a_afdP_azbON). - Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) - -> Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) -[LclId, - Arity=4, - Str=DmdType ] -$s$wsFoldr1_szbtK = - \ (@ (m_azbFg :: a_afdP_azbON)) - (@ (x_azbOM :: TyFun - a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *) - -> *)) - (@ (a_afdP_azbON :: BOX)) - (@ (ipv_szbwN :: a_afdP_azbON)) - (@ (ipv_szbwO :: [a_afdP_azbON])) - (sg_szbtL - :: R:Sing[]z (ipv_szbwN : ipv_szbwO) - ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO)) - (sc_szbtM :: Sing ipv_szbwO) - (sc_szbtN :: Sing ipv_szbwN) - (sc_szbtP - :: forall (t_azbNM :: a_afdP_azbON). - Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) -> - case (SCons - @ a_afdP_azbON - @ (ipv_szbwN : ipv_szbwO) - @ ipv_szbwO - @ ipv_szbwN - @~ (_N - :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO)) - sc_szbtN - sc_szbtM) - `cast` (sg_szbtL - ; TFCo:R:Sing[]z[0] _N _N - :: R:Sing[]z (ipv_szbwN : ipv_szbwO) - ~R# R:Sing[]z - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) - of wild_XD { - SNil dt_dzbxX -> - (lvl_szbwi @ a_afdP_azbON) - `cast` ((Sing - (Sym (TFCo:R:Foldr1[2] _N _N) - ; Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N <'[]>_N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) - (Sym dt_dzbxX))_N))_R - :: Sing (Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list") - ~R# Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); - SCons @ n_azbFh @ m_XzbGe dt_dzbxK _sX_azbOH - ds_dzbyu [Dmd=] -> - case ds_dzbyu - `cast` (TFCo:R:Sing[]z[0] _N _N - :: Sing n_azbFh ~R# R:Sing[]z n_azbFh) - of wild_Xo { - SNil dt_dzbxk -> - (lvl_szbw1 @ a_afdP_azbON @ m_XzbGe) - `cast` ((Sing - (Sym (TFCo:R:Foldr1[0] _N _N _N) - ; Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N <'[m_XzbGe]>_N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) - ((_N ': Sym dt_dzbxk)_N ; Sym dt_dzbxK))_N))_R - :: Sing m_XzbGe - ~R# Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); - SCons @ ipv_XzbxR @ ipv_XzbyV ipv_szbwM ipv_szbwL ipv_szbwK -> - case (sc_szbtP @ m_XzbGe _sX_azbOH) - `cast` (TFCo:R:Sing(->)f[0] - _N _N _N - :: Sing (Apply x_azbOM m_XzbGe) - ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe)) - of wild_X3X { SLambda ds_XzbBr [Dmd=] -> - (ds_XzbBr - @ (Foldr1 x_azbOM (ipv_XzbyV : ipv_XzbxR)) - (($wsFoldr1_szbuc - @ a_afdP_azbON - @ x_azbOM - @ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR) - sc_szbtP - ((SCons - @ a_afdP_azbON - @ (ipv_XzbyV : ipv_XzbxR) - @ ipv_XzbxR - @ ipv_XzbyV - @~ (_N - :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR)) - ipv_szbwL - ipv_szbwK) - `cast` (Sym (TFCo:R:Sing[]z[0] _N) (Sym - (TFCo:R:Apply[][]:$$i[0] - _N - _N - _N) - ; (Apply - (Sym - (TFCo:R:Applyk(->):$l[0] - _N - _N)) - _N)_N) - :: R:Sing[]z (ipv_XzbyV : ipv_XzbxR) - ~R# Sing (Apply (Apply (:$) ipv_XzbyV) ipv_XzbxR)))) - `cast` ((Sing - ((Apply - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N) - _N)_N - ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N - ((Apply - (TFCo:R:Applyk(->):$l[0] _N _N) - _N)_N - ; TFCo:R:Apply[][]:$$i[0] - _N _N _N) - _N))_R - :: Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR)) - ~R# Sing (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))))) - `cast` ((Sing - ((Apply - _N - (Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N _N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] - _N _N)) - (Sym - (TFCo:R:Apply[][]:$$i[0] - _N _N _N) - ; (Apply - (Sym - (TFCo:R:Applyk(->):$l[0] _N _N)) - _N)_N))_N))_N - ; Sym - (TFCo:R:Foldr1[1] - _N - _N - _N - _N - _N) - ; Sym - (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] - _N _N _N) - ; (Apply - (Sym - (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) - ((_N ': Sym ipv_szbwM)_N ; Sym dt_dzbxK))_N))_R - :: Sing - (Apply - (Apply x_azbOM m_XzbGe) - (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))) - ~R# Sing - (Apply - (Apply Foldr1Sym0 x_azbOM) - (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))) - } - } - } -... --} - -module List (sFoldr1) where - -data Proxy t - -data family Sing (a :: k) - -data TyFun (a :: *) (b :: *) - -type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2 - -data instance Sing (f :: TyFun k1 k2 -> *) = - SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } - -type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) - -type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) -singFun2 :: Proxy f -> SingFunction2 f -> Sing f -singFun2 _ f = SLambda (\x -> SLambda (f x)) - -data (:$$) (j :: a) (i :: TyFun [a] [a]) -type instance Apply ((:$$) j) i = (:) j i - -data (:$) (l :: TyFun a (TyFun [a] [a] -> *)) -type instance Apply (:$) l = (:$$) l -data instance Sing (z :: [a]) - = z ~ '[] => - SNil - | forall (m :: a) - (n :: [a]). z ~ (:) m n => - SCons (Sing m) (Sing n) - -data ErrorSym0 (t1 :: TyFun k1 k2) - -type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh - -type Let1627448493Xs f_afe9 - x_afea - wild_1627448474_afeb - wild_1627448476_afec = - Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec -type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) - -> *) - (t_afdZ :: [a_afdP]) = - Foldr1 t_afdY t_afdZ -data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) - -> *) - (l_afe2 :: TyFun [a_afdP] a_afdP) -type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 - -data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP - -> *) - -> *) (TyFun [a_afdP] a_afdP -> *)) -type instance Apply Foldr1Sym0 l = Foldr1Sym1 l - -type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP - -> *) - -> *) - (a_afe6 :: [a_afdP]) :: a_afdP where - Foldr1 z_afe7 '[x_afe8] = x_afe8 - Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) - Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" - -sFoldr1 :: - forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) - (y :: [a_afdP]). - Sing x - -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) -sFoldr1 _ (SCons _sX SNil) = undefined -sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) - = let - lambda_afeC :: - forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. - Sing f_afe9 - -> Sing x_afea - -> Sing wild_1627448474_afeb - -> Sing wild_1627448476_afec - -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) - lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG - = let - sXs :: - Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) - sXs - = applySing - (applySing - (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) - wild_1627448476_afeG - in - applySing - (applySing f_afeD x_afeE) - (applySing - (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) - sXs) - in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 -sFoldr1 _ SNil = undefined diff --git a/tests/examples/pre-ghc86/dynamic-paper.hs b/tests/examples/pre-ghc86/dynamic-paper.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/dynamic-paper.hs +++ /dev/null @@ -1,341 +0,0 @@ -{- This is the code extracted from "A reflection on types", by Simon PJ, -Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -} - -{-# LANGUAGE RankNTypes, PolyKinds, TypeOperators, - ScopedTypeVariables, GADTs, FlexibleInstances, - UndecidableInstances, RebindableSyntax, - DataKinds, MagicHash, AutoDeriveTypeable, TypeInType #-} -{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-redundant-constraints #-} - -module Dynamic where - -import Data.Map ( Map ) -import qualified Data.Map as Map -import Unsafe.Coerce ( unsafeCoerce ) -import Control.Monad ( (<=<) ) -import Prelude hiding ( lookup, fromInteger, replicate ) -import qualified Prelude -import qualified Data.Typeable -import qualified Data.Data -import Data.Kind - -lookupMap = Map.lookup -insertMap = Map.insert - --- let's ignore overloaded numbers -fromInteger :: Integer -> Int -fromInteger = Prelude.fromInteger - -insertStore = undefined -schema = undefined -withTypeable = undefined -throw# = undefined - -toDynamicST = undefined -fromDynamicST = undefined - -extendStore :: Typeable a => STRef s a -> a -> Store -> Store -lookupStore :: Typeable a => STRef s a -> Store -> Maybe a - -type Key = Int -data STRef s a = STR Key -type Store = Map Key Dynamic - -extendStore (STR k) v s = insertMap k (toDynamicST v) s -lookupStore (STR k) s = case lookupMap k s of - Just d -> fromDynamicST d - Nothing -> Nothing - -toDynamicST :: Typeable a => a -> Dynamic -fromDynamicST :: Typeable a => Dynamic -> Maybe a - -eval = undefined -data Term - -data DynamicSilly = DIntSilly Int - | DBoolSilly Bool - | DCharSilly Char - | DPairSilly DynamicSilly DynamicSilly - - -toDynInt :: Int -> DynamicSilly -toDynInt = DIntSilly - -fromDynInt :: DynamicSilly -> Maybe Int -fromDynInt (DIntSilly n) = Just n -fromDynInt _ = Nothing - -toDynPair :: DynamicSilly -> DynamicSilly -> DynamicSilly -toDynPair = DPairSilly - -dynFstSilly :: DynamicSilly -> Maybe DynamicSilly -dynFstSilly (DPairSilly x1 x2) = Just x1 -dynFstSilly _ = Nothing - -eval :: Term -> DynamicSilly - -eqT = undefined - -instance Typeable (->) -instance Typeable Maybe -instance Typeable Bool -instance Typeable Int -instance (Typeable a, Typeable b) => Typeable (a b) -instance Typeable (,) - -instance Eq TypeRepX - -data Dynamic where - Dyn :: TypeRep a -> a -> Dynamic - -toDynamic :: Typeable a => a -> Dynamic -toDynamic x = Dyn typeRep x - -eqTNoKind = undefined - -eqTNoKind :: TypeRep a -> TypeRep b -> Maybe (a :***: b) - -- Primitive; implemented by compiler - -data a :***: b where - ReflNoKind :: a :***: a - -fromDynamic :: forall d. Typeable d => Dynamic -> Maybe d -fromDynamic (Dyn (ra :: TypeRep a) (x :: a)) - = case eqT ra (typeRep :: TypeRep d) of - Nothing -> Nothing - Just Refl -> Just x - -fromDynamicMonad :: forall d. Typeable d => Dynamic -> Maybe d - -fromDynamicMonad (Dyn ra x) - = do Refl <- eqT ra (typeRep :: TypeRep d) - return x - -cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b -cast x = do Refl <- eqT (typeRep :: TypeRep a) - (typeRep :: TypeRep b) - return x - -gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b) -gcast x = do Refl <- eqT (typeRep :: TypeRep a) - (typeRep :: TypeRep b) - return x - -data SameKind :: k -> k -> * -type CheckAppResult = SameKind AppResult AppResultNoKind - -- not the most thorough check -foo :: AppResult x -> AppResultNoKind x -foo (App y z) = AppNoKind y z - -splitApp :: TypeRep a -> Maybe (AppResult a) -splitApp = undefined -splitAppNoKind = undefined -splitAppNoKind :: TypeRep a -> Maybe (AppResultNoKind a) - -- Primitive; implemented by compiler - -data AppResultNoKind t where - AppNoKind :: TypeRep a -> TypeRep b -> AppResultNoKind (a b) - -dynFstNoKind :: Dynamic -> Maybe Dynamic -dynFstNoKind (Dyn rpab x) - = do AppNoKind rpa rb <- splitAppNoKind rpab - AppNoKind rp ra <- splitAppNoKind rpa - Refl <- eqT rp (typeRep :: TypeRep (,)) - return (Dyn ra (fst x)) - -dynApply :: Dynamic -> Dynamic -> Maybe Dynamic -dynApply (Dyn rf f) (Dyn rx x) = do - App ra rt2 <- splitApp rf - App rtc rt1 <- splitApp ra - Refl <- eqT rtc (typeRep :: TypeRep (->)) - Refl <- eqT rt1 rx - return (Dyn rt2 (f x)) - -data TypeRepAbstract (a :: k) -- primitive, indexed by type and kind - -class Typeable (a :: k) where - typeRep :: TypeRep a - -data AppResult (t :: k) where - App :: forall k1 k (a :: k1 -> k) (b :: k1). - TypeRep a -> TypeRep b -> AppResult (a b) - -dynFst :: Dynamic -> Maybe Dynamic -dynFst (Dyn (rpab :: TypeRep pab) (x :: pab)) - - = do App (rpa :: TypeRep pa ) (rb :: TypeRep b) <- splitApp rpab - -- introduces kind |k2|, and types |pa :: k2 -> *|, |b :: k2| - - App (rp :: TypeRep p ) (ra :: TypeRep a) <- splitApp rpa - -- introduces kind |k1|, and types |p :: k1 -> k2 -> *|, |a :: k1| - - Refl <- eqT rp (typeRep :: TypeRep (,)) - -- introduces |p ~ (,)| and |(k1 -> k2 -> *) ~ (* -> * -> *)| - - return (Dyn ra (fst x)) - -eqT :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~: b) - -data (a :: k1) :~: (b :: k2) where - Refl :: forall k (a :: k). a :~: a - -castDance :: (Typeable a, Typeable b) => a -> Maybe b -castDance = castR typeRep typeRep - -withTypeable :: TypeRep a -> (Typeable a => r) -> r - -castR :: TypeRep a -> TypeRep b -> a -> Maybe b -castR ta tb = withTypeable ta (withTypeable tb castDance) - -cmpT = undefined -compareTypeRep = undefined - -data TypeRepX where - TypeRepX :: TypeRep a -> TypeRepX - -type TyMapLessTyped = Map TypeRepX Dynamic - -insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped -insertLessTyped x = Map.insert (TypeRepX (typeRep :: TypeRep a)) (toDynamic x) - -lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a -lookupLessTyped = fromDynamic <=< Map.lookup (TypeRepX (typeRep :: TypeRep a)) - -instance Ord TypeRepX where - compare (TypeRepX tr1) (TypeRepX tr2) = compareTypeRep tr1 tr2 - -compareTypeRep :: TypeRep a -> TypeRep b -> Ordering -- primitive - -data TyMap = Empty | Node Dynamic TyMap TyMap - -lookup :: TypeRep a -> TyMap -> Maybe a -lookup tr1 (Node (Dyn tr2 v) left right) = - case compareTypeRep tr1 tr2 of - LT -> lookup tr1 left - EQ -> castR tr2 tr1 v -- know this cast will succeed - GT -> lookup tr1 right -lookup tr1 Empty = Nothing - -cmpT :: TypeRep a -> TypeRep b -> OrderingT a b - -- definition is primitive - -data OrderingT a b where - LTT :: OrderingT a b - EQT :: OrderingT t t - GTT :: OrderingT a b - -data TypeRep (a :: k) where - TrApp :: TypeRep a -> TypeRep b -> TypeRep (a b) - TrTyCon :: TyCon -> TypeRep k -> TypeRep (a :: k) - -data TyCon = TyCon { tc_module :: Module, tc_name :: String } -data Module = Module { mod_pkg :: String, mod_name :: String } - -tcMaybe :: TyCon -tcMaybe = TyCon { tc_module = Module { mod_pkg = "base" - , mod_name = "Data.Maybe" } - , tc_name = "Maybe" } - -rt = undefined - -delta1 :: Dynamic -> Dynamic -delta1 dn = case fromDynamic dn of - Just f -> f dn - Nothing -> dn -loop1 = delta1 (toDynamic delta1) - -data Rid = MkT (forall a. TypeRep a -> a -> a) -rt :: TypeRep Rid -delta :: forall a. TypeRep a -> a -> a -delta ra x = case (eqT ra rt) of - Just Refl -> case x of MkT y -> y rt x - Nothing -> x -loop = delta rt (MkT delta) - -throw# :: SomeException -> a - -data SomeException where - SomeException :: Exception e => e -> SomeException - -class (Typeable e, Show e) => Exception e where { } - -data Company -data Salary -incS :: Float -> Salary -> Salary -incS = undefined - --- some impedance matching with SYB -instance Data.Data.Data Company -instance {-# INCOHERENT #-} Data.Typeable.Typeable a => Typeable a - -mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a -mkT f x = case (cast f) of - Just g -> g x - Nothing -> x - -data Expr a -frontEnd = undefined - -data DynExp where - DE :: TypeRep a -> Expr a -> DynExp - -frontEnd :: String -> DynExp - -data TyConOld - -typeOf = undefined -eqTOld = undefined -funTcOld = undefined :: TyConOld -splitTyConApp = undefined -mkTyCon3 = undefined -boolTcOld = undefined -tupleTc = undefined -mkTyConApp = undefined -instance Eq TypeRepOld -instance Eq TyConOld - -data TypeRepOld -- Abstract - -class TypeableOld a where - typeRepOld :: proxy a -> TypeRepOld - -data DynamicOld where - DynOld :: TypeRepOld -> a -> DynamicOld - -data Proxy a = Proxy - -fromDynamicOld :: forall d. TypeableOld d => DynamicOld -> Maybe d -fromDynamicOld (DynOld trx x) - | typeRepOld (Proxy :: Proxy d) == trx = Just (unsafeCoerce x) - | otherwise = Nothing - -dynApplyOld :: DynamicOld -> DynamicOld -> Maybe DynamicOld -dynApplyOld (DynOld trf f) (DynOld trx x) = - case splitTyConApp trf of - (tc, [t1,t2]) | tc == funTcOld && t1 == trx -> - Just (DynOld t2 ((unsafeCoerce f) x)) - _ -> Nothing - -data DynamicClosed where - DynClosed :: TypeRepClosed a -> a -> DynamicClosed - -data TypeRepClosed (a :: *) where - TBool :: TypeRepClosed Bool - TFun :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a -> b) - TProd :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a, b) - - -lookupPil = undefined - -lookupPil :: Typeable a => [Dynamic] -> Maybe a - -data Dyn1 = Dyn1 Int - | DynFun (Dyn1 -> Dyn1) - | DynPair (Dyn1, Dyn1) - -data TypeEnum = IntType | FloatType | BoolType | DateType | StringType -data Schema = Object [Schema] | - Field TypeEnum | - Array Schema - -schema :: Typeable a => a -> Schema diff --git a/tests/examples/pre-ghc86/mkGADTVars.hs b/tests/examples/pre-ghc86/mkGADTVars.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/mkGADTVars.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE GADTs, TypeInType #-} - -module GADTVars where - -import Data.Kind -import Data.Proxy - -data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where - MkT :: T x1 * (Proxy (y :: x1), z) z diff --git a/tests/examples/pre-ghc86/overloadedrecflds_generics.hs b/tests/examples/pre-ghc86/overloadedrecflds_generics.hs deleted file mode 100644 --- a/tests/examples/pre-ghc86/overloadedrecflds_generics.hs +++ /dev/null @@ -1,50 +0,0 @@ --- Test that DuplicateRecordFields doesn't affect the metadata --- generated by GHC.Generics or Data.Data - --- Based on a Stack Overflow post by bennofs --- (http://stackoverflow.com/questions/24474581) --- licensed under cc by-sa 3.0 - -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} - -import GHC.Generics -import Data.Data -import Data.Proxy - -type family FirstSelector (f :: * -> *) :: Meta -type instance FirstSelector (M1 D x f) = FirstSelector f -type instance FirstSelector (M1 C x f) = FirstSelector f -type instance FirstSelector (a :*: b) = FirstSelector a -type instance FirstSelector (M1 S s f) = s - -data SelectorProxy (s :: Meta) (f :: * -> *) a = SelectorProxy -type SelectorProxy' (s :: Meta) = SelectorProxy s Proxy () - --- Extract the first selector name using GHC.Generics -firstSelectorName :: forall a. Selector (FirstSelector (Rep a)) - => Proxy a -> String -firstSelectorName _ = - selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a))) - --- Extract the list of selector names for a constructor using Data.Data -selectorNames :: Data a => a -> [String] -selectorNames = constrFields . toConstr - -data T = MkT { foo :: Int } deriving (Data, Generic) -data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic) - -main = do -- This should yield "foo", not "$sel:foo:MkT" - print (firstSelectorName (Proxy :: Proxy T)) - -- Similarly this should yield "foo" - print (firstSelectorName (Proxy :: Proxy U)) - -- This should yield ["foo"] - print (selectorNames (MkT 3)) - -- And this should yield ["foo","bar"] - print (selectorNames (MkU 3 True)) diff --git a/tests/examples/pre-ghc90/GADTContext.hs b/tests/examples/pre-ghc90/GADTContext.hs deleted file mode 100644 --- a/tests/examples/pre-ghc90/GADTContext.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - -data StackItem a where - Snum :: forall a. Fractional a => a -> StackItem a - Sop :: OpDesc -> StackItem a -deriving instance Show a => Show (StackItem a) - -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]) - TestParens :: (forall v . (Eq v) => MaybeDefault v) - TestParens2 :: (forall v . ((Eq v)) => MaybeDefault v) - TestParens3 :: (forall v . (((Eq v)) => (MaybeDefault v))) - TestParens4 :: (forall v . (((Eq v)) => (MaybeDefault v -> MaybeDefault v))) - -data T a where - K1 :: forall a. Ord a => { x :: [a], y :: Int } -> T a - K2 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> T a - K3 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> (T a) - K4 :: (forall a. Ord a => { x :: [a], y :: Int } -> T a) - -[t| Map.Map T.Text $tc |] - -bar $( [p| x |] ) = x diff --git a/tests/examples/pre-ghc90/Test10399.hs b/tests/examples/pre-ghc90/Test10399.hs deleted file mode 100644 --- a/tests/examples/pre-ghc90/Test10399.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -module Test10399 where - -type MPI = ?mpi_secret :: MPISecret - -mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) - -data MaybeDefault v where - SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v - SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v - -> a -> MaybeDefault [a]) - -[t| Map.Map T.Text $tc |] - -bar $( [p| x |] ) = x diff --git a/tests/examples/pre-ghc910/A.32.hs b/tests/examples/pre-ghc910/A.32.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/A.32.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +module A where + +import Language.Haskell.TH.Quote +import Language.Haskell.TH + +foo :: QuasiQuoter +foo = QuasiQuoter{quotePat = \s -> viewP [|(*2)|] (varP . mkName $ s)} + +bar :: QuasiQuoter +bar = QuasiQuoter{quotePat = \_ -> [p|((*3) -> fixed_var)|] } + diff --git a/tests/examples/pre-ghc910/A.hs b/tests/examples/pre-ghc910/A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/A.hs @@ -0,0 +1,4 @@ +module A where + +class A a where + has :: a diff --git a/tests/examples/pre-ghc910/AddAndOr3.hs b/tests/examples/pre-ghc910/AddAndOr3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/AddParams2.hs b/tests/examples/pre-ghc910/AddParams2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/AddParams2.hs @@ -0,0 +1,9 @@ +module AddParams2 where + +collapse rightInner rightOuter = right + where + right = (rightInner, rightOuter) + righ2 = (rightInner, (rightOuter baz bar)) + +baz = undefined +bar = undefined diff --git a/tests/examples/pre-ghc910/AdhocRule.hs b/tests/examples/pre-ghc910/AdhocRule.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/AdhocRule.hs @@ -0,0 +1,3 @@ +{-# RULES "adhoc1" forall r i. r { rOne = i } = r { rOne = i + 12 } #-} +{-# RULES "adhoc2" forall s. Record { rTwo = s } = Record { rTwo = s ++ s } #-} + diff --git a/tests/examples/pre-ghc910/AltsSemis.hs b/tests/examples/pre-ghc910/AltsSemis.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Ann01.hs b/tests/examples/pre-ghc910/Ann01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/AnnPackageName.hs b/tests/examples/pre-ghc910/AnnPackageName.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/AnnPackageName.hs @@ -0,0 +1,4 @@ + + +import "base" Prelude +import "base" Data.Data diff --git a/tests/examples/pre-ghc910/Annotations.hs b/tests/examples/pre-ghc910/Annotations.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Arith.hs b/tests/examples/pre-ghc910/Arith.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Arith.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +module Arith where + +data E a b = E (a -> b) (b -> a) + +eqRefl :: E a a +eqRefl = E id id + +-- just to construct unique strings +data W +data M a + +-- terms +data Var a where + VarW :: Var W + VarM :: Var (M a) + +-- expose s in the type level making sure it is a string +data Abs s e1 where + Abs :: (Var s) -> e1 -> Abs (Var s) e1 + +data App e1 e2 = App e1 e2 +data Lit = Lit + +data TyBase = TyBase +data TyArr t1 t2 = TyArr t1 t2 + +-- (x:ty) in G +data IN g p where + INOne :: IN (g,(x,ty)) (x,ty) + INShift :: IN g0 (x,ty) -> IN (g0,a) (x,ty) + +data INEX g x where + INEX :: IN g (x,v) -> INEX g x + + +-- G1 subseteq G2 +type SUP g1 g2 = forall a. IN g1 a -> IN g2 a + +-- typing derivations +data DER g a ty where + DVar :: IN (g,g0) ((Var a),ty) -> DER (g,g0) (Var a) ty -- the g,g0 makes sure that env is non-empty + DApp :: DER g a1 (TyArr ty1 ty2) -> + DER g a2 ty1 -> DER g (App a1 a2) ty2 + DAbs :: DER (g,(Var a,ty1)) e ty2 -> + DER g (Abs (Var a) e) (TyArr ty1 ty2) + DLit :: DER g Lit TyBase + +-- G |- \x.x : a -> a +test1 :: DER g (Abs (Var W) (Var W)) (TyArr ty ty) +test1 = DAbs (DVar INOne) + +-- G |- (\x.x) Lit : Lit +test2 :: DER g (App (Abs (Var W) (Var W)) Lit) TyBase +test2 = DApp (DAbs (DVar INOne)) DLit + +-- G |- \x.\y. x y : (C -> C) -> C -> C +test3 :: DER g (Abs (Var W) (Abs (Var (M W)) (App (Var W) (Var (M W))))) (TyArr (TyArr ty ty) (TyArr ty ty)) +test3 = DAbs (DAbs (DApp (DVar (INShift INOne)) (DVar INOne))) + +data ISVAL e where + ISVALAbs :: ISVAL (Abs (Var v) e) + ISVALLit :: ISVAL Lit + +data React e1 e2 where + SUBSTReact :: React (Abs (Var y) e) v + +-- evaluation +data EDER e1 e2 where + -- EVar :: IN (a,val) -> ISVAL val -> EDER c a val + EApp1 :: EDER e1 e1' -> EDER (App e1 e2) (App e1' e2) + EApp2 :: ISVAL v1 -> EDER e2 e2' -> EDER (App v1 e2) (App v1 e2') + EAppAbs :: ISVAL v2 -> React (Abs (Var v) e) v2 -> EDER (App (Abs (Var v) e) v2) e1 + +-- (\x.x) 3 -> 3 +-- test4 :: EDER (App (Abs (Var W) (Var W)) Lit) Lit +-- test4 = EAppAbs ISVALLit SUBSTEqVar + + +-- existential +data REDUCES e1 where + REDUCES :: EDER e1 e2 -> REDUCES e1 + +-- data WFEnv x c g where +-- WFOne :: ISVAL v -> DER g v ty -> WFEnv (Var x) (c,(Var x,v)) (g,(Var x,ty)) +-- WFShift :: WFEnv v c0 g0 -> WFEnv v (c0,(y,y1)) (g0,(z,z1)) + +-- data WFENVWRAP c g where +-- WFENVWRAP :: (forall v ty . IN g (v,ty) -> WFEnv v c g) -> WFENVWRAP c g + + +-- data INEXVAL c x where +-- INEXVAL :: IN c (x,v) -> ISVAL v -> INEXVAL c x + +-- -- the first cool theorem! +-- fromTEnvToEnv :: IN g (x,ty) -> WFEnv x c g -> INEXVAL c x +-- fromTEnvToEnv INOne (WFOne isv _) = INEXVAL INOne isv +-- fromTEnvToEnv (INShift ind1) (WFShift ind2) = +-- case (fromTEnvToEnv ind1 ind2) of +-- INEXVAL i isv -> INEXVAL (INShift i) isv + + +data ISLAMBDA v where ISLAMBDA :: ISLAMBDA (Abs (Var x) e) +data ISLIT v where ISLIT :: ISLIT Lit + +data EXISTAbs where + EXISTSAbs :: (Abs (Var x) e) -> EXISTAbs + +bot = bot + +canFormsLam :: ISVAL v -> DER g v (TyArr ty1 ty2) -> ISLAMBDA v +canFormsLam ISVALAbs _ = ISLAMBDA +-- canFormsLam ISVALLit _ = bot <== unfortunately I cannot catch this ... requires some exhaustiveness check :-( + +canFormsLit :: ISVAL v -> DER g v TyBase -> ISLIT v +canFormsLit ISVALLit _ = ISLIT + +data NULL + +progress :: DER NULL e ty -> Either (ISVAL e) (REDUCES e) + +progress (DAbs prem) = Left ISVALAbs +progress (DLit) = Left ISVALLit +-- progress (DVar iw) = bot <== here is the cool trick! I cannot even wite this down! +progress (DApp e1 e2) = + case (progress e1) of + Right (REDUCES r1) -> Right (REDUCES (EApp1 r1)) + Left isv1 -> case (progress e2) of + Right (REDUCES r2) -> Right (REDUCES (EApp2 isv1 r2)) + Left isv2 -> case (canFormsLam isv1 e1) of + ISLAMBDA -> Right (REDUCES (EAppAbs isv2 SUBSTReact)) + + +-- case fromTEnvToEnv iw (f iw) of +-- INEXVAL i isv -> Right (REDUCES (EVar i isv)) +-- progress (WFENVWRAP f) (DApp e1 e2) = +-- case (progress (WFENVWRAP f) e1) of +-- Right (REDUCES r1) -> Right (REDUCES (EApp1 r1)) +-- Left isv1 -> case (progress (WFENVWRAP f) e2) of +-- Right (REDUCES r2) -> Right (REDUCES (EApp2 isv1 r2)) +-- Left isv2 -> case (canFormsLam isv1 e1) of +-- ISLAMBDA -> EAppAbs isv2 e1 + diff --git a/tests/examples/pre-ghc910/Arity2.hs b/tests/examples/pre-ghc910/Arity2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Arity2.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Arity2 where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint +-} + +--import GHC.Base + +data Id a = Id a + +(<$>) :: (a -> b) -> Id a -> Id b +(<$>) f (Id a) = Id (f a) + +(<*>) :: Id (a -> b) -> Id a -> Id b +(<*>) (Id a) (Id b) = Id (a b) + +data Q = Q () () +data S = S () + +-- Q only gets eta-expand once and then trapped +foo = Q <$> Id () <*> Id () + +-- This compiles fine +foo2 = S <$> Id () + +{- +[1 of 1] Compiling Arity2 ( linear-tests/Arity2.hs, linear-tests/Arity2.o ) + +linear-tests/Arity2.hs:21:7: error: + • Couldn't match type ‘() ⊸ Q’ with ‘() -> b’ + Expected type: Id (() -> b) + Actual type: Id (() ⊸ Q) + • In the first argument of ‘(<*>)’, namely ‘Q <$> Id ()’ + In the expression: Q <$> Id () <*> Id () + In an equation for ‘foo’: foo = Q <$> Id () <*> Id () + • Relevant bindings include + foo :: Id b (bound at linear-tests/Arity2.hs:21:1) + | +21 | foo = Q <$> Id () <*> Id () + | ^^^^^^^^^^^ +-} diff --git a/tests/examples/pre-ghc910/Arrow.hs b/tests/examples/pre-ghc910/Arrow.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ArrowLambdaCase.hs b/tests/examples/pre-ghc910/ArrowLambdaCase.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ArrowLambdaCase.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Arrows, LambdaCase #-} +module Main (main) where + +import Control.Arrow + +main :: IO () +main = do + putStrLn $ foo (Just 42) + putStrLn $ foo (Just 500) + putStrLn $ foo Nothing + +foo :: ArrowChoice p => p (Maybe Int) String +foo = proc x -> + (| id (\case + Just x | x > 100 -> returnA -< "big " ++ show x + | otherwise -> returnA -< "small " ++ show x + Nothing -> returnA -< "none") + |) x + diff --git a/tests/examples/pre-ghc910/Arrows.hs b/tests/examples/pre-ghc910/Arrows.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Associated.1.hs b/tests/examples/pre-ghc910/Associated.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Associated.1.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/pre-ghc910/Associated.hs b/tests/examples/pre-ghc910/Associated.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Associated1.hs b/tests/examples/pre-ghc910/Associated1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Associated1.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +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 diff --git a/tests/examples/pre-ghc910/AssociatedInternal.hs b/tests/examples/pre-ghc910/AssociatedInternal.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/AssociatedType.hs b/tests/examples/pre-ghc910/AssociatedType.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Async.hs b/tests/examples/pre-ghc910/Async.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Async.hs @@ -0,0 +1,11 @@ + +asyncUsing :: (IO () -> IO ThreadId) + -> IO a -> IO (Async a) +asyncUsing doFork = \action -> do + var <- newEmptyTMVarIO + -- t <- forkFinally action (\r -> atomically $ putTMVar var r) + -- slightly faster: + t <- mask $ \restore -> + doFork $ try (restore action) >>= atomically . putTMVar var + return (Async t (readTMVar var)) + diff --git a/tests/examples/pre-ghc910/B.1.hs b/tests/examples/pre-ghc910/B.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/B.1.hs @@ -0,0 +1,4 @@ + +foo x = case (odd x) of + True -> "Odd" + False -> "Even" diff --git a/tests/examples/pre-ghc910/B.hs b/tests/examples/pre-ghc910/B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/B.hs @@ -0,0 +1,4 @@ +module B where + +class B a where + has :: a diff --git a/tests/examples/pre-ghc910/BCase.hs b/tests/examples/pre-ghc910/BCase.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/BIf.hs b/tests/examples/pre-ghc910/BIf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Backquote.hs b/tests/examples/pre-ghc910/Backquote.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/BadTelescope.hs b/tests/examples/pre-ghc910/BadTelescope.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BadTelescope.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeInType #-} + +module BadTelescope where + +import Data.Kind + +data SameKind :: k -> k -> Type + +data X a k (b :: k) (c :: SameKind a b) diff --git a/tests/examples/pre-ghc910/BadTelescope2.hs b/tests/examples/pre-ghc910/BadTelescope2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BadTelescope2.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeInType, ExplicitForAll #-} + +module BadTelescope2 where + +import Data.Kind +import Data.Proxy + +data SameKind :: k -> k -> Type + +foo :: forall a k (b :: k). SameKind a b +foo = undefined + +bar :: forall a (c :: Proxy b) (d :: Proxy a). Proxy c -> SameKind b d +bar = undefined diff --git a/tests/examples/pre-ghc910/BadTelescope3.hs b/tests/examples/pre-ghc910/BadTelescope3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BadTelescope3.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeInType, ExplicitForAll #-} + +module BadTelescope3 where + +import Data.Kind + +data SameKind :: k -> k -> Type + +type S a k (b :: k) = SameKind a b diff --git a/tests/examples/pre-ghc910/BadTelescope4.hs b/tests/examples/pre-ghc910/BadTelescope4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BadTelescope4.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ExistentialQuantification, TypeInType #-} +module BadTelescope4 where + +import Data.Proxy +import Data.Kind + +data SameKind :: k -> k -> Type + +data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +data Borked a (b :: k) = forall (c :: k). B (Proxy c) + -- this last one is OK. But there was a bug involving renaming + -- that failed here, so the test case remains. diff --git a/tests/examples/pre-ghc910/BalanceComments1.hs b/tests/examples/pre-ghc910/BalanceComments1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BalanceComments1.hs @@ -0,0 +1,11 @@ +module BalanceComments1 where + +-- Captured in https://gitlab.haskell.org/ghc/ghc/-/issues/20297 +-- The '-- do stuff' comment is attached to the wrong annotation + +-- Chris done comment attachment problem +foo = x + where -- do stuff + doStuff = do stuff +x = 1 +stuff = 4 diff --git a/tests/examples/pre-ghc910/BangPatterns.hs b/tests/examples/pre-ghc910/BangPatterns.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Base.hs b/tests/examples/pre-ghc910/Base.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Base.hs @@ -0,0 +1,6 @@ +module Base (AClass(..), BClass()) where + +import Extends (BClass ()) + +class AClass a where + has :: a diff --git a/tests/examples/pre-ghc910/BaseDescriptor.hs b/tests/examples/pre-ghc910/BaseDescriptor.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BaseDescriptor.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.ByteString.Mp4.Boxes.BaseDescriptor where + +import Data.ByteString.IsoBaseFileFormat.ReExports +import Data.ByteString.Mp4.Boxes.Expandable + +-- * Static base constructor + +-- | Abstract class of /descriptors/ as recognized by ISO/IEC 14496-1 (Systems). +-- A specifc descriptor is identified by the 'ClassTag'. +data Descriptor :: ClassTag n -> Type where + MkDescriptor ::BitRecord -> Descriptor tag + +-- TODO ok... this fixed the current problem in DecoderSpecificInfo .. but remove this instances ... or the above ... or ... I dunno + +data BitRecordOfDescriptor :: Extends (Descriptor c -> BitRecord) + +type instance + Apply BitRecordOfDescriptor ('MkDescriptor body :: Descriptor (tag :: ClassTag tagInd)) = + FieldU8 := tagInd + .+: From (StaticExpandableContent body) + +type family GetClassTag (c :: ClassTag n) :: Nat where + GetClassTag (c :: ClassTag n) = n + +-- | Base Descriptor Class Tags TODO rename to xxxTag +data ClassTag (tag :: Nat) where + ObjectDescr ::ClassTag 0x01 + InitialObjectDescr ::ClassTag 0x02 + ES_Descr ::ClassTag 0x03 + DecoderConfigDescr ::ClassTag 0x04 + DecSpecificInfo ::ClassTag 0x05 + SLConfigDescr ::ClassTag 0x06 + ContentIdentDescr ::ClassTag 0x07 + SupplContentIdentDescr ::ClassTag 0x08 + IPI_DescrPointer ::ClassTag 0x09 + IPMP_DescrPointer ::ClassTag 0x0A + IPMP_Descr ::ClassTag 0x0B + QoS_Descr ::ClassTag 0x0C + RegistrationDescr ::ClassTag 0x0D + ES_ID_Ref ::ClassTag 0x0F + MP4_IOD_ ::ClassTag 0x10 + MP4_OD_ ::ClassTag 0x11 + IPL_DescrPointerRef ::ClassTag 0x12 + ExtensionProfileLevelDescr ::ClassTag 0x13 + ProfileLevelIndicationIndexDescr ::ClassTag 0x14 + ContentClassificationDescr ::ClassTag 0x40 + KeyWordDescr ::ClassTag 0x41 + RatingDescr ::ClassTag 0x42 + LanguageDescr ::ClassTag 0x43 + ShortTextualDescr ::ClassTag 0x44 + ExpandedTextualDescr ::ClassTag 0x45 + ContentCreatorNameDescr ::ClassTag 0x46 + ContentCreationDateDescr ::ClassTag 0x47 + OCICreatorNameDescr ::ClassTag 0x48 + OCICreationDateDescr ::ClassTag 0x49 + SmpteCameraPositionDescr ::ClassTag 0x4A + SegmentDescr ::ClassTag 0x4B + MediaTimeDescr ::ClassTag 0x4C + IPMP_ToolsListDescr ::ClassTag 0x60 + IPMP_Tool ::ClassTag 0x61 + M4MuxTimingDescr ::ClassTag 0x62 + M4MuxCodeTableDescr ::ClassTag 0x63 + ExtSLConfigDescr ::ClassTag 0x64 + M4MuxBufferSizeDescr ::ClassTag 0x65 + M4MuxIdentDescr ::ClassTag 0x66 + DependencyPointer ::ClassTag 0x67 + DependencyMarker ::ClassTag 0x68 + M4MuxChannelDescr ::ClassTag 0x69 + ExtDescrTag :: (forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n) + OCIDescrTag :: (forall (n :: Nat) . (0x40 <= n, n <= 0x5F) => ClassTag n) diff --git a/tests/examples/pre-ghc910/BaseDescriptor2.hs b/tests/examples/pre-ghc910/BaseDescriptor2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BaseDescriptor2.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +module BaseDescriptors2 where + +data ClassTag (tag :: Nat) where + ExtDescrTag :: (forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n) + +data ClassTag2 (tag :: Nat) where + ExtDescrTag2 :: forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n diff --git a/tests/examples/pre-ghc910/Binary.hs b/tests/examples/pre-ghc910/Binary.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Binary.hs @@ -0,0 +1,259 @@ +{-# OPTIONS -fno-warn-orphans #-} + +module Data.Curve.Binary + ( module Data.Curve + , Point(..) + -- * Binary curves + , BCurve(..) + , BPoint + -- ** Binary affine curves + , BACurve(..) + , BAPoint + -- ** Binary projective curves + , BPCurve(..) + , BPPoint + ) where + +import Protolude + +import Data.Field.Galois as F (GaloisField, PrimeField, frob, quad) +import GHC.Natural (Natural) +import Text.PrettyPrint.Leijen.Text (Pretty(..)) + +import Data.Curve + +------------------------------------------------------------------------------- +-- Binary form +------------------------------------------------------------------------------- + +-- | Binary points. +type BPoint = Point 'Binary + +-- | Binary curves. +class (GaloisField q, PrimeField r, Curve 'Binary c e q r) => BCurve c e q r where + {-# MINIMAL a_, b_, h_, p_, r_ #-} + a_ :: BPoint c e q r -> q -- ^ Coefficient @A@. + b_ :: BPoint c e q r -> q -- ^ Coefficient @B@. + h_ :: BPoint c e q r -> Natural -- ^ Curve cofactor. + p_ :: BPoint c e q r -> Natural -- ^ Curve polynomial. + r_ :: BPoint c e q r -> Natural -- ^ Curve order. + +------------------------------------------------------------------------------- +-- Affine coordinates +------------------------------------------------------------------------------- + +-- | Binary affine points. +type BAPoint = BPoint 'Affine + +-- | Binary affine curves @y^2 + xy = x^3 + Ax^2 + B@. +class BCurve 'Affine e q r => BACurve e q r where + {-# MINIMAL gA_ #-} + gA_ :: BAPoint e q r -- ^ Curve generator. + +-- Binary affine curves are elliptic curves. +instance BACurve e q r => Curve 'Binary 'Affine e q r where + + data instance Point 'Binary 'Affine e q r = A q q -- ^ Affine point. + | O -- ^ Infinite point. + deriving (Eq, Generic, NFData, Read, Show) + + add p O = p + add O q = q + add (A x1 y1) (A x2 y2) + | xx == 0 = O + | otherwise = A x3 y3 + where + a = a_ (witness :: BAPoint e q r) + xx = x1 + x2 + yy = y1 + y2 + l = yy / xx + x3 = l * (l + 1) + xx + a + y3 = l * (x1 + x3) + x3 + y1 + {-# INLINABLE add #-} + + char = const 2 + {-# INLINABLE char #-} + + cof = h_ + {-# INLINABLE cof #-} + + dbl O = O + dbl (A x y) + | x == 0 = O + | otherwise = A x' y' + where + a = a_ (witness :: BAPoint e q r) + l = x + y / x + l' = l + 1 + x' = l * l' + a + y' = x * x + l' * x' + {-# INLINABLE dbl #-} + + def O = True + def (A x y) = ((x + a) * x + y) * x + b + y * y == 0 + where + a = a_ (witness :: BAPoint e q r) + b = b_ (witness :: BAPoint e q r) + {-# INLINABLE def #-} + + disc _ = b_ (witness :: BAPoint e q r) + {-# INLINABLE disc #-} + + frob O = O + frob (A x y) = A (F.frob x) (F.frob y) + {-# INLINABLE frob #-} + + fromA = identity + {-# INLINABLE fromA #-} + + gen = gA_ + {-# INLINABLE gen #-} + + id = O + {-# INLINABLE id #-} + + inv O = O + inv (A x y) = A x (x + y) + {-# INLINABLE inv #-} + + order = r_ + {-# INLINABLE order #-} + + point x y = let p = A x y in if def p then Just p else Nothing + {-# INLINABLE point #-} + + pointX x = A x <$> yX (witness :: BAPoint e q r) x + {-# INLINABLE pointX #-} + + toA = identity + {-# INLINABLE toA #-} + + yX _ x = quad 1 x ((x + a) * x * x + b) + where + a = a_ (witness :: BAPoint e q r) + b = b_ (witness :: BAPoint e q r) + {-# INLINABLE yX #-} + +-- Binary affine points are pretty. +instance BACurve e q r => Pretty (BAPoint e q r) where + + pretty (A x y) = pretty (x, y) + pretty O = "O" + +------------------------------------------------------------------------------- +-- Projective coordinates +------------------------------------------------------------------------------- + +-- | Binary projective points. +type BPPoint = BPoint 'Projective + +-- | Binary projective curves @y^2z + xyz = x^3 + Ax^2z + Bz@. +class BCurve 'Projective e q r => BPCurve e q r where + {-# MINIMAL gP_ #-} + gP_ :: BPPoint e q r -- ^ Curve generator. + +-- Binary projective curves are elliptic curves. +instance BPCurve e q r => Curve 'Binary 'Projective e q r where + + data instance Point 'Binary 'Projective e q r = P q q q -- ^ Projective point. + deriving (Generic, NFData, Read, Show) + + -- Addition formula add-2008-bl + add p (P _ _ 0) = p + add (P _ _ 0) q = q + add (P x1 y1 z1) (P x2 y2 z2) = P x3 y3 z3 + where + a' = a_ (witness :: BPPoint e q r) + y1z2 = y1 * z2 + x1z2 = x1 * z2 + a = y1z2 + z1 * y2 + b = x1z2 + z1 * x2 + ab = a + b + c = b * b + d = z1 * z2 + e = b * c + f = (a * ab + a' * c) * d + e + x3 = b * f + y3 = c * (a * x1z2 + b * y1z2) + ab * f + z3 = e * d + {-# INLINABLE add #-} + + char = const 2 + {-# INLINABLE char #-} + + cof = h_ + {-# INLINABLE cof #-} + + -- Doubling formula dbl-2008-bl + dbl (P _ _ 0) = P 0 1 0 + dbl (P x1 y1 z1) = P x3 y3 z3 + where + a' = a_ (witness :: BPPoint e q r) + a = x1 * x1 + b = a + y1 * z1 + c = x1 * z1 + bc = b + c + d = c * c + e = b * bc + a' * d + x3 = c * e + y3 = bc * e + a * a * c + z3 = c * d + {-# INLINABLE dbl #-} + + def (P x y z) = ((x + a * z) * x + yz) * x + y * yz + b * z * z * z == 0 + where + a = a_ (witness :: BPPoint e q r) + b = b_ (witness :: BPPoint e q r) + yz = y * z + {-# INLINABLE def #-} + + disc _ = b_ (witness :: BPPoint e q r) + {-# INLINABLE disc #-} + + frob (P x y z) = P (F.frob x) (F.frob y) (F.frob z) + {-# INLINABLE frob #-} + + fromA (A x y) = P x y 1 + fromA _ = P 0 1 0 + {-# INLINABLE fromA #-} + + gen = gP_ + {-# INLINABLE gen #-} + + id = P 0 1 0 + {-# INLINABLE id #-} + + inv (P x y z) = P x (x + y) z + {-# INLINABLE inv #-} + + order = r_ + {-# INLINABLE order #-} + + point x y = let p = P x y 1 in if def p then Just p else Nothing + {-# INLINABLE point #-} + + pointX x = flip (P x) 1 <$> yX (witness :: BPPoint e q r) x + {-# INLINABLE pointX #-} + + toA (P _ _ 0) = O + toA (P x y z) = A (x / z) (y / z) + {-# INLINABLE toA #-} + + yX _ x = quad 1 x ((x + a) * x * x + b) + where + a = a_ (witness :: BPPoint e q r) + b = b_ (witness :: BPPoint e q r) + {-# INLINABLE yX #-} + +-- Binary projective points are equatable. +instance BPCurve e q r => Eq (BPPoint e q r) where + + P x1 y1 z1 == P x2 y2 z2 = z1 == 0 && z2 == 0 + || x1 * z2 == x2 * z1 && y1 * z2 == y2 * z1 + {-# INLINABLE (==) #-} + +-- Binary projective points are pretty. +instance BPCurve e q r => Pretty (BPPoint e q r) where + + pretty (P x y z) = pretty (x, y, z) + diff --git a/tests/examples/pre-ghc910/BlockComment.hs b/tests/examples/pre-ghc910/BlockComment.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BlockComment.hs @@ -0,0 +1,7 @@ +module BlockComment where + +foo x = do + blah + where + {- a comment -} + blah = 3 diff --git a/tests/examples/pre-ghc910/Boot1.hs b/tests/examples/pre-ghc910/Boot1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Boot1.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes #-} +module Boot where + +import A + +data Data = forall n. Class n => D n + diff --git a/tests/examples/pre-ghc910/BootImport.hs b/tests/examples/pre-ghc910/BootImport.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BootImport.hs @@ -0,0 +1,3 @@ +module BootImport where + +data Foo = Foo Int diff --git a/tests/examples/pre-ghc910/BootImport.hs-boot b/tests/examples/pre-ghc910/BootImport.hs-boot new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BootImport.hs-boot @@ -0,0 +1,3 @@ +module BootImport where + +data Foo diff --git a/tests/examples/pre-ghc910/BracesSemiDataDecl.hs b/tests/examples/pre-ghc910/BracesSemiDataDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Branches.hs b/tests/examples/pre-ghc910/Branches.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Branches.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +module GuardTup where + +data Q = Q () + +mkQ :: () -> Q +mkQ = Q + +foo smart + | smart = mkQ + | otherwise = Q + +fooIf smart = if smart then mkQ else Q diff --git a/tests/examples/pre-ghc910/Bundle.hs b/tests/examples/pre-ghc910/Bundle.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Bundle.hs @@ -0,0 +1,9 @@ +module Bundle(A(..)) where + +import BundleInternal (A(..)) + +foo = MkA 5 +baz = NoA + +qux (MkA x) = x +qux NoA = 0 diff --git a/tests/examples/pre-ghc910/Bundle1.hs b/tests/examples/pre-ghc910/Bundle1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Bundle1.hs @@ -0,0 +1,9 @@ +module Associated1(A(..)) where + +import BundleInternal1 (A(..)) + +foo = MkA 5 +baz = NoA + +qux (MkA x) = x +qux NoA = 0 diff --git a/tests/examples/pre-ghc910/BundleExport.hs b/tests/examples/pre-ghc910/BundleExport.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BundleExport.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +module BundleExport(P(.., A), Q(B)) where + +data P = P + +data Q = Q + +pattern A = P +pattern B = Q diff --git a/tests/examples/pre-ghc910/BundleInternal.hs b/tests/examples/pre-ghc910/BundleInternal.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BundleInternal.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} +module BundleInternal (A(NewA,MkA, NoA)) where + +newtype A = NewA (Maybe Int) + +pattern MkA n = NewA (Just n) + +pattern NoA = NewA Nothing diff --git a/tests/examples/pre-ghc910/BundleInternal1.hs b/tests/examples/pre-ghc910/BundleInternal1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/BundleInternal1.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} +module BundleInternal1 (A(NewA,MkA, NoA)) where + +newtype A = NewA (Maybe Int) + +pattern MkA n = NewA (Just n) + +pattern NoA = NewA Nothing diff --git a/tests/examples/pre-ghc910/C.hs b/tests/examples/pre-ghc910/C.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/C.hs @@ -0,0 +1,3 @@ +module C (oops) where + +import {-# SOURCE #-} B diff --git a/tests/examples/pre-ghc910/CExpected.hs b/tests/examples/pre-ghc910/CExpected.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/CExpected1.hs b/tests/examples/pre-ghc910/CExpected1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CExpected1.hs @@ -0,0 +1,4 @@ +module CExpected where +-- Comment + +foo x = 1 diff --git a/tests/examples/pre-ghc910/CSETest.hs b/tests/examples/pre-ghc910/CSETest.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CSETest.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UnicodeSyntax #-} +{- This test makes sure that if two expressions with conflicting types are + CSEd then appropiate things happen. -} +module CSETest where + +minimal :: a ⊸ a +minimal x = x + +maximal :: a -> a +maximal x = x + diff --git a/tests/examples/pre-ghc910/Case.hs b/tests/examples/pre-ghc910/Case.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Case.hs @@ -0,0 +1,5 @@ + +foo x = case x of + True -> "a" + False -> "b" + diff --git a/tests/examples/pre-ghc910/Cg008.hs b/tests/examples/pre-ghc910/Cg008.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Character.hs b/tests/examples/pre-ghc910/Character.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Character.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE QuasiQuotes #-} +module Atomo.Kernel.Character where + +import Data.Char + +import Atomo + + +load :: VM () +load = do + [p|(c: Character) control?|] =: liftM Boolean (onCharacter isControl) + [p|(c: Character) space?|] =: liftM Boolean (onCharacter isSpace) + [p|(c: Character) lower?|] =: liftM Boolean (onCharacter isLower) + [p|(c: Character) upper?|] =: liftM Boolean (onCharacter isUpper) + [p|(c: Character) alpha?|] =: liftM Boolean (onCharacter isAlpha) + [p|(c: Character) alphanum?|] =: liftM Boolean (onCharacter isAlphaNum) + [p|(c: Character) print?|] =: liftM Boolean (onCharacter isPrint) + [p|(c: Character) digit?|] =: liftM Boolean (onCharacter isDigit) + [p|(c: Character) oct-digit?|] =: liftM Boolean (onCharacter isOctDigit) + [p|(c: Character) hex-digit?|] =: liftM Boolean (onCharacter isHexDigit) + [p|(c: Character) letter?|] =: liftM Boolean (onCharacter isLetter) + [p|(c: Character) mark?|] =: liftM Boolean (onCharacter isMark) + [p|(c: Character) number?|] =: liftM Boolean (onCharacter isNumber) + [p|(c: Character) punctuation?|] =: liftM Boolean (onCharacter isPunctuation) + [p|(c: Character) symbol?|] =: liftM Boolean (onCharacter isSymbol) + [p|(c: Character) separator?|] =: liftM Boolean (onCharacter isSeparator) + [p|(c: Character) ascii?|] =: liftM Boolean (onCharacter isAscii) + [p|(c: Character) latin1?|] =: liftM Boolean (onCharacter isLatin1) + [p|(c: Character) ascii-upper?|] =: liftM Boolean (onCharacter isAsciiLower) + [p|(c: Character) ascii-lower?|] =: liftM Boolean (onCharacter isAsciiUpper) + + [p|(c: Character) uppercase|] =: liftM Character (onCharacter toUpper) + [p|(c: Character) lowercase|] =: liftM Character (onCharacter toLower) + [p|(c: Character) titlecase|] =: liftM Character (onCharacter toTitle) + + [p|(c: Character) from-digit|] =: liftM (Integer . fromIntegral) (onCharacter digitToInt) + [p|(i: Integer) to-digit|] =: liftM Character (onInteger (intToDigit . fromIntegral)) + + [p|(c: Character) ord|] =: liftM (Integer . fromIntegral) (onCharacter ord) + [p|(i: Integer) chr|] =: liftM Character (onInteger (chr . fromIntegral)) + + [p|(c: Character) category|] =: liftM c (onCharacter generalCategory) + where + onCharacter :: (Char -> a) -> VM a + onCharacter f = here "c" >>= liftM (f . fromCharacter) . findCharacter + + onInteger :: (Integer -> a) -> VM a + onInteger f = here "i" >>= liftM (f . Atomo.fromInteger) . findInteger + + c UppercaseLetter = keyParticleN ["letter"] [particle "uppercase"] + c LowercaseLetter = keyParticleN ["letter"] [particle "lowercase"] + c TitlecaseLetter = keyParticleN ["letter"] [particle "titlecase"] + c ModifierLetter = keyParticleN ["letter"] [particle "modified"] + c OtherLetter = keyParticleN ["letter"] [particle "other"] + c NonSpacingMark = keyParticleN ["mark"] [particle "non-spacing"] + c SpacingCombiningMark = keyParticleN ["mark"] [particle "space-combining"] + c EnclosingMark = keyParticleN ["mark"] [particle "enclosing"] + c DecimalNumber = keyParticleN ["number"] [particle "decimal"] + c LetterNumber = keyParticleN ["number"] [particle "letter"] + c OtherNumber = keyParticleN ["number"] [particle "other"] + c ConnectorPunctuation = keyParticleN ["punctuation"] [particle "connector"] + c DashPunctuation = keyParticleN ["punctuation"] [particle "dash"] + c OpenPunctuation = keyParticleN ["punctuation"] [particle "open"] + c ClosePunctuation = keyParticleN ["punctuation"] [particle "close"] + c InitialQuote = keyParticleN ["quote"] [particle "initial"] + c FinalQuote = keyParticleN ["quote"] [particle "final"] + c OtherPunctuation = keyParticleN ["punctuation"] [particle "other"] + c MathSymbol = keyParticleN ["symbol"] [particle "math"] + c CurrencySymbol = keyParticleN ["symbol"] [particle "currency"] + c ModifierSymbol = keyParticleN ["symbol"] [particle "modifier"] + c OtherSymbol = keyParticleN ["symbol"] [particle "other"] + c Space = particle "space" + c LineSeparator = keyParticleN ["separator"] [particle "line"] + c ParagraphSeparator = keyParticleN ["separator"] [particle "paragraph"] + c Control = particle "control" + c Format = particle "format" + c Surrogate = particle "surrogate" + c PrivateUse = particle "private-use" + c NotAssigned = particle "not-assigned" diff --git a/tests/examples/pre-ghc910/CheckUtils.hs b/tests/examples/pre-ghc910/CheckUtils.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Checkpoint.hs b/tests/examples/pre-ghc910/Checkpoint.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Checkpoint.hs @@ -0,0 +1,45 @@ +-- | Checkpoints in the blockchain (every 1000th blocks) + +{-# LANGUAGE CPP #-} +module Bitcoin.BlockChain.Checkpoint where + +--6----------------------------------------------------------------------------- + +import Bitcoin.Protocol.Hash + +--10---------------------------------------------------------------------------- + +#ifndef WITH_TESTNET + +--14---------------------------------------------------------------------------- +-- * the real network + +theGenesisBlock :: Hash256 +theGenesisBlock = hash256FromTextBE "000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f" + +theCheckpoints :: [(Int,Hash256)] +theCheckpoints = + [ (0 , hash256FromTextBE "000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f" ) + , (248000 , hash256FromTextBE "000000000000004d945017c14b75a3a58a2aa6772cacbfcaf907b3bee6d7f344" ) + ] + +--273--------------------------------------------------------------------------- + +#else + +--277--------------------------------------------------------------------------- +-- * testnet3 + +theGenesisBlock :: Hash256 +theGenesisBlock = hash256FromTextBE "000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943" + +theCheckpoints :: [(Int,Hash256)] +theCheckpoints = + [ (0 , hash256FromTextBE "000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943" ) + , (97000 , hash256FromTextBE "0000000000096581c7c0fe4d15ea0212f1087fc79f3735a892ee262c384b3741" ) + ] + +#endif + +--387--------------------------------------------------------------------------- + diff --git a/tests/examples/pre-ghc910/Class.hs b/tests/examples/pre-ghc910/Class.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Class.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE UndecidableInstances #-} +module Servant.Auth.Server.Internal.Class where + +import Servant.Auth +import Data.Monoid +import Servant hiding (BasicAuth) + +import Servant.Auth.Server.Internal.Types +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.BasicAuth +import Servant.Auth.Server.Internal.Cookie +import Servant.Auth.Server.Internal.JWT + +-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all +-- elements of @ctx@ to be the in the Context and whose authentication check +-- returns an @AuthCheck v@. +class IsAuth a v where + type family AuthArgs a :: [*] + runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v) + diff --git a/tests/examples/pre-ghc910/ClassParens.hs b/tests/examples/pre-ghc910/ClassParens.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ClassParens.hs @@ -0,0 +1,11 @@ +module ClassParens where + +class LiftingMonad (trans :: MTrans) where + proof :: Monad m :- Monad (trans m) + +class LiftingMonad2 ((trans :: MTrans)) where + proof :: Monad m :- Monad (trans m) + +data Nat (t :: NatKind) where + ZeroNat :: Nat Zero + SuccNat :: Nat t -> Nat (Succ t) diff --git a/tests/examples/pre-ghc910/ClosedFam1a.hs b/tests/examples/pre-ghc910/ClosedFam1a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ClosedFam1a.hs @@ -0,0 +1,3 @@ +module ClosedFam1a where + +import {-# SOURCE #-} ClosedFam1 diff --git a/tests/examples/pre-ghc910/ClosedFam2a.hs b/tests/examples/pre-ghc910/ClosedFam2a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ClosedFam2a.hs @@ -0,0 +1,2 @@ +module ClosedFam2a where +import {-# SOURCE #-} ClosedFam2 diff --git a/tests/examples/pre-ghc910/ClosedFam3a.hs b/tests/examples/pre-ghc910/ClosedFam3a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ClosedFam3a.hs @@ -0,0 +1,3 @@ +module ClosedFam3a where + +import {-# SOURCE #-} ClosedFam3 diff --git a/tests/examples/pre-ghc910/CmmSwitchTest.hs b/tests/examples/pre-ghc910/CmmSwitchTest.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/CmmSwitchTestGen.hs b/tests/examples/pre-ghc910/CmmSwitchTestGen.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Collapse1.hs b/tests/examples/pre-ghc910/Collapse1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Collapse1.hs @@ -0,0 +1,16 @@ +module LiftToTop3evel.Collapse1 where + +collapse' _ _ [] = [] +collapse' left space (t:ts) = new : collapse' right space rest + where + (_, leftInner) = left + rightInner = leftInner + symbolSize t + right = (rightInner, (rightOuter rightInner rights)) + (rights, rest) = span space ts + new = (t, Bounds left right) + +rightOuter rightInner rights = rightInner + symbolSize rights + +data Bounds = Bounds (Int,Int) (Int,Int) +symbolSize t = 4 + diff --git a/tests/examples/pre-ghc910/Commands.hs b/tests/examples/pre-ghc910/Commands.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/CommentOrder.hs b/tests/examples/pre-ghc910/CommentOrder.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CommentOrder.hs @@ -0,0 +1,7 @@ +module CommentOrder where + +x = 1 + +-- First +-- Second +-- Third diff --git a/tests/examples/pre-ghc910/CommentPlacement.hs b/tests/examples/pre-ghc910/CommentPlacement.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CommentPlacement.hs @@ -0,0 +1,17 @@ +module CommentPlacement where + +liftToTopLevel' modName pn@(L _ n) = do + liftToMod + --step0: comment + liftToMod + where + --step1: comment + liftToMod = return () + +c04 r@Resource{..} = do + let result = do + acceptStr <- lookup HTTP.hAccept reqHeaders + where + -- this is so that in addition to getting back the resource + provided' = map dupContentType provided + dupContentType (a, b) = (a, (a, b)) diff --git a/tests/examples/pre-ghc910/CommentPlacement2.hs b/tests/examples/pre-ghc910/CommentPlacement2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CommentPlacement2.hs @@ -0,0 +1,8 @@ +module CommentPlacement2 where + +c04 = do + let result = do + acceptStr <- y + where + --COMMENT + aa = bb diff --git a/tests/examples/pre-ghc910/CommentPlacement3.hs b/tests/examples/pre-ghc910/CommentPlacement3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CommentPlacement3.hs @@ -0,0 +1,7 @@ +module CommentPlacement where + +--a comment +x = y1 +--b comment +y = x1 +--c comment diff --git a/tests/examples/pre-ghc910/CommentPlacement4.hs b/tests/examples/pre-ghc910/CommentPlacement4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CommentPlacement4.hs @@ -0,0 +1,9 @@ +module CommentPlacement4 where + +data family GMap k :: * -> * + +data family Array e + +-- data GMap () v = GMapUnit (Maybe v) +-- deriving Show + diff --git a/tests/examples/pre-ghc910/CommentPlacement5.hs b/tests/examples/pre-ghc910/CommentPlacement5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CommentPlacement5.hs @@ -0,0 +1,9 @@ +module CommentPlacement5 where + +bar :: Foo -> () +bar a = + case a of + GInt -> () + -- GBool -> () +bar _ = () + diff --git a/tests/examples/pre-ghc910/CommentPlacement6.hs b/tests/examples/pre-ghc910/CommentPlacement6.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CommentPlacement6.hs @@ -0,0 +1,27 @@ +-- | Checkpoints in the blockchain (every 1000th blocks) + +{-# LANGUAGE CPP #-} +module CommentPlacement6 where + +#ifndef WITH_TESTNET + +--8----------------------------------------------------------------------------- +-- * the real network + +theGenesisBlock :: Hash256 +theGenesisBlock = 1 + +--14---------------------------------------------------------------------------- + +#else + +--18---------------------------------------------------------------------------- +-- * testnet3 + +theGenesisBlock :: Hash256 +theGenesisBlock = 2 + +#endif + +--26---------------------------------------------------------------------------- + diff --git a/tests/examples/pre-ghc910/CommonUI.hs b/tests/examples/pre-ghc910/CommonUI.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CommonUI.hs @@ -0,0 +1,11 @@ +module CommonUI where + +-- | Prints a document in a none XMl format + +createRuleItem frame state g n e = + do + when (isJust maybeRes) $ + do{ + ;let ;palette = getPalette doc + } + diff --git a/tests/examples/pre-ghc910/Compare.hs b/tests/examples/pre-ghc910/Compare.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Compare.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE Trustworthy, + TypeOperators, + PolyKinds, DataKinds, + TypeFamilies, + UndecidableInstances #-} + + +module Type.Compare where + +import Data.Ord +import GHC.TypeLits + +type family (a :: Ordering) $$ (b :: Ordering) :: Ordering where + LT $$ b = LT + GT $$ b = GT + EQ $$ b = b +infixl 0 $$ + +-- | Compare two types of any (possibly different) kinds. +-- Since `Compare` itself is a closed type family, add instances to `CompareUser` if you want to compare other types. +type family Compare (a :: k) (b :: k') :: Ordering where + + Compare '() '() = EQ diff --git a/tests/examples/pre-ghc910/Completesig03A.hs b/tests/examples/pre-ghc910/Completesig03A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Completesig03A.hs @@ -0,0 +1,6 @@ +module Completesig03A where + +data A = A | B + +{-# COMPLETE A #-} + diff --git a/tests/examples/pre-ghc910/ConDeclEmptyCtx.hs b/tests/examples/pre-ghc910/ConDeclEmptyCtx.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ConDeclEmptyCtx.hs @@ -0,0 +1,3 @@ +module ConDeclEmptyCtx where + +data Foo a = () => Foo a diff --git a/tests/examples/pre-ghc910/ConPat.hs b/tests/examples/pre-ghc910/ConPat.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ConPat.hs @@ -0,0 +1,5 @@ +module ConPat where + +{-# RULES +"infix" forall a. let x1:x2:xs = flipFirst a in f x2 x1 = let x1:x2:xs = a in f x1 x2 + #-} diff --git a/tests/examples/pre-ghc910/ConstructorComment.hs b/tests/examples/pre-ghc910/ConstructorComment.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ConstructorComment.hs @@ -0,0 +1,7 @@ +module ConstructorComment where + + +data instance Method PGMigration = MigrationQuery Query + -- ^ Run a query against the database + | MigrationCode (Connection -> IO (Either String ())) + -- ^ Run any arbitrary IO code diff --git a/tests/examples/pre-ghc910/ContinuationIO.hs b/tests/examples/pre-ghc910/ContinuationIO.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ContinuationIO.hs @@ -0,0 +1,3 @@ +module ContinuationIO{-(module ContinuationIO, module DialogueIO)-} where + +stdin = "stdin" diff --git a/tests/examples/pre-ghc910/Control.hs b/tests/examples/pre-ghc910/Control.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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 !Foo + | 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/pre-ghc910/CoreIr.hs b/tests/examples/pre-ghc910/CoreIr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CoreIr.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Llvm.Data.CoreIr + ( module Llvm.Data.CoreIr + , module Llvm.Data.Shared + , module Llvm.Data.IrType + , module Data.Word + , Label + ) where +import Llvm.Data.Shared +import Llvm.Data.IrType +import Compiler.Hoopl (Label) +import Data.Int +import Data.Word (Word8, Word16, Word32, Word64) +import Data.DoubleWord + +data Conversion s v where { + AddrSpaceCast :: T (Type s P) v -> Type s P -> Conversion s v; + } deriving (Eq, Ord, Show) + diff --git a/tests/examples/pre-ghc910/CorePragma.hs b/tests/examples/pre-ghc910/CorePragma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Cpp.hs b/tests/examples/pre-ghc910/Cpp.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Cpp.hs @@ -0,0 +1,21 @@ +{-# Language CPP #-} +#if __GLASGOW_HASKELL__ >= 718 +{-# LANGUAGE RoleAnnotations #-} +#endif + +module Cpp where + +#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/pre-ghc910/CustomTypeErrors01.hs b/tests/examples/pre-ghc910/CustomTypeErrors01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CustomTypeErrors01.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds, UndecidableInstances #-} +module T1 where +import GHC.TypeLits + + +data MyType = MyType + +instance + TypeError (Text "Values of type 'MyType' cannot be compared for equality.") + => Eq MyType where (==) = undefined + +err x = x == MyType + + diff --git a/tests/examples/pre-ghc910/CustomTypeErrors02.hs b/tests/examples/pre-ghc910/CustomTypeErrors02.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CustomTypeErrors02.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds, UndecidableInstances #-} +{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts #-} +module T2 where + +import GHC.TypeLits + +type family IntRep a where + IntRep Int = Integer + IntRep Integer = Integer + IntRep Bool = Integer + IntRep a = TypeError (Text "The type '" :<>: ShowType a :<>: + Text "' cannot be represented as an integer.") + +convert :: Num (IntRep a) => a -> IntRep a +convert _ = 5 + +err = convert id + + diff --git a/tests/examples/pre-ghc910/CustomTypeErrors03.hs b/tests/examples/pre-ghc910/CustomTypeErrors03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/CustomTypeErrors03.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DataKinds #-} +module T3 where + +import GHC.TypeLits + +f :: TypeError (Text "This is a type error") +f = undefined diff --git a/tests/examples/pre-ghc910/D.hs b/tests/examples/pre-ghc910/D.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/DataDecl.1.hs b/tests/examples/pre-ghc910/DataDecl.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DataDecl.1.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/pre-ghc910/DataDecl.hs b/tests/examples/pre-ghc910/DataDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DataDecl.hs @@ -0,0 +1,9 @@ +module DataDecl where + +data FileGlob + -- | No glob at all, just an ordinary file + = NoGlob FilePath + + -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to + -- @FileGlob \"foo\/bar\" \".baz\"@ + | FileGlob FilePath String diff --git a/tests/examples/pre-ghc910/DataFamilies.hs b/tests/examples/pre-ghc910/DataFamilies.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/DataFamilyInstanceLHS.hs b/tests/examples/pre-ghc910/DataFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/DatatypeContexts.hs b/tests/examples/pre-ghc910/DatatypeContexts.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DatatypeContexts.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DatatypeContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- I don't know how to silence the -XDatatypeContexts warnings otherwise... +{-# OPTIONS_GHC -w #-} + +{-| +Module: Derived.DatatypeContexts +Copyright: (C) 2014-2016 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Stability: Provisional +Portability: GHC + +Defines data types with DatatypeContexts (which are gross, but still possible). +-} +module Derived.DatatypeContexts where + + +data family TyFamily x y z :: * + +data instance Ord a => TyFamily a b c = TyFamily a b c + deriving Show + diff --git a/tests/examples/pre-ghc910/Dead1.hs b/tests/examples/pre-ghc910/Dead1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Decision.hs b/tests/examples/pre-ghc910/Decision.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Decision.hs @@ -0,0 +1,726 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Airship.Internal.Decision + ( flow + , appendRequestPath + ) where + +import Airship.Internal.Date (parseRfc1123Date, utcTimeToRfc1123) +import Airship.Headers (addResponseHeader) +import Airship.Types ( Response(..) + , ResponseBody(..) + , Webmachine + , etagToByteString + , getResponseBody + , getResponseHeaders + , halt + , pathInfo + , putResponseBody + , request + , requestHeaders + , requestMethod + , requestTime ) + +import Airship.Resource(Resource(..), PostResponse(..)) +import Airship.Internal.Parsers (parseEtagList) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif +import Control.Monad (when) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.State.Strict (StateT(..), evalStateT, + get, modify) +import Control.Monad.Writer.Class (tell) + +import Blaze.ByteString.Builder (toByteString) +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.ByteString (ByteString, intercalate) + +import Network.HTTP.Media +import qualified Network.HTTP.Types as HTTP + +------------------------------------------------------------------------------ +-- HTTP Headers +-- These are headers not defined for us already in +-- Network.HTTP.Types +------------------------------------------------------------------------------ +-- TODO this exist in http-types-0.9, see CHANGES.txt +hAcceptCharset :: HTTP.HeaderName +hAcceptCharset = "Accept-Charset" + +hAcceptEncoding :: HTTP.HeaderName +hAcceptEncoding = "Accept-Encoding" + +hIfMatch :: HTTP.HeaderName +hIfMatch = "If-Match" + +hIfUnmodifiedSince :: HTTP.HeaderName +hIfUnmodifiedSince = "If-Unmodified-Since" + +hIfNoneMatch :: HTTP.HeaderName +hIfNoneMatch = "If-None-Match" + +------------------------------------------------------------------------------ +-- FlowState: StateT used for recording information as we walk the decision +-- tree +------------------------------------------------------------------------------ + +data FlowState m = FlowState + { _contentType :: Maybe (MediaType, Webmachine m ResponseBody) } + +type FlowStateT m a = StateT (FlowState m) (Webmachine m) a + +type Flow m = Resource m -> FlowStateT m Response + +initFlowState :: FlowState m +initFlowState = FlowState Nothing + +flow :: Monad m => Resource m -> Webmachine m Response +flow r = evalStateT (b13 r) initFlowState + +trace :: Monad m => Text -> FlowStateT m () +trace t = lift $ tell [t] + +----------------------------------------------------------------------------- +-- Header value data newtypes +------------------------------------------------------------------------------ + +newtype IfMatch = IfMatch ByteString +newtype IfNoneMatch = IfNoneMatch ByteString + +------------------------------------------------------------------------------ +-- Decision Helpers +------------------------------------------------------------------------------ + +negotiateContentTypesAccepted :: Monad m => Resource m -> FlowStateT m () +negotiateContentTypesAccepted Resource{..} = do + req <- lift request + accepted <- lift contentTypesAccepted + let reqHeaders = requestHeaders req + result = do + cType <- lookup HTTP.hContentType reqHeaders + mapContentMedia accepted cType + case result of + (Just process) -> lift process + Nothing -> lift $ halt HTTP.status415 + +appendRequestPath :: Monad m => [Text] -> Webmachine m ByteString +appendRequestPath ts = do + currentPath <- pathInfo <$> request + return $ toByteString (HTTP.encodePathSegments (currentPath ++ ts)) + +requestHeaderDate :: Monad m => HTTP.HeaderName -> + Webmachine m (Maybe UTCTime) +requestHeaderDate headerName = do + req <- request + let reqHeaders = requestHeaders req + dateHeader = lookup headerName reqHeaders + parsedDate = dateHeader >>= parseRfc1123Date + return parsedDate + +writeCacheTags :: Monad m => Resource m -> FlowStateT m () +writeCacheTags Resource{..} = lift $ do + etag <- generateETag + case etag of + Nothing -> return () + Just t -> addResponseHeader ("ETag", etagToByteString t) + modified <- lastModified + case modified of + Nothing -> return () + Just d -> addResponseHeader ("Last-Modified", utcTimeToRfc1123 d) + +------------------------------------------------------------------------------ +-- Type definitions for all decision nodes +------------------------------------------------------------------------------ + +b13, b12, b11, b10, b09, b08, b07, b06, b05, b04, b03 :: Monad m => Flow m +c04, c03 :: Monad m => Flow m +d05, d04 :: Monad m => Flow m +e06, e05 :: Monad m => Flow m +f07, f06 :: Monad m => Flow m +g11, g09 :: Monad m => IfMatch -> Flow m +g08, g07 :: Monad m => Flow m +h12, h11, h10, h07 :: Monad m => Flow m +i13 :: Monad m => IfNoneMatch -> Flow m +i12, i07, i04 :: Monad m => Flow m +j18 :: Monad m => Flow m +k13 :: Monad m => IfNoneMatch -> Flow m +k07, k05 :: Monad m => Flow m +l17, l15, l14, l13, l07, l05 :: Monad m => Flow m +m20, m16, m07, m05 :: Monad m => Flow m +n16, n11, n05 :: Monad m => Flow m +o20, o18, o16, o14 :: Monad m => Flow m +p11, p03 :: Monad m => Flow m + +------------------------------------------------------------------------------ +-- B column +------------------------------------------------------------------------------ + +b13 r@Resource{..} = do + trace "b13" + available <- lift serviceAvailable + if available + then b12 r + else lift $ halt HTTP.status503 + +b12 r@Resource{..} = do + trace "b12" + -- known method + req <- lift request + let knownMethods = [ HTTP.methodGet + , HTTP.methodPost + , HTTP.methodHead + , HTTP.methodPut + , HTTP.methodDelete + , HTTP.methodTrace + , HTTP.methodConnect + , HTTP.methodOptions + , HTTP.methodPatch + ] + if requestMethod req `elem` knownMethods + then b11 r + else lift $ halt HTTP.status501 + +b11 r@Resource{..} = do + trace "b11" + long <- lift uriTooLong + if long + then lift $ halt HTTP.status414 + else b10 r + +b10 r@Resource{..} = do + trace "b10" + req <- lift request + allowed <- lift allowedMethods + if requestMethod req `elem` allowed + then b09 r + else do + lift $ addResponseHeader ("Allow", intercalate "," allowed) + lift $ halt HTTP.status405 + +b09 r@Resource{..} = do + trace "b09" + malformed <- lift malformedRequest + if malformed + then lift $ halt HTTP.status400 + else b08 r + +b08 r@Resource{..} = do + trace "b08" + authorized <- lift isAuthorized + if authorized + then b07 r + else lift $ halt HTTP.status401 + +b07 r@Resource{..} = do + trace "b07" + forbid <- lift forbidden + if forbid + then lift $ halt HTTP.status403 + else b06 r + +b06 r@Resource{..} = do + trace "b06" + validC <- lift validContentHeaders + if validC + then b05 r + else lift $ halt HTTP.status501 + +b05 r@Resource{..} = do + trace "b05" + known <- lift knownContentType + if known + then b04 r + else lift $ halt HTTP.status415 + +b04 r@Resource{..} = do + trace "b04" + large <- lift entityTooLarge + if large + then lift $ halt HTTP.status413 + else b03 r + +b03 r@Resource{..} = do + trace "b03" + req <- lift request + allowed <- lift allowedMethods + if requestMethod req == HTTP.methodOptions + then do + lift $ addResponseHeader ("Allow", intercalate "," allowed) + lift $ halt HTTP.status204 + else c03 r + +------------------------------------------------------------------------------ +-- C column +------------------------------------------------------------------------------ + +c04 r@Resource{..} = do + trace "c04" + req <- lift request + provided <- lift contentTypesProvided + let reqHeaders = requestHeaders req + result = do + acceptStr <- lookup HTTP.hAccept reqHeaders + (acceptTyp, resource) <- mapAcceptMedia provided' acceptStr + Just (acceptTyp, resource) + where + -- this is so that in addition to getting back the resource + -- that we match, we also return the content-type provided + -- by that resource. + provided' = map dupContentType provided + dupContentType (a, b) = (a, (a, b)) + + case result of + Nothing -> lift $ halt HTTP.status406 + Just res -> do + modify (\fs -> fs { _contentType = Just res }) + d04 r + +c03 r@Resource{..} = do + trace "c03" + req <- lift request + let reqHeaders = requestHeaders req + case lookup HTTP.hAccept reqHeaders of + (Just _h) -> + c04 r + Nothing -> + d04 r + +------------------------------------------------------------------------------ +-- D column +------------------------------------------------------------------------------ + +d05 r@Resource{..} = do + trace "d05" + langAvailable <- lift languageAvailable + if langAvailable + then e05 r + else lift $ halt HTTP.status406 + +d04 r@Resource{..} = do + trace "d04" + req <- lift request + let reqHeaders = requestHeaders req + case lookup HTTP.hAcceptLanguage reqHeaders of + (Just _h) -> + d05 r + Nothing -> + e05 r + +------------------------------------------------------------------------------ +-- E column +------------------------------------------------------------------------------ + +e06 r@Resource{..} = do + trace "e06" + -- TODO: charset negotiation + f06 r + +e05 r@Resource{..} = do + trace "e05" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hAcceptCharset reqHeaders of + (Just _h) -> + e06 r + Nothing -> + f06 r + +------------------------------------------------------------------------------ +-- F column +------------------------------------------------------------------------------ + +f07 r@Resource{..} = do + trace "f07" + -- TODO: encoding negotiation + g07 r + +f06 r@Resource{..} = do + trace "f06" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hAcceptEncoding reqHeaders of + (Just _h) -> + f07 r + Nothing -> + g07 r + +------------------------------------------------------------------------------ +-- G column +------------------------------------------------------------------------------ + +g11 (IfMatch ifMatch) r@Resource{..} = do + trace "g11" + let etags = parseEtagList ifMatch + if null etags + then lift $ halt HTTP.status412 + else h10 r + +g09 ifMatch r@Resource{..} = do + trace "g09" + case ifMatch of + -- TODO: should we be stripping whitespace here? + (IfMatch "*") -> + h10 r + _ -> + g11 ifMatch r + +g08 r@Resource{..} = do + trace "g08" + req <- lift request + let reqHeaders = requestHeaders req + case IfMatch <$> lookup hIfMatch reqHeaders of + (Just h) -> + g09 h r + Nothing -> + h10 r + +g07 r@Resource{..} = do + trace "g07" + -- TODO: set Vary headers + exists <- lift resourceExists + if exists + then g08 r + else h07 r + +------------------------------------------------------------------------------ +-- H column +------------------------------------------------------------------------------ + +h12 r@Resource{..} = do + trace "h12" + modified <- lift lastModified + parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince + let maybeGreater = do + lastM <- modified + headerDate <- parsedDate + return (lastM > headerDate) + if maybeGreater == Just True + then lift $ halt HTTP.status412 + else i12 r + +h11 r@Resource{..} = do + trace "h11" + parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince + if isJust parsedDate + then h12 r + else i12 r + +h10 r@Resource{..} = do + trace "h10" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hIfUnmodifiedSince reqHeaders of + (Just _h) -> + h11 r + Nothing -> + i12 r + +h07 r@Resource {..} = do + trace "h07" + req <- lift request + let reqHeaders = requestHeaders req + case lookup hIfMatch reqHeaders of + -- TODO: should we be stripping whitespace here? + (Just "*") -> + lift $ halt HTTP.status412 + _ -> + i07 r + +------------------------------------------------------------------------------ +-- I column +------------------------------------------------------------------------------ + +i13 ifNoneMatch r@Resource{..} = do + trace "i13" + case ifNoneMatch of + -- TODO: should we be stripping whitespace here? + (IfNoneMatch "*") -> + j18 r + _ -> + k13 ifNoneMatch r + +i12 r@Resource{..} = do + trace "i12" + req <- lift request + let reqHeaders = requestHeaders req + case IfNoneMatch <$> lookup hIfNoneMatch reqHeaders of + (Just h) -> + i13 h r + Nothing -> + l13 r + +i07 r = do + trace "i07" + req <- lift request + if requestMethod req == HTTP.methodPut + then i04 r + else k07 r + +i04 r@Resource{..} = do + trace "i04" + moved <- lift movedPermanently + case moved of + (Just loc) -> do + lift $ addResponseHeader ("Location", loc) + lift $ halt HTTP.status301 + Nothing -> + p03 r + +------------------------------------------------------------------------------ +-- J column +------------------------------------------------------------------------------ + +j18 _ = do + trace "j18" + req <- lift request + let getOrHead = [ HTTP.methodGet + , HTTP.methodHead + ] + if requestMethod req `elem` getOrHead + then lift $ halt HTTP.status304 + else lift $ halt HTTP.status412 + +------------------------------------------------------------------------------ +-- K column +------------------------------------------------------------------------------ + +k13 (IfNoneMatch ifNoneMatch) r@Resource{..} = do + trace "k13" + let etags = parseEtagList ifNoneMatch + if null etags + then l13 r + else j18 r + +k07 r@Resource{..} = do + trace "k07" + prevExisted <- lift previouslyExisted + if prevExisted + then k05 r + else l07 r + +k05 r@Resource{..} = do + trace "k05" + moved <- lift movedPermanently + case moved of + (Just loc) -> do + lift $ addResponseHeader ("Location", loc) + lift $ halt HTTP.status301 + Nothing -> + l05 r + +------------------------------------------------------------------------------ +-- L column +------------------------------------------------------------------------------ + +l17 r@Resource{..} = do + trace "l17" + parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince + modified <- lift lastModified + let maybeGreater = do + lastM <- modified + ifModifiedSince <- parsedDate + return (lastM > ifModifiedSince) + if maybeGreater == Just True + then m16 r + else lift $ halt HTTP.status304 + +l15 r@Resource{..} = do + trace "l15" + parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince + now <- lift requestTime + let maybeGreater = (> now) <$> parsedDate + if maybeGreater == Just True + then m16 r + else l17 r + +l14 r@Resource{..} = do + trace "l14" + req <- lift request + let reqHeaders = requestHeaders req + dateHeader = lookup HTTP.hIfModifiedSince reqHeaders + validDate = isJust (dateHeader >>= parseRfc1123Date) + if validDate + then l15 r + else m16 r + +l13 r@Resource{..} = do + trace "l13" + req <- lift request + let reqHeaders = requestHeaders req + case lookup HTTP.hIfModifiedSince reqHeaders of + (Just _h) -> + l14 r + Nothing -> + m16 r + +l07 r = do + trace "l07" + req <- lift request + if requestMethod req == HTTP.methodPost + then m07 r + else lift $ halt HTTP.status404 + +l05 r@Resource{..} = do + trace "l05" + moved <- lift movedTemporarily + case moved of + (Just loc) -> do + lift $ addResponseHeader ("Location", loc) + lift $ halt HTTP.status307 + Nothing -> + m05 r + +------------------------------------------------------------------------------ +-- M column +------------------------------------------------------------------------------ + +m20 r@Resource{..} = do + trace "m20" + deleteAccepted <- lift deleteResource + if deleteAccepted + then do + completed <- lift deleteCompleted + if completed + then o20 r + else lift $ halt HTTP.status202 + else lift $ halt HTTP.status500 + +m16 r = do + trace "m16" + req <- lift request + if requestMethod req == HTTP.methodDelete + then m20 r + else n16 r + +m07 r@Resource{..} = do + trace "m07" + allowMissing <- lift allowMissingPost + if allowMissing + then n11 r + else lift $ halt HTTP.status404 + +m05 r = do + trace "m05" + req <- lift request + if requestMethod req == HTTP.methodPost + then n05 r + else lift $ halt HTTP.status410 + +------------------------------------------------------------------------------ +-- N column +------------------------------------------------------------------------------ + +n16 r = do + trace "n16" + req <- lift request + if requestMethod req == HTTP.methodPost + then n11 r + else o16 r + +n11 r@Resource{..} = trace "n11" >> lift processPost >>= flip processPostAction r + +create :: Monad m => [Text] -> Resource m -> FlowStateT m () +create ts r = do + loc <- lift (appendRequestPath ts) + lift (addResponseHeader ("Location", loc)) + negotiateContentTypesAccepted r + +processPostAction :: Monad m => PostResponse m -> Flow m +processPostAction (PostCreate ts) r = do + create ts r + p11 r +processPostAction (PostCreateRedirect ts) r = do + create ts r + lift $ halt HTTP.status303 +processPostAction (PostProcess p) r = + lift p >> p11 r +processPostAction (PostProcessRedirect ts) _r = do + locBs <- lift ts + lift $ addResponseHeader ("Location", locBs) + lift $ halt HTTP.status303 + +n05 r@Resource{..} = do + trace "n05" + allow <- lift allowMissingPost + if allow + then n11 r + else lift $ halt HTTP.status410 + +------------------------------------------------------------------------------ +-- O column +------------------------------------------------------------------------------ + +o20 r = do + trace "o20" + body <- lift getResponseBody + -- ResponseBody is a little tough to make an instance of 'Eq', + -- so we just use a pattern match + case body of + Empty -> lift $ halt HTTP.status204 + _ -> o18 r + +o18 r@Resource{..} = do + trace "o18" + multiple <- lift multipleChoices + if multiple + then lift $ halt HTTP.status300 + else do + -- TODO: set etag, expiration, etc. headers + req <- lift request + let getOrHead = [ HTTP.methodGet + , HTTP.methodHead + ] + when (requestMethod req `elem` getOrHead) $ do + m <- _contentType <$> get + (cType, body) <- case m of + Nothing -> do + provided <- lift contentTypesProvided + return (head provided) + Just (cType, body) -> + return (cType, body) + b <- lift body + lift $ putResponseBody b + lift $ addResponseHeader ("Content-Type", renderHeader cType) + writeCacheTags r + lift $ halt HTTP.status200 + +o16 r = do + trace "o16" + req <- lift request + if requestMethod req == HTTP.methodPut + then o14 r + else o18 r + +o14 r@Resource{..} = do + trace "o14" + conflict <- lift isConflict + if conflict + then lift $ halt HTTP.status409 + else negotiateContentTypesAccepted r >> p11 r + +------------------------------------------------------------------------------ +-- P column +------------------------------------------------------------------------------ + +p11 r = do + trace "p11" + headers <- lift getResponseHeaders + case lookup HTTP.hLocation headers of + (Just _) -> + lift $ halt HTTP.status201 + _ -> + o20 r + +p03 r@Resource{..} = do + trace "p03" + conflict <- lift isConflict + if conflict + then lift $ halt HTTP.status409 + else negotiateContentTypesAccepted r >> p11 r diff --git a/tests/examples/pre-ghc910/Default.hs b/tests/examples/pre-ghc910/Default.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/DefaultTypeInstance.hs b/tests/examples/pre-ghc910/DefaultTypeInstance.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Defer03.hs b/tests/examples/pre-ghc910/Defer03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Defer03.hs @@ -0,0 +1,7 @@ +module Main where + +a :: Int +a = 'p' + +main :: IO () +main = print "No errors!" diff --git a/tests/examples/pre-ghc910/Dep1.hs b/tests/examples/pre-ghc910/Dep1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Dep1.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeInType #-} + +module Dep1 where + +import Data.Kind + +data Proxy k (a :: k) = P + +x :: Proxy * Int +x = P + +y :: Proxy Bool True +y = P diff --git a/tests/examples/pre-ghc910/Dep2.hs b/tests/examples/pre-ghc910/Dep2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Dep2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PolyKinds, GADTs #-} + +module Dep2 where + +data G (a :: k) where + G1 :: G Int + G2 :: G Maybe diff --git a/tests/examples/pre-ghc910/Dep3.hs b/tests/examples/pre-ghc910/Dep3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Dep3.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-} + +module Dep3 where + +import Data.Kind +import GHC.Exts ( Constraint ) + +type Star1 = Type + +data Id1 (a :: Star1) where + Id1 :: a -> Id1 a + +data Id1' :: Star1 -> Type where + Id1' :: a -> Id1' a + +type family Star2 x where + Star2 x = Type + +data Id2a (a :: Star2 Constraint) = Id2a a + + +data Id2 (a :: Star2 Constraint) where + Id2 :: a -> Id2 a + +data Id2' :: Star2 Constraint -> Type where + Id2' :: a -> Id2' a diff --git a/tests/examples/pre-ghc910/DepFail1.hs b/tests/examples/pre-ghc910/DepFail1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DepFail1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeInType #-} + +module DepFail1 where + +data Proxy k (a :: k) = P + +z :: Proxy Bool +z = P + +a :: Proxy Int Bool +a = P diff --git a/tests/examples/pre-ghc910/DependentStmt.hs b/tests/examples/pre-ghc910/DependentStmt.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DependentStmt.hs @@ -0,0 +1,10 @@ +module DependentStmt where + +-- This test rewrites foo to baz, but only in scope of 'y'. + +main :: IO () +main = do + x <- bar 7 + foo x + y <- bar 54 + baz y diff --git a/tests/examples/pre-ghc910/DeprM.hs b/tests/examples/pre-ghc910/DeprM.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/DeprU.hs b/tests/examples/pre-ghc910/DeprU.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Deprecation.hs b/tests/examples/pre-ghc910/Deprecation.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Deriving.hs b/tests/examples/pre-ghc910/Deriving.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/DerivingOC.hs b/tests/examples/pre-ghc910/DerivingOC.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/DoParens.hs b/tests/examples/pre-ghc910/DoParens.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DoParens.hs @@ -0,0 +1,4 @@ + +foo = do + (-) <- Just 5 + return () diff --git a/tests/examples/pre-ghc910/DoPatBind.hs b/tests/examples/pre-ghc910/DoPatBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DoPatBind.hs @@ -0,0 +1,4 @@ +module Main where + +bar = do + foo :: String <- baz diff --git a/tests/examples/pre-ghc910/DocDecls.hs b/tests/examples/pre-ghc910/DocDecls.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Dollar2.hs b/tests/examples/pre-ghc910/Dollar2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Dollar2.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Dollar2 where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint +-} + + +import GHC.Base + +data AB = A () | B () + +qux :: Bool +qux = True +{-# NOINLINE qux #-} + +foo = id $ ((if qux then A else B) $ ()) + +{- + +-} diff --git a/tests/examples/pre-ghc910/DollarDefault.hs b/tests/examples/pre-ghc910/DollarDefault.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DollarDefault.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} +module DollarDefault where + +class C p where + cid :: p a a -> p a a + +instance C (->) where + cid = id + +foo = (cid $ id) $ () diff --git a/tests/examples/pre-ghc910/DollarTest.hs b/tests/examples/pre-ghc910/DollarTest.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DollarTest.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UnicodeSyntax #-} +module Dollar where +{- +Check $ interacting with multiplicity polymorphism. +This caused Core Lint error previously. +-} + +import GHC.Base + +data Q a = Q a + +data QU = QU () + +test = QU $ () + +qux = Q $ () diff --git a/tests/examples/pre-ghc910/DoubleForall.hs b/tests/examples/pre-ghc910/DoubleForall.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/DroppedComma.hs b/tests/examples/pre-ghc910/DroppedComma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DroppedComma.hs @@ -0,0 +1,5 @@ + + +foo = + let (xs, ys) = ([1,2..3], [4,5..6]) in + bar diff --git a/tests/examples/pre-ghc910/DroppedDoSpace.hs b/tests/examples/pre-ghc910/DroppedDoSpace.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/DroppedDoSpace2.hs b/tests/examples/pre-ghc910/DroppedDoSpace2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DroppedDoSpace2.hs @@ -0,0 +1,6 @@ + + +save state = do \fileName -> + 4 + + diff --git a/tests/examples/pre-ghc910/DsStrict.hs b/tests/examples/pre-ghc910/DsStrict.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DsStrict.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE Strict #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +module Main where + +import Debug.Trace + +f0 a = "fun" +f0' ~a = "fun2" + +f1 ~n = + case n of + a -> "case" +f1' ~n = + case n of + ~a -> "case2" + +f2 = \a -> "lamda" +f2' = \ ~a -> "lambda2" + +newtype Age = MkAge Int + +f4, f4' :: Age -> String +f4 (MkAge a) = "newtype" +f4' ~(MkAge a) = "newtype2" + +main :: IO () +main = mapM_ (\(what,f) -> putStrLn (f (v what))) fs + where fs = + [("fun",f0 ) + ,("fun lazy",f0') + ,("case",f1) + ,("case lazy",f1') + ,("lambda",f2) + ,("lambda lazy",f2') + ,("newtype",(\ ~i -> f4 (MkAge i))) + ,("newtype lazy",(\ ~i -> f4' (MkAge i)))] + v n = trace ("evaluated in " ++ n) 1 diff --git a/tests/examples/pre-ghc910/DsStrictData.hs b/tests/examples/pre-ghc910/DsStrictData.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/DsStrictFail.hs b/tests/examples/pre-ghc910/DsStrictFail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DsStrictFail.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE Strict #-} +module Main where + +main = let False = True + in return () diff --git a/tests/examples/pre-ghc910/DsStrictLet.hs b/tests/examples/pre-ghc910/DsStrictLet.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DsStrictLet.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Strict #-} +module Main where + +import Debug.Trace + +main = let False = trace "no binders" False -- evaluated + + a :: a -> a + a = trace "polymorphic" id -- evaluated + + f :: Eq a => a -> a -> Bool + f = trace "overloaded" (==) -- not evaluated + + xs :: [Int] + xs = (trace "recursive" (:) 1 xs) -- evaluated + in return () diff --git a/tests/examples/pre-ghc910/DsStrictWarn.hs b/tests/examples/pre-ghc910/DsStrictWarn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DsStrictWarn.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-} +{-# LANGUAGE Strict #-} +module DsStrictWarn where + +-- should warn about non-exhaustive pattern match +w :: String -> String +w x = let (_:_) = x in "1" diff --git a/tests/examples/pre-ghc910/DumpParsedAst.hs b/tests/examples/pre-ghc910/DumpParsedAst.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/DumpParsedAst.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies + , TypeApplications, TypeInType #-} + +module DumpParsedAst where +import Data.Kind + +data Peano = Zero | Succ Peano + +type family Length (as :: [k]) :: Peano where + Length (a : as) = Succ (Length as) + Length '[] = Zero + +-- vis kind app +data T f (a :: k) = MkT (f a) + +type family F1 (a :: k) (f :: k -> Type) :: Type where + F1 @Peano a f = T @Peano f a + +main = putStrLn "hello" + diff --git a/tests/examples/pre-ghc910/EmptyCase008.hs b/tests/examples/pre-ghc910/EmptyCase008.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/EmptyCase008.hs @@ -0,0 +1,55 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +{-# LANGUAGE TypeFamilies, GADTs, EmptyCase, LambdaCase #-} + +-- Check interaction between Newtypes and DataFamilies +module EmptyCase008 where + +import Data.Kind (Type) + +data family DA a + +newtype Foo3 a = Foo3 (DA a) + +data instance DA Int = MkDA1 Char | MkDA2 + +-- Non-exhaustive. Missing: MkDA1 Char, MkDA2 +f11 :: Foo3 Int -> () +f11 = \case + +-- Non-exhaustive. (no info about a) +f12 :: Foo3 a -> () +f12 = \case + +data instance DA () -- Empty data type + +-- Exhaustive. +f13 :: Foo3 () -> () +f13 = \case + +-- ---------------- +data family DB a :: Type -> Type + +data instance DB Int a where + MkDB1 :: DB Int () + MkDB2 :: DB Int Bool + +newtype Foo4 a b = Foo4 (DB a b) + +-- Non-exhaustive. Missing: Foo4 MkDB1 +f14 :: Foo4 Int () -> () +f14 = \case + +-- Exhaustive +f15 :: Foo4 Int [a] -> () +f15 = \case + +-- Non-exhaustive. Missing: (_ :: Foo4 a b) (no information about a or b) +f16 :: Foo4 a b -> () +f16 = \case + +data instance DB Char Bool -- Empty data type + +-- Exhaustive (empty data type) +f17 :: Foo4 Char Bool -> () +f17 = \case + diff --git a/tests/examples/pre-ghc910/EmptyMostly.hs b/tests/examples/pre-ghc910/EmptyMostly.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/EmptyMostly.hs @@ -0,0 +1,14 @@ +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;;;;;;;;} +-- ;; + } +-- really trailing diff --git a/tests/examples/pre-ghc910/EmptyMostly2.hs b/tests/examples/pre-ghc910/EmptyMostly2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/EmptyMostly2.hs @@ -0,0 +1,8 @@ +module EmptyMostly2 where + { +;;;;;;;;;;;; +; +class Baz a where {;;;;;;;;; + ; baz :: a -> Int;;; +} + } diff --git a/tests/examples/pre-ghc910/EmptyMostlyInst.hs b/tests/examples/pre-ghc910/EmptyMostlyInst.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/EmptyMostlyInst.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleInstances #-} +module EmptyMostlyInst where + { +;;;;;;;;;;;; +; +instance Eq (Int,Integer) where {;;;;;;;;; +;;;;;;; a == b = False;;;;;;;;;;; +} + } diff --git a/tests/examples/pre-ghc910/EmptyMostlyNoSemis.hs b/tests/examples/pre-ghc910/EmptyMostlyNoSemis.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/EmptyMostlyTrailing.hs b/tests/examples/pre-ghc910/EmptyMostlyTrailing.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/EmptyMostlyTrailing.hs @@ -0,0 +1,8 @@ +-- top of module +module EmptyMostlyTrailing where +-- after module header + { +x = 1 +-- comment + } +-- really trailing diff --git a/tests/examples/pre-ghc910/Eq.hs b/tests/examples/pre-ghc910/Eq.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Eq.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, + RankNTypes, FlexibleContexts, TemplateHaskell, + UndecidableInstances, GADTs, DefaultSignatures #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Prelude.Eq +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines the SEq singleton version of the Eq type class. +-- +----------------------------------------------------------------------------- + +module Data.Singletons.Prelude.Eq ( + PEq(..), SEq(..), + (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$) + ) where + +import Data.Singletons.Prelude.Bool +import Data.Singletons +import Data.Singletons.Single +import Data.Singletons.Prelude.Instances +import Data.Singletons.Util +import Data.Singletons.Promote +import Data.Type.Equality + +-- NB: These must be defined by hand because of the custom handling of the +-- default for (:==) to use Data.Type.Equality.== + +-- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)', +-- then it defaults to a use of '(==)', from @Data.Type.Equality@. +class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where + type (:==) (x :: a) (y :: a) :: Bool + type (:/=) (x :: a) (y :: a) :: Bool + + type (x :: a) :== (y :: a) = x == y + type (x :: a) :/= (y :: a) = Not (x :== y) + +infix 4 :== +infix 4 :/= + +$(genDefunSymbols [''(:==), ''(:/=)]) + +-- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required +-- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'. +class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where + -- | Boolean equality on singletons + (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b) + infix 4 %:== + + -- | Boolean disequality on singletons + (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b) + default (%:/=) :: forall (a :: k) (b :: k). + ((a :/= b) ~ Not (a :== b)) + => Sing a -> Sing b -> Sing (a :/= b) + a %:/= b = sNot (a %:== b) + infix 4 %:/= + +$(singEqInstances basicTypes) diff --git a/tests/examples/pre-ghc910/Existential.hs b/tests/examples/pre-ghc910/Existential.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Exp.hs b/tests/examples/pre-ghc910/Exp.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Exp.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +module Data.Array.Accelerate.Utility.Lift.Exp ( + Unlift, + Unlifted, + Tuple, + unlift, + modify, + modify2, + modify3, + modify4, + Exp(Exp), expr, atom, + unliftPair, + unliftTriple, + unliftQuadruple, + asExp, + mapFst, + mapSnd, + fst3, + snd3, + thd3, + indexCons, + ) where + +import qualified Data.Array.Accelerate.Data.Complex as Complex +import qualified Data.Array.Accelerate as A +import Data.Complex (Complex((:+))) +import Data.Array.Accelerate ((:.)((:.))) + +import qualified Data.Tuple.HT as Tuple +import Data.Tuple.HT (mapTriple) + + +{- | +This class simplifies untupling of expressions. +If you have a function + +> g :: ((Exp a, Exp b), Exp (c,d)) -> (Exp e, Exp f) + +you cannot apply it to an array @arr :: Array sh ((a,b),(c,d))@ using 'A.map'. +Here, the 'modify' function helps: + +> modify ((expr,expr),expr) g :: Exp ((a,b),(c,d)) -> Exp (e,f) + +The 'expr'-pattern tells, how deep the tuple shall be unlifted. +This way you can write: + +> A.map +> (Exp.modify ((expr,expr),expr) $ \((a,b), cd) -> g ((a,b), cd)) +> arr + +'modify' is based on 'unlift'. +In contrast to 'A.unlift' it does not only unlift one level of tupels, +but is guided by an 'expr'-pattern. +In the example I have demonstrated, +how the pair @(a,b)@ is unlifted, but the pair @(c,d)@ is not. +For the result tuple, 'modify' simply calls 'A.lift'. +In contrast to 'A.unlift', +'A.lift' lifts over all tupel levels until it obtains a single 'Exp'. +-} +class + (A.Elt (Tuple pattern), A.Plain (Unlifted pattern) ~ Tuple pattern) => + Unlift pattern where + type Unlifted pattern + type Tuple pattern + unlift :: pattern -> A.Exp (Tuple pattern) -> Unlifted pattern + +modify :: + (A.Lift A.Exp a, Unlift pattern) => + pattern -> + (Unlifted pattern -> a) -> + A.Exp (Tuple pattern) -> A.Exp (A.Plain a) +modify p f = A.lift . f . unlift p + +modify2 :: + (A.Lift A.Exp a, Unlift patternA, Unlift patternB) => + patternA -> + patternB -> + (Unlifted patternA -> Unlifted patternB -> a) -> + A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> A.Exp (A.Plain a) +modify2 pa pb f a b = A.lift $ f (unlift pa a) (unlift pb b) + +modify3 :: + (A.Lift A.Exp a, Unlift patternA, Unlift patternB, Unlift patternC) => + patternA -> + patternB -> + patternC -> + (Unlifted patternA -> Unlifted patternB -> Unlifted patternC -> a) -> + A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> + A.Exp (Tuple patternC) -> A.Exp (A.Plain a) +modify3 pa pb pc f a b c = + A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c) + +modify4 :: + (A.Lift A.Exp a, + Unlift patternA, Unlift patternB, Unlift patternC, Unlift patternD) => + patternA -> + patternB -> + patternC -> + patternD -> + (Unlifted patternA -> Unlifted patternB -> + Unlifted patternC -> Unlifted patternD -> a) -> + A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> + A.Exp (Tuple patternC) -> A.Exp (Tuple patternD) -> A.Exp (A.Plain a) +modify4 pa pb pc pd f a b c d = + A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c) (unlift pd d) + + +instance (A.Elt a) => Unlift (Exp a) where + type Unlifted (Exp a) = A.Exp a + type Tuple (Exp a) = a + unlift _ = id + +data Exp e = Exp + +expr :: Exp e +expr = Exp + +{-# DEPRECATED atom "use expr instead" #-} +-- | for compatibility with accelerate-utility-0.0 +atom :: Exp e +atom = expr + + +instance (Unlift pa, Unlift pb) => Unlift (pa,pb) where + type Unlifted (pa,pb) = (Unlifted pa, Unlifted pb) + type Tuple (pa,pb) = (Tuple pa, Tuple pb) + unlift (pa,pb) ab = + (unlift pa $ A.fst ab, unlift pb $ A.snd ab) + +instance + (Unlift pa, Unlift pb, Unlift pc) => + Unlift (pa,pb,pc) where + type Unlifted (pa,pb,pc) = (Unlifted pa, Unlifted pb, Unlifted pc) + type Tuple (pa,pb,pc) = (Tuple pa, Tuple pb, Tuple pc) + unlift (pa,pb,pc) = + mapTriple (unlift pa, unlift pb, unlift pc) . A.unlift + + +instance (Unlift pa, A.Slice (Tuple pa), int ~ Exp Int) => Unlift (pa :. int) where + type Unlifted (pa :. int) = Unlifted pa :. A.Exp Int + type Tuple (pa :. int) = Tuple pa :. Int + unlift (pa:.pb) ab = + (unlift pa $ A.indexTail ab) :. (unlift pb $ A.indexHead ab) + + +instance (Unlift p) => Unlift (Complex p) where + type Unlifted (Complex p) = Complex (Unlifted p) + type Tuple (Complex p) = Complex (Tuple p) + unlift (preal:+pimag) z = + unlift preal (Complex.real z) + :+ + unlift pimag (Complex.imag z) + + +unliftPair :: (A.Elt a, A.Elt b) => A.Exp (a,b) -> (A.Exp a, A.Exp b) +unliftPair = A.unlift + +unliftTriple :: + (A.Elt a, A.Elt b, A.Elt c) => A.Exp (a,b,c) -> (A.Exp a, A.Exp b, A.Exp c) +unliftTriple = A.unlift + +unliftQuadruple :: + (A.Elt a, A.Elt b, A.Elt c, A.Elt d) => + A.Exp (a,b,c,d) -> (A.Exp a, A.Exp b, A.Exp c, A.Exp d) +unliftQuadruple = A.unlift + +asExp :: A.Exp a -> A.Exp a +asExp = id + +mapFst :: + (A.Elt a, A.Elt b, A.Elt c) => + (A.Exp a -> A.Exp b) -> A.Exp (a,c) -> A.Exp (b,c) +mapFst f = modify (expr,expr) $ \(a,c) -> (f a, c) + +mapSnd :: + (A.Elt a, A.Elt b, A.Elt c) => + (A.Exp b -> A.Exp c) -> A.Exp (a,b) -> A.Exp (a,c) +mapSnd f = modify (expr,expr) $ \(a,b) -> (a, f b) + + +fst3 :: + (A.Elt a, A.Elt b, A.Elt c) => + A.Exp (a,b,c) -> A.Exp a +fst3 = modify (expr,expr,expr) Tuple.fst3 + +snd3 :: + (A.Elt a, A.Elt b, A.Elt c) => + A.Exp (a,b,c) -> A.Exp b +snd3 = modify (expr,expr,expr) Tuple.snd3 + +thd3 :: + (A.Elt a, A.Elt b, A.Elt c) => + A.Exp (a,b,c) -> A.Exp c +thd3 = modify (expr,expr,expr) Tuple.thd3 + + + +indexCons :: + (A.Slice ix) => A.Exp ix -> A.Exp Int -> A.Exp (ix :. Int) +indexCons ix n = A.lift $ ix:.n + diff --git a/tests/examples/pre-ghc910/ExpandSynsFail1.hs b/tests/examples/pre-ghc910/ExpandSynsFail1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExpandSynsFail1.hs @@ -0,0 +1,4 @@ +type Foo = Int +type Bar = Bool + +main = print $ (1 :: Foo) == (False :: Bar) diff --git a/tests/examples/pre-ghc910/ExpandSynsFail2.hs b/tests/examples/pre-ghc910/ExpandSynsFail2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ExpandSynsFail3.hs b/tests/examples/pre-ghc910/ExpandSynsFail3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ExpandSynsFail4.hs b/tests/examples/pre-ghc910/ExpandSynsFail4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ExperimIOP.hs b/tests/examples/pre-ghc910/ExperimIOP.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExperimIOP.hs @@ -0,0 +1,24 @@ +-- +-- (C) Susumu Katayama +-- +-- (Typed)IOPairs¾å¤Ç¥Ç¡¼¥¿¤ò¤È¤ë¡¥ghci¾å¤Ç :cmd ¤ò»È¤¤¤Þ¤¯¤ë´¶¤¸¡¥ +{-# LANGUAGE RankNTypes, CPP, TemplateHaskell #-} +module ExperimIOP(module ExperimIOP, module MagicHaskeller.RunAnalytical) where + +import MagicHaskeller.Analytical +#ifdef DEBUG + hiding (rev) +#endif +import MagicHaskeller.Classification(Filtrable) +import MagicHaskeller.RunAnalytical +#ifdef DEBUG + hiding (main) +#endif +import MagicHaskeller.GetTime(batchWrite) + +main = do iop <- runQ andL + let e = getOne iop [] + putStrLn $ pprint e + +emptyBK = [d| {} |] + diff --git a/tests/examples/pre-ghc910/ExplicitForAllRules1.hs b/tests/examples/pre-ghc910/ExplicitForAllRules1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExplicitForAllRules1.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeApplications #-} + +module ExplicitForAllRules1 where + +import Data.Proxy +import Data.Kind + +-- From Proposal 0007 (w/ fix to "example") + +{-# RULES +"example" forall a b. forall. map @a @b f = f +"example2" forall a. forall (x :: a). id x = x + #-} + +{-# NOINLINE f #-} +f :: a -> b +f = undefined + +-- More tests + +{-# RULES +"example3" forall (a :: Type -> Type) (b :: a Int) c. forall x y. g @(Proxy b) @(Proxy c) x y = () +"example4" forall (a :: Bool) (b :: Proxy a). forall x. g @(Proxy b) @() x = id @() +"example5" forall (a :: Type). forall. h @a = id @a +"example5" forall k (c :: k). forall (x :: Proxy c). id @(Proxy c) x = x + #-} + +{-# NOINLINE g #-} +g :: a -> b -> () +g _ _ = () + +{-# NOINLINE h #-} +h :: a -> a +h x = x + +-- GHC 9.10 now has a parse error for the following, if a pragma +{- RULES "example6" forall a forall. g a forall = () -} + +-- Should generate a warning +{-# RULES "example7" forall a b. forall (x :: a). id x = x #-} + diff --git a/tests/examples/pre-ghc910/ExplicitNamespaces.hs b/tests/examples/pre-ghc910/ExplicitNamespaces.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExplicitNamespaces.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +module CLaSH.Prelude.BitIndex where + +import GHC.TypeLits (KnownNat, type (+), type (-)) diff --git a/tests/examples/pre-ghc910/ExplicitSpecificity4.hs b/tests/examples/pre-ghc910/ExplicitSpecificity4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExplicitSpecificity4.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module ExplicitSpecificity4 where + +class C a where + f :: forall {z}. z -> a -> a + default f :: forall {z}. z -> a -> a + f _ x = x + + g :: forall z. z -> a -> a + g _ x = x diff --git a/tests/examples/pre-ghc910/ExplicitSpecificityA1.hs b/tests/examples/pre-ghc910/ExplicitSpecificityA1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExplicitSpecificityA1.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE RankNTypes + , PolyKinds + , GADTs + , TypeApplications + , PatternSynonyms + , ExistentialQuantification + , StandaloneKindSignatures + , DataKinds + , ExistentialQuantification +#-} + +module ExplicitSpecificityA1 where + +import Data.Proxy +import Data.Kind + +-- Type variables bound in RULES +{-# RULES "parametricity" forall (f :: forall {a}. a -> a). map f = id #-} + +-- Type signatures +foo1 :: a -> a +foo1 x = x + +foo2 :: forall a. a -> a +foo2 x = x + +foo3 :: forall {a}. a -> a +foo3 x = x + +foo4 :: forall a {b}. a -> b -> b +foo4 _ x = x + +foo5 :: forall {a} b. a -> b -> b +foo5 _ x = x + +bar1 :: () +bar1 = let { x1 = foo1 42 + ; x2 = foo2 @Int 42 + ; x3 = foo3 42 + ; x4 = foo4 @Bool True 42 + ; x5 = foo5 @Int True 42 + } + in () + +-- Data declarations +data T1 a = C1 a + +data T2 (a :: k) = C2 { f2 :: Proxy a } + +data T3 a where C3 :: forall k (a::k). Proxy a -> T3 a + +data T4 a where C4 :: forall {k} (a::k). Proxy a -> T4 a + +data T5 k (a :: k) where C5 :: forall k (a::k). Proxy a -> T5 k a + +data T6 k a where C6 :: forall {k} (a::k). Proxy a -> T6 k a + +bar2 :: () +bar2 = let { x1 = C1 @Int 42 + ; x2 = C2 @Type @Int Proxy + ; x3 = C3 @Type @Int Proxy + ; x4 = C4 @Int Proxy + ; x5 = C5 @Type @Int Proxy + ; x6 = C6 @Int Proxy + } + in () + +-- Pattern synonyms +data T7 a where C7 :: forall a b. a -> b -> T7 a + +data T8 a where C8 :: forall a {b}. a -> b -> T8 a + +pattern Pat1 :: forall a. () => forall b. a -> b -> T7 a +pattern Pat1 x y = C7 x y + +pattern Pat2 :: forall {a}. () => forall b. a -> b -> T7 a +pattern Pat2 x y = C7 x y + +pattern Pat3 :: forall a. () => forall b. a -> b -> T8 a +pattern Pat3 x y = C8 x y + +pattern Pat4 :: forall {a}. () => forall b. a -> b -> T8 a +pattern Pat4 x y = C8 x y + +pattern Pat5 :: forall {a}. () => forall {b}. a -> b -> T7 a +pattern Pat5 x y = C7 x y + +bar3 :: (T7 a) -> () +bar3 (Pat1 x y) = () +bar3 (Pat2 x y) = () + +bar4 :: (T8 a) -> () +bar4 (Pat3 x y) = () +bar4 (Pat4 x y) = () + +-- Existential variable quantification +data HList = HNil + | forall {a}. HCons a HList + +-- Type synonyms +type TySy = forall a {b}. Either a b + +-- Standalone kind signatures +type Foo :: forall a {b}. a -> b -> b +type Foo x y = y + +type Bar = Foo @Bool True 42 + diff --git a/tests/examples/pre-ghc910/ExportSyntax.hs b/tests/examples/pre-ghc910/ExportSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ExportSyntaxImport.hs b/tests/examples/pre-ghc910/ExportSyntaxImport.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExportSyntaxImport.hs @@ -0,0 +1,7 @@ +module ExportSyntaxImport where + +import ExportSyntax + +foo = NoA + +baz = A diff --git a/tests/examples/pre-ghc910/ExportWarnings_aux.hs b/tests/examples/pre-ghc910/ExportWarnings_aux.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExportWarnings_aux.hs @@ -0,0 +1,7 @@ +module ExportWarnings_aux ( + {-# WARNING "warn" #-} x, + {-# WARNING in "x-custom-\72" [ "is" , "deprecated"] #-} S(S1), + ) where +import ExportWarnings_base (x) + +data S = S1 | S2 diff --git a/tests/examples/pre-ghc910/Expr.hs b/tests/examples/pre-ghc910/Expr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ExprPragmas.hs b/tests/examples/pre-ghc910/ExprPragmas.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ExprSigLocal.hs b/tests/examples/pre-ghc910/ExprSigLocal.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExprSigLocal.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PartialTypeSignatures, RankNTypes #-} + +module ExprSigLocal where + +-- We expect this to compile fine, +-- reporting that '_' stands 'a' + +y :: forall b. b->b +y = ((\x -> x) :: forall a. a -> _) + +g :: forall a. a -> _ +g x = x diff --git a/tests/examples/pre-ghc910/Extends.hs b/tests/examples/pre-ghc910/Extends.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Extends.hs @@ -0,0 +1,4 @@ +module Extends where + +class BClass b where + has :: b diff --git a/tests/examples/pre-ghc910/ExtraConstraints1.hs b/tests/examples/pre-ghc910/ExtraConstraints1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ExtraConstraintsWildcardInExpressionSignature.hs b/tests/examples/pre-ghc910/ExtraConstraintsWildcardInExpressionSignature.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExtraConstraintsWildcardInExpressionSignature.hs @@ -0,0 +1,3 @@ +module ExtraConstraintsWildcardInExpressionSignature where + +foo x y = ((==) :: _ => _) x y diff --git a/tests/examples/pre-ghc910/ExtraConstraintsWildcardInPatternSignature.hs b/tests/examples/pre-ghc910/ExtraConstraintsWildcardInPatternSignature.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExtraConstraintsWildcardInPatternSignature.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module ExtraConstraintsWildcardInPatternSignature where + +foo (x :: _ => _) y = x == y diff --git a/tests/examples/pre-ghc910/ExtraConstraintsWildcardInPatternSplice.hs b/tests/examples/pre-ghc910/ExtraConstraintsWildcardInPatternSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExtraConstraintsWildcardInPatternSplice.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +module ExtraConstraintsWildcardInPatternSplice where + +foo $( [p| (x :: _) |] ) = x diff --git a/tests/examples/pre-ghc910/ExtraConstraintsWildcardInTypeSplice.hs b/tests/examples/pre-ghc910/ExtraConstraintsWildcardInTypeSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExtraConstraintsWildcardInTypeSplice.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module ExtraConstraintsWildcardInTypeSplice where + +import Language.Haskell.TH + +metaType :: TypeQ +metaType = [t| _ => _ |] diff --git a/tests/examples/pre-ghc910/ExtraConstraintsWildcardInTypeSplice2.hs b/tests/examples/pre-ghc910/ExtraConstraintsWildcardInTypeSplice2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ExtraConstraintsWildcardInTypeSpliceUsed.hs b/tests/examples/pre-ghc910/ExtraConstraintsWildcardInTypeSpliceUsed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ExtraConstraintsWildcardTwice.hs b/tests/examples/pre-ghc910/ExtraConstraintsWildcardTwice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ExtraConstraintsWildcardTwice.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ExtraConstraintsWildcardTwice where + +foo :: ((_), _) => a -> a +foo = undefined diff --git a/tests/examples/pre-ghc910/F.hs b/tests/examples/pre-ghc910/F.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/F.hs @@ -0,0 +1,20 @@ +-- | Thompson's group F. +-- +-- See eg. +-- +-- Based mainly on James Michael Belk's PhD thesis \"THOMPSON'S GROUP F\"; +-- see +-- + +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns, PatternSynonyms, DeriveFunctor #-} +module Math.Combinat.Groups.Thompson.F where + +-- | Remove the carets with the given indices +-- (throws an error if there is no caret at the given index) +removeCarets :: [Int] -> T -> T +removeCarets idxs tree = if null rem then final else error ("removeCarets: some stuff remained: " ++ show rem) where + + (_,rem,final) = go 0 idxs tree where + + go :: Int -> [Int] -> T -> (Int,[Int],T) + go !x [] t = (x + treeWidth t , [] , t) diff --git a/tests/examples/pre-ghc910/FDsFromGivens2.hs b/tests/examples/pre-ghc910/FDsFromGivens2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/FOL.hs b/tests/examples/pre-ghc910/FOL.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/FOL.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, + TypeFamilies, TypeSynonymInstances #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +module Data.Logic.Types.Harrison.FOL + ( TermType(..) + , FOL(..) + , Function(..) + ) where + +-- Baz +import qualified Data.Logic.Types.Common ({- instance Variable String -}) +-- Bar + diff --git a/tests/examples/pre-ghc910/Families.hs b/tests/examples/pre-ghc910/Families.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Families.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds, KindSignatures, + TypeOperators, UndecidableInstances #-} + +{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, EmptyDataDecls #-} + +-- | A prelude for type-level programming with type families + +module Prelude.Type.Families where + +-- >>> T :: T ((I 4) `Minus` (I 7)) +-- -3 +type family (a :: k) `Minus` (b :: k) :: k +type instance a `Minus` b = a + Negate b + diff --git a/tests/examples/pre-ghc910/Field.hs b/tests/examples/pre-ghc910/Field.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Field.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} +{-| + Module : AERN2.MP.Ball.Field + Description : Field operations on arbitrary precision dyadic balls + Copyright : (c) Michal Konecny + License : BSD3 + + Maintainer : mikkonecny@gmail.com + Stability : experimental + Portability : portable + + Field operations on arbitrary precision dyadic balls +-} +module AERN2.MP.Ball.Field +(mulBalls, mulByEndpoints) +where + +import MixedTypesNumPrelude +-- import qualified Prelude as P + +import qualified Numeric.CollectErrors as CN + +import AERN2.Normalize + + +mulByEndpoints :: MPBall -> MPBall -> MPBall +mulByEndpoints b1 b2 = + fromEndpoints l r + where + (l,r) + | 0 <= l1 && 0 <= l2 = (l1*.l2, r1*^r2) -- 0 <= l1 <= r1, 0 <= l2 <= r2 + | r1 <= 0 && r2 <= 0 = (r1*.r2, l1*^l2) -- l1 <= r1 <= 0, l2 <= r2 <= 0 + | 0 <= l1 && r2 <= 0 = (r1*.l2, l1*^r2) -- l2 <= r2 <= 0 <= l1 <= r1 + | r1 <= 0 && 0 <= l2 = (l1*.r2, r1*^l2) -- l1 <= r1 <= 0 <= l2 <= r2 + | l1 < 0 && 0 < r1 && 0 <= l2 = (l1*.r2, r1*^r2) -- l1 < 0 < r1, 0 <= l2 <= r2 + | l1 < 0 && 0 < r1 && r2 <= 0 = (r1*.l2, l1*^l2) -- l1 < 0 < r1, l2 <= r2 <= 0 + | l2 < 0 && 0 < r2 && 0 <= l1 = (l2*.r1, r2*^r1) -- l2 < 0 < r2, 0 <= l1 <= r1 + | l2 < 0 && 0 < r2 && r1 <= 0 = (r2*.l1, l2*^l1) -- l2 < 0 < r2, l1 <= r1 <= 0 + | otherwise = -- l1 < 0 < r1, l2 < 0 < r2 + ((l1 *. r2) `min` (r1 *. l2) + ,(l1 *^ l2) `max` (r1 *^ r2)) + (l1,r1) = endpoints b1 + (l2,r2) = endpoints b2 + + diff --git a/tests/examples/pre-ghc910/Field1.hs b/tests/examples/pre-ghc910/Field1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Field1.hs @@ -0,0 +1,10 @@ +module Field1 where + +--Rename field name 'pointx' to 'pointx1' + +data Point = Pt {pointx, pointy :: Float} deriving Show + +absPoint :: Point -> Float +absPoint p = sqrt (pointx p * pointx p + + pointy p * pointy p) + diff --git a/tests/examples/pre-ghc910/FooBar.hs b/tests/examples/pre-ghc910/FooBar.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/FooBar.hs @@ -0,0 +1,4 @@ +module FooBar where + +import Foo +import Bar diff --git a/tests/examples/pre-ghc910/FooExpected.hs b/tests/examples/pre-ghc910/FooExpected.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ForAll.hs b/tests/examples/pre-ghc910/ForAll.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ForFree.hs b/tests/examples/pre-ghc910/ForFree.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ForFree.hs @@ -0,0 +1,23 @@ + +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Control.ForFree where { + +-- | Free monad from a functor +; + data Free f x = Pure x | Free (f (Free f x)); + + deriving instance (Eq (f (Free f a)), Eq a) => Eq (Free f a); + deriving instance (Ord (f (Free f a)), Ord a) => Ord (Free f a); + deriving instance (Read (f (Free f a)), Read a) => Read (Free f a); + deriving instance (Show (f (Free f a)), Show a) => Show (Free f a); +} diff --git a/tests/examples/pre-ghc910/ForeignDecl.hs b/tests/examples/pre-ghc910/ForeignDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ForeignDecl1.hs b/tests/examples/pre-ghc910/ForeignDecl1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ForeignDecl1.hs @@ -0,0 +1,8 @@ +module ForeignDecl1 where + + +-- comment + +x = 1; + + diff --git a/tests/examples/pre-ghc910/FromGrin2.hs b/tests/examples/pre-ghc910/FromGrin2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/FromGrin2.hs @@ -0,0 +1,6 @@ + +-- ./hackage-roundtrip-work/ajhc-0.8.0.10/src/C/FromGrin2.hs +-- orig line 588 +convertExp :: Exp -> C (Statement,Expression) +convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do + return (mempty,e) diff --git a/tests/examples/pre-ghc910/FromManual.hs b/tests/examples/pre-ghc910/FromManual.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/FromManual.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UnicodeSyntax #-} + +module FromManual where + +data T1 a = MkT1 a + +construct :: a %1 -> MkT1 a +construct x = MkT1 x + +deconstruct :: MkT1 a %1 -> a +deconstruct (MkT1 x) = x -- must consume `x` exactly once + +data T2 a b c where + MkT2 :: a -> b %1 -> c %1 -> T2 a b -- Note unrestricted arrow in the first argument + +data T3 a b c where + MkT3 :: a -> b ⊸ c ⊸ T2 a b -- Note unrestricted arrow in the first argument + +g :: A %1 -> (A, B) +h :: A %1 -> B %1 -> C + +f :: A %1 -> C +f x = f' (g x) + where + f' :: (A, B) %1 -> C + f' (y, z) = h y z diff --git a/tests/examples/pre-ghc910/FromUtils.hs b/tests/examples/pre-ghc910/FromUtils.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/FrontendPlugin.hs b/tests/examples/pre-ghc910/FrontendPlugin.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/FrontendPlugin.hs @@ -0,0 +1,52 @@ +module FrontendPlugin where + +import GhcPlugins +import qualified GHC +import GHC ( Ghc, LoadHowMuch(..) ) + +import DriverPipeline hiding ( hsc_env ) +import DriverPhases +import System.Exit +import Control.Monad +import Data.List + +frontendPlugin :: FrontendPlugin +frontendPlugin = defaultFrontendPlugin { + frontend = doMake + } + +-- Copypasted from ghc/Main.hs +doMake :: [String] -> [(String,Maybe Phase)] -> Ghc () +doMake opts srcs = do + liftIO $ print opts + let (hs_srcs, non_hs_srcs) = partition haskellish srcs + + haskellish (f,Nothing) = + looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f + haskellish (_,Just phase) = + phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm + , StopLn] + + hsc_env <- GHC.getSession + + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then liftIO (oneShot hsc_env StopLn srcs) + else do + + o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) + non_hs_srcs + dflags <- GHC.getSessionDynFlags + let dflags' = dflags { ldInputs = map (FileOption "") o_files + ++ ldInputs dflags } + _ <- GHC.setSessionDynFlags dflags' + + targets <- mapM (uncurry GHC.guessTarget) hs_srcs + GHC.setTargets targets + ok_flag <- GHC.load LoadAllTargets + + when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) + return () diff --git a/tests/examples/pre-ghc910/FunDeps.hs b/tests/examples/pre-ghc910/FunDeps.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/FunctionalDeps.hs b/tests/examples/pre-ghc910/FunctionalDeps.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Functors.hs b/tests/examples/pre-ghc910/Functors.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Functors.hs @@ -0,0 +1,530 @@ +-- | Types are great. Lifting them into some sort of applicative functor makes +-- them even better. This module is an homage to our favorite applicatives, and +-- to the semigroups with which they are instrinsically connected. + +{-# LANGUAGE NoImplicitPrelude #-} -- Prelude is bad +{-# LANGUAGE DeriveFunctor #-} -- Writing Functor instances is boring + +module Acme.Functors + ( + -- * Lifted-but-why + LiftedButWhy (..) + + -- * Or-not + , OrNot (..) + + -- * Two + , Two (..) + + -- * Any-number-of + , AnyNumberOf (..), (~~) + + -- * One-or-more + , OneOrMore (..) + + -- * Also-extra-thing + , Also (..) + + -- * Or-instead-other-thing + , OrInstead (..) + + -- * Or-instead-other-thing ("first" variant) + , OrInsteadFirst (..) + + -- * Determined-by-parameter + , DeterminedBy (..) + + ) where + +import Acme.Functors.Classes + + +-------------------------------------------------------------------------------- +-- Lifted-but-why +-------------------------------------------------------------------------------- + +-- | __@LiftedButWhy@__ is a boring functor that just has one value and no other +-- structure or interesting properties. + +data LiftedButWhy a = + + LiftedButWhy a + -- ^ A value that has been lifted for some damned reason. + -- + -- ... Okay, to be honest, this one is /nobody's/ favorite, but it is + -- included here for completeness. + + deriving (Eq, Functor, Show) + +-- | > pure = LiftedButWhy +-- > +-- > LiftedButWhy f <*> LiftedButWhy a = LiftedButWhy (f a) + +instance Applicative LiftedButWhy where + + pure = LiftedButWhy + + LiftedButWhy f <*> LiftedButWhy a = LiftedButWhy (f a) + +-- | > LiftedButWhy a >>= f = f a +instance Monad LiftedButWhy where + + LiftedButWhy a >>= f = f a + +-- | > LiftedButWhy x <> LiftedButWhy y = LiftedButWhy (x <> y) + +instance Semigroup a => Semigroup (LiftedButWhy a) where + + LiftedButWhy x <> LiftedButWhy y = LiftedButWhy (x <> y) + +-- | > mempty = LiftedButWhy mempty + +instance Monoid a => Monoid (LiftedButWhy a) where + + mempty = LiftedButWhy mempty + + +-------------------------------------------------------------------------------- +-- Or-not +-------------------------------------------------------------------------------- + +-- | __@OrNot@__ is somehow slightly more interesting than @LiftedButWhy@, even +-- though it may actually contain /less/. Instead of a value, there might /not/ +-- be a value. +-- +-- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to +-- be present. If any of them are absent, the whole expression evaluates to +-- @Nope@. + +data OrNot a = ActuallyYes a -- ^ Some normal value. + | Nope -- ^ Chuck Testa. + deriving (Eq, Functor, Show) + +-- | If you have a function @f@ that might not actually be there, and a value +-- @a@ that might not actually be there, lifted application @(\<*\>)@ gives you +-- @f a@ only if both of them are actually there. +-- +-- > pure = ActuallyYes +-- > +-- > ActuallyYes f <*> ActuallyYes a = ActuallyYes (f a) +-- > _ <*> _ = Nope + +instance Applicative OrNot where + + pure = ActuallyYes + + ActuallyYes f <*> ActuallyYes a = ActuallyYes (f a) + _ <*> _ = Nope + +instance Monad OrNot where + + ActuallyYes a >>= f = f a + Nope >>= _ = Nope + +-- | If you have value @a@ that may not actually be there, and another value +-- @a'@ that might not actually be there, the lifted semigroup operation +-- @(\<\>)@ gives you @a \<\> a'@ only if both of them are actually there. +-- +-- > ActuallyYes a <> ActuallyYes a' = ActuallyYes (a <> a') +-- > _ <> _ = Nope + +instance Semigroup a => Semigroup (OrNot a) where + + ActuallyYes a <> ActuallyYes a' = ActuallyYes (a <> a') + _ <> _ = Nope + +-- | > mempty = ActuallyYes mempty + +instance Monoid a => Monoid (OrNot a) where + + mempty = ActuallyYes mempty + + +-------------------------------------------------------------------------------- +-- Two +-------------------------------------------------------------------------------- + +-- | __@Two@__ is /two/ values. Yep. Just two values. + +data Two a = Two { firstOfTwo :: a -- ^ One value. + , secondOfTwo :: a -- ^ Another value. + } + deriving (Eq, Functor, Show) + +-- | If you have two functions @f@ and @g@ and two values @a@ and @a'@, then you +-- can apply them with @(\<*\>)@ to get two results @f a@ and @g a'@. +-- +-- > pure a = Two a a +-- > +-- > Two f g <*> Two a a' = Two (f a) (g a') + +instance Applicative Two where + + pure a = Two a a + + Two f g <*> Two a a' = Two (f a) (g a') + +-- | > Two x y <> Two x' y' = Two (x <> x') (y <> y') + +instance Semigroup a => Semigroup (Two a) where + + Two x y <> Two x' y' = Two (x <> x') (y <> y') + +-- | > mempty = Two mempty mempty + +instance Monoid a => Monoid (Two a) where + + mempty = Two mempty mempty + + +-------------------------------------------------------------------------------- +-- Any-number-of +-------------------------------------------------------------------------------- + +-- | __@AnyNumberOf@__ starts to get exciting. Any number of values you want. +-- Zero... one ... two ... three ... four ... five ... The possibilities are +-- /truly/ endless. + +data AnyNumberOf a = + + OneAndMaybeMore a (AnyNumberOf a) + -- ^ One value, and maybe even more after that! + + | ActuallyNone -- ^ Oh. Well this is less fun. + + deriving (Eq, Functor, Show) + +-- | Alias for 'OneAndMaybeMore' which provides some brevity. + +(~~) :: a -> AnyNumberOf a -> AnyNumberOf a +(~~) = OneAndMaybeMore + +infixr 5 ~~ + +-- | You can use this to apply any number of functions to any number of +-- arguments. +-- +-- > pure a = OneAndMaybeMore a ActuallyNone +-- > +-- > OneAndMaybeMore f fs <*> OneAndMaybeMore x xs = +-- > OneAndMaybeMore (f x) (fs <*> xs) +-- > _ <*> _ = ActuallyNone +-- +-- Example: +-- +-- > ( (+ 1) ~~ (* 2) ~~ (+ 5) ~~ ActuallyNone ) +-- > <*> ( 1 ~~ 6 ~~ 4 ~~ 37 ~~ ActuallyNone ) +-- > = ( 7 ~~ 12 ~~ 9 ~~ ActuallyNone ) +-- +-- This example demonstrates how when there are more arguments than functions, +-- any excess arguments (in this case, the @37@) are ignored. + +instance Applicative AnyNumberOf where + + pure a = OneAndMaybeMore a ActuallyNone + + OneAndMaybeMore f fs <*> OneAndMaybeMore x xs = + OneAndMaybeMore (f x) (fs <*> xs) + _ <*> _ = ActuallyNone + +-- | The operation of combining some number of @a@ with some other number of @a@ +-- is sometimes referred to as /zipping/. +-- +-- > OneAndMaybeMore x xs <> OneAndMaybeMore y ys = +-- > OneAndMaybeMore (x <> y) (xs <> ys) +-- > _ <> _ = ActuallyNone + +instance Semigroup a => Semigroup (AnyNumberOf a) where + + OneAndMaybeMore x xs <> OneAndMaybeMore y ys = + OneAndMaybeMore (x <> y) (xs <> ys) + _ <> _ = ActuallyNone + +-- | > mempty = mempty ~~ mempty + +instance Monoid a => Monoid (AnyNumberOf a) where + + mempty = mempty ~~ mempty + + +-------------------------------------------------------------------------------- +-- One-or-more +-------------------------------------------------------------------------------- + +-- | __@OneOrMore@__ is more restrictive than AnyNumberOf, yet somehow actually +-- /more/ interesting, because it excludes that dull situation where there +-- aren't any values at all. + +data OneOrMore a = OneOrMore + { theFirstOfMany :: a -- ^ Definitely at least this one. + , possiblyMore :: AnyNumberOf a -- ^ And perhaps others. + } deriving (Eq, Functor, Show) + +-- | > pure a = OneOrMore a ActuallyNone +-- > +-- > OneOrMore f fs <*> OneOrMore x xs = OneOrMore (f x) (fs <*> xs) + +instance Applicative OneOrMore where + + pure a = OneOrMore a ActuallyNone + + OneOrMore f fs <*> OneOrMore x xs = OneOrMore (f x) (fs <*> xs) + +-- | +-- > OneOrMore a more <> OneOrMore a' more' = +-- > OneOrMore a (more <> OneAndMaybeMore a' more') + +instance Semigroup a => Semigroup (OneOrMore a) where + + OneOrMore a more <> OneOrMore a' more' = + OneOrMore a (more <> OneAndMaybeMore a' more') + +-- | > mempty = OneOrMore mempty ActuallyNone + +instance Monoid a => Monoid (OneOrMore a) where + + mempty = OneOrMore mempty ActuallyNone + + +-------------------------------------------------------------------------------- +-- Also-extra-thing +-------------------------------------------------------------------------------- + +-- | __@Also extraThing@__ is a functor in which each value has an @extraThing@ +-- of some other type that tags along with it. + +data (Also extraThing) a = Also + { withoutExtraThing :: a -- ^ A value. + , theExtraThing :: extraThing -- ^ An additional thing that tags along. + } + deriving (Eq, Functor, Show) + +-- | Dragging the @extraThing@ along can be a bit of a burden. It prevents @Also +-- extraThing@ from being an applicative functor — unless the @extraThing@ can +-- pull its weight by bringing a monoid to the table. +-- +-- > pure = (`Also` mempty) +-- > +-- > (f `Also` extra1) <*> (a `Also` extra2) = f a +-- > `Also` (extra1 <> extra2) + +instance Monoid extraThing => Applicative (Also extraThing) where + + pure = (`Also` mempty) + + (f `Also` extra1) <*> (a `Also` extra2) = f a + `Also` (extra1 <> extra2) + +-- | +-- > (a `Also` extra1) <> (a' `Also` extra2) = (a <> a') +-- > `Also` (extra1 <> extra2) + +instance (Semigroup extraThing, Semigroup a) => Semigroup ((Also extraThing) a) + where + + (a `Also` extra1) <> (a' `Also` extra2) = (a <> a') + `Also` (extra1 <> extra2) + +-- | > mempty = Also mempty mempty + +instance (Monoid extraThing, Monoid a) => Monoid ((Also extraThing) a) + where + + mempty = Also mempty mempty + + +-------------------------------------------------------------------------------- +-- Or-instead-other-thing +-------------------------------------------------------------------------------- + +-- | __@OrInstead otherThing@__ is a functor in which, instead of having a +-- value, can actually just have some totally unrelated @otherThing@ instead. +-- +-- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to +-- be present. If any of them are the @otherThing@ instead, then the whole +-- expression evaluates to the combination of the @otherThing@s. + +data (OrInstead otherThing) a = + NotInstead a -- ^ Some normal value. + | Instead otherThing -- ^ Some totally unrelated other thing. + deriving (Eq, Functor, Show) + +-- | The possibility of having an @otherThing@ obstructs this functor's ability +-- to be applicative, much like the extra thing in @Also extraThing@ does. In +-- this case, since we do not need an empty value for the @otherThing@, it needs +-- only a semigroup to be in compliance. +-- +-- > pure = NotInstead +-- > +-- > NotInstead f <*> NotInstead a = NotInstead (f a) +-- > Instead other1 <*> Instead other2 = Instead (other1 <> other2) +-- > Instead other <*> _ = Instead other +-- > _ <*> Instead other = Instead other + +instance Semigroup otherThing => Applicative (OrInstead otherThing) where + + pure = NotInstead + + NotInstead f <*> NotInstead a = NotInstead (f a) + Instead other1 <*> Instead other2 = Instead (other1 <> other2) + Instead other <*> _ = Instead other + _ <*> Instead other = Instead other + +-- | +-- > NotInstead a <> NotInstead a' = NotInstead (a <> a') +-- > Instead other1 <> Instead other2 = Instead (other1 <> other2) +-- > Instead other <> _ = Instead other +-- > _ <> Instead other = Instead other + +instance (Semigroup otherThing, Semigroup a) => + Semigroup ((OrInstead otherThing) a) where + + NotInstead a <> NotInstead a' = NotInstead (a <> a') + Instead other1 <> Instead other2 = Instead (other1 <> other2) + Instead other <> _ = Instead other + _ <> Instead other = Instead other + +-- > mempty = NotInstead mempty + +instance (Semigroup otherThing, Monoid a) => Monoid ((OrInstead otherThing) a) + where + + mempty = NotInstead mempty + + +-------------------------------------------------------------------------------- +-- Or-instead-first-thing +-------------------------------------------------------------------------------- + +-- | __@OrInsteadFirst otherThing@__ looks a lot like @OrInstead otherThing@, +-- but it manages to always be an applicative functor — and even a monad too — +-- by handling the @otherThing@s a bit more hamfistedly. +-- +-- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to +-- be present. If any of them are the @otherThing@ instead, then the whole +-- expression evaluates to the /first/ @otherThing@ encountered, ignoring any +-- additional @otherThings@ that may subsequently pop up + +data (OrInsteadFirst otherThing) a = + NotInsteadFirst a -- ^ Some normal value. + | InsteadFirst otherThing -- ^ Some totally unrelated other thing. + deriving (Eq, Functor, Show) + +-- | +-- > pure = NotInsteadFirst +-- > +-- > NotInsteadFirst f <*> NotInsteadFirst a = NotInsteadFirst (f a) +-- > InsteadFirst other <*> _ = InsteadFirst other +-- > _ <*> InsteadFirst other = InsteadFirst other + +instance Applicative (OrInsteadFirst otherThing) where + + pure = NotInsteadFirst + + NotInsteadFirst f <*> NotInsteadFirst a = NotInsteadFirst (f a) + InsteadFirst other <*> _ = InsteadFirst other + _ <*> InsteadFirst other = InsteadFirst other + +-- | +-- > InsteadFirst other >>= _ = InsteadFirst other +-- > NotInsteadFirst a >>= f = f a + +instance Monad (OrInsteadFirst otherThing) where + + InsteadFirst other >>= _ = InsteadFirst other + NotInsteadFirst a >>= f = f a + +-- | +-- > NotInsteadFirst a <> NotInsteadFirst a' = NotInsteadFirst (a <> a') +-- > InsteadFirst other <> _ = InsteadFirst other +-- > _ <> InsteadFirst other = InsteadFirst other + +instance (Semigroup otherThing, Semigroup a) => + Semigroup ((OrInsteadFirst otherThing) a) where + + NotInsteadFirst a <> NotInsteadFirst a' = NotInsteadFirst (a <> a') + InsteadFirst other <> _ = InsteadFirst other + _ <> InsteadFirst other = InsteadFirst other + +-- | > mempty = NotInsteadFirst mempty + +instance (Semigroup otherThing, Monoid a) => + Monoid ((OrInsteadFirst otherThing) a) where + + mempty = NotInsteadFirst mempty + + +-------------------------------------------------------------------------------- +-- Determined-by-parameter +-------------------------------------------------------------------------------- + +-- | __@DeterminedBy parameter@__ is a value that... well, we're not really sure +-- what it is. We'll find out once a @parameter@ is provided. +-- +-- The mechanism for deciding /how/ the value is determined from the +-- @parameter@ is opaque; all you can do is test it with different parameters +-- and see what results. There aren't even @Eq@ or @Show@ instances, which is +-- annoying. + +data DeterminedBy parameter a = Determination ((->) parameter a) + deriving (Functor) + +-- | +-- > pure a = Determination (\_ -> a) +-- > +-- > Determination f <*> Determination a = Determination (\x -> f x (a x)) + +instance Applicative (DeterminedBy parameter) where + + pure a = Determination (\_ -> a) + + Determination f <*> Determination a = Determination (\x -> f x (a x)) + +-- | +-- > Determination fa >>= ff = +-- > Determination (\x -> let Determination f = ff (fa x) in f x) + +instance Monad (DeterminedBy parameter) where + + Determination fa >>= ff = + Determination (\x -> let Determination f = ff (fa x) in f x) + +-- | > Determination f <> Determination g = Determination (\x -> f x <> g x) + +instance Semigroup a => Semigroup ((DeterminedBy parameter) a) where + + Determination f <> Determination g = Determination (\x -> f x <> g x) + +-- | > mempty = Determination (\_ -> mempty) + +instance Monoid a => Monoid ((DeterminedBy parameter) a) where + + mempty = Determination (\_ -> mempty) + + +{- + +-------------------------------------------------------------------------------- +-- Notes +-------------------------------------------------------------------------------- + +LiftedButWhy is Identity. + +OrNot is Maybe, but with a different semigroup and monoid. + +Two doesn't have an analogue in the standard library as far as I know. + +AnyNumberOf is ZipList. + +OneOrMore is NonEmpty. + +Also is (,), the 2-tuple. + +OrInstead is AccValidation from the 'validation' package. + +OrInsteadFirst is Either. + +DeterminedBy is (->) also known as a function, whose functor is also known as +Reader. + +-} diff --git a/tests/examples/pre-ghc910/GA1r.hs b/tests/examples/pre-ghc910/GA1r.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/GA1r.hs @@ -0,0 +1,5 @@ +module GA1r where +import Text.ParserCombinators.Parsec + +parseStr :: CharParser () String +parseStr = char '"' *> (many1 (noneOf "\"")) <* char '"' diff --git a/tests/examples/pre-ghc910/GADT.hs b/tests/examples/pre-ghc910/GADT.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/GADT.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE RankNTypes #-} + +data Empty +data NonEmpty + +data SafeList x y where + Nil :: SafeList x Empty + Cons:: Eq x => x -> SafeList x y -> SafeList x NonEmpty + One :: Eq x => x -> SafeList x Empty -> SafeList x NonEmpty + +safeHead :: SafeList x NonEmpty -> x +safeHead (Cons x _) = x + +foo = Cons 3 (Cons 6 (Cons 9 Nil)) + + +data Dict x where + DictN :: Num x => x -> Dict x + DictE :: Eq x => x -> Dict x + +data Exist where + Exist :: forall a. a -> Exist diff --git a/tests/examples/pre-ghc910/GADTRecords.hs b/tests/examples/pre-ghc910/GADTRecords.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/GADTRecords2.hs b/tests/examples/pre-ghc910/GADTRecords2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/GHCOrig.hs b/tests/examples/pre-ghc910/GHCOrig.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Generate.hs b/tests/examples/pre-ghc910/Generate.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Generate.hs @@ -0,0 +1,7 @@ +import Control.Monad (forM_) + +main :: IO () +main = forM_ [0..0xffff] $ \i -> do + putStrLn $ ".section s" ++ show i ++ ",\"\",@progbits" + putStrLn $ ".asciz \"Section " ++ show i ++ "\"" + putStrLn "" diff --git a/tests/examples/pre-ghc910/Generic.hs b/tests/examples/pre-ghc910/Generic.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Generic.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +module Env.Generic + ( Record(..) + , type (?)(..) + ) where + +import Data.Promotion.Prelude (type (:+$), type (:*$), type (:^$), type (:-$)) +import Options.Generic (Generic, ParseRecord, type ()(..)) diff --git a/tests/examples/pre-ghc910/GenericDeriving.hs b/tests/examples/pre-ghc910/GenericDeriving.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Group.hs b/tests/examples/pre-ghc910/Group.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Group.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE RebindableSyntax,QuasiQuotes #-} + +-- | This module contains most of the math types not directly related to linear algebra +-- +-- FIXME: there is probably a better name for this +module SubHask.Algebra.Group + where + +import Control.Monad +import qualified Prelude as P + +import SubHask.Algebra +import SubHask.Category +import SubHask.Mutable +import SubHask.SubType +import SubHask.Internal.Prelude +import SubHask.TemplateHaskell.Deriving + +------------------------------------------------------------------------------- +-- non-negative objects + +newtype NonNegative t = NonNegative { unNonNegative :: t } + +deriveHierarchy ''NonNegative [ ''Enum, ''Boolean, ''Rig, ''Metric ] + +instance (Ord t, Group t) => Cancellative (NonNegative t) where + (NonNegative t1)-(NonNegative t2) = if diff>zero + then NonNegative diff + else NonNegative zero + where + diff=t1-t2 + +------------------- + +{- +newtype a +> b = HomHask { unHomHask :: a -> b } +infixr +> + +unsafeHomHask2 :: (a -> b -> c) -> (a +> b +> c) +unsafeHomHask2 f = HomHask (\a -> HomHask $ \b -> f a b) + +instance Category (+>) where + type ValidCategory (+>) a = () + id = HomHask id + (HomHask a).(HomHask b) = HomHask $ a.b + +instance Sup (+>) (->) (->) +instance Sup (->) (+>) (->) +instance (+>) <: (->) where + embedType_ = Embed2 unHomHask + +instance Monoidal (+>) where + type Tensor (+>) = (,) + tensor = unsafeHomHask2 $ \a b -> (a,b) + +instance Braided (+>) where + braid = HomHask $ \(a,b) -> (b,a) + unbraid = braid + +instance Closed (+>) where + curry (HomHask f) = HomHask $ \ a -> HomHask $ \b -> f (a,b) + uncurry (HomHask f) = HomHask $ \ (a,b) -> unHomHask (f a) b + +mkSubtype [t|Int|] [t|Integer|] 'toInteger + +[subhask| +poop :: (Semigroup' g, Ring g) => g +> g +poop = (+:1) +|] + +class Semigroup' a where + (+:) :: a +> a +> a + +instance Semigroup' Int where (+:) = unsafeHomHask2 (+) + +instance Semigroup' [a] where (+:) = unsafeHomHask2 (+) + +f :: Integer +> Integer +f = HomHask $ \i -> i+1 + +n1 = NonNegative 5 :: NonNegative Int +n2 = NonNegative 3 :: NonNegative Int +i1 = 5 :: Int +i2 = 3 :: Int +j1 = 5 :: Integer +j2 = 3 :: Integer +-} + +------------------------------------------------------------------------------- +-- integers modulo n + +-- | Maps members of an equivalence class into the "canonical" element. +class Quotient a (b::k) where + mkQuotient :: a -> a/b + +-- | The type of equivalence classes created by a mod b. +newtype (/) (a :: *) (b :: k) = Mod a + +-- mkDefaultMutable [t| forall a b. a/b |] + +-- newtype instance Mutable m (a/b) = Mutable_Mod (Mutable m a) + +instance (Quotient a b, Arbitrary a) => Arbitrary (a/b) where + arbitrary = liftM mkQuotient arbitrary + +deriveHierarchyFiltered ''(/) [ ''Eq_, ''P.Ord ] [''Arbitrary] + +instance (Semigroup a, Quotient a b) => Semigroup (a/b) where + (Mod z1) + (Mod z2) = mkQuotient $ z1 + z2 + +instance (Abelian a, Quotient a b) => Abelian (a/b) + +instance (Monoid a, Quotient a b) => Monoid (a/b) + where zero = Mod zero + +instance (Cancellative a, Quotient a b) => Cancellative (a/b) where + (Mod i1)-(Mod i2) = mkQuotient $ i1-i2 + +instance (Group a, Quotient a b) => Group (a/b) where + negate (Mod i) = mkQuotient $ negate i + +instance (Rg a, Quotient a b) => Rg (a/b) where + (Mod z1)*(Mod z2) = mkQuotient $ z1 * z2 + +instance (Rig a, Quotient a b) => Rig (a/b) where + one = Mod one + +instance (Ring a, Quotient a b) => Ring (a/b) where + fromInteger i = mkQuotient $ fromInteger i + +type instance ((a/b)> Module (a/b) where + (Mod a) .* r = mkQuotient $ a .* r + +-- | The type of integers modulo n +type Z (n::Nat) = Integer/n + +instance KnownNat n => Quotient Int n + where + mkQuotient i = Mod $ i `P.mod` (fromIntegral $ natVal (Proxy::Proxy n)) + +instance KnownNat n => Quotient Integer n + where + mkQuotient i = Mod $ i `P.mod` (natVal (Proxy::Proxy n)) + +-- | Extended Euclid's algorithm is used to calculate inverses in modular arithmetic +extendedEuclid :: (Eq t, Integral t) => t -> t -> (t,t,t,t,t,t) +extendedEuclid a b = go zero one one zero b a + where + go s1 s0 t1 t0 r1 r0 = if r1==zero + then (s1,s0,t1,t0,undefined,r0) + else go s1' s0' t1' t0' r1' r0' + where + q = r0 `div` r1 + (r0', r1') = (r1,r0-q*r1) + (s0', s1') = (s1,s0-q*s1) + (t0', t1') = (t1,t0-q*t1) + +------------------------------------------------------------------------------- +-- example: Galois field + +-- | @Galois p k@ is the type of integers modulo p^k, where p is prime. +-- All finite fields have this form. +-- +-- See wikipedia for more details. +-- +-- FIXME: Many arithmetic operations over Galois Fields can be implemented more efficiently than the standard operations. +-- See . +newtype Galois (p::Nat) (k::Nat) = Galois (Z (p^k)) + +type instance Galois p k >< Integer = Galois p k + +deriveHierarchy ''Galois [''Eq_,''Ring] + +instance KnownNat (p^k) => Module (Galois p k) where + z .* i = Galois (Mod i) * z + +instance (Prime p, KnownNat (p^k)) => Field (Galois p k) where + reciprocal (Galois (Mod i)) = Galois $ mkQuotient $ t + where + (_,_,_,t,_,_) = extendedEuclid n i + n = natVal (Proxy::Proxy (p^k)) + +------------------- + +class Prime (n::Nat) +instance Prime 1 +instance Prime 2 +instance Prime 3 +instance Prime 5 +instance Prime 7 +instance Prime 11 +instance Prime 13 +instance Prime 17 +instance Prime 19 +instance Prime 23 + +------------------------------------------------------------------------------- +-- the symmetric group + +-- | The symmetric group is one of the simplest and best studied finite groups. +-- It is efficiently implemented as a "BijectiveT SparseFunction (Z n) (Z n)". +-- See + +-- newtype Sym (n::Nat) = Sym (BijectiveT SparseFunction (Z n) (Z n)) +-- +-- instance KnownNat n => Monoid (Sym n) where +-- zero = Sym id +-- (Sym s1)+(Sym s2) = Sym $ s1.s2 +-- +-- instance KnownNat n => Group (Sym n) where +-- negate (Sym s) = Sym $ inverse s + +------------------------------------------------------------------------------- +-- | The GrothendieckGroup is a general way to construct groups from cancellative semigroups. +-- +-- FIXME: How should this be related to the Ratio type? +-- +-- See for more details. +data GrothendieckGroup g where + GrotheindieckGroup :: Cancellative g => g -> GrothendieckGroup g + +------------------------------------------------------------------------------- +-- the vedic square + +-- | The Vedic Square always forms a monoid, +-- and sometimes forms a group depending on the value of "n". +-- (The type system isn't powerful enough to encode these special cases.) +-- +-- See for more detail. +newtype VedicSquare (n::Nat) = VedicSquare (Z n) + +deriveHierarchy ''VedicSquare [''Eq_] + +instance KnownNat n => Semigroup (VedicSquare n) where + (VedicSquare v1)+(VedicSquare v2) = VedicSquare $ v1*v2 + +instance KnownNat n => Monoid (VedicSquare n) where + zero = VedicSquare one + +------------------------------------------------------------------------------ +-- Minkowski addition + +-- | TODO: implement +-- More details available at . + diff --git a/tests/examples/pre-ghc910/Guards.hs b/tests/examples/pre-ghc910/Guards.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Haddock.hs b/tests/examples/pre-ghc910/Haddock.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Haddock.hs @@ -0,0 +1,408 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-} +----------------------------------------------------------------------------- +-- | +-- Module : Test +-- Copyright : (c) Simon Marlow 2002 +-- License : BSD-style +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- This module illustrates & tests most of the features of Haddock. +-- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'. +-- +----------------------------------------------------------------------------- + +-- This is plain comment, ignored by Haddock. + +module Haddock ( + + -- Section headings are introduced with '-- *': + -- * Type declarations + + -- Subsection headings are introduced with '-- **' and so on. + -- ** Data types + T(..), T2, T3(..), T4(..), T5(..), T6(..), + N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..), + + -- ** Records + R(..), R1(..), + + -- | test that we can export record selectors on their own: + p, q, u, + + -- * Class declarations + C(a,b), D(..), E, F(..), + + -- | Test that we can export a class method on its own: + a, + + -- * Function types + f, g, + + -- * Auxiliary stuff + + -- $aux1 + + -- $aux2 + + -- $aux3 + + -- $aux4 + + -- $aux5 + + -- $aux6 + + -- $aux7 + + -- $aux8 + + -- $aux9 + + -- $aux10 + + -- $aux11 + + -- $aux12 + + -- | This is some inline documentation in the export list + -- + -- > a code block using bird-tracks + -- > each line must begin with > (which isn't significant unless it + -- > is at the beginning of the line). + + -- * A hidden module + module Hidden, + + -- * A visible module + module Visible, + + {-| nested-style doc comments -} + + -- * Existential \/ Universal types + Ex(..), + + -- * Type signatures with argument docs + k, l, m, o, + + -- * A section + -- and without an intervening comma: + -- ** A subsection + +{-| + > a literal line + + $ a non /literal/ line $ +-} + + f', + ) where + +import Hidden +import Visible + +-- | This comment applies to the /following/ declaration +-- and it continues until the next non-comment line +data T a b + = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor + | -- | This comment describes the 'B' constructor + B (T a b, T Int Float) -- ^ + +-- | An abstract data declaration +data T2 a b = T2 a b + +-- | A data declaration with no documentation annotations on the constructors +data T3 a b = A1 a | B1 b + +-- A data declaration with no documentation annotations at all +data T4 a b = A2 a | B2 b + +-- A data declaration documentation on the constructors only +data T5 a b + = A3 a -- ^ documents 'A3' + | B3 b -- ^ documents 'B3' + +-- | Testing alternative comment styles +data T6 + -- | This is the doc for 'A4' + = A4 + | B4 + | -- ^ This is the doc for 'B4' + + -- | This is the doc for 'C4' + C4 + +-- | A newtype +newtype N1 a = N1 a + +-- | A newtype with a fieldname +newtype N2 a b = N2 {n :: a b} + +-- | A newtype with a fieldname, documentation on the field +newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field + } + +-- | An abstract newtype - we show this one as data rather than newtype because +-- the difference isn\'t visible to the programmer for an abstract type. +newtype N4 a b = N4 a + +newtype N5 a b = N5 {n5 :: a b -- ^ no docs on the datatype or the constructor + } + +newtype N6 a b = N6 {n6 :: a b + } + -- ^ docs on the constructor only + +-- | docs on the newtype and the constructor +newtype N7 a b = N7 {n7 :: a b + } + -- ^ The 'N7' constructor + + +class (D a) => C a where + -- |this is a description of the 'a' method + a :: IO a + b :: [a] + -- ^ this is a description of the 'b' method + c :: a -- c is hidden in the export list + +-- ^ This comment applies to the /previous/ declaration (the 'C' class) + +class D a where + d :: T a b + e :: (a,a) +-- ^ This is a class declaration with no separate docs for the methods + +instance D Int where + d = undefined + e = undefined + +-- instance with a qualified class name +instance Test.D Float where + d = undefined + e = undefined + +class E a where + ee :: a +-- ^ This is a class declaration with no methods (or no methods exported) + +-- This is a class declaration with no documentation at all +class F a where + ff :: a + +-- | This is the documentation for the 'R' record, which has four fields, +-- 'p', 'q', 'r', and 's'. +data R = + -- | This is the 'C1' record constructor, with the following fields: + C1 { p :: Int -- ^ This comment applies to the 'p' field + , q :: forall a . a->a -- ^ This comment applies to the 'q' field + , -- | This comment applies to both 'r' and 's' + r,s :: Int + } + | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (), + u,v :: Int + } + -- ^ This is the 'C2' record constructor, also with some fields: + +-- | Testing different record commenting styles +data R1 + -- | This is the 'C3' record constructor + = C3 { + -- | The 's1' record selector + s1 :: Int + -- | The 's2' record selector + , s2 :: Int + , s3 :: Int -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here. + -- Since GHC doesn't allow that, I have removed it in this file. + -- ^ The 's3' record selector + } + +-- These section headers are only used when there is no export list to +-- give the structure of the documentation: + +-- * This is a section header (level 1) +-- ** This is a section header (level 2) +-- *** This is a section header (level 3) + +{-| +In a comment string we can refer to identifiers in scope with +single quotes like this: 'T', and we can refer to modules by +using double quotes: "Foo". We can add emphasis /like this/. + + * This is a bulleted list + + - This is the next item (different kind of bullet) + + (1) This is an ordered list + + 2. This is the next item (different kind of bullet) + +@ + This is a block of code, which can include other markup: 'R' + formatting + is + significant +@ + +> this is another block of code + +We can also include URLs in documentation: . +-} + +f :: C a => a -> Int + +-- | we can export foreign declarations too +foreign import ccall "header.h" g :: Int -> IO CInt + +-- | this doc string has a parse error in it: \' +h :: Int +h = 42 + + +-- $aux1 This is some documentation that is attached to a name ($aux1) +-- rather than a source declaration. The documentation may be +-- referred to in the export list using its name. +-- +-- @ code block in named doc @ + +-- $aux2 This is some documentation that is attached to a name ($aux2) + +-- $aux3 +-- @ code block on its own in named doc @ + +-- $aux4 +-- +-- @ code block on its own in named doc (after newline) @ + +{- $aux5 a nested, named doc comment + + with a paragraph, + + @ and a code block @ +-} + +-- some tests for various arrangements of code blocks: + +{- $aux6 +>test +>test1 + +@ test2 + test3 +@ +-} + +{- $aux7 +@ +test1 +test2 +@ +-} + +{- $aux8 +>test3 +>test4 +-} + +{- $aux9 +@ +test1 +test2 +@ + +>test3 +>test4 +-} + +{- $aux10 +>test3 +>test4 + +@ +test1 +test2 +@ +-} + +-- This one is currently wrong (Haddock 0.4). The @...@ part is +-- interpreted as part of the bird-tracked code block. +{- $aux11 +aux11: + +>test3 +>test4 + +@ +test1 +test2 +@ +-} + +-- $aux12 +-- > foo +-- +-- > bar +-- + +-- | A data-type using existential\/universal types +data Ex a + = forall b . C b => Ex1 b + | forall b . Ex2 b + | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file + | Ex4 (forall a . a -> a) + +-- | This is a function with documentation for each argument +k :: T () () -- ^ This argument has type 'T' + -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int' + -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@ + -> T5 () () -- ^ This argument has a very long description that should + -- hopefully cause some wrapping to happen when it is finally + -- rendered by Haddock in the generated HTML page. + -> IO () -- ^ This is the result type + +-- This function has arg docs but no docs for the function itself +l :: (Int, Int, Float) -- ^ takes a triple + -> Int -- ^ returns an 'Int' + +-- | This function has some arg docs +m :: R + -> N1 () -- ^ one of the arguments + -> IO Int -- ^ and the return value + +-- | This function has some arg docs but not a return value doc + +-- can't use the original name ('n') with GHC +newn :: R -- ^ one of the arguments, an 'R' + -> N1 () -- ^ one of the arguments + -> IO Int +newn = undefined + + +-- | A foreign import with argument docs +foreign import ccall unsafe "header.h" + o :: Float -- ^ The input float + -> IO Float -- ^ The output float + +-- | We should be able to escape this: \#\#\# + +-- p :: Int +-- can't use the above original definition with GHC +newp :: Int +newp = undefined + +-- | a function with a prime can be referred to as 'f'' +-- but f' doesn't get link'd 'f\'' +f' :: Int + + +-- Add some definitions here so that this file can be compiled with GHC + +data T1 +f = undefined +f' = undefined +type CInt = Int +k = undefined +l = undefined +m = undefined diff --git a/tests/examples/pre-ghc910/Haddock1.hs b/tests/examples/pre-ghc910/Haddock1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Haddock1.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-} +-- | Haddock comment, +-- coming before the module +module Haddock1 ( + + -- | This is some inline documentation in the export list + -- + -- > a code block using bird-tracks + -- > each line must begin with > (which isn't significant unless it + -- > is at the beginning of the line). + f + + {-| nested-style doc comments -} + , g + + -- * A section + -- and without an intervening comma: + -- ** A subsection + ) where + +-- | Haddock before imports +import Data.List + +-- | Haddock before decl +f = undefined +g = undefined + +-- | This comment applies to the /following/ declaration +-- and it continues until the next non-comment line +data T a b + = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor + | -- | This comment describes the 'B' constructor + B (T a b, T Int Float) -- ^ abcd + +-- | An abstract data declaration +data T2 a b = T2 a b diff --git a/tests/examples/pre-ghc910/Haddock2.hs b/tests/examples/pre-ghc910/Haddock2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Haddock2.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock -ddump-parsed -dkeep-comments #-} +module Haddock2 where + +data T + = B -- ^ abcd + +-- | An abstract data declaration +data T2 = T2 diff --git a/tests/examples/pre-ghc910/Haddock3.hs b/tests/examples/pre-ghc910/Haddock3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Haddock3.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-} +module Haddock3 ( + + f + + {-| nested-style doc comments -} + , g + + ) where + +f = undefined +g = undefined + diff --git a/tests/examples/pre-ghc910/HangingRecord.hs b/tests/examples/pre-ghc910/HangingRecord.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/HangingRecord.hs @@ -0,0 +1,5 @@ + +data Foo = Foo + { r1 :: Int + , r2 :: Int + } diff --git a/tests/examples/pre-ghc910/HashQQ.hs b/tests/examples/pre-ghc910/HashQQ.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/HashTab.hs b/tests/examples/pre-ghc910/HashTab.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/HashTab.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.HashTable +-- Copyright : (c) The University of Glasgow 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- An implementation of extensible hash tables, as described in +-- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988, +-- pp. 446--457. The implementation is also derived from the one +-- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@). +-- +----------------------------------------------------------------------------- + +module Data.HashTab ( + -- * Basic hash table operations + HashTable, new, insert, delete, lookup, update, + -- * Converting to and from lists + fromList, toList, + -- * Hash functions + -- $hash_functions + hashInt, hashString, + prime, + -- * Diagnostics + longestChain + ) where + +-- This module is imported by Data.Typeable, which is pretty low down in the +-- module hierarchy, so don't import "high-level" modules + +-- Right now we import high-level modules with gay abandon. +import Prelude hiding ( lookup ) +import Data.Tuple ( fst ) +import Data.Bits +import Data.Maybe +import Data.List ( maximumBy, partition, concat, foldl ) +import Data.Int ( Int32 ) + +import Data.Array.Base +import Data.Array hiding (bounds) +import Data.Array.IO + +import Data.Char ( ord ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Control.Monad ( mapM, sequence_ ) + + +----------------------------------------------------------------------- + +readHTArray :: HTArray a -> Int32 -> IO a +readMutArray :: MutArray a -> Int32 -> IO a +writeMutArray :: MutArray a -> Int32 -> a -> IO () +freezeArray :: MutArray a -> IO (HTArray a) +thawArray :: HTArray a -> IO (MutArray a) +newMutArray :: (Int32, Int32) -> a -> IO (MutArray a) +#if defined(DEBUG) || defined(__NHC__) +type MutArray a = IOArray Int32 a +type HTArray a = MutArray a +newMutArray = newArray +readHTArray = readArray +readMutArray = readArray +writeMutArray = writeArray +freezeArray = return +thawArray = return +#else +type MutArray a = IOArray Int32 a +type HTArray a = Array Int32 a +newMutArray = newArray +readHTArray arr i = return $! (unsafeAt arr (fromIntegral i)) +readMutArray arr i = unsafeRead arr (fromIntegral i) +writeMutArray arr i x = unsafeWrite arr (fromIntegral i) x +freezeArray = unsafeFreeze +thawArray = unsafeThaw +#endif + +newtype HashTable key val = HashTable (IORef (HT key val)) +-- TODO: the IORef should really be an MVar. + +data HT key val + = HT { + kcount :: !Int32, -- Total number of keys. + buckets :: !(HTArray [(key,val)]), + bmask :: !Int32, + hash_fn :: key -> Int32, + cmp :: key -> key -> Bool + } + +-- ----------------------------------------------------------------------------- +-- Sample hash functions + +-- $hash_functions +-- +-- This implementation of hash tables uses the low-order /n/ bits of the hash +-- value for a key, where /n/ varies as the hash table grows. A good hash +-- function therefore will give an even distribution regardless of /n/. +-- +-- If your keyspace is integrals such that the low-order bits between +-- keys are highly variable, then you could get away with using 'id' +-- as the hash function. +-- +-- We provide some sample hash functions for 'Int' and 'String' below. + +-- | A sample hash function for 'Int', implemented as simply @(x `mod` P)@ +-- where P is a suitable prime (currently 1500007). Should give +-- reasonable results for most distributions of 'Int' values, except +-- when the keys are all multiples of the prime! +-- +hashInt :: Int -> Int32 +hashInt = (`rem` prime) . fromIntegral + +-- | A sample hash function for 'String's. The implementation is: +-- +-- > hashString = fromIntegral . foldr f 0 +-- > where f c m = ord c + (m * 128) `rem` 1500007 +-- +-- which seems to give reasonable results. +-- +hashString :: String -> Int32 +hashString = fromIntegral . foldl f 0 + where f m c = ord c + (m * 128) `rem` fromIntegral prime + +-- | A prime larger than the maximum hash table size +prime :: Int32 +prime = 1500007 + +-- ----------------------------------------------------------------------------- +-- Parameters + +tABLE_MAX = 1024 * 1024 :: Int32 -- Maximum size of hash table +#if tABLE_MIN +#else +tABLE_MIN = 16 :: Int32 + +hLOAD = 4 :: Int32 -- Maximum average load of a single hash bucket + +hYSTERESIS = 0 :: Int32 -- entries to ignore in load computation +#endif + +{- Hysteresis favors long association-list-like behavior for small tables. -} + +-- ----------------------------------------------------------------------------- +-- Creating a new hash table + +-- | Creates a new hash table. The following property should hold for the @eq@ +-- and @hash@ functions passed to 'new': +-- +-- > eq A B => hash A == hash B +-- +new + :: (key -> key -> Bool) -- ^ @eq@: An equality comparison on keys + -> (key -> Int32) -- ^ @hash@: A hash function on keys + -> IO (HashTable key val) -- ^ Returns: an empty hash table + +new cmpr hash = do + -- make a new hash table with a single, empty, segment + let mask = tABLE_MIN-1 + bkts' <- newMutArray (0,mask) [] + bkts <- freezeArray bkts' + + let + kcnt = 0 + ht = HT { buckets=bkts, kcount=kcnt, bmask=mask, + hash_fn=hash, cmp=cmpr } + + table <- newIORef ht + return (HashTable table) + +-- ----------------------------------------------------------------------------- +-- Inserting a key\/value pair into the hash table + +-- | Inserts a key\/value mapping into the hash table. +-- +-- Note that 'insert' doesn't remove the old entry from the table - +-- the behaviour is like an association list, where 'lookup' returns +-- the most-recently-inserted mapping for a key in the table. The +-- reason for this is to keep 'insert' as efficient as possible. If +-- you need to update a mapping, then we provide 'update'. +-- +insert :: HashTable key val -> key -> val -> IO () + +insert (HashTable ref) key val = do + table@HT{ kcount=k, buckets=bkts, bmask=b } <- readIORef ref + let table1 = table{ kcount = k+1 } + indx = bucketIndex table key + bucket <- readHTArray bkts indx + bkts' <- thawArray bkts + writeMutArray bkts' indx ((key,val):bucket) + freezeArray bkts' + table2 <- + if tooBig k b + then expandHashTable table1 + else return table1 + writeIORef ref table2 + +tooBig :: Int32 -> Int32 -> Bool +tooBig k b = k-hYSTERESIS > hLOAD * b + +bucketIndex :: HT key val -> key -> Int32 +bucketIndex HT{ hash_fn=hash, bmask=mask } key = + let h = hash key + in (h .&. mask) + +expandHashTable :: HT key val -> IO (HT key val) +expandHashTable + table@HT{ buckets=bkts, bmask=mask } = do + let + oldsize = mask + 1 + newmask = mask + mask + 1 + newsize = newmask + 1 + -- + if newsize > tABLE_MAX + then return table + else do + -- + newbkts' <- newMutArray (0,newmask) [] + + let + table'=table{ bmask=newmask } + splitBucket oldindex = do + bucket <- readHTArray bkts oldindex + let (oldb,newb) = partition ((oldindex==).bucketIndex table' . fst) bucket + writeMutArray newbkts' oldindex oldb + writeMutArray newbkts' (oldindex + oldsize) newb + mapM_ splitBucket [0..mask] + + newbkts <- freezeArray newbkts' + + return ( table'{ buckets=newbkts } ) + +-- ----------------------------------------------------------------------------- +-- Deleting a mapping from the hash table + +-- Remove a key from a bucket +deleteBucket :: (key -> Bool) -> [(key,val)] -> (Int32, [(key, val)]) +deleteBucket _ [] = (0,[]) +deleteBucket del (pair@(k,_):bucket) = + case deleteBucket del bucket of + (dels, bucket') | del k -> dels' `seq` (dels', bucket') + | otherwise -> (dels, pair:bucket') + where dels' = dels + 1 + +-- | Remove an entry from the hash table. +delete :: HashTable key val -> key -> IO () + +delete (HashTable ref) key = do + table@HT{ buckets=bkts, kcount=kcnt, cmp=cmpr } <- readIORef ref + let indx = bucketIndex table key + bkts' <- thawArray bkts + bucket <- readMutArray bkts' indx + let (removed,bucket') = deleteBucket (cmpr key) bucket + writeMutArray bkts' indx bucket' + freezeArray bkts' + writeIORef ref ( table{kcount = kcnt - removed} ) + +-- ----------------------------------------------------------------------------- +-- Updating a mapping in the hash table + +-- | Updates an entry in the hash table, returning 'True' if there was +-- already an entry for this key, or 'False' otherwise. After 'update' +-- there will always be exactly one entry for the given key in the table. +-- +-- 'insert' is more efficient than 'update' if you don't care about +-- multiple entries, or you know for sure that multiple entries can't +-- occur. However, 'update' is more efficient than 'delete' followed +-- by 'insert'. +update :: HashTable key val -> key -> val -> IO Bool + +update (HashTable ref) key val = do + table@HT{ kcount=k, buckets=bkts, cmp=cmpr, bmask=b } <- readIORef ref + let indx = bucketIndex table key + bkts' <- thawArray bkts + bucket <- readMutArray bkts' indx + let (deleted,bucket') = deleteBucket (cmpr key) bucket + k' = k + 1 - deleted + table1 = table{ kcount=k' } + + writeMutArray bkts' indx ((key,val):bucket') + freezeArray bkts' + table2 <- + if tooBig k' b -- off by one from insert's resize heuristic. + then expandHashTable table1 + else return table1 + writeIORef ref table2 + return (deleted>0) + +-- ----------------------------------------------------------------------------- +-- Looking up an entry in the hash table + +-- | Looks up the value of a key in the hash table. +lookup :: HashTable key val -> key -> IO (Maybe val) + +lookup (HashTable ref) key = do + table@HT{ buckets=bkts, cmp=cmpr } <- readIORef ref + let indx = bucketIndex table key + bucket <- readHTArray bkts indx + case [ val | (key',val) <- bucket, cmpr key key' ] of + [] -> return Nothing + (v:_) -> return (Just v) + +-- ----------------------------------------------------------------------------- +-- Converting to/from lists + +-- | Convert a list of key\/value pairs into a hash table. Equality on keys +-- is taken from the Eq instance for the key type. +-- +fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val) +fromList hash list = do + table <- new (==) hash + sequence_ [ insert table k v | (k,v) <- list ] + return table + +-- | Converts a hash table to a list of key\/value pairs. +-- +toList :: (Ord key, Ord val) => HashTable key val -> IO [(key,val)] +toList (HashTable ref) = do + HT{ buckets=bkts, bmask=b } <- readIORef ref + fmap concat (mapM (readHTArray bkts) [0..b]) + +-- ----------------------------------------------------------------------------- +-- Diagnostics + +-- | This function is useful for determining whether your hash function +-- is working well for your data set. It returns the longest chain +-- of key\/value pairs in the hash table for which all the keys hash to +-- the same bucket. If this chain is particularly long (say, longer +-- than 10 elements), then it might be a good idea to try a different +-- hash function. +-- +longestChain :: HashTable key val -> IO [(key,val)] +longestChain (HashTable ref) = do + HT{ buckets=bkts, bmask=b } <- readIORef ref + let lengthCmp (_:x)(_:y) = lengthCmp x y + lengthCmp [] [] = EQ + lengthCmp [] _ = LT + lengthCmp _ [] = GT + fmap (maximumBy lengthCmp) (mapM (readHTArray bkts) [0..b]) + diff --git a/tests/examples/pre-ghc910/HsDo.hs b/tests/examples/pre-ghc910/HsDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/HsDocTy.hs b/tests/examples/pre-ghc910/HsDocTy.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/HsDocTy.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -haddock #-} +module HsDocTy where + +class C1 a where + f1 :: a -> Int + -- ^ comment on Int diff --git a/tests/examples/pre-ghc910/IPLocation.hs b/tests/examples/pre-ghc910/IPLocation.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/IfThenElse1.hs b/tests/examples/pre-ghc910/IfThenElse1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/IfThenElse2.hs b/tests/examples/pre-ghc910/IfThenElse2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/IfThenElse3.hs b/tests/examples/pre-ghc910/IfThenElse3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ImplicitParams.hs b/tests/examples/pre-ghc910/ImplicitParams.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ImplicitSemi.hs b/tests/examples/pre-ghc910/ImplicitSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ImplicitTypeSyn.hs b/tests/examples/pre-ghc910/ImplicitTypeSyn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Import.hs b/tests/examples/pre-ghc910/Import.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Import.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ImportQualifiedPost #-} +module Import where + +import safe A +import qualified B as B +import B qualified as B +import C hiding (a,b) +import D (x,y) +import Data.List as L ( intersperse ) +import "base" Prelude hiding (String) diff --git a/tests/examples/pre-ghc910/Imports.hs b/tests/examples/pre-ghc910/Imports.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ImportsSemi.hs b/tests/examples/pre-ghc910/ImportsSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ImportsSemi.hs @@ -0,0 +1,6 @@ +module ImportsSemi where +{ +; ; ; ; ; ; +import Data.List +;;; +} diff --git a/tests/examples/pre-ghc910/Improvement.hs b/tests/examples/pre-ghc910/Improvement.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/IndentedComments.hs b/tests/examples/pre-ghc910/IndentedComments.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/IndentedComments.hs @@ -0,0 +1,12 @@ +module IndentedComments where + +-- | 'ls_get strsMany n' ls_get strs 'n' elements in order, without blowing the stack. +ls_getMany strs n = go [] n + where + go xs 0 = return $! reverse xs + go xs i = do x <- ls_get strs + -- indented comment + x `seq` go (x:xs) (i-1) + +-- compat newtype for deserialization of v2-v4 CaptureData +newtype IntLen a = IntLen { fromIntLen :: a } diff --git a/tests/examples/pre-ghc910/IndentedDo.hs b/tests/examples/pre-ghc910/IndentedDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/IndentedModule2.hs b/tests/examples/pre-ghc910/IndentedModule2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/IndentedModule2.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} +{- -} module Main where +main = putStr "foo" + diff --git a/tests/examples/pre-ghc910/Infix.hs b/tests/examples/pre-ghc910/Infix.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Infix.hs @@ -0,0 +1,8 @@ + +infix 3 &&& + +(&&&) :: (Eq a) => [a] -> [a] -> [a] +(&&& ) [] [] = [] +xs &&& [] = xs +( &&&) [] ys = ys + diff --git a/tests/examples/pre-ghc910/InfixPatternSynonyms.hs b/tests/examples/pre-ghc910/InfixPatternSynonyms.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/InlineSemi.hs b/tests/examples/pre-ghc910/InlineSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/InlineSemi.hs @@ -0,0 +1,1 @@ +{-# INLINE (|.) #-}; (|.)::Storable a=>Ptr a -> Int -> IO a ; (|.) a i = peekElemOff a i diff --git a/tests/examples/pre-ghc910/Internal.hs b/tests/examples/pre-ghc910/Internal.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Internal.hs @@ -0,0 +1,342 @@ +{-# language GADTs, RankNTypes #-} +{-# language FlexibleContexts, DefaultSignatures #-} +{-# language TypeOperators #-} +{-# language LambdaCase #-} +{-# language EmptyCase #-} +module Hedgehog.Function.Internal where + +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Data.Bifunctor (first) +import Data.Functor.Contravariant (Contravariant(..)) +import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable(..)) +import Data.Functor.Identity (Identity(..)) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Maybe (fromJust) +import Data.Void (Void, absurd) +import Data.Word (Word8, Word64) +import Hedgehog.Internal.Gen (GenT(..), Gen, runGenT) +import Hedgehog.Internal.Seed (Seed(..)) +import Hedgehog.Internal.Tree (Tree(..), Node(..)) +import Hedgehog.Internal.Property (PropertyT, forAll) + +import GHC.Generics + +import qualified Hedgehog.Internal.Tree as Tree + +infixr 5 :-> + +-- | Shrinkable, showable functions +-- +-- Claessen, K. (2012, September). Shrinking and showing functions:(functional pearl). +-- In ACM SIGPLAN Notices (Vol. 47, No. 12, pp. 73-80). ACM. +data a :-> c where + Unit :: c -> () :-> c + Nil :: a :-> c + Pair :: a :-> b :-> c -> (a, b) :-> c + Sum :: a :-> c -> b :-> c -> Either a b :-> c + Map :: (a -> b) -> (b -> a) -> b :-> c -> a :-> c + +instance Functor ((:->) r) where + fmap f (Unit c) = Unit $ f c + fmap _ Nil = Nil + fmap f (Pair a) = Pair $ fmap (fmap f) a + fmap f (Sum a b) = Sum (fmap f a) (fmap f b) + fmap f (Map a b c) = Map a b (fmap f c) + +-- | Tabulate the function +table :: a :-> c -> [(a, c)] +table (Unit c) = [((), c)] +table Nil = [] +table (Pair f) = do + (a, bc) <- table f + (b, c) <- table bc + pure ((a, b), c) +table (Sum a b) = + [(Left x, c) | (x, c) <- table a] ++ + [(Right x, c) | (x, c) <- table b] +table (Map _ g a) = first g <$> table a + +class GArg a where + gbuild' :: (a x -> c) -> a x :-> c + +-- | Reify a function whose domain has an instance of 'Generic' +gbuild :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c +gbuild = gvia from to + +-- | @instance Arg A where@ allows functions which take @A@s to be reified +class Arg a where + build :: (a -> c) -> a :-> c + default build :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c + build = gbuild + +variant :: Word64 -> GenT m b -> GenT m b +variant n (GenT f) = GenT $ \sz sd -> f sz (sd { seedValue = seedValue sd + n}) + +variant' :: Word64 -> CoGenT m b -> CoGenT m b +variant' n (CoGenT f) = + CoGenT $ \a -> variant n . f a + +class GVary a where + gvary' :: CoGenT m (a x) + +instance GVary V1 where + gvary' = conquer + +instance GVary U1 where + gvary' = conquer + +instance (GVary a, GVary b) => GVary (a :+: b) where + gvary' = + choose + (\case; L1 a -> Left a; R1 a -> Right a) + (variant' 0 gvary') + (variant' 1 gvary') + +instance (GVary a, GVary b) => GVary (a :*: b) where + gvary' = + divide + (\(a :*: b) -> (a, b)) + (variant' 0 gvary') + (variant' 1 gvary') + +instance GVary c => GVary (M1 a b c) where + gvary' = contramap unM1 gvary' + +instance Vary b => GVary (K1 a b) where + gvary' = contramap unK1 vary + +-- | Build a co-generator for a type which has a 'Generic' instance +gvary :: (Generic a, GVary (Rep a)) => CoGenT m a +gvary = CoGenT $ \a -> applyCoGenT gvary' (from a) + +-- | 'Vary' provides a canonical co-generator for a type. +-- +-- While technically there are many possible co-generators for a given type, we don't get any +-- benefit from caring. +class Vary a where + vary :: CoGenT m a + default vary :: (Generic a, GVary (Rep a)) => CoGenT m a + vary = gvary + +-- | Build a co-generator for an 'Integral' type +varyIntegral :: Integral a => CoGenT m a +varyIntegral = CoGenT $ variant . fromIntegral + +-- | +-- A @'CoGenT' m a@ is used to perturb a @'GenT' m b@ based on the value of the @a@. This way, +-- the generated function will have a varying (but still deterministic) right hand side. +-- +-- Co-generators can be built using 'Divisible' and 'Decidable', but it is recommended to +-- derive 'Generic' and use the default instance of the 'Vary' type class. +-- +-- @'CoGenT' m ~ 'Data.Functor.Contravariabe.Op' ('Data.Monoid.Endo' ('GenT' m b))@ +newtype CoGenT m a = CoGenT { applyCoGenT :: forall b. a -> GenT m b -> GenT m b } +type CoGen = CoGenT Identity + +instance Contravariant (CoGenT m) where + contramap f (CoGenT g) = CoGenT (g . f) + +instance Divisible (CoGenT m) where + divide f (CoGenT gb) (CoGenT gc) = + CoGenT $ \a -> + let (b, c) = f a in gc c . gb b + conquer = CoGenT $ const id + +instance Decidable (CoGenT m) where + choose f (CoGenT gb) (CoGenT gc) = + CoGenT $ \a -> + case f a of + Left b -> gb b . variant 0 + Right c -> gc c . variant 1 + lose f = CoGenT $ \a -> absurd (f a) + +instance (Show a, Show b) => Show (a :-> b) where + show = show . table + +-- | Evaluate a possibly partial function +apply' :: a :-> b -> a -> Maybe b +apply' (Unit c) () = Just c +apply' Nil _ = Nothing +apply' (Pair f) (a, b) = do + f' <- apply' f a + apply' f' b +apply' (Sum f _) (Left a) = apply' f a +apply' (Sum _ g) (Right a) = apply' g a +apply' (Map f _ g) a = apply' g (f a) + +-- | Evaluate a total function. Unsafe. +unsafeApply :: a :-> b -> a -> b +unsafeApply f = fromJust . apply' f + +-- | The type of randomly-generated functions +data Fn a b = Fn b (a :-> Tree (MaybeT Identity) b) + +-- | Extract the root value from a 'Tree'. Unsafe. +unsafeFromTree :: Functor m => Tree (MaybeT m) a -> m a +unsafeFromTree = + fmap (maybe (error "empty generator in function") nodeValue) . + runMaybeT . + runTree + +instance (Show a, Show b) => Show (Fn a b) where + show (Fn b a) = + case table a of + [] -> "_ -> " ++ show b + ta -> showTable ta ++ "_ -> " ++ show b + where + showTable :: (Show a, Show b) => [(a, Tree (MaybeT Identity) b)] -> String + showTable [] = "\n" + showTable (x : xs) = unlines (showCase <$> x : xs) + where + showCase (lhs, rhs) = show lhs ++ " -> " ++ show (runIdentity $ unsafeFromTree rhs) + +-- | Shrink the function +shrinkFn :: (b -> [b]) -> a :-> b -> [a :-> b] +shrinkFn shr (Unit a) = Unit <$> shr a +shrinkFn _ Nil = [] +shrinkFn shr (Pair f) = + (\case; Nil -> Nil; a -> Pair a) <$> shrinkFn (shrinkFn shr) f +shrinkFn shr (Sum a b) = + fmap (\case; Sum Nil Nil -> Nil; x -> x) $ + [ Sum a Nil | notNil b ] ++ + [ Sum Nil b | notNil a ] ++ + fmap (`Sum` b) (shrinkFn shr a) ++ + fmap (a `Sum`) (shrinkFn shr b) + where + notNil Nil = False + notNil _ = True +shrinkFn shr (Map f g a) = (\case; Nil -> Nil; x -> Map f g x) <$> shrinkFn shr a + +shrinkTree :: Monad m => Tree (MaybeT m) a -> m [Tree (MaybeT m) a] +shrinkTree (Tree m) = do + a <- runMaybeT m + case a of + Nothing -> pure [] + Just (Node _ cs) -> pure cs + +-- | Evaluate an 'Fn' +apply :: Fn a b -> a -> b +apply (Fn b f) = maybe b (runIdentity . unsafeFromTree) . apply' f + +-- | Generate a function using the user-supplied co-generator +fnWith :: Arg a => CoGen a -> Gen b -> Gen (Fn a b) +fnWith cg gb = + Fn <$> + gb <*> + genFn (\a -> applyCoGenT cg a gb) + where + genFn :: Arg a => (a -> Gen b) -> Gen (a :-> Tree (MaybeT Identity) b) + genFn g = + GenT $ \sz sd -> + Tree.unfold (shrinkFn $ runIdentity . shrinkTree) . + fmap (runGenT sz sd) $ build g + +-- | Generate a function +fn :: (Arg a, Vary a) => Gen b -> Gen (Fn a b) +fn = fnWith vary + +-- | Run the function generator to retrieve a function +forAllFn :: (Show a, Show b, Monad m) => Gen (Fn a b) -> PropertyT m (a -> b) +forAllFn = fmap apply . forAll + +instance Vary () +instance (Vary a, Vary b) => Vary (Either a b) +instance (Vary a, Vary b) => Vary (a, b) +instance Vary Void +instance Vary Bool +instance Vary Ordering +instance Vary a => Vary (Maybe a) +instance Vary a => Vary [a] +instance Vary Int8 where; vary = varyIntegral +instance Vary Int16 where; vary = varyIntegral +instance Vary Int32 where; vary = varyIntegral +instance Vary Int64 where; vary = varyIntegral +instance Vary Int where; vary = varyIntegral +instance Vary Integer where; vary = varyIntegral +instance Vary Word8 where; vary = varyIntegral + +-- | Reify a function via an isomorphism. +-- +-- If your function's domain has no instance of 'Generic' then you can still reify it using +-- an isomorphism to a better domain type. For example, the 'Arg' instance for 'Integral' +-- uses an isomorphism from @Integral a => a@ to @(Bool, [Bool])@, where the first element +-- is the sign, and the second element is the bit-string. +-- +-- Note: @via f g@ will only be well-behaved if @g . f = id@ and @f . g = id@ +via :: Arg b => (a -> b) -> (b -> a) -> (a -> c) -> a :-> c +via a b f = Map a b . build $ f . b + +instance Arg Void where + build _ = Nil + +instance Arg () where + build f = Unit $ f () + +instance (Arg a, Arg b) => Arg (a, b) where + build f = Pair . build $ \a -> build $ \b -> f (a, b) + +instance (Arg a, Arg b) => Arg (Either a b) where + build f = Sum (build $ f . Left) (build $ f . Right) + +gvia :: GArg b => (a -> b x) -> (b x -> a) -> (a -> c) -> a :-> c +gvia a b f = Map a b . gbuild' $ f . b + +instance GArg V1 where + gbuild' _ = Nil + +instance GArg U1 where + gbuild' f = Map (\U1 -> ()) (\() -> U1) (Unit $ f U1) + +instance (GArg a, GArg b) => GArg (a :*: b) where + gbuild' f = Map fromPair toPair $ Pair . gbuild' $ \a -> gbuild' $ \b -> f (a :*: b) + where + fromPair (a :*: b) = (a, b) + toPair (a, b) = (a :*: b) + +instance (GArg a, GArg b) => GArg (a :+: b) where + gbuild' f = Map fromSum toSum $ Sum (gbuild' $ f . L1) (gbuild' $ f . R1) + where + fromSum = \case; L1 a -> Left a; R1 a -> Right a + toSum = either L1 R1 + +instance GArg c => GArg (M1 a b c) where + gbuild' = gvia unM1 M1 + +instance Arg b => GArg (K1 a b) where + gbuild' f = Map unK1 K1 . build $ f . K1 + +-- | Reify a function on 'Integral's +buildIntegral :: (Arg a, Integral a) => (a -> c) -> (a :-> c) +buildIntegral = via toBits fromBits + where + toBits :: Integral a => a -> (Bool, [Bool]) + toBits n + | n >= 0 = (True, go n) + | otherwise = (False, go $ -n - 1) + where + go 0 = [] + go m = + let + (q, r) = quotRem m 2 + in + (r == 1) : go q + + fromBits :: Integral a => (Bool, [Bool]) -> a + fromBits (pos, bts) + | pos = go bts + | otherwise = negate $ go bts + 1 + where + go [] = 0 + go (x:xs) = (if x then 1 else 0) + 2 * go xs + +instance Arg Bool +instance Arg Ordering +instance Arg a => Arg (Maybe a) +instance Arg a => Arg [a] +instance Arg Int8 where; build = buildIntegral +instance Arg Int16 where; build = buildIntegral +instance Arg Int32 where; build = buildIntegral +instance Arg Int64 where; build = buildIntegral +instance Arg Int where; build = buildIntegral +instance Arg Integer where; build = buildIntegral + diff --git a/tests/examples/pre-ghc910/Internals.hs b/tests/examples/pre-ghc910/Internals.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Issue91.hs b/tests/examples/pre-ghc910/Issue91.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Issue91.hs @@ -0,0 +1,8 @@ +module Issue91 where + +-- Based on https://github.com/alanz/ghc-exactprint/issues/91 + +foo = case hi of + _ -> hi + _ -> hi + _ -> hi diff --git a/tests/examples/pre-ghc910/Jon.hs b/tests/examples/pre-ghc910/Jon.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/KindEqualities.hs b/tests/examples/pre-ghc910/KindEqualities.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/KindEqualities.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE PolyKinds, GADTs, ExplicitForAll #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module KindEqualities where + +data TyRep1 :: * -> * where + TyInt1 :: TyRep1 Int + TyBool1 :: TyRep1 Bool + +zero1 :: forall a. TyRep1 a -> a +zero1 TyInt1 = 0 +zero1 TyBool1 = False + +data Proxy (a :: k) = P + +data TyRep :: k -> * where + TyInt :: TyRep Int + TyBool :: TyRep Bool + TyMaybe :: TyRep Maybe + TyApp :: TyRep a -> TyRep b -> TyRep (a b) + +zero :: forall (a :: *). TyRep a -> a +zero TyInt = 0 +zero TyBool = False +zero (TyApp TyMaybe _) = Nothing diff --git a/tests/examples/pre-ghc910/KindEqualities2.hs b/tests/examples/pre-ghc910/KindEqualities2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/KindEqualities2.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll, + TemplateHaskell, UndecidableInstances, ScopedTypeVariables, + TypeInType #-} + +module KindEqualities2 where + +import Data.Kind +import GHC.Exts ( Any ) + +data Kind = Star | Arr Kind Kind + +data Ty :: Kind -> Type where + TInt :: Ty Star + TBool :: Ty Star + TMaybe :: Ty (Arr Star Star) + TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2 + + +data TyRep (k :: Kind) (t :: Ty k) where + TyInt :: TyRep Star TInt + TyBool :: TyRep Star TBool + TyMaybe :: TyRep (Arr Star Star) TMaybe + TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b) + +type family IK (k :: Kind) +type instance IK Star = Type +type instance IK (Arr k1 k2) = IK k1 -> IK k2 + +$(return []) -- necessary because the following instances depend on the + -- previous ones. + +type family I (t :: Ty k) :: IK k +type instance I TInt = Int +type instance I TBool = Bool +type instance I TMaybe = Maybe +type instance I (TApp a b) = (I a) (I b) + +zero :: forall (a :: Ty 'Star). TyRep Star a -> I a +zero TyInt = 0 +zero TyBool = False +zero (TyApp TyMaybe TyInt) = Nothing + +main = print $ zero (TyApp TyMaybe TyInt) diff --git a/tests/examples/pre-ghc910/KindLevels.hs b/tests/examples/pre-ghc910/KindLevels.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/KindLevels.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, PolyKinds #-} + +module KindLevels where + +data A +data B :: A -> * +data C :: B a -> * +data D :: C b -> * +data E :: D c -> * diff --git a/tests/examples/pre-ghc910/LambdaCase.hs b/tests/examples/pre-ghc910/LambdaCase.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/LayoutLet.hs b/tests/examples/pre-ghc910/LayoutLet.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LayoutLet.hs @@ -0,0 +1,7 @@ + +foo x = + let + a = 1 + b = 2 + in x + a + b + diff --git a/tests/examples/pre-ghc910/LayoutWhere.hs b/tests/examples/pre-ghc910/LayoutWhere.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LayoutWhere.hs @@ -0,0 +1,6 @@ + +foo x = r + where + a = 3 + b = 4 + r = a + a + b diff --git a/tests/examples/pre-ghc910/LetExpr.hs b/tests/examples/pre-ghc910/LetExpr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/LetExpr2.hs b/tests/examples/pre-ghc910/LetExpr2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LetExpr2.hs @@ -0,0 +1,4 @@ +l z = + let + ll = 34 + in ll + z diff --git a/tests/examples/pre-ghc910/LetExprSemi.hs b/tests/examples/pre-ghc910/LetExprSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/LetIn.hs b/tests/examples/pre-ghc910/LetIn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LetIn.hs @@ -0,0 +1,4 @@ + +ff = let + x = 1 + in 4 diff --git a/tests/examples/pre-ghc910/LetStmt.hs b/tests/examples/pre-ghc910/LetStmt.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/LexerM2.hs b/tests/examples/pre-ghc910/LexerM2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LexerM2.hs @@ -0,0 +1,215 @@ +---------------------------------------------------------------------------- +-- | +-- Module : FastTags.LexerM +-- Copyright : (c) Sergey Vinokurov 2019 +-- +-- All the types and functions needed to make lexer run: +-- - 'AlexInput' - primary workhorse, an optimized representation of input +-- stream as a pointer to utf8 bytes and our position within it. +-- - Lexer monad 'AlexM' - a monad (self-explanatory) with state that describes +-- current lexing context. +-- - 'AlexState' - state of the lexing monad, maintains current Alex code, +-- comment depth, quasiquoter depth, indentation size, whether we're in +-- a literate mode (and in which one) or vanilla mode and whether there +-- are any TH quasiquotes present till the end of file. +-- +-- All the functions are to do with +---------------------------------------------------------------------------- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} + +module FastTags.LexerM + ( AlexState(..) + , mkAlexState + , alexEnterBirdLiterateEnv + , alexEnterLiterateLatexEnv + , alexExitLiterateEnv + , pushContext + , modifyCommentDepth + , modifyQuasiquoterDepth + , modifyPreprocessorDepth + , addIndentationSize + , checkQuasiQuoteEndPresent + + , AlexM + , runAlexM + , alexSetInput + , alexSetNextCode + + , AlexInput(..) + , aiLineL + , takeText + , countInputSpace + , extractDefineOrLetName + , dropUntilNL + , dropUntilUnescapedNL + , dropUntilNLOr + , dropUntilNLOrEither + , unsafeTextHeadAscii + , unsafeTextHeadOfTailAscii + , unsafeTextHead + , utf8BS + + , asCodeL + , asCommentDepthL + , asQuasiquoterDepthL + , asIndentationSizeL + , asPreprocessorDepthL + , asLiterateLocL + , asHaveQQEndL + + -- * Alex interface + , alexInputPrevChar + , alexGetByte + ) where + +import Control.Applicative as A +import Control.DeepSeq +import Control.Exception +import Control.Monad.ST +import Control.Monad.State.Strict +import Control.Monad.Writer.Strict + +import Data.Char +import Data.Int +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Void (Void, vacuous) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Internal as BSI +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as UM + +import Foreign.ForeignPtr +import Foreign.Ptr +import GHC.Base +import GHC.Ptr +import GHC.Word +import Text.Printf + +import FastTags.LensBlaze +import FastTags.LexerTypes +import FastTags.Token + +import GHC.Exts (word8ToWord#, wordToWord8#) + + +data AlexState = AlexState + { asInput :: {-# UNPACK #-} !AlexInput + , asIntStore :: {-# UNPACK #-} !Word64 + -- ^ Integer field that stores all the other useful fields for lexing. + , asContextStack :: [Context] + } deriving (Show, Eq, Ord) + + +checkQuasiQuoteEndPresent :: Ptr Word8 -> Bool +checkQuasiQuoteEndPresent + = (\x -> isTrue# (qqessPresent x)) + . utf8Foldl' combine (QQEndsState 0# '\n'#) + where + combine :: QQEndsState -> Char# -> QQEndsState + combine QQEndsState{qqessPresent, qqessPrevChar} c# = QQEndsState + { qqessPresent = + qqessPresent `orI#` + case (# qqessPrevChar, c# #) of + (# '|'#, ']'# #) -> 1# + (# _, '⟧'# #) -> 1# + _ -> 0# + , qqessPrevChar = c# + } + +countInputSpace :: AlexInput -> Int -> Int +countInputSpace AlexInput{aiPtr} len = + utf8FoldlBounded len inc 0 aiPtr + where + inc !acc ' '# = acc + 1 + inc !acc '\t'# = acc + 8 + inc !acc c# = case fixChar c# of + 1## -> acc + 1 + _ -> acc + +-- Translate unicode character into special symbol we teached Alex to recognize. +{-# INLINE fixChar #-} +fixChar :: Char# -> Word# +fixChar = \case + -- These should not be translated since Alex knows about them + '→'# -> reservedSym + '∷'# -> reservedSym + '⇒'# -> reservedSym + '∀'# -> reservedSym + '⦇'# -> reservedSym + '⦈'# -> reservedSym + '⟦'# -> reservedSym + '⟧'# -> reservedSym + '\x00'# -> fullStop + '\x01'# -> fullStop + '\x02'# -> fullStop + '\x03'# -> fullStop + '\x04'# -> fullStop + '\x05'# -> fullStop + '\x06'# -> fullStop + '\x07'# -> fullStop + '\x08'# -> other + c# -> case ord# c# of + c2# | isTrue# (c2# <=# 0x7f#) -> + int2Word# c2# -- Plain ascii needs no fixing. + | otherwise -> + case generalCategory (C# c#) of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> suffix + OtherLetter -> lower + NonSpacingMark -> suffix + DecimalNumber -> digit + OtherNumber -> digit + Space -> space + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + + SpacingCombiningMark -> space + EnclosingMark -> other + LetterNumber -> symbol + OpenPunctuation -> symbol + ClosePunctuation -> symbol + InitialQuote -> symbol + FinalQuote -> symbol + LineSeparator -> space + ParagraphSeparator -> space + Control -> other + Format -> other + Surrogate -> other + PrivateUse -> other + NotAssigned -> other + where + fullStop, space, upper, lower, symbol :: Word# + digit, suffix, reservedSym, other :: Word# + fullStop = 0x00## -- Don't care about these + space = 0x01## + upper = 0x02## + lower = 0x03## + symbol = 0x04## + digit = 0x05## + suffix = 0x06## + reservedSym = 0x07## + other = 0x08## + diff --git a/tests/examples/pre-ghc910/Lib.1.hs b/tests/examples/pre-ghc910/Lib.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Lib.1.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE UnboxedSums, MagicHash #-} + +module Lib (flip, getInt) where + +import GHC.Exts +import Prelude (Int) + +{-# NOINLINE flip #-} +flip :: (# Int | Int# #) -> (# Int# | Int #) +flip (# i | #) = (# | i #) +flip (# | i #) = (# i | #) + +{-# NOINLINE getInt #-} +getInt :: (# Int# | Int #) -> Int +getInt (# i | #) = I# i +getInt (# | i #) = i + diff --git a/tests/examples/pre-ghc910/Lib.hs b/tests/examples/pre-ghc910/Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Lib.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds, TypeData #-} +module T22315a.Lib where + +data TermLevel = Mk +type data TypeLevel = Mk + +class C (a :: TypeLevel) +instance C Mk where + +foo :: C a => proxy a -> () +foo _ = () + diff --git a/tests/examples/pre-ghc910/LiftedConstructors.hs b/tests/examples/pre-ghc910/LiftedConstructors.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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 :: [Type] -> Type 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/pre-ghc910/LiftedInfixConstructor.hs b/tests/examples/pre-ghc910/LiftedInfixConstructor.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/LinePragma.hs b/tests/examples/pre-ghc910/LinePragma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/LinePragmas.hs b/tests/examples/pre-ghc910/LinePragmas.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LinePragmas.hs @@ -0,0 +1,7 @@ +module LinePragmas where + +x = 1 +-- Comment 1 +{-# LINE 93 "Foo.chs" #-} +-- Comment 2 +y = 2 diff --git a/tests/examples/pre-ghc910/Linear.hs b/tests/examples/pre-ghc910/Linear.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Linear.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LinearTypes #-} +module Monad.Linear where + +import Prelude(Int, (+)) + +data T where T :: Int -> T +data TM a = TM a + +class Monad m where + return :: a #-> m a + (>>=) :: m a #-> (a #-> m b) #-> m b + +(>>) :: Monad m => m () #-> m b #-> m b +m1 >> m2 = m1 >>= \() -> m2 + +instance Monad TM where + return = TM + TM a >>= f = f a + +data Unrestricted a where + Unrestricted :: a -> Unrestricted a + +runTM :: TM (Unrestricted a) -> a +runTM (TM (Unrestricted a)) = a + +newT :: TM T +newT = return (T 0) + +increaseT :: T #-> TM T +increaseT (T i) = return (T (i+1)) + +extractT :: T #-> TM (T, Unrestricted Int) +extractT (T i) = return (T i, Unrestricted i) + +deleteT :: T #-> TM () +deleteT (T _) = return () + diff --git a/tests/examples/pre-ghc910/Linear10.hs b/tests/examples/pre-ghc910/Linear10.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Linear10.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE GADTs #-} +module Linear10 where + +data Unrestricted a where Unrestricted :: a -> Unrestricted a + +unrestrictedDup :: Unrestricted a ⊸ (a, a) +unrestrictedDup (Unrestricted a) = (a,a) + diff --git a/tests/examples/pre-ghc910/Linear12.hs b/tests/examples/pre-ghc910/Linear12.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Linear12.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE GADTs #-} +module Linear12 where + +type N a = a ⊸ () + +consume :: a ⊸ N a ⊸ () +consume x k = k x + +data N' a where N :: N a ⊸ N' a + +data M' a where M :: M a -> M' a + +consume' :: a ⊸ N' a ⊸ () +consume' x (N k) = k x + +data W = W (W ⊸ ()) + +wPlusTwo :: W ⊸ W +wPlusTwo n = W (\(W k) -> k n) + +data Nat = S Nat + +natPlusOne :: Nat ⊸ Nat +natPlusOne n = S n + +data D = D () + +mkD :: () ⊸ D +mkD x = D x + +data Odd = E Even +data Even = O Odd + +evenPlusOne :: Even ⊸ Odd +evenPlusOne e = E e + diff --git a/tests/examples/pre-ghc910/Linear14.hs b/tests/examples/pre-ghc910/Linear14.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Linear14.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear14 where + +-- Inference-related behaviour. Slightly sub-optimal still. + +bind1 :: (d ⊸ (a ⊸ b) ⊸ c) ⊸ d ⊸ (a⊸b) ⊸ c +bind1 b x f = b x (\a -> f a) + +newtype I a = I a + +bind2 :: (d ⊸ (a ⊸ b) ⊸ c) ⊸ d ⊸ (I a⊸b) ⊸ c +bind2 b x f = b x (\a -> f (I a)) + +bind3 :: (d ⊸ I (a ⊸ b) ⊸ c) ⊸ d ⊸ (a⊸b) ⊸ c +bind3 b x f = b x (I (\a -> f a)) + +bind4 :: (d ⊸ I ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c +bind4 b x f = b x (I (\g -> f g)) + +bind5 :: (d ⊸ ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c +bind5 b x f = b x (\g -> f (\a -> g a)) + +bind6 :: (d ⊸ I ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c +bind6 b x f = b x (I (\g -> f (\a -> g a))) + diff --git a/tests/examples/pre-ghc910/Linear15.hs b/tests/examples/pre-ghc910/Linear15.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Linear15.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear15 where + +correctWhere :: Int ⊸ Int +correctWhere a = g a + where + f :: Int ⊸ Int + f x = x + + g :: Int ⊸ Int + g x = f x + diff --git a/tests/examples/pre-ghc910/Linear16.hs b/tests/examples/pre-ghc910/Linear16.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Linear16.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE RebindableSyntax #-} +module Linear16 where + +-- Rebindable do notation + +(>>=) :: a ⊸ (a ⊸ b) ⊸ b +(>>=) x f = f x + +-- `fail` is needed due to pattern matching on (); +-- ideally, it shouldn't be there. +fail :: a +fail = fail + +correctDo = do + x <- () + (y,z) <- ((),x) + () <- y + () <- z + () + diff --git a/tests/examples/pre-ghc910/Linear1Rule.hs b/tests/examples/pre-ghc910/Linear1Rule.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Linear1Rule.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +module Linear1Rule where + +-- Test the 1 <= p rule +f :: a %1 -> b +f = f + +-- f1 :: a %001 -> b +-- f1 = f1 + +g :: a %p -> b +g x = f x + diff --git a/tests/examples/pre-ghc910/Linear3.hs b/tests/examples/pre-ghc910/Linear3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Linear3.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear3 where + +correctApp1 :: (a⊸b) ⊸ a ⊸ b +correctApp1 f a = f a + +correctApp2 :: (a⊸a) -> a ⊸ a +correctApp2 f a = f (f a) + +correctApp3 :: Int ⊸ Int +correctApp3 x = f x + where + f :: Int ⊸ Int + f y = y + +correctApp4 :: Int ⊸ Int +correctApp4 x = f (f x) + where + f :: Int ⊸ Int + f y = y + +correctIf :: Bool ⊸ a ⊸ a +correctIf x n = + if x then n else n + diff --git a/tests/examples/pre-ghc910/Linear4.hs b/tests/examples/pre-ghc910/Linear4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Linear4.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LambdaCase, GADTs #-} +module Linear4 where + +correctCase :: Bool ⊸ a ⊸ a +correctCase x n = + case x of + True -> n + False -> n + diff --git a/tests/examples/pre-ghc910/Linear6.hs b/tests/examples/pre-ghc910/Linear6.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Linear6.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear6 where + +correctEqn :: Bool ⊸ Int ⊸ Int +correctEqn True n = n +correctEqn False n = n + diff --git a/tests/examples/pre-ghc910/Linear8.hs b/tests/examples/pre-ghc910/Linear8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Linear8.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LambdaCase #-} +module Linear8 where + +correctLCase :: Int ⊸ Bool -> Int +correctLCase n = \case + True -> n + False -> n + diff --git a/tests/examples/pre-ghc910/LinearArrow.hs b/tests/examples/pre-ghc910/LinearArrow.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LinearArrow.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LinearTypes, DataKinds, UnicodeSyntax #-} + +module LinearArrow where + +import GHC.Types (Multiplicity(One, Many)) + +n1 :: a %1 -> b +n1 = undefined + +u1 :: a %1 → b +u1 = undefined + +n2 :: a %(Many) -> b +n2 = undefined + +u2 :: a %(Many) → b +u2 = undefined + +m3 :: a ⊸ b +m3 = undefined + +n4 :: a %p -> b +n4 = undefined + +u4 :: a %p → b +u4 = undefined diff --git a/tests/examples/pre-ghc910/LinearConstructors.hs b/tests/examples/pre-ghc910/LinearConstructors.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LinearConstructors.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE TupleSections #-} +module LinearConstructors where + +data T a b = MkT a b + +f1 :: a %1 -> b %1 -> T a b +f1 = MkT + +f2 :: a %1 -> b -> T a b +f2 = MkT + +f3 :: a -> b %1 -> T a b +f3 = MkT + +f4 :: a -> b -> T a b +f4 = MkT + +-- tuple sections +g1 :: a %1 -> b %1 -> (a, b, Int) +g1 = (,,0) + +g2 :: a %1 -> b -> (a, b, Int) +g2 = (,,0) + +g3 :: a -> b %1 -> (a, b, Int) +g3 = (,,0) + +g4 :: a -> b -> (a, b, Int) +g4 = (,,0) + diff --git a/tests/examples/pre-ghc910/LinearEmptyCase.hs b/tests/examples/pre-ghc910/LinearEmptyCase.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LinearEmptyCase.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE EmptyCase, LinearTypes #-} + +module LinearEmptyCase where + +data Void + +f :: a %1 -> Void -> b +f x y = case y of {} + diff --git a/tests/examples/pre-ghc910/LinearGuards.hs b/tests/examples/pre-ghc910/LinearGuards.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LinearGuards.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE LinearTypes #-} +module LinearGuards where + +f :: Bool -> a %1 -> a +f b a | b = a + | True = a + diff --git a/tests/examples/pre-ghc910/LinearTH1.hs b/tests/examples/pre-ghc910/LinearTH1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LinearTH1.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LinearTypes, TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module LinearTH1 where + +x1 = [t|Int -> Int|] diff --git a/tests/examples/pre-ghc910/LinearTH2.hs b/tests/examples/pre-ghc910/LinearTH2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LinearTH2.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE LinearTypes, TemplateHaskell, RankNTypes, NoMonomorphismRestriction #-} +module LinearTH2 where + +x1 = [t|forall p. Int %p -> Int|] diff --git a/tests/examples/pre-ghc910/LinearTypeable.hs b/tests/examples/pre-ghc910/LinearTypeable.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LinearTypeable.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LinearTypes, TypeOperators #-} +module Main (main) where + +import Data.Typeable +import Data.Maybe + +x :: Maybe ((Int -> Int) :~: (Int #-> Int)) +x = eqT + +main = print (isJust x) + diff --git a/tests/examples/pre-ghc910/List2.hs b/tests/examples/pre-ghc910/List2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/List2.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE GADTs #-} +----------------------------------------------------------------------------- +-- | +-- Module : Type.Family.List +-- Copyright : Copyright (C) 2015 Kyle Carter +-- License : BSD3 +-- +-- Maintainer : Kyle Carter +-- Stability : experimental +-- Portability : RankNTypes +-- +-- Convenient aliases and type families for working with +-- type-level lists. +---------------------------------------------------------------------------- + +module Type.Family.List where + +import Type.Family.Constraint +import Type.Family.Monoid +import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>)) +import Type.Class.Witness + +type Ø = '[] +type (:<) = '(:) +infixr 5 :< + diff --git a/tests/examples/pre-ghc910/ListComments.hs b/tests/examples/pre-ghc910/ListComments.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ListComments.hs @@ -0,0 +1,5 @@ +module ListComments where + +foo :: Int -- nonterm + -> IO Int +foo = undefined diff --git a/tests/examples/pre-ghc910/ListComprehensions.1.hs b/tests/examples/pre-ghc910/ListComprehensions.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ListComprehensions.1.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/pre-ghc910/ListComprehensions.hs b/tests/examples/pre-ghc910/ListComprehensions.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/LiteralsTest2.hs b/tests/examples/pre-ghc910/LiteralsTest2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LiteralsTest2.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE MagicHash #-} +module LiteralsTest2 where + +x,y :: Int +x = 0003 +y = 0x04 + +s :: String +s = "\x20" + +c :: Char +c = '\x20' + +d :: Double +d = 0.00 + +blah = x + where + charH = '\x41'# + intH = 0004# + wordH = 005## + floatH = 3.20# + doubleH = 04.16## + x = 1 diff --git a/tests/examples/pre-ghc910/LocalDecls2Expected.hs b/tests/examples/pre-ghc910/LocalDecls2Expected.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/LocalDecls2Expected.hs @@ -0,0 +1,6 @@ +module LocalDecls2Expected where + +foo a = bar a + where + nn :: Int + nn = 2 diff --git a/tests/examples/pre-ghc910/MachineTypes.hs b/tests/examples/pre-ghc910/MachineTypes.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MachineTypes.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE Trustworthy #-} -- Safe if eliminate GeneralizedNewtypeInstance +{-# LANGUAGE Arrows #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module + Control.Arrow.Machine.Types +where + +import qualified Control.Category as Cat +import Data.Profunctor (Profunctor, dimap, rmap) +import Control.Arrow +import Control.Monad +import Control.Monad.Trans +import Control.Monad.State +import Control.Monad.Reader +import Control.Monad.Writer hiding ((<>)) +import Control.Monad.Identity +import Control.Applicative +import Data.Foldable as Fd +import Data.Traversable as Tv +import Data.Semigroup (Semigroup, (<>)) +import Data.Maybe (fromMaybe, isNothing, isJust) +import qualified Control.Monad.Trans.Free as F +import qualified Control.Monad.Trans.Free.Church as F +import Control.Arrow.Machine.ArrowUtil +import GHC.Exts (build) + + +-- | To get multiple outputs by one input, the `Phase` parameter is introduced. +-- +-- Once a value `Feed`ed, the machine is `Sweep`ed until it `Suspend`s. +data Phase = Feed | Sweep | Suspend deriving (Eq, Show) + +instance + Monoid Phase + where + mempty = Sweep + + mappend Feed _ = Feed + mappend _ Feed = Feed + mappend Suspend _ = Suspend + mappend _ Suspend = Suspend + mappend Sweep Sweep = Sweep + + +type ProcType a b c = ProcessA a b c + +-- | The stream transducer arrow. +-- +-- To construct `ProcessA` instances, use `Control.Arrow.Machine.Plan.Plan`, +-- `arr`, functions declared in `Control.Arrow.Machine.Utils`, +-- or arrow combinations of them. +-- +-- See an introduction at "Control.Arrow.Machine" documentation. +data ProcessA a b c = ProcessA { + feed :: a b (c, ProcessA a b c), + sweep :: a b (Maybe c, ProcessA a b c), + suspend :: !(b -> c) + } + + +-- For internal use +class + (Applicative f, Monad f) => ProcessHelper f + where + step :: ArrowApply a => ProcessA a b c -> a b (f c, ProcessA a b c) + helperToMaybe :: f a -> Maybe a + weakly :: a -> f a + + step' :: ArrowApply a => ProcessA a b c -> a (f b) (f c, ProcessA a b c) + step' pa = proc hx -> + do + let mx = helperToMaybe hx + maybe + (arr $ const (suspend pa <$> hx, pa)) + (\x -> proc _ -> step pa -< x) + mx + -<< () + diff --git a/tests/examples/pre-ghc910/MagicHash.hs b/tests/examples/pre-ghc910/MagicHash.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Main.1.hs b/tests/examples/pre-ghc910/Main.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Main.1.hs @@ -0,0 +1,14 @@ +-- Copyright (C) 2015, Luke Iannini + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main where +import Printf ( pr ) + +foreign import ccall "talkToCxx" talkToCxx :: IO () + +main :: IO () +main = do + putStrLn ( $(pr "Hello From Template Haskell!") ) + talkToCxx diff --git a/tests/examples/pre-ghc910/Main.2.hs b/tests/examples/pre-ghc910/Main.2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Main.2.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, StandaloneDeriving, TypeFamilies, GADTs + , ViewPatterns, TypeOperators, TypeApplications, StandaloneDeriving + , UnicodeSyntax, PatternSynonyms, FlexibleContexts, DataKinds, UndecidableInstances + , TypeFamilyDependencies #-} + +-- invoke as: ghci Main.hs -ddump-parsed -ddump-rn +-- or in GHCi: :set -ddump-parsed -ddump-rn + +import TyFamWitnesses +import Language.Haskell.TH hiding (Type) +import Data.Type.Equality hiding (apply) +import Type.Reflection +import Unsafe.Coerce (unsafeCoerce) +import Data.Char (ord) +import GHC.TypeLits + + +stuffhave = [d| type family Foo a b where + Foo a a = Int + Foo (IO a) a = Float + Foo (IO a) b = Bool + Foo a Char = String + Foo a b = Char |] + +stuffhave1 = [d| type family Bar a where Bar Bool = Bool; Bar a = IO a |] + +stuffhave2 = [d| type family Elim a b where Elim a (a -> b) = b; Elim a (c -> b) = c -> Elim a b |] + + +witnesses [d| type family Foo a b where + Foo a a = Int + Foo (IO a) a = Float + Foo (IO a) b = Bool + Foo a Char = String + Foo a b = Char |] + +deriving instance Show (FooRefl a b) + +-- now you can: +-- +-- >>> :info FooRefl +-- type role FooRefl nominal nominal +-- data FooRefl a b where +-- Foo0 :: (Foo a a ~ Int) => FooRefl a a +-- Foo1 :: (Foo (IO b) b ~ Float) => FooRefl (IO b) b +-- Foo2 :: (Foo (IO a1) b ~ Bool) => FooRefl (IO a1) b +-- Foo3 :: (Foo a Char ~ String) => FooRefl a Char +-- Foo4 :: (Foo a b ~ Char) => FooRefl a b +-- -- Defined at Main.hs:13:1 +-- instance Show (FooRefl a b) -- Defined at Main.hs:14:1 +-- +-- >>> :info reify_Foo +-- reify_Foo :: TypeRep a -> TypeRep b -> Maybe (FooRefl a b) +-- -- Defined at Main.hs:13:1 +-- +-- >>> reify_Foo (typeOf getChar) (typeRep @Char) +-- Just Foo1 +-- + +witnesses [d| type family Bar a where Bar Bool = Bool; Bar a = IO a |] +deriving instance Show (BarRefl a) + +witnesses [d| type family Elim a b where Elim a (a -> b) = b; Elim a (c -> b) = c -> Elim a b |] +deriving instance Show (ElimRefl a b) + +pure [] + +stuffwant2 = [d| + fooRefl :: forall a b . TypeRep a -> TypeRep b -> Maybe (FooRefl a b) + fooRefl a b | Just HRefl <- eqTypeRep a b = pure Foo0 + fooRefl a b | Refl <- unsafeCoerce Refl :: Foo a b :~: Char = pure Foo1 + |] + +stuffhave3 = [d| data Peano = Z | S Peano + type family ToPeano (n :: Nat) :: Peano where ToPeano 0 = Z; ToPeano n = S (ToPeano (n-1)) + type family FromPeano (p :: Peano) :: Nat where FromPeano Z = 0; FromPeano (S n) = 1 + FromPeano n + |] + + +witnesses [d| data Peano = Z | S Peano + type family ToPeano (n :: Nat) :: Peano where ToPeano 0 = Z; ToPeano n = S (ToPeano (n-1)) + type family FromPeano (p :: Peano) :: Nat where FromPeano Z = 0; FromPeano (S n) = 1 + FromPeano n + |] + + +deriving instance Show (ToPeanoRefl n) +deriving instance Show (FromPeanoRefl p) + +witnesses [d| type family Unspell (w :: Symbol) = (r :: Nat) | r -> w where + Unspell "zero" = 0 + Unspell "one" = 1 + Unspell "two" = 2 + Unspell "three" = 3 + |] +deriving instance Show (UnspellRefl w) + +main = runQ (witnesses stuffhave2) >>= print + +test@Just{} = reify_Elim (typeRep @Integer) (typeOf ((+1)::Integer->Integer)) + +lemma :: v -> TypeRep f -> TypeRep v + -> Maybe (TypeRep (v `Elim` f), f -> v `Elim` f) +lemma w f v = do d `Fun'` c <- pure f + witness <- v `reify_Elim` f + case witness of + Elim0 -> pure (c, ($ w)) + Elim1 -> do (e, g) <- lemma w c v + pure (d `Fun` e, (g.)) + +data Tag = Source | Destination | CheckSource Bool | CheckDest Bool | Cut Bool + +newtype TaggedAction (t :: Tag) = Tagged (IO ()) + +data Action where + Action :: Typeable t ⇒ TaggedAction t → Action + Catalyst :: Typeable (c → d) ⇒ (c → d) → Action + +pattern A :: forall k a. () => forall b. (TaggedAction b ~~ a) => TypeRep b → TypeRep a +pattern A b ← (eqTypeRep (typeRep @TaggedAction) → Just HRefl) `App` b + + +reaction :: Action → Action → Maybe Action +reaction (Catalyst f) (Action v) = do (rep, f') ← lemma v (typeOf f) (typeOf v) + pure $ case rep of + _ `Fun'` _ → withTypeable rep (Catalyst $ f' f) + A indx → withTypeable indx (Action $ f' f) + + +member :: Eq a => a -> [a] -> Bool +member = elem + +y $$ x = ($ y).($ x) + +--Just (t3r, (($ elem) -> t3)) = lemma 'j' (typeOf $ member @Char) (typeOf 'j') -- https://ghc.haskell.org/trac/ghc/ticket/14293 +Just (t3r, (($ "joe").($ elem) -> t3@True)) = lemma 'j' (typeOf $ member @Char) (typeOf 'j') +Just (t4r, (($ 'o').($ elem) -> t4@True)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe") +-- Just (t4'r, ('x' $$ elem -> t4'@False)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe") -- Same bug +Just (t4'r, (($ 'x').($ elem) -> t4'@False)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe") + +t0@Nothing = lemma "joe" (typeOf ord) (typeOf "joe") + + +Just u0 = reify_FromPeano (typeRep @Z) +Just u1 = reify_FromPeano (typeRep @(S Z)) +Just u2 = reify_FromPeano (typeRep @(S (S Z))) + +Just un0 = reify_Unspell (typeRep @"zero") +Just un1 = reify_Unspell (typeRep @"one") +Just un2 = reify_Unspell (typeRep @"two") + diff --git a/tests/examples/pre-ghc910/Main.hs b/tests/examples/pre-ghc910/Main.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Main.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedLabels, FlexibleContexts, OverloadedStrings, RecursiveDo, TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +module Main where + + +main :: IO () +main = do + Gtk.applicationNew (Just "de.weltraumschlangen.reflex-test") [] + >>= maybe + (die "Failed to initialize GTK") + ( \application -> do + ret <- runReflexGtk application (Just argv) $ do + runGtk $ do + #add mainWindow + #packStart outerBox + + ) + + + -- #add mainWindow + -- #packStart outerBox diff --git a/tests/examples/pre-ghc910/MangledSemiLet.hs b/tests/examples/pre-ghc910/MangledSemiLet.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Manipulate.hs b/tests/examples/pre-ghc910/Manipulate.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Manipulate.hs @@ -0,0 +1,39 @@ +{- | +Module : Control.Comonad.Sheet.Manipulate +Description : Generic functions for manipulating multi-dimensional comonadic spreadsheets. +Copyright : Copyright (c) 2014 Kenneth Foner + +Maintainer : kenneth.foner@gmail.com +Stability : experimental +Portability : non-portable + +This module defines the 'take', 'view', 'go', and 'insert' functions generically for any dimensionality of sheet. These +constitute the preferred way of manipulating sheets, providing an interface to: take finite slices ('take'), infinite +slices ('view'), move to locations ('go'), and insert finite or infinite structures ('insert'). +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Control.Comonad.Sheet.Manipulate where + + +-- | In the case of a @Nested@ structure, @asDimensionalAs@ defaults to @asNestedAs@. +instance (NestedAs x (Nested ts y), AsDimensionalAs x (Nested ts y) ~ AsNestedAs x (Nested ts y)) => DimensionalAs x (Nested ts y) where + type x `AsDimensionalAs` (Nested ts a) = x `AsNestedAs` (Nested ts a) + asDimensionalAs = asNestedAs + +-- | @DimensionalAs@ also knows the dimensionality of an 'Indexed' sheet as well as regular @Nested@ structures. +instance (NestedAs x (Nested ts y)) => DimensionalAs x (Indexed ts y) where + type x `AsDimensionalAs` (Indexed ts a) = x `AsNestedAs` (Nested ts a) + x `asDimensionalAs` (Indexed i t) = x `asNestedAs` t + + +instance DepIndex (a,b) TH_0 where + type (a,b) `DepIndexResult` TH_0 = a + (a,b) # TH_0 = a diff --git a/tests/examples/pre-ghc910/Match.hs b/tests/examples/pre-ghc910/Match.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Match.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK hide #-} + +-- Discriminate binary functions that commute, and if so return the operands in +-- a stable ordering such that matching recognises expressions modulo +-- commutativity. +-- +commutes + :: forall acc env aenv a r. + HashAcc acc + -> PrimFun (a -> r) + -> PreOpenExp acc env aenv a + -> Maybe (PreOpenExp acc env aenv a) +commutes h f x = case f of + PrimAdd _ -> Just (swizzle x) + PrimMul _ -> Just (swizzle x) + PrimBAnd _ -> Just (swizzle x) + PrimBOr _ -> Just (swizzle x) + PrimBXor _ -> Just (swizzle x) + PrimEq _ -> Just (swizzle x) + PrimNEq _ -> Just (swizzle x) + PrimMax _ -> Just (swizzle x) + PrimMin _ -> Just (swizzle x) + PrimLAnd -> Just (swizzle x) + PrimLOr -> Just (swizzle x) + _ -> Nothing + where + swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a') + swizzle exp + | Tuple (NilTup `SnocTup` a `SnocTup` b) <- exp + , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a) + -- + | otherwise = exp diff --git a/tests/examples/pre-ghc910/MatchSemis.hs b/tests/examples/pre-ghc910/MatchSemis.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MatchSemis.hs @@ -0,0 +1,5 @@ +module MatchSemis where +{ +a 0 = 1; +a _ = 2; +} diff --git a/tests/examples/pre-ghc910/Memoize.hs b/tests/examples/pre-ghc910/Memoize.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Memoize.hs @@ -0,0 +1,23 @@ +module Feldspar.Memoize where + +import qualified Prelude + +import Feldspar + +-- | Accelerate the function @f@ using a lookup table. +-- The table will span all possible input values. +tabulate :: (Bits i, Integral i, Syntax a) + => (Data i -> a) -> Data i -> a +tabulate f i = tabulateLen (2 ^ bitSize i) f i + +-- | Accelerate the function @f@ by creating a lookup table of the results for the +-- @len@ first argument values +-- +-- Note. To really get a table the function must be closed after the +-- application to @i@ +-- +tabulateLen :: (Integral i, Syntax a) + => Data Length -> (Data i -> a) -> Data i -> a +-- tabulateLen len f i = sugar $ share (parallel len (desugar.f.i2n)) (!i2n i) +tabulateLen len f i = sugar $ share (parallel len (desugar.f.i2n)) (! i2n i) + diff --git a/tests/examples/pre-ghc910/Minimal.hs b/tests/examples/pre-ghc910/Minimal.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Mixed.hs b/tests/examples/pre-ghc910/Mixed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Mixed.hs @@ -0,0 +1,50 @@ + +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 + , Integer -> Integer #-} +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 + {-# Specialise instance Num (Int,Int) #-} + 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/pre-ghc910/ModuleComments.hs b/tests/examples/pre-ghc910/ModuleComments.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ModuleComments.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +x = 1 diff --git a/tests/examples/pre-ghc910/ModuleComments1.hs b/tests/examples/pre-ghc910/ModuleComments1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ModuleComments1.hs @@ -0,0 +1,13 @@ +-- top of module +module {- c1 -} ModuleComments1 {- c2 -} + -- c3 + ( + -- c4 + foo + -- c5 + ) {- c6 -} where {- c7 -} +-- c8 + +foo = x + +-- eof diff --git a/tests/examples/pre-ghc910/ModuleComments2.hs b/tests/examples/pre-ghc910/ModuleComments2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ModuleComments2.hs @@ -0,0 +1,15 @@ +-- top of module +module {- c1 -} ModuleComments1 {- c2 -} + -- c3 + ( + -- c4 + foo + -- c5 + ) {- c6 -} where {- c7 -} +-- c8 +import Data.Text +-- c9 + +foo = x + +-- eof diff --git a/tests/examples/pre-ghc910/ModuleComments3.hs b/tests/examples/pre-ghc910/ModuleComments3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ModuleComments3.hs @@ -0,0 +1,25 @@ +-- top of module +module {- c1 -} ModuleComments1 {- c2 -} + -- c3 + ( + -- c4 + foo + -- c5 + ) {- c6 -} where {- c7 -} +{ +-- c8 +; +-- c9 + +-- c10 +import Data.Text +-- c11 +; + +-- c12 +foo = x +-- c13 +; +-- c14 +} +-- eof diff --git a/tests/examples/pre-ghc910/ModuleOnly.hs b/tests/examples/pre-ghc910/ModuleOnly.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ModuleOnly.hs @@ -0,0 +1,1 @@ +module ModuleOnly where diff --git a/tests/examples/pre-ghc910/MonadComprehensions.hs b/tests/examples/pre-ghc910/MonadComprehensions.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/MonadFailErrors.hs b/tests/examples/pre-ghc910/MonadFailErrors.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MonadFailErrors.hs @@ -0,0 +1,95 @@ +-- Test purpose: +-- Break properly if MonadFail is live + +{- # LANGUAGE MonadFailDesugaring # -} + +module MonadFailWarnings where + +import Control.Monad.Fail +import Control.Monad.ST +import Data.Functor.Identity + + + +general :: Monad m => m a +general = do + Just x <- undefined + undefined + + + +general' :: MonadFail m => m a +general' = do + Just x <- undefined + undefined + + + +identity :: Identity a +identity = do + Just x <- undefined + undefined + + + +io :: IO a +io = do + Just x <- undefined + undefined + + + +st :: ST s a +st = do + Just x <- undefined + undefined + + + +reader :: r -> a +reader = do + Just x <- undefined + undefined + + + +newtype Newtype a = Newtype a +newtypeMatch :: Identity a +newtypeMatch = do + Newtype x <- undefined + undefined + + + +data Data a = Data a +singleConMatch :: Identity a +singleConMatch = do + Data x <- undefined + undefined + + + +data Maybe' a = Nothing' | Just' a +instance Functor Maybe' where fmap = undefined +instance Applicative Maybe' where pure = undefined; (<*>) = undefined +instance Monad Maybe' where (>>=) = undefined +instance MonadFail Maybe' where fail = undefined +customFailable :: Maybe' a +customFailable = do + Just x <- undefined + undefined + + +wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a +wildcardx = do + x <- undefined + undefined +explicitlyIrrefutable = do + ~(x:y) <- undefined + undefined +wildcard_ = do + _ <- undefined + undefined +tuple = do + (a,b) <- undefined + undefined diff --git a/tests/examples/pre-ghc910/MonadFailWarnings.hs b/tests/examples/pre-ghc910/MonadFailWarnings.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MonadFailWarnings.hs @@ -0,0 +1,107 @@ +-- Test purpose: +-- Ensure that MonadFail warnings are issued correctly if the warning flag +-- is enabled + +{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-} + +module MonadFailWarnings where + +import Control.Monad.Fail +import Control.Monad.ST +import Data.Functor.Identity + + + +-- should warn, because the do-block gets a general Monad constraint, +-- but should have MonadFail +general :: Monad m => m a +general = do + Just x <- undefined + undefined + + + +-- should NOT warn, because the constraint is correct +general' :: MonadFail m => m a +general' = do + Just x <- undefined + undefined + + + +-- should warn, because Identity isn't MonadFail +identity :: Identity a +identity = do + Just x <- undefined + undefined + + + +-- should NOT warn, because IO is MonadFail +io :: IO a +io = do + Just x <- undefined + undefined + + + +-- should warn, because (ST s) is not MonadFail +st :: ST s a +st = do + Just x <- undefined + undefined + + + +-- should warn, because (r ->) is not MonadFail +reader :: r -> a +reader = do + Just x <- undefined + undefined + + + +-- should NOT warn, because matching against newtype +newtype Newtype a = Newtype a +newtypeMatch :: Identity a +newtypeMatch = do + Newtype x <- undefined + undefined + + + +-- should NOT warn, because Data has only one constructor +data Data a = Data a +singleConMatch :: Identity a +singleConMatch = do + Data x <- undefined + undefined + + + +-- should NOT warn, because Maybe' has a MonadFail instance +data Maybe' a = Nothing' | Just' a +instance Functor Maybe' where fmap = undefined +instance Applicative Maybe' where pure = undefined; (<*>) = undefined +instance Monad Maybe' where (>>=) = undefined +instance MonadFail Maybe' where fail = undefined +customFailable :: Maybe' a +customFailable = do + Just x <- undefined + undefined + + +-- should NOT warn, because patterns always match +wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a +wildcardx = do + x <- undefined + undefined +explicitlyIrrefutable = do + ~(x:y) <- undefined + undefined +wildcard_ = do + _ <- undefined + undefined +tuple = do + (a,b) <- undefined + undefined diff --git a/tests/examples/pre-ghc910/MonadFailWarningsDisabled.hs b/tests/examples/pre-ghc910/MonadFailWarningsDisabled.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MonadFailWarningsDisabled.hs @@ -0,0 +1,94 @@ +-- Test purpose: +-- Make sure that not enabling MonadFail warnings makes code compile just +-- as it did in < 8.0 + +module MonadFailWarnings where + +import Control.Monad.Fail +import Control.Monad.ST +import Data.Functor.Identity + + + +general :: Monad m => m a +general = do + Just x <- undefined + undefined + + + +general' :: MonadFail m => m a +general' = do + Just x <- undefined + undefined + + + +identity :: Identity a +identity = do + Just x <- undefined + undefined + + + +io :: IO a +io = do + Just x <- undefined + undefined + + + +st :: ST s a +st = do + Just x <- undefined + undefined + + + +reader :: r -> a +reader = do + Just x <- undefined + undefined + + + +newtype Newtype a = Newtype a +newtypeMatch :: Identity a +newtypeMatch = do + Newtype x <- undefined + undefined + + + +data Data a = Data a +singleConMatch :: Identity a +singleConMatch = do + Data x <- undefined + undefined + + + +data Maybe' a = Nothing' | Just' a +instance Functor Maybe' where fmap = undefined +instance Applicative Maybe' where pure = undefined; (<*>) = undefined +instance Monad Maybe' where (>>=) = undefined +instance MonadFail Maybe' where fail = undefined +customFailable :: Maybe' a +customFailable = do + Just x <- undefined + undefined + + +wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a +wildcardx = do + x <- undefined + undefined +explicitlyIrrefutable = do + ~(x:y) <- undefined + undefined +wildcard_ = do + _ <- undefined + undefined +tuple = do + (a,b) <- undefined + undefined diff --git a/tests/examples/pre-ghc910/MonadFailWarningsWithRebindableSyntax.hs b/tests/examples/pre-ghc910/MonadFailWarningsWithRebindableSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MonadFailWarningsWithRebindableSyntax.hs @@ -0,0 +1,14 @@ +-- Test purpose: +-- RebindableSyntax does not play that well with MonadFail, so here we ensure +-- that when both settings are enabled we get the proper warning. + +{-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-} +{-# LANGUAGE RebindableSyntax #-} + +module MonadFailWarningsWithRebindableSyntax where + +import Prelude + +test1 f g = do + Just x <- f + g diff --git a/tests/examples/pre-ghc910/MonadT.hs b/tests/examples/pre-ghc910/MonadT.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MonadT.hs @@ -0,0 +1,48 @@ +{-# OPTIONS -XRank2Types #-} + +module Control.Monatron.MonadT ( + MonadT(..), FMonadT(..), MMonadT(..), FComp(..), FunctorD(..), tmap, mtmap, + module Control.Monad +) where + +import Control.Monad + + +---------------------------------------------------------- +-- Class of monad transformers with +-- a lifting of first-order operations +---------------------------------------------------------- + +class MonadT t where + lift :: Monad m => m a -> t m a + treturn :: Monad m => a -> t m a + treturn = lift. return + tbind :: Monad m => t m a -> (a -> t m b) -> t m b + +newtype FunctorD f = FunctorD {fmapD :: forall a b . (a -> b) -> f a -> f b} + +functor :: Functor f => FunctorD f +functor = FunctorD fmap + +class MonadT t => FMonadT t where + tmap' :: FunctorD m -> FunctorD n -> (a -> b) -> (forall x. m x -> n x) -> t m a -> t n b + +tmap :: (FMonadT t, Functor m, Functor n) => (forall b. m b -> n b) -> t m a -> t n a +tmap = tmap' functor functor id + +mtmap :: FMonadT t => FunctorD f -> (a -> b) -> t f a -> t f b +mtmap fd f = tmap' fd fd f id + +class FMonadT t => MMonadT t where + flift :: Functor f => f a -> t f a --should coincide with lift! + monoidalT :: (Functor f, Functor g) => t f (t g a) -> t (FComp f g) a + +---------------------------------------- +-- Functor Composition +---------------------------------------- + +newtype (FComp f g) a = Comp {deComp :: (f (g a)) } + +instance (Functor f, Functor g) => Functor (FComp f g) where + fmap f (Comp fga) = Comp (fmap (fmap f) fga) + diff --git a/tests/examples/pre-ghc910/MonoidsFD.hs b/tests/examples/pre-ghc910/MonoidsFD.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MonoidsFD.hs @@ -0,0 +1,112 @@ +-- From a blog post: http://www.jonmsterling.com/posts/2012-01-12-unifying-monoids-and-monads-with-polymorphic-kinds.html + +-------------------- FUNCTIONAL DEPENDENCY VERSION ---------------- + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE UnicodeSyntax #-} + +module Main where +import Control.Monad (Monad(..), join, ap) +import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) + +-- First we define the type class Monoidy: + +class Monoidy to comp id m | m to → comp id where + munit :: id `to` m + mjoin :: (m `comp` m) `to` m + +-- We use functional dependencies to help the typechecker understand that +-- m and ~> uniquely determine comp (times) and id. +-- +-- This kind of type class would not have been possible in previous +-- versions of GHC; with the new kind system, however, we can abstract +-- over kinds!2 Now, let’s create types for the additive and +-- multiplicative monoids over the natural numbers: + +newtype Sum a = Sum a deriving Show +newtype Product a = Product a deriving Show +instance Num a ⇒ Monoidy (→) (,) () (Sum a) where + munit _ = Sum 0 + mjoin (Sum x, Sum y) = Sum $ x + y +instance Num a ⇒ Monoidy (→) (,) () (Product a) where + munit _ = Product 1 + mjoin (Product x, Product y) = Product $ x * y + +-- It will be slightly more complicated to make a monadic instance with +-- Monoidy. First, we need to define the identity functor, a type for +-- natural transformations, and a type for functor composition: + +data Id α = Id { runId :: α } deriving Functor + +-- A natural transformation (Λ f g α. (f α) → (g α)) may be encoded in Haskell as follows: + +data NT f g = NT { runNT :: ∀ α. f α → g α } + +-- Functor composition (Λ f g α. f (g α)) is encoded as follows: + +data FC f g α = FC { runFC :: f (g α) } + +-- Now, let us define some type T which should be a monad: + +data Wrapper a = Wrapper { runWrapper :: a } deriving (Show, Functor) +instance Monoidy NT FC Id Wrapper where + munit = NT $ Wrapper . runId + mjoin = NT $ runWrapper . runFC + +-- With these defined, we can use them as follows: + +test1 = do { print (mjoin (munit (), Sum 2)) + -- Sum 2 + ; print (mjoin (Product 2, Product 3)) + -- Product 6 + ; print (runNT mjoin $ FC $ Wrapper (Wrapper "hello, world")) + -- Wrapper {runWrapper = "hello, world" } + } + +-- We can even provide a special binary operator for the appropriate monoids as follows: + +(<+>) :: Monoidy (→) (,) () m ⇒ m → m → m +(<+>) = curry mjoin + +test2 = print (Sum 1 <+> Sum 2 <+> Sum 4) -- Sum 7 + +-- Now, all the extra wrapping that Haskell requires for encoding this is +-- rather cumbersome in actual use. So, we can give traditional Monad and +-- Monoid instances for instances of Monoidy: + +instance Monoidy (→) (,) () m ⇒ Semigroup m where + (<>) = curry mjoin + +instance Monoidy (→) (,) () m ⇒ Monoid m where + mempty = munit () + +instance Applicative Wrapper where + pure x = runNT munit $ Id x + (<*>) = ap + +-- instance (Functor m, Monoidy NT FC Id m) ⇒ Monad m where +instance Monad Wrapper where + x >>= f = runNT mjoin $ FC (f `fmap` x) + +-- And so the following works: + +test3 + = do { print (mappend mempty (Sum 2)) + -- Sum 2 + ; print (mappend (Product 2) (Product 3)) + -- Product 6 + ; print (join $ Wrapper $ Wrapper "hello") + -- Wrapper {runWrapper = "hello" } + ; print (Wrapper "hello, world" >>= return) + -- Wrapper {runWrapper = "hello, world" } + } + +main = test1 >> test2 >> test3 diff --git a/tests/examples/pre-ghc910/MonoidsFD1.hs b/tests/examples/pre-ghc910/MonoidsFD1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MonoidsFD1.hs @@ -0,0 +1,7 @@ + +module Main where + +-- comment + +x = 1 + diff --git a/tests/examples/pre-ghc910/Move1.hs b/tests/examples/pre-ghc910/Move1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/MultConstructor.hs b/tests/examples/pre-ghc910/MultConstructor.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MultConstructor.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTSyntax, DataKinds, LinearTypes, KindSignatures, ExplicitForAll #-} +module MultConstructor where + +import GHC.Types + +data T p a where + MkT :: a %p -> T p a + +{- +this currently fails +g :: forall (b :: Type). T 'Many b %1 -> (b,b) +g (MkT x) = (x,x) +-} diff --git a/tests/examples/pre-ghc910/MultiImplicitParams.hs b/tests/examples/pre-ghc910/MultiImplicitParams.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/MultiLineCommentWithPragmas.hs b/tests/examples/pre-ghc910/MultiLineCommentWithPragmas.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/MultiLineWarningPragma.hs b/tests/examples/pre-ghc910/MultiLineWarningPragma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/MultiParamTypeClasses.hs b/tests/examples/pre-ghc910/MultiParamTypeClasses.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/MultiQuote.hs b/tests/examples/pre-ghc910/MultiQuote.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MultiQuote.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes#-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Internal API for the store package. The functions here which are +-- not re-exported by "Data.Store" are less likely to have stable APIs. +-- +-- This module also defines most of the included 'Store' instances, for +-- types from the base package and other commonly used packages +-- (bytestring, containers, text, time, etc). +module Data.Store.Internal where + +------------------------------------------------------------------------ +-- Instances generated by TH + +$($(derive [d| + -- TODO + -- instance Deriving (Store ()) + instance Deriving (Store All) + instance Deriving (Store Any) + instance Deriving (Store Void) + instance Deriving (Store Bool) + |])) + diff --git a/tests/examples/pre-ghc910/MultiWayIf.1.hs b/tests/examples/pre-ghc910/MultiWayIf.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MultiWayIf.1.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/pre-ghc910/MultiWayIf.hs b/tests/examples/pre-ghc910/MultiWayIf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/MultiWayIf.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultiWayIf #-} +module MultiWayIf where + +foo = if | test1 -> e1 + | test2 witharg -> e2 + | otherwise -> def + +bar = if { | test1 -> if { | test2 -> e1 + | test3 -> e2 } + | test4 -> e3 + } + +-- taken from GHC's test suite +x = 10 +x1 = if | x < 10 -> "< 10" | otherwise -> "" +x2 = if | x < 10 -> "< 10" + | otherwise -> "" +x3 = if | x < 10 -> "< 10" + | otherwise -> "" +x4 = if | True -> "yes" +x5 = if | True -> if | False -> 1 | True -> 2 + +x6 = if | x < 10 -> if | True -> "yes" + | False -> "no" + | otherwise -> "maybe" + +x7 = (if | True -> 0) + +-- issue #98 +spam = if | () <- () -> () diff --git a/tests/examples/pre-ghc910/NamedWildcardInDataFamilyInstanceLHS.hs b/tests/examples/pre-ghc910/NamedWildcardInDataFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/NamedWildcardInTypeFamilyInstanceLHS.hs b/tests/examples/pre-ghc910/NamedWildcardInTypeFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/NamedWildcardInTypeFamilyInstanceLHS.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE NamedWildCards #-} +module NamedWildcardInTypeFamilyInstanceLHS where + +type family F a where + F _t = Int diff --git a/tests/examples/pre-ghc910/NamedWildcardInTypeSplice.hs b/tests/examples/pre-ghc910/NamedWildcardInTypeSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/NestedDoLambda.hs b/tests/examples/pre-ghc910/NestedDoLambda.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/NestedLambda.hs b/tests/examples/pre-ghc910/NestedLambda.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/NullaryTypeClasses.hs b/tests/examples/pre-ghc910/NullaryTypeClasses.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Obscure.hs b/tests/examples/pre-ghc910/Obscure.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Observer.hs b/tests/examples/pre-ghc910/Observer.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Observer.hs @@ -0,0 +1,325 @@ +-- | Observer Effects +-- +-- This module supports the implementation of observerRegistry and observables. Expected use +-- case is event propagation. +-- +-- The observable event sources and the observers are usually server processes for a +-- protocol that embeds the 'ObserverRegistry' and 'Observer' 'Pdu's respectively. +-- +-- A generic FIFO queue based observer can be found in "Control.Eff.Concurrent.Protocol.Observer.Queue". +-- +-- @since 0.16.0 +module Control.Eff.Concurrent.Protocol.Observer + ( Observer (..), + ObservationSink (), + IsObservable, + CanObserve, + Pdu (RegisterObserver, ForgetObserver, Observed), + registerObserver, + forgetObserver, + forgetObserverUnsafe, + ObserverRegistry (..), + ObserverRegistryState, + observerRegistryNotify, + evalObserverRegistryState, + emptyObserverRegistry, + observerRegistryHandlePdu, + observerRegistryRemoveProcess, + ) +where + +import Control.DeepSeq (NFData (rnf)) +import Control.Eff +import Control.Eff.Concurrent.Process +import Control.Eff.Concurrent.Protocol +import Control.Eff.Concurrent.Protocol.Client +import Control.Eff.Concurrent.Protocol.Wrapper (Request (Cast)) +import Control.Eff.Log +import Control.Eff.State.Strict +import Control.Lens +import Control.Monad +import Data.Dynamic +import Data.Kind +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Proxy +import Data.Semigroup +import GHC.Generics +import GHC.Stack + +-- * Observers + +-- ** Observables + +-- | A /protocol/ to communicate 'Observed' events from a sources to many sinks. +-- +-- A sink is any process that serves a protocol with a 'Pdu' instance that embeds +-- the 'Observer' Pdu via an 'HasPduPrism' instance. +-- +-- This type has /dual use/, for one it serves as type-index for 'Pdu', i.e. +-- 'HasPdu' respectively, and secondly it contains an 'ObservationSink' and +-- a 'MonitorReference'. +-- +-- The 'ObservationSink' is used to serialize and send the 'Observed' events, +-- while the 'ProcessId' serves as key for internal maps. +-- +-- @since 0.28.0 +newtype Observer event + = MkObserver (Arg ProcessId (ObservationSink event)) + deriving (Eq, Ord, Typeable) + +instance ToTypeLogMsg event => ToLogMsg (Observer event) where + toLogMsg (MkObserver (Arg t _)) = toTypeLogMsg (Proxy @(Observer event)) <> toLogMsg t + +instance ToTypeLogMsg event => ToTypeLogMsg (Observer event) where + toTypeLogMsg _ = toTypeLogMsg (Proxy @event) <> packLogMsg "_observer" + +instance NFData (Observer event) where + rnf (MkObserver (Arg x y)) = rnf x `seq` rnf y + +instance (Tangible event) => HasPdu (Observer event) where + data Pdu (Observer event) r where + Observed :: event -> Pdu (Observer event) 'Asynchronous + deriving (Typeable) + +instance NFData event => NFData (Pdu (Observer event) r) where + rnf (Observed event) = rnf event + +instance ToLogMsg event => ToLogMsg (Pdu (Observer event) r) where + toLogMsg (Observed event) = + packLogMsg "observed: " <> toLogMsg event + +-- | The Information necessary to wrap an 'Observed' event to a process specific +-- message, e.g. the embedded 'Observer' 'Pdu' instance, and the 'MonitorReference' of +-- the destination process. +-- +-- @since 0.28.0 +data ObservationSink event = MkObservationSink + { _observerSerializer :: Serializer (Pdu (Observer event) 'Asynchronous), + _observerMonitorReference :: MonitorReference + } + deriving (Generic, Typeable) + +instance NFData (ObservationSink event) where + rnf (MkObservationSink s p) = s `seq` rnf p + +-- | Convenience type alias. +-- +-- @since 0.28.0 +type IsObservable eventSource event = + ( Tangible event, + Embeds eventSource (ObserverRegistry event), + HasPdu eventSource, + ToTypeLogMsg event, + ToLogMsg event + ) + +-- | Convenience type alias. +-- +-- @since 0.28.0 +type CanObserve eventSink event = + ( Tangible event, + Embeds eventSink (Observer event), + HasPdu eventSink + ) + +-- | And an 'Observer' to the set of recipients for all observations reported by 'observerRegistryNotify'. +-- Note that the observerRegistry are keyed by the observing process, i.e. a previous entry for the process +-- contained in the 'Observer' is overwritten. If you want multiple entries for a single process, just +-- combine several filter functions. +-- +-- @since 0.16.0 +registerObserver :: + forall event eventSink eventSource r q. + ( HasProcesses r q, + TangiblePdu eventSource 'Asynchronous, + IsObservable eventSource event, + TangiblePdu eventSink 'Asynchronous, + CanObserve eventSink event + ) => + Endpoint eventSource -> + Endpoint eventSink -> + Eff r () +registerObserver eventSource eventSink = + cast eventSource (RegisterObserver serializer (eventSink ^. fromEndpoint)) + where + serializer = + MkSerializer + ( toMessage + . Cast + . embedPdu @eventSink @(Observer event) @('Asynchronous) + ) + +-- | Send the 'ForgetObserver' message +-- +-- @since 0.16.0 +forgetObserver :: + forall event eventSink eventSource r q. + ( HasProcesses r q, + TangiblePdu eventSource 'Asynchronous, + IsObservable eventSource event + ) => + Endpoint eventSource -> + Endpoint eventSink -> + Eff r () +forgetObserver eventSource eventSink = + forgetObserverUnsafe @event @eventSource eventSource (eventSink ^. fromEndpoint) + +-- | Send the 'ForgetObserver' message, use a raw 'ProcessId' as parameter. +-- +-- @since 0.28.0 +forgetObserverUnsafe :: + forall event eventSource r q. + ( HasProcesses r q, + TangiblePdu eventSource 'Asynchronous, + IsObservable eventSource event + ) => + Endpoint eventSource -> + ProcessId -> + Eff r () +forgetObserverUnsafe eventSource eventSink = + cast eventSource (ForgetObserver @event eventSink) + +-- ** Observer Support Functions + +-- * Managing Observers + +-- | A protocol for managing 'Observer's, encompassing registration and de-registration of +-- 'Observer's. +-- +-- @since 0.28.0 +data ObserverRegistry (event :: Type) = MkObserverRegistry + {_observerRegistry :: Map ProcessId (ObservationSink event)} + deriving (Typeable) + +instance ToTypeLogMsg event => ToTypeLogMsg (ObserverRegistry event) where + toTypeLogMsg _ = toTypeLogMsg (Proxy @event) <> packLogMsg "_observer_registry_event" + +instance (Tangible event) => HasPdu (ObserverRegistry event) where + data Pdu (ObserverRegistry event) r where + -- | This message denotes that the given 'Observer' should receive observations until 'ForgetObserver' is + -- received. + -- + -- @since 0.28.0 + RegisterObserver :: Serializer (Pdu (Observer event) 'Asynchronous) -> ProcessId -> Pdu (ObserverRegistry event) 'Asynchronous + -- | This message denotes that the given 'Observer' should not receive observations anymore. + -- + -- @since 0.16.1 + ForgetObserver :: ProcessId -> Pdu (ObserverRegistry event) 'Asynchronous + -- -- | This message denotes that a monitored process died + -- -- + -- -- @since 0.28.0 + -- ObserverMightBeDown :: MonitorReference -> Pdu (ObserverRegistry event) ( 'Synchronous Bool) + deriving (Typeable) + +instance NFData (Pdu (ObserverRegistry event) r) where + rnf (RegisterObserver ser pid) = rnf ser `seq` rnf pid + rnf (ForgetObserver pid) = rnf pid + +instance ToTypeLogMsg event => ToLogMsg (Pdu (ObserverRegistry event) r) where + toLogMsg (RegisterObserver _ser pid) = packLogMsg "register " <> toTypeLogMsg (Proxy @event) <> packLogMsg " observer " <> toLogMsg pid + toLogMsg (ForgetObserver pid) = packLogMsg "forget " <> toTypeLogMsg (Proxy @event) <> packLogMsg " observer " <> toLogMsg pid + +-- ** Protocol for integrating 'ObserverRegistry' into processes. + +-- | Provide the implementation for the 'ObserverRegistry' Protocol, this handled 'RegisterObserver' and 'ForgetObserver' +-- messages. It also adds the 'ObserverRegistryState' constraint to the effect list. +-- +-- @since 0.28.0 +observerRegistryHandlePdu :: + forall event q r. + ( HasCallStack, + ToTypeLogMsg event, + HasProcesses r q, + Member (ObserverRegistryState event) r, + Member Logs r + ) => + Pdu (ObserverRegistry event) 'Asynchronous -> + Eff r () +observerRegistryHandlePdu = \case + RegisterObserver ser pid -> do + monRef <- monitor pid + let sink = MkObservationSink ser monRef + observer = MkObserver (Arg pid sink) + modify @(ObserverRegistry event) (over observerRegistry (Map.insert pid sink)) + os <- get @(ObserverRegistry event) + logDebug + (LABEL "registered" observer) + ( LABEL + "current number of observers" -- TODO put this info into the process details + (Map.size (view observerRegistry os)) + ) + ForgetObserver ob -> do + wasRemoved <- observerRegistryRemoveProcess @event ob + unless wasRemoved $ + logDebug (LABEL "unknown observer " ob) + +-- | Remove the entry in the 'ObserverRegistry' for the 'ProcessId' +-- and return 'True' if there was an entry, 'False' otherwise. +-- +-- @since 0.28.0 +observerRegistryRemoveProcess :: + forall event q r. + ( HasCallStack, + ToTypeLogMsg event, + HasProcesses r q, + Member (ObserverRegistryState event) r, + Member Logs r + ) => + ProcessId -> + Eff r Bool +observerRegistryRemoveProcess ob = do + mSink <- view (observerRegistry . at ob) <$> get @(ObserverRegistry event) + modify @(ObserverRegistry event) (observerRegistry . at ob .~ Nothing) + os <- get @(ObserverRegistry event) + maybe + (pure False) + (foundIt os) + mSink + where + foundIt os sink@(MkObservationSink _ monRef) = do + demonitor monRef + logDebug + (LABEL "removed" (MkObserver $ Arg ob sink)) + (LABEL "current number of observers" (Map.size (view observerRegistry os))) + pure True + +-- | Keep track of registered 'Observer's. +-- +-- Handle the 'ObserverRegistryState' effect, i.e. run 'evalState' on an 'emptyObserverRegistry'. +-- +-- @since 0.28.0 +evalObserverRegistryState :: Eff (ObserverRegistryState event ': r) a -> Eff r a +evalObserverRegistryState = evalState emptyObserverRegistry + +-- | The empty 'ObserverRegistryState' +-- +-- @since 0.28.0 +emptyObserverRegistry :: ObserverRegistry event +emptyObserverRegistry = MkObserverRegistry Map.empty + +-- | Alias for the effect that contains the observers managed by 'evalObserverRegistryState' +type ObserverRegistryState event = State (ObserverRegistry event) + +-- | An 'Iso' for the 'Map' used internally. +observerRegistry :: Iso' (ObserverRegistry event) (Map ProcessId (ObservationSink event)) +observerRegistry = iso _observerRegistry MkObserverRegistry + +-- | Report an observation to all observers. +-- The process needs to 'evalObserverRegistryState' and to 'observerRegistryHandlePdu'. +-- +-- @since 0.28.0 +observerRegistryNotify :: + forall event r q. + ( HasProcesses r q, + Member (ObserverRegistryState event) r + ) => + event -> + Eff r () +observerRegistryNotify observation = do + os <- view observerRegistry <$> get + mapM_ notifySomeObserver (Map.assocs os) + where + notifySomeObserver (destination, (MkObservationSink serializer _)) = + sendAnyMessage destination (runSerializer serializer (Observed observation)) + diff --git a/tests/examples/pre-ghc910/Observer1.hs b/tests/examples/pre-ghc910/Observer1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Observer1.hs @@ -0,0 +1,10 @@ +module Observer1 where + +instance HasPdu Int where + data Pdu Int r where + --a comment + RegisterObserver :: Int + --b comment + ForgetObserver :: Int + --c comment + deriving (Typeable) diff --git a/tests/examples/pre-ghc910/OldList.hs b/tests/examples/pre-ghc910/OldList.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/OldList.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables, BangPatterns, RankNTypes #-} + +{- +This is a simplified version of Data.OldList module from base. +This caused an assertion failure in earlier version of linear +types implementation. +-} + +module Data.OldList where + +import GHC.Base + +sortBy :: forall a . (a -> a -> Ordering) -> [a] +sortBy cmp = [] + where + sequences (a:b:xs) + | a `cmp` b == GT = descending b [a] xs + | otherwise = ascending b (a:) xs + sequences xs = [xs] + +-- descending :: a -> [a] -> [a] -> [[a]] + descending a as (b:bs) + | a `cmp` b == GT = descending b (a:as) bs + descending a as bs = (a:as): sequences bs + + ascending :: a -> (forall i . [a] %i -> [a]) -> [a] -> [[a]] + ascending a as (b:bs) + | a `cmp` b /= GT = ascending b foo bs + where + foo :: [a] %k -> [a] + foo ys = as (a:ys) + ascending a as bs = let !x = as [a] + in x : sequences bs diff --git a/tests/examples/pre-ghc910/Op.hs b/tests/examples/pre-ghc910/Op.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Op.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Op where +{- +See Control.Arrow and Data.Functor.Contravariant +-} + +import GHC.Base + +class Or p where + or :: p a b -> p a b -> p a b + +instance Or (->) where + or x _ = x + + +foo = or Just (\x -> Just x) + +{- +This caused an error in the earlier version of linear types: + +linear-tests/Op.hs:18:16: error: + • Couldn't match expected type ‘a ⊸ Maybe a’ + with actual type ‘a0 -> Maybe a0’ + • The lambda expression ‘\ x -> Just x’ has one argument, + its type is ‘p0 a b0’, + it is specialized to ‘a ⊸ Maybe a’ + In the second argument of ‘or’, namely ‘(\ x -> Just x)’ + In the expression: or Just (\ x -> Just x) + • Relevant bindings include + foo :: a ⊸ Maybe a (bound at linear-tests/Op.hs:18:1) + | +18 | foo = or Just (\x -> Just x) + | ^^^^^^^^^^^^ +-} diff --git a/tests/examples/pre-ghc910/OptSig.hs b/tests/examples/pre-ghc910/OptSig.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/OptSig2.hs b/tests/examples/pre-ghc910/OptSig2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/OptSig2.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +errors= do + let ls :: Int = undefined + return () diff --git a/tests/examples/pre-ghc910/OutOfHeap.hs b/tests/examples/pre-ghc910/OutOfHeap.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/OveridingPrimitives.hs b/tests/examples/pre-ghc910/OveridingPrimitives.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/OveridingPrimitives.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +(~#) :: Comonad w => CascadeW w (t ': ts) -> w t -> Last (t ': ts) +(~#) = cascadeW +infixr 0 ~# + diff --git a/tests/examples/pre-ghc910/OverloadedRecFldsFail04_A.hs b/tests/examples/pre-ghc910/OverloadedRecFldsFail04_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/OverloadedRecFldsFail04_A.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module OverloadedRecFldsFail04_A (U(..), V(MkV, x), Unused(..), u) where + +data U = MkU { x :: Bool, y :: Bool } +data V = MkV { x :: Int } +data Unused = MkUnused { unused :: Bool } + +u = MkU False True diff --git a/tests/examples/pre-ghc910/OverloadedRecFldsFail06_A.hs b/tests/examples/pre-ghc910/OverloadedRecFldsFail06_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/OverloadedRecFldsFail06_A.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -fwarn-unused-binds #-} + +module OverloadedRecFldsFail06_A (U(..), V(..), Unused(unused), u, getX, getY, z) where + +data U = MkU { x :: Bool, y :: Bool } | MkU2 { used_locally :: Bool } + deriving Show +data V = MkV { x :: Int } | MkV2 { y :: Bool } +data Unused = MkUnused { unused :: Bool, unused2 :: Bool, used_locally :: Bool } + +u = MkU False True + +z MkU2{used_locally=used_locally} = used_locally + +getX MkU{x=x} = x +getY MkV2{y=y} = y diff --git a/tests/examples/pre-ghc910/OverloadedRecFldsFail10_A.hs b/tests/examples/pre-ghc910/OverloadedRecFldsFail10_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/OverloadedRecFldsFail10_A.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} +module OverloadedRecFldsFail10_A where + +data family F a +data instance F Int = MkFInt { foo :: Int } diff --git a/tests/examples/pre-ghc910/OverloadedRecFldsFail10_B.hs b/tests/examples/pre-ghc910/OverloadedRecFldsFail10_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/OverloadedRecFldsFail10_B.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module OverloadedRecFldsFail10_B (F(..)) where + +import OverloadedRecFldsFail10_A hiding (foo) + +data instance F Bool = MkFBool { foo :: Int } diff --git a/tests/examples/pre-ghc910/OverloadedRecFldsFail10_C.hs b/tests/examples/pre-ghc910/OverloadedRecFldsFail10_C.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/OverloadedRecFldsFail10_C.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} +module OverloadedRecFldsFail10_C (F(..)) where + +import OverloadedRecFldsFail10_A + +data instance F Char = MkFChar { foo :: Char } diff --git a/tests/examples/pre-ghc910/OverloadedRecFldsFail11_A.hs b/tests/examples/pre-ghc910/OverloadedRecFldsFail11_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/OverloadedRecFldsFail11_A.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module OverloadedRecFldsFail11_A where + +{-# WARNING foo "Warning on a record field" #-} +data S = MkS { foo :: Bool } +data T = MkT { foo :: Int } diff --git a/tests/examples/pre-ghc910/OverloadedRecFldsFail12_A.hs b/tests/examples/pre-ghc910/OverloadedRecFldsFail12_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/OverloadedRecFldsFail12_A.hs @@ -0,0 +1,5 @@ +module OverloadedRecFldsFail12_A where + +{-# WARNING foo "Deprecated foo" #-} +{-# WARNING bar "Deprecated bar" #-} +data T = MkT { foo :: Int, bar :: Int } diff --git a/tests/examples/pre-ghc910/OverloadedRecFldsRun02_A.hs b/tests/examples/pre-ghc910/OverloadedRecFldsRun02_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/OverloadedRecFldsRun02_A.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module OverloadedRecFldsRun02_A (U(..), V(MkV, x), Unused(..), u) where + +data U = MkU { x :: Bool, y :: Bool } +data V = MkV { x :: Int } +data Unused = MkUnused { unused :: Bool } + +u = MkU False True diff --git a/tests/examples/pre-ghc910/OverloadedStrings.hs b/tests/examples/pre-ghc910/OverloadedStrings.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/P.hs b/tests/examples/pre-ghc910/P.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/PArr.hs b/tests/examples/pre-ghc910/PArr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/PSQ.hs b/tests/examples/pre-ghc910/PSQ.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/PSQ.hs @@ -0,0 +1,4 @@ + +data TourView a = Null + | Single {-# UNPACK #-} !(Elem a) + | (PSQ a) `Play` (PSQ a) diff --git a/tests/examples/pre-ghc910/ParenFunBind.hs b/tests/examples/pre-ghc910/ParenFunBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ParenFunBind.hs @@ -0,0 +1,5 @@ +module ParenFunBind where + +(foo x) y = x + y +((bar x)) y = x + y +((baz x)) (y) = x + y diff --git a/tests/examples/pre-ghc910/ParenTypeSynonym.hs b/tests/examples/pre-ghc910/ParenTypeSynonym.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ParenTypeSynonym.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} +module ParenTypeSynonym where + +type Is = (~) diff --git a/tests/examples/pre-ghc910/ParensAroundContext.hs b/tests/examples/pre-ghc910/ParensAroundContext.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ParensGADT.hs b/tests/examples/pre-ghc910/ParensGADT.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ParensGADT.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +module ParensGADT where + +-- | Base Descriptor Class Tags TODO rename to xxxTag +data ClassTag (tag :: Nat) where + M4MuxChannelDescr ::ClassTag 0x69 + ExtDescrTag :: ( forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n) + OCIDescrTag :: ((forall (n :: Nat) . (0x40 <= n, n <= 0x5F) => ClassTag n)) + +-- End of file comment diff --git a/tests/examples/pre-ghc910/Parse.hs b/tests/examples/pre-ghc910/Parse.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Parse.hs @@ -0,0 +1,5 @@ + +module Language.Python.Internal.Parse where + +compoundStatement pIndent indentBefore = + do; a <- doAsync; fundef diff --git a/tests/examples/pre-ghc910/Parser.hs b/tests/examples/pre-ghc910/Parser.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Parser.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} + +{-# OPTIONS_GHC + -Weverything + -fno-warn-unsafe + -fno-warn-implicit-prelude + -fno-warn-missing-import-lists + -fno-warn-noncanonical-monoid-instances + -O2 +#-} + +module Packed.Bytes.Parser + ( Parser(..) + , Result(..) + , Leftovers(..) + , parseStreamST + , any + , failure + ) where + +import Control.Applicative +import Data.Primitive (ByteArray(..)) +import GHC.Int (Int(I#)) +import GHC.ST (ST(..),runST) +import GHC.Types (TYPE) +import GHC.Word (Word8(W8#)) +import Packed.Bytes (Bytes(..)) +import Packed.Bytes.Stream.ST (ByteStream(..)) +import Prelude hiding (any,replicate) + +import qualified Data.Primitive as PM +import qualified Control.Monad + +import GHC.Exts (Int#,ByteArray#,Word#,State#,(+#),(-#),(>#),indexWord8Array#) + +type Bytes# = (# ByteArray#, Int#, Int# #) +type Maybe# (a :: TYPE r) = (# (# #) | a #) +type Leftovers# s = (# Bytes# , ByteStream s #) +type Result# s a = (# Maybe# (Leftovers# s), Maybe# a #) + +data Result s a = Result + { resultLeftovers :: !(Maybe (Leftovers s)) + , resultValue :: !(Maybe a) + } + +data Leftovers s = Leftovers + { leftoversChunk :: {-# UNPACK #-} !Bytes + -- ^ The last chunk pulled from the stream + , leftoversStream :: ByteStream s + -- ^ The remaining stream + } + +data PureResult a = PureResult + { pureResultLeftovers :: {-# UNPACK #-} !Bytes + , pureResultValue :: !(Maybe a) + } deriving (Show) + +emptyByteArray :: ByteArray +emptyByteArray = runST (PM.newByteArray 0 >>= PM.unsafeFreezeByteArray) + +parseStreamST :: ByteStream s -> Parser a -> ST s (Result s a) +parseStreamST stream (Parser f) = ST $ \s0 -> + case f (# | (# (# unboxByteArray emptyByteArray, 0#, 0# #), stream #) #) s0 of + (# s1, r #) -> (# s1, boxResult r #) + +boxResult :: Result# s a -> Result s a +boxResult (# leftovers, val #) = case val of + (# (# #) | #) -> Result (boxLeftovers leftovers) Nothing + (# | a #) -> Result (boxLeftovers leftovers) (Just a) + +boxLeftovers :: Maybe# (Leftovers# s) -> Maybe (Leftovers s) +boxLeftovers (# (# #) | #) = Nothing +boxLeftovers (# | (# theBytes, stream #) #) = Just (Leftovers (boxBytes theBytes) stream) + +instance Functor Parser where + fmap = mapParser + +-- Remember to write liftA2 by hand at some point. +instance Applicative Parser where + pure = pureParser + (<*>) = Control.Monad.ap + +instance Monad Parser where + return = pure + (>>=) = bindLifted + +newtype Parser a = Parser + { getParser :: forall s. + Maybe# (Leftovers# s) + -> State# s + -> (# State# s, Result# s a #) + } + +nextNonEmpty :: ByteStream s -> State# s -> (# State# s, Maybe# (Leftovers# s) #) +nextNonEmpty (ByteStream f) s0 = case f s0 of + (# s1, r #) -> case r of + (# (# #) | #) -> (# s1, (# (# #) | #) #) + (# | (# theBytes@(# _,_,len #), stream #) #) -> case len of + 0# -> nextNonEmpty stream s1 + _ -> (# s1, (# | (# theBytes, stream #) #) #) + +withNonEmpty :: forall s b. + Maybe# (Leftovers# s) + -> State# s + -> (State# s -> (# State# s, Result# s b #)) + -> (Word# -> Bytes# -> ByteStream s -> State# s -> (# State# s, Result# s b #)) + -- The first argument is a Word8, not a full machine word. + -- The second argument is the complete,non-empty chunk + -- with the head byte still intact. + -> (# State# s, Result# s b #) +withNonEmpty (# (# #) | #) s0 g _ = g s0 +withNonEmpty (# | (# bytes0@(# arr0,off0,len0 #), stream0 #) #) s0 g f = case len0 ># 0# of + 1# -> f (indexWord8Array# arr0 off0) bytes0 stream0 s0 + _ -> case nextNonEmpty stream0 s0 of + (# s1, r #) -> case r of + (# (# #) | #) -> g s1 + (# | (# bytes1@(# arr1, off1, _ #), stream1 #) #) -> + f (indexWord8Array# arr1 off1) bytes1 stream1 s1 + +-- | Consume the next byte from the input. +any :: Parser Word8 +any = Parser go where + go :: Maybe# (Leftovers# s) -> State# s -> (# State# s, Result# s Word8 #) + go m s0 = withNonEmpty m s0 + (\s -> (# s, (# (# (# #) | #), (# (# #) | #) #) #)) + (\theByte theBytes stream s -> + (# s, (# (# | (# unsafeDrop# 1# theBytes, stream #) #), (# | W8# theByte #) #) #) + ) + +-- TODO: improve this +mapParser :: (a -> b) -> Parser a -> Parser b +mapParser f p = bindLifted p (pureParser . f) + +pureParser :: a -> Parser a +pureParser a = Parser $ \leftovers0 s0 -> + (# s0, (# leftovers0, (# | a #) #) #) + +bindLifted :: Parser a -> (a -> Parser b) -> Parser b +bindLifted (Parser f) g = Parser $ \leftovers0 s0 -> case f leftovers0 s0 of + (# s1, (# leftovers1, val #) #) -> case val of + (# (# #) | #) -> (# s1, (# leftovers1, (# (# #) | #) #) #) + (# | x #) -> case g x of + Parser k -> k leftovers1 s1 + +-- This assumes that the Bytes is longer than the index. It also does +-- not eliminate zero-length references to byte arrays. +unsafeDrop# :: Int# -> Bytes# -> Bytes# +unsafeDrop# i (# arr, off, len #) = (# arr, off +# i, len -# i #) + +unboxByteArray :: ByteArray -> ByteArray# +unboxByteArray (ByteArray arr) = arr + +boxBytes :: Bytes# -> Bytes +boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c) + +failure :: Parser a +failure = Parser (\m s -> (# s, (# m, (# (# #) | #) #) #)) + diff --git a/tests/examples/pre-ghc910/ParserArrowLambdaCase.hs b/tests/examples/pre-ghc910/ParserArrowLambdaCase.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ParserArrowLambdaCase.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Arrows, LambdaCase #-} +module ParserArrowLambdaCase where + +import Control.Arrow + +foo :: () -> () +foo = proc () -> (| id (\case + () -> () >- returnA) |) () + diff --git a/tests/examples/pre-ghc910/PartialClassMethodSignature2.hs b/tests/examples/pre-ghc910/PartialClassMethodSignature2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/PatBind.hs b/tests/examples/pre-ghc910/PatBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/PatSigBind.hs b/tests/examples/pre-ghc910/PatSigBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/PatSynBind.hs b/tests/examples/pre-ghc910/PatSynBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/PatternGuards.hs b/tests/examples/pre-ghc910/PatternGuards.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/PluralS.hs b/tests/examples/pre-ghc910/PluralS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/PluralS.hs @@ -0,0 +1,27 @@ +-- Test purpose: +-- +-- Ensure the plural "s" in warnings is only shown if there are more than +-- one entries + +{-# OPTIONS_GHC -Wredundant-constraints #-} +{-# OPTIONS_GHC -Wtype-defaults #-} + +module PluralS () where + + + +-- Defaulting type classes + +defaultingNum = 123 `seq` () + +defaultingNumAndShow = show 123 + + + +-- Redundant constraints + +redundantNum :: (Num a, Num a) => a +redundantNum = 123 + +redundantMultiple :: (Num a, Show a, Num a, Eq a, Eq a) => a +redundantMultiple = 123 diff --git a/tests/examples/pre-ghc910/PolyInstances.hs b/tests/examples/pre-ghc910/PolyInstances.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/PolyInstances.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE PolyKinds, FlexibleInstances, ScopedTypeVariables, + UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module PolyInstances where + +import GHC.Exts +import Data.Proxy + +class C (a :: k) + +instance (C a, C b) => C (a b) + +data Dict :: Constraint -> * + +instance C Dict + +foo :: C p => proxy p -> () +foo = undefined + +bar :: forall (p :: Constraint) proxy. C p => proxy p -> () +bar _ = foo (Proxy :: Proxy (Dict p)) diff --git a/tests/examples/pre-ghc910/PopCnt.hs b/tests/examples/pre-ghc910/PopCnt.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/PopCnt.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-} +module Main where + +import GHC.Exts + +foreign import prim "do_popcnt32" popcnt32 :: Int# -> Int# + +main = print (I# (popcnt32 0xffff#)) + diff --git a/tests/examples/pre-ghc910/PostgreSQL.hs b/tests/examples/pre-ghc910/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/PostgreSQL.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Drifter.PostgreSQL + ( PGMigration + , Method(..) + , DBConnection(..) + , ChangeHistory(..) + , runMigrations + , getChangeHistory + , getChangeNameHistory + ) where + +------------------------------------------------------------------------------- +import Control.Applicative as A +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Except +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Time +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.SqlQQ +import Drifter +------------------------------------------------------------------------------- + + +data PGMigration + + +data instance Method PGMigration = MigrationQuery Query + -- ^ Run a query against the database + | MigrationCode (Connection -> IO (Either String ())) + -- ^ Run any arbitrary IO code + + +data instance DBConnection PGMigration = DBConnection PGMigrationConnection + + +data PGMigrationConnection = PGMigrationConnection (Set ChangeName) Connection + + +instance Drifter PGMigration where + migrateSingle (DBConnection migrationConn) change = do + runExceptT $ migrateChange migrationConn change + + +------------------------------------------------------------------------------- +-- Change History Tracking +------------------------------------------------------------------------------- +newtype ChangeId = ChangeId Int deriving (Eq, Ord, Show, FromField) + + +data ChangeHistory = ChangeHistory { + histId :: ChangeId + , histName :: ChangeName + , histDescription :: Maybe Description + , histTime :: UTCTime + } deriving (Show) + + +instance Eq ChangeHistory where + a == b = (histName a) == (histName b) + + +instance Ord ChangeHistory where + compare a b = compare (histId a) (histId b) + + +instance FromRow ChangeHistory where + fromRow = ChangeHistory <$> field + <*> (ChangeName <$> field) + <*> field + <*> field + + +------------------------------------------------------------------------------- +-- Queries +------------------------------------------------------------------------------- +bootstrapQ :: Query +bootstrapQ = [sql| +CREATE TABLE IF NOT EXISTS schema_migrations ( + id serial NOT NULL, + name text NOT NULL, + description text, + time timestamptz NOT NULL DEFAULT now(), + + PRIMARY KEY (id), + UNIQUE (name) +); +|] + + +------------------------------------------------------------------------------- +changeHistoryQ :: Query +changeHistoryQ = + "SELECT id, name, description, time FROM schema_migrations ORDER BY id;" + + +------------------------------------------------------------------------------- +changeNameHistoryQ :: Query +changeNameHistoryQ = + "SELECT name FROM schema_migrations ORDER BY id;" + + +------------------------------------------------------------------------------- +insertLogQ :: Query +insertLogQ = + "INSERT INTO schema_migrations (name, description, time) VALUES (?, ?, ?);" + + +------------------------------------------------------------------------------- +migrateChange :: PGMigrationConnection -> Change PGMigration -> ExceptT String IO () +migrateChange (PGMigrationConnection hist c) ch@Change{..} = do + if Set.member changeName hist + then lift $ putStrLn $ "Skipping: " ++ show (changeNameText changeName) + else do + runMethod c changeMethod + logChange c ch + lift $ putStrLn $ "Committed: " ++ show changeName + + +------------------------------------------------------------------------------- +runMethod :: Connection -> Method PGMigration -> ExceptT String IO () +runMethod c (MigrationQuery q) = + void $ ExceptT $ (Right <$> execute_ c q) `catches` errorHandlers +runMethod c (MigrationCode f) = + ExceptT $ f c `catches` errorHandlers + + + ------------------------------------------------------------------------------- +logChange :: Connection -> Change PGMigration -> ExceptT String IO () +logChange c Change{..} = do + now <- lift getCurrentTime + void $ ExceptT $ (Right <$> go now) `catches` errorHandlers + where + go now = execute c insertLogQ (changeNameText changeName, changeDescription, now) + + +------------------------------------------------------------------------------- +errorHandlers :: [Handler (Either String b)] +errorHandlers = [ Handler (\(ex::SqlError) -> return $ Left $ show ex) + , Handler (\(ex::FormatError) -> return $ Left $ show ex) + , Handler (\(ex::ResultError) -> return $ Left $ show ex) + , Handler (\(ex::QueryError) -> return $ Left $ show ex) + ] + + +------------------------------------------------------------------------------- +-- | Takes a connection and builds the state to thread throughout the migration. +-- This includes bootstrapping the migration tables and collecting all the +-- migrations that have already been committed. +makePGMigrationConnection :: Connection -> IO PGMigrationConnection +makePGMigrationConnection conn = do + void $ execute_ conn bootstrapQ + hist <- getChangeNameHistory conn + return $ PGMigrationConnection (Set.fromList hist) conn + + +------------------------------------------------------------------------------- +-- | Takes the list of all migrations, removes the ones that have +-- already run and runs them. Use this instead of 'migrate'. +runMigrations :: Connection -> [Change PGMigration] -> IO (Either String ()) +runMigrations conn changes = do + begin conn + migrationConn <- makePGMigrationConnection conn + res <- migrate (DBConnection migrationConn) changes `onException` rollback conn + case res of + Right _ -> commit conn + Left _ -> rollback conn + return res + + +------------------------------------------------------------------------------- +-- | Get all changes from schema_migrations table for all the migrations that +-- have previously run. +getChangeHistory :: Connection -> IO [ChangeHistory] +getChangeHistory conn = query_ conn changeHistoryQ + + +------------------------------------------------------------------------------- +-- | Get just the names of all changes from schema_migrations for migrations +-- that have previously run. +getChangeNameHistory :: Connection -> IO [ChangeName] +getChangeNameHistory conn = fmap (\(Only nm) -> ChangeName nm) + A.<$> query_ conn changeNameHistoryQ + diff --git a/tests/examples/pre-ghc910/Ppr006a.hs b/tests/examples/pre-ghc910/Ppr006a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Ppr006a.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE QuasiQuotes #-} +module Ppr006a where + +commands :: [Command] +commands = [ + command "novisual" "cancel visual selection" $ + sendEventCurrent EvNoVisual + + -- 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 + + ] + diff --git a/tests/examples/pre-ghc910/Ppr017.hs b/tests/examples/pre-ghc910/Ppr017.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Ppr017.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ExplicitNamespaces #-} +module Imports( f, type (+), pattern Single ) where + +import GHC.TypeLits + +pattern Single x = [x] + +f = undefined diff --git a/tests/examples/pre-ghc910/Ppr048.hs b/tests/examples/pre-ghc910/Ppr048.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Ppr048.hs @@ -0,0 +1,10 @@ +module Ppr048 where + +{-# SCc foo #-} +foo :: Int -> Int +foo x = x + +{-# SCc foo2 "label" #-} +foo2 :: () +foo2 = () + diff --git a/tests/examples/pre-ghc910/Pr110.hs b/tests/examples/pre-ghc910/Pr110.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Pr110.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LinearTypes #-} +module Pr110 where + +data Bloop = Bloop Bool + +g :: Bloop %1 -> Bool +g (Bloop x) = x + +h :: Bool %1 -> Bloop +h x = Bloop x + diff --git a/tests/examples/pre-ghc910/PragmaSpans.hs b/tests/examples/pre-ghc910/PragmaSpans.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/PragmaSpans.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE GADTs #-} +module PragmaSpans where + +-- The following pragma gets the wrong previous span. +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/20720 +{-# LANGUAGE TypeFamilies #-} diff --git a/tests/examples/pre-ghc910/Primop.hs b/tests/examples/pre-ghc910/Primop.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Primop.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE GHCForeignImportPrim, MagicHash, + UnliftedFFITypes, UnboxedTuples #-} + +import GHC.Exts + +foreign import prim "dummy" + dummy :: Word# -> Word# + +foreign import prim "dummy2" + dummy2 :: Any -> State# RealWorld -> (# State# RealWorld, Word# #) diff --git a/tests/examples/pre-ghc910/Printf.hs b/tests/examples/pre-ghc910/Printf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Printf.hs @@ -0,0 +1,34 @@ +-- Copyright (C) 2015, Luke Iannini + +{-# LANGUAGE TemplateHaskell #-} +module Printf where + +-- Skeletal printf from the paper: +-- http://research.microsoft.com/pubs/67015/meta-haskell.pdf +-- It needs to be in a separate module to the one where +-- you intend to use it. + +-- Import some Template Haskell syntax +import Language.Haskell.TH + +-- Describe a format string +data Format = D | S | L String + +-- Parse a format string. This is left largely to you +-- as we are here interested in building our first ever +-- Template Haskell program and not in building printf. +parse :: String -> [Format] +parse s = [ L s ] + +-- Generate Haskell source code from a parsed representation +-- of the format string. This code will be spliced into +-- the module which calls "pr", at compile time. +gen :: [Format] -> Q Exp +gen [D] = [| \n -> show n |] +gen [S] = [| \s -> s |] +gen [L s] = stringE s + +-- Here we generate the Haskell code for the splice +-- from an input format string. +pr :: String -> Q Exp +pr s = gen (parse s) diff --git a/tests/examples/pre-ghc910/ProcNotation.hs b/tests/examples/pre-ghc910/ProcNotation.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Process.hs b/tests/examples/pre-ghc910/Process.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Process.hs @@ -0,0 +1,717 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Synthesizer.MIDI.CausalIO.Process ( + Events, + + slice, + controllerLinear, + controllerExponential, + pitchBend, + channelPressure, + bendWheelPressure, + constant, + + Instrument, + Bank, + GateChunk, + noteEvents, + embedPrograms, + applyInstrument, + applyModulatedInstrument, + flattenControlSchedule, + applyModulation, + arrangeStorable, + sequenceCore, + sequenceModulated, + sequenceModulatedMultiProgram, + sequenceModulatedMultiProgramVelocityPitch, + sequenceStorable, + + -- auxiliary function + initWith, + mapMaybe, + ) where + +import qualified Synthesizer.CausalIO.Gate as Gate +import qualified Synthesizer.CausalIO.Process as PIO + +import qualified Synthesizer.MIDI.Value.BendModulation as BM +import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP +import qualified Synthesizer.MIDI.Value as MV + +import qualified Synthesizer.MIDI.EventList as MIDIEv +import Synthesizer.MIDI.EventList (StrictTime, ) + +import qualified Synthesizer.PiecewiseConstant.Signal as PC +import qualified Synthesizer.Storable.Cut as CutSt +import qualified Synthesizer.Generic.Cut as CutG +import qualified Synthesizer.Zip as Zip + +import qualified Sound.MIDI.Message.Class.Check as Check +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import Control.DeepSeq (rnf, ) + +import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.BodyTime as EventListBT +import qualified Data.EventList.Relative.TimeTime as EventListTT +import qualified Data.EventList.Relative.TimeMixed as EventListTM +import qualified Data.EventList.Relative.MixedTime as EventListMT +import qualified Data.EventList.Absolute.TimeBody as AbsEventList + +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Class as NonNeg + +import qualified Algebra.Transcendental as Trans +import qualified Algebra.RealRing as RealRing +import qualified Algebra.Field as Field +import qualified Algebra.Additive as Additive +import qualified Algebra.ToInteger as ToInteger + +import qualified Data.StorableVector as SV +import qualified Data.StorableVector.ST.Strict as SVST +import Foreign.Storable (Storable, ) + +import qualified Control.Monad.Trans.Writer as MW +import qualified Control.Monad.Trans.State as MS +import qualified Control.Monad.Trans.Class as MT +import Control.Monad.IO.Class (liftIO, ) + +import qualified Data.Traversable as Trav +import Data.Traversable (Traversable, ) +import Data.Foldable (traverse_, ) + +import Control.Arrow (Arrow, arr, (^<<), (<<^), ) +import Control.Category ((.), ) + +import qualified Data.Map as Map + +import qualified Data.List.HT as ListHT +import qualified Data.Maybe as Maybe +import Data.Monoid (Monoid, mempty, mappend, ) +import Data.Maybe (maybeToList, ) +import Data.Tuple.HT (mapFst, mapPair, ) + +import NumericPrelude.Numeric +import NumericPrelude.Base hiding ((.), sequence, ) +import Prelude () + + +type Events event = EventListTT.T StrictTime [event] + + +initWith :: + (y -> c) -> + c -> + PIO.T + (Events y) + (EventListBT.T PC.ShortStrictTime c) +initWith f initial = + PIO.traverse initial $ + \evs0 -> do + y0 <- MS.get + fmap (PC.subdivideLongStrict . EventListMT.consBody y0) $ + Trav.traverse (\ys -> traverse_ (MS.put . f) ys >> MS.get) evs0 + +slice :: + (Check.C event) => + (event -> Maybe Int) -> + (Int -> y) -> y -> + PIO.T + (Events event) + (EventListBT.T PC.ShortStrictTime y) +slice select f initial = + initWith f initial . mapMaybe select + + + +mapMaybe :: + (Arrow arrow, Functor f) => + (a -> Maybe b) -> + arrow (f [a]) (f [b]) +mapMaybe f = + arr $ fmap $ Maybe.mapMaybe f + +catMaybes :: + (Arrow arrow, Functor f) => + arrow (f [Maybe a]) (f [a]) +catMaybes = + arr $ fmap Maybe.catMaybes + +traverse :: + (Traversable f) => + s -> (a -> MS.State s b) -> + PIO.T (f [a]) (f [b]) +traverse initial f = + PIO.traverse initial (Trav.traverse (Trav.traverse f)) + + +controllerLinear :: + (Check.C event, Field.C y) => + MIDIEv.Channel -> + MIDIEv.Controller -> + (y,y) -> y -> + PIO.T + (Events event) + (EventListBT.T PC.ShortStrictTime y) +controllerLinear chan ctrl bnd initial = + slice (Check.controller chan ctrl) + (MV.controllerLinear bnd) initial + +controllerExponential :: + (Check.C event, Trans.C y) => + MIDIEv.Channel -> + MIDIEv.Controller -> + (y,y) -> y -> + PIO.T + (Events event) + (EventListBT.T PC.ShortStrictTime y) +controllerExponential chan ctrl bnd initial = + slice (Check.controller chan ctrl) + (MV.controllerExponential bnd) initial + +pitchBend :: + (Check.C event, Trans.C y) => + MIDIEv.Channel -> + y -> y -> + PIO.T + (Events event) + (EventListBT.T PC.ShortStrictTime y) +pitchBend chan range center = + slice (Check.pitchBend chan) + (MV.pitchBend range center) center + +channelPressure :: + (Check.C event, Trans.C y) => + MIDIEv.Channel -> + y -> y -> + PIO.T + (Events event) + (EventListBT.T PC.ShortStrictTime y) +channelPressure chan maxVal initial = + slice (Check.channelPressure chan) + (MV.controllerLinear (zero,maxVal)) initial + +bendWheelPressure :: + (Check.C event, RealRing.C y, Trans.C y) => + MIDIEv.Channel -> + Int -> y -> y -> + PIO.T + (Events event) + (EventListBT.T PC.ShortStrictTime (BM.T y)) +bendWheelPressure chan + pitchRange wheelDepth pressDepth = + let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth + in initWith toBM (toBM BWP.deflt) + . + catMaybes + . + traverse BWP.deflt (BWP.check chan) + + +-- might be moved to synthesizer-core +constant :: + (Arrow arrow) => + y -> arrow (Events event) (EventListBT.T PC.ShortStrictTime y) +constant y = arr $ + EventListBT.singleton y . + NonNegW.fromNumberMsg "MIDI.CausalIO.constant" . + fromIntegral . + EventListTT.duration + +_constant :: + (Arrow arrow, CutG.Read input) => + y -> arrow input (EventListBT.T PC.ShortStrictTime y) +_constant y = arr $ + EventListBT.singleton y . + NonNegW.fromNumberMsg "MIDI.CausalIO.constant" . + CutG.length + + + +noteEvents :: + (Check.C event, Arrow arrow) => + MIDIEv.Channel -> + arrow + (Events event) + (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool))) +noteEvents chan = + mapMaybe $ MIDIEv.checkNoteEvent chan + + +embedPrograms :: + MIDIEv.Program -> + PIO.T + (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool))) + (Events (MIDIEv.NoteBoundary (Maybe MIDIEv.Program))) +embedPrograms initPgm = + catMaybes . + traverse initPgm MIDIEv.embedProgramState + + +type GateChunk = Gate.Chunk MIDIEv.Velocity +type Instrument y chunk = y -> y -> PIO.T GateChunk chunk +type Bank y chunk = MIDIEv.Program -> Instrument y chunk + + + +{- +for distinction of notes with the same pitch + +We must use Integer instead of Int, in order to avoid an overflow +that would invalidate the check for unmatched NoteOffs +that is based on comparison of the NoteIds. +We cannot re-use NoteIds easily, +since the events at one time point are handled out of order. +-} +newtype NoteId = NoteId Integer + deriving (Show, Eq, Ord) + +succNoteId :: NoteId -> NoteId +succNoteId (NoteId n) = NoteId (n+1) + +flattenNoteIdRange :: (NoteId,NoteId) -> [NoteId] +flattenNoteIdRange (start,afterEnd) = + takeWhile ( rnf (NonNegW.toNumber t)) . + unwrapNoteOffList + +instance Monoid NoteOffList where + mempty = NoteOffList (EventListTT.pause mempty) + mappend (NoteOffList xs) (NoteOffList ys) = + NoteOffList (mappend xs ys) + +{- | +The function defined here are based on the interpretation +of event lists as piecewise constant signals. +They do not fit to the interpretation of atomic events. +Because e.g. it makes no sense to split an atomic event into two instances by splitAt, +and it is also not clear, whether dropping the first chunk +shall leave a chunk of length zero +or remove that chunk completely. +-} +instance CutG.Transform NoteOffList where + take n (NoteOffList xs) = + NoteOffList $ + EventListTT.takeTime + (NonNegW.fromNumberMsg "NoteOffList.take" $ fromIntegral n) xs + drop n (NoteOffList xs) = + NoteOffList $ + EventListTT.dropTime + (NonNegW.fromNumberMsg "NoteOffList.drop" $ fromIntegral n) xs + splitAt n (NoteOffList xs) = + mapPair (NoteOffList, NoteOffList) $ + EventListTT.splitAtTime + (NonNegW.fromNumberMsg "NoteOffList.splitAtTime" $ fromIntegral n) xs + + -- cf. ChunkySize.dropMarginRem + dropMarginRem = + CutG.dropMarginRemChunky + (fmap fromIntegral . EventListTT.getTimes . unwrapNoteOffList) + + reverse (NoteOffList xs) = + NoteOffList . EventListTT.reverse $ xs + + +findEvent :: + (a -> Bool) -> + Events a -> (Events a, Maybe a) +findEvent p = + EventListTT.foldr + (\t -> mapFst (EventListMT.consTime t)) + (\evs rest -> + case ListHT.break p evs of + (prefix, suffix) -> + mapFst (EventListMT.consBody prefix) $ + case suffix of + [] -> rest + ev:_ -> (EventListTT.pause mempty, Just ev)) + (EventListBT.empty, Nothing) + +gateFromNoteOffs :: + (MIDIEv.Pitch, NoteId) -> + NoteOffList -> + GateChunk +gateFromNoteOffs pitchNoteId (NoteOffList noteOffs) = + let dur = EventListTT.duration noteOffs + (sustain, mEnd) = + findEvent + (\bnd -> + case bnd of + -- AllNotesOff -> True + NoteBoundary endPitch _ noteId -> + pitchNoteId == (endPitch, noteId)) + noteOffs + in Gate.chunk dur $ + flip fmap mEnd $ \end -> + (EventListTT.duration sustain, + case end of + NoteBoundary _ endVel _ -> endVel + {- + AllNotesOff -> VoiceMsg.normalVelocity -} ) + + +data NoteBoundary a = + NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a +-- | AllSoundOff + deriving (Eq, Show) + +{- | +We count NoteIds per pitch, +such that the pair (pitch,noteId) identifies a note. +We treat nested notes in a first-in-first-out order (FIFO). +E.g. + +> On, On, On, Off, Off, Off + +is interpreted as + +> On 0, On 1, On 2, Off 0, Off 1, Off 2 + +NoteOffs without previous NoteOns are thrown away. +-} +assignNoteIds :: + (Traversable f) => + PIO.T + (f [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)]) + (f [NoteBoundary (NoteId, Maybe MIDIEv.Program)]) +assignNoteIds = + fmap concat + ^<< + traverse Map.empty (\bnd -> + case bnd of + MIDIEv.AllNotesOff -> do + notes <- MS.get + MS.put Map.empty + return $ + concatMap (\(pitch, range) -> + map + (\noteId -> + NoteBoundary pitch VoiceMsg.normalVelocity + (noteId, Nothing)) + (flattenNoteIdRange range)) $ + Map.toList notes + MIDIEv.NoteBoundary pitch vel mpgm -> + fmap (fmap (\noteId -> + NoteBoundary pitch vel (noteId,mpgm))) $ + case mpgm of + Nothing -> do + mNoteId <- MS.gets (Map.lookup pitch) + case mNoteId of + Nothing -> return [] + Just (nextNoteOffId, nextNoteOnId) -> + if nextNoteOffId >= nextNoteOnId + then return [] + else do + MS.modify (Map.insert pitch (succNoteId nextNoteOffId, nextNoteOnId)) + return [nextNoteOffId] + Just _ -> do + mNoteId <- MS.gets (Map.lookup pitch) + let (nextNoteOffId, nextNoteOnId) = + case mNoteId of + Nothing -> (NoteId 0, NoteId 0) + Just ids -> ids + + MS.modify (Map.insert pitch (nextNoteOffId, succNoteId nextNoteOnId)) + return [nextNoteOnId]) + +{-# INLINE velFreqBank #-} +velFreqBank :: + (Trans.C y) => + (MIDIEv.Program -> y -> y -> process) -> + (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> process) +velFreqBank bank pgm vel pitch = + bank pgm (MV.velocity vel) (MV.frequencyFromPitch pitch) + +applyInstrumentCore :: + (Arrow arrow) => + ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) -> + (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> + PIO.T gateCtrl chunk) -> + arrow + (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) + (Zip.T + NoteOffList + (Events (PIO.T noteOffListCtrl chunk))) +applyInstrumentCore makeGate bank = arr $ + uncurry Zip.Cons . + mapFst NoteOffList . + EventListTT.unzip . + fmap (ListHT.unzipEithers . fmap (\ev -> + case ev of +-- MIDIEv.AllNotesOff -> Left MIDIEv.AllNotesOff + NoteBoundary pitch vel (noteId, mpgm) -> + case mpgm of + Nothing -> Left $ NoteBoundary pitch vel noteId + Just pgm -> + Right $ + bank pgm vel pitch + <<^ + makeGate (pitch, noteId))) + +applyInstrument :: + (Arrow arrow) => + (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> + PIO.T GateChunk chunk) -> + arrow + (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) + (Zip.T + NoteOffList + (Events (PIO.T NoteOffList chunk))) +applyInstrument bank = + applyInstrumentCore gateFromNoteOffs bank + + +type ModulatedBank y ctrl chunk = + MIDIEv.Program -> y -> y -> + PIO.T (Zip.T GateChunk ctrl) chunk + +applyModulatedInstrument :: + (Arrow arrow, CutG.Read ctrl) => + (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> + PIO.T (Zip.T GateChunk ctrl) chunk) -> + arrow + (Zip.T + (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) + ctrl) + (Zip.T + (Zip.T NoteOffList ctrl) + (Events (PIO.T (Zip.T NoteOffList ctrl) chunk))) +applyModulatedInstrument bank = + (\(Zip.Cons (Zip.Cons noteOffs events) ctrl) -> + Zip.Cons (Zip.Cons noteOffs ctrl) events) + ^<< + Zip.arrowFirst + (applyInstrumentCore + (Zip.arrowFirst . gateFromNoteOffs) bank) + + +{- | +Turn an event list with bundles of elements +into an event list with single events. +ToDo: Move to event-list package? +-} +flatten :: + (NonNeg.C time) => + a -> + EventListTT.T time [a] -> + EventListTT.T time a +flatten empty = + EventListTT.foldr + EventListMT.consTime + (\bt xs -> + uncurry EventListMT.consBody $ + case bt of + [] -> (empty, xs) + b:bs -> (b, foldr (\c rest -> EventListTT.cons NonNeg.zero c rest) xs bs)) + EventListBT.empty + + +flattenControlSchedule :: + (Monoid chunk, Arrow arrow) => + arrow + (Zip.T ctrl + (EventListTT.T StrictTime [PIO.T ctrl chunk])) + (Zip.T ctrl + (EventListTT.T StrictTime (PIO.T ctrl chunk))) +flattenControlSchedule = arr $ + \(Zip.Cons ctrl evs) -> + -- Zip.consChecked "flattenControlSchedule" ctrl $ + Zip.Cons ctrl $ + flatten (arr (const mempty)) evs + + + +data CausalState a b = + forall state. + CausalState + (a -> state -> IO (b, state)) + (state -> IO ()) + state + +_applyChunkSimple :: CausalState a b -> a -> IO (b, CausalState a b) +_applyChunkSimple (CausalState next delete state0) input = do + (output, state1) <- next input state0 + return (output, CausalState next delete state1) + +applyChunk :: + (CutG.Read a, CutG.Read b) => + CausalState a b -> a -> IO (b, Maybe (CausalState a b)) +applyChunk (CausalState next delete state0) input = do + (output, state1) <- next input state0 + cs <- + if CutG.length output < CutG.length input + then do + delete state1 + return Nothing + else return $ Just $ CausalState next delete state1 + return (output, cs) + +-- could be moved to synthesizer-core +applyModulation :: + (CutG.Transform ctrl, CutG.NormalForm ctrl, + CutG.Read chunk, + Monoid time, ToInteger.C time) => + PIO.T + (Zip.T ctrl (EventListTT.T time (PIO.T ctrl chunk))) + (EventListTT.T time chunk) +applyModulation = PIO.Cons + (\(Zip.Cons ctrl evs) acc0 -> do + acc1 <- mapM (flip applyChunk ctrl) acc0 + let (accChunks, acc2) = unzip acc1 + + (newChunks, newAcc) <- + MW.runWriterT $ + flip MS.evalStateT ctrl $ + EventListTT.mapM + (\time -> do + ctrl_ <- MS.gets (CutG.drop (fromIntegral time)) + MS.put ctrl_ + return (case CutG.evaluateHead ctrl_ of () -> time)) + (\(PIO.Cons next create delete) -> do + state0 <- liftIO create + (chunk, state1) <- + liftIO . applyChunk (CausalState next delete state0) + =<< MS.get + MT.lift $ MW.tell $ maybeToList state1 + return chunk) + evs + + return + (EventListTM.prependBodyEnd + (EventList.fromPairList $ + map ((,) mempty) accChunks) + newChunks, + Maybe.catMaybes acc2 ++ newAcc)) + + (return []) + (mapM_ (\(CausalState _ close state) -> close state)) + +-- move synthesizer-core:CausalIO +arrangeStorable :: + (Arrow arrow, Storable a, Additive.C a) => + arrow + (EventListTT.T StrictTime (SV.Vector a)) + (SV.Vector a) +arrangeStorable = + arr $ \evs -> + SVST.runSTVector (do + v <- SVST.new (fromIntegral $ EventListTT.duration evs) zero + mapM_ (uncurry $ CutSt.addChunkToBuffer v) $ + AbsEventList.toPairList $ + AbsEventList.mapTime fromIntegral $ + EventList.toAbsoluteEventList 0 $ + EventListTM.switchTimeR const evs + return v) + + + +sequenceCore :: + (Check.C event, Monoid chunk, CutG.Read chunk, Trans.C y) => + MIDIEv.Channel -> + Bank y chunk -> + PIO.T (Events event) (EventListTT.T StrictTime chunk) +sequenceCore channel bank = + applyModulation + . + flattenControlSchedule + . + applyInstrument (velFreqBank bank) + . + assignNoteIds + . + embedPrograms (VoiceMsg.toProgram 0) + . + noteEvents channel + + +sequenceModulated :: + (Check.C event, Monoid chunk, CutG.Read chunk, + CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) => + MIDIEv.Channel -> + ModulatedBank y ctrl chunk -> + PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk) +sequenceModulated channel bank = + applyModulation + . + flattenControlSchedule + . + applyModulatedInstrument (velFreqBank bank) + . + Zip.arrowFirst + (assignNoteIds + . + embedPrograms (VoiceMsg.toProgram 0) + . + noteEvents channel) + + +sequenceModulatedMultiProgram :: + (Check.C event, Monoid chunk, CutG.Read chunk, + CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) => + MIDIEv.Channel -> + MIDIEv.Program -> + ModulatedBank y ctrl chunk -> + PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk) +sequenceModulatedMultiProgram channel initPgm bank = + applyModulation + . + flattenControlSchedule + . + applyModulatedInstrument (velFreqBank bank) + . + Zip.arrowFirst + (assignNoteIds + . + embedPrograms initPgm + . + noteEvents channel) + + +-- | may replace the other functions +sequenceModulatedMultiProgramVelocityPitch :: + (Check.C event, Monoid chunk, CutG.Read chunk, + CutG.Transform ctrl, CutG.NormalForm ctrl) => + MIDIEv.Channel -> + MIDIEv.Program -> + (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> + PIO.T (Zip.T GateChunk ctrl) chunk) -> + PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk) +sequenceModulatedMultiProgramVelocityPitch channel initPgm bank = + applyModulation + . + flattenControlSchedule + . + applyModulatedInstrument bank + . + Zip.arrowFirst + (assignNoteIds + . + embedPrograms initPgm + . + noteEvents channel) + + +sequenceStorable :: + (Check.C event, Storable a, Additive.C a, Trans.C y) => + MIDIEv.Channel -> + Bank y (SV.Vector a) -> + PIO.T (Events event) (SV.Vector a) +sequenceStorable channel bank = + arrangeStorable + . + sequenceCore channel bank diff --git a/tests/examples/pre-ghc910/Process1.hs b/tests/examples/pre-ghc910/Process1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Process1.hs @@ -0,0 +1,7 @@ +module Synthesizer.MIDI.CausalIO.Process1 where + +gateFromNoteOffs= + let dur = 1 + in (d, 3 + {- + AllNotesOff -> VoiceMsg.normalVelocity -} ) diff --git a/tests/examples/pre-ghc910/Process2.hs b/tests/examples/pre-ghc910/Process2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Process2.hs @@ -0,0 +1,8 @@ +module Process2 where + +type Events event = Ev event + +instance Transform NoteOffList where + + -- comment + dropMarginRem = undefined diff --git a/tests/examples/pre-ghc910/PromotedClass.hs b/tests/examples/pre-ghc910/PromotedClass.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/PromotedClass.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeInType, GADTs #-} + +module PromotedClass where + +import Data.Proxy + +data X a where + MkX :: Show a => a -> X a + +foo :: Proxy ('MkX 'True) +foo = Proxy diff --git a/tests/examples/pre-ghc910/Pseudonym.hs b/tests/examples/pre-ghc910/Pseudonym.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/PuncFunctions.hs b/tests/examples/pre-ghc910/PuncFunctions.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Q.hs b/tests/examples/pre-ghc910/Q.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/QQ.hs b/tests/examples/pre-ghc910/QQ.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/QuasiQuote.hs b/tests/examples/pre-ghc910/QuasiQuote.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/QuasiQuote2.hs b/tests/examples/pre-ghc910/QuasiQuote2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/QuasiQuote2.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} +module Test where + +a = bar + where + bar = [q| + |] + +b = bar + where + bar = [q| + |] + +c = bar + where + bar = [q| + |] + +d = [q| + |] diff --git a/tests/examples/pre-ghc910/Query.hs b/tests/examples/pre-ghc910/Query.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Query.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} + +module AWS.Lib.Query where + +requestQuery = do + if st < 400 +#ifdef DEBUG + do e +#else + then return body + else fail "not reached" +#endif + diff --git a/tests/examples/pre-ghc910/RAE_T32a.hs b/tests/examples/pre-ghc910/RAE_T32a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/RAE_T32a.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds, + PolyKinds, TypeFamilies, GADTs, TypeInType #-} + +module RAE_T32a where + +import Data.Kind + +data family Sing (k :: Type) :: k -> Type + +data TyArr' (a :: Type) (b :: Type) :: Type +type TyArr (a :: Type) (b :: Type) = TyArr' a b -> Type +type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2 +data TyPi' (a :: Type) (b :: TyArr a Type) :: Type +type TyPi (a :: Type) (b :: TyArr a Type) = TyPi' a b -> Type +type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b +$(return []) + +data MkStar (p :: Type) (x :: TyArr' p Type) +type instance MkStar p @@ x = Type +$(return []) + +data Sigma (p :: Type) (r :: TyPi p (MkStar p)) :: Type where + Sigma :: + forall (p :: Type) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a). + Sing Type p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b -> Sigma p r +$(return []) + +data instance Sing Sigma (Sigma p r) x where + SSigma :: + forall (p :: Type) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a) + (sp :: Sing Type p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) (sb :: Sing (r @@@ a) b). + Sing (Sing (r @@@ a) b) sb -> + Sing (Sigma p r) ('Sigma sp sr sa sb) + +-- I (RAE) believe this last definition is ill-typed. diff --git a/tests/examples/pre-ghc910/RAE_T32b.hs b/tests/examples/pre-ghc910/RAE_T32b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/RAE_T32b.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, DataKinds, PolyKinds, + RankNTypes, TypeOperators, TypeInType #-} + +module RAE_T32b where + +import Data.Kind + +data family Sing (k :: Type) :: k -> Type + +data TyArr (a :: Type) (b :: Type) :: Type +type family (a :: TyArr k1 k2 -> Type) @@ (b :: k1) :: k2 +$(return []) + +data Sigma (p :: Type) (r :: TyArr p Type -> Type) :: Type where + Sigma :: forall (p :: Type) (r :: TyArr p Type -> Type) (a :: p) (b :: r @@ a). + Sing Type p -> Sing (TyArr p Type -> Type) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r +$(return []) + +data instance Sing (Sigma p r) (x :: Sigma p r) :: Type where + SSigma :: forall (p :: Type) (r :: TyArr p Type -> Type) (a :: p) (b :: r @@ a) + (sp :: Sing Type p) (sr :: Sing (TyArr p Type -> Type) r) (sa :: Sing p a) (sb :: Sing (r @@ a) b). + Sing (Sing (r @@ a) b) sb -> + Sing (Sigma p r) ('Sigma sp sr sa sb) diff --git a/tests/examples/pre-ghc910/RList.hs b/tests/examples/pre-ghc910/RList.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/RList.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE TypeOperators, EmptyDataDecls, RankNTypes #-} +{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds, KindSignatures #-} +{-# LANGUAGE GADTs, TypeInType, PatternGuards #-} + +-- | +-- Module : Data.Type.RList +-- Copyright : (c) 2016 Edwin Westbrook +-- +-- License : BSD3 +-- +-- Maintainer : westbrook@galois.com +-- Stability : experimental +-- Portability : GHC +-- +-- A /right list/, or 'RList', is a list where cons adds to the end, or the +-- right-hand side, of a list. This is useful conceptually for contexts of +-- name-bindings, where the most recent name-binding is intuitively at the end +-- of the context. + +module Data.Type.RList where + +import Prelude hiding (map, foldr) +import Data.Kind +import Data.Type.Equality +import Data.Proxy (Proxy(..)) +import Data.Functor.Constant +import Data.Typeable + +------------------------------------------------------------------------------- +-- * Right-lists as a datatype +------------------------------------------------------------------------------- + +-- | A form of lists where elements are added to the right instead of the left +data RList a + = RNil + | (RList a) :> a + +-- | Append two 'RList's at the type level +type family ((r1 :: RList k) :++: (r2 :: RList k)) :: RList k +infixr 5 :++: +type instance (r :++: 'RNil) = r +type instance (r1 :++: (r2 ':> a)) = (r1 :++: r2) ':> a + +------------------------------------------------------------------------------- +-- * Proofs of membership in a type-level list +------------------------------------------------------------------------------- + +{-| + A @Member ctx a@ is a \"proof\" that the type @a@ is in the type + list @ctx@, meaning that @ctx@ equals + +> t0 ':>' a ':>' t1 ':>' ... ':>' tn + + for some types @t0,t1,...,tn@. +-} +data Member (ctx :: RList k1) (a :: k2) where + Member_Base :: Member (ctx :> a) a + Member_Step :: Member ctx a -> Member (ctx :> b) a + deriving Typeable + +instance Show (Member r a) where + showsPrec p = showsPrecMember (p > 10) where + showsPrecMember :: Bool -> Member ctx a -> ShowS + showsPrecMember _ Member_Base = showString "Member_Base" + showsPrecMember p (Member_Step prf) = showParen p $ + showString "Member_Step" . showsPrec 10 prf + +instance TestEquality (Member ctx) where + testEquality Member_Base Member_Base = Just Refl + testEquality (Member_Step memb1) (Member_Step memb2) + | Just Refl <- testEquality memb1 memb2 + = Just Refl + testEquality _ _ = Nothing + +instance Eq (Member ctx a) where + Member_Base == Member_Base = True + (Member_Step memb1) == (Member_Step memb2) = memb1 == memb2 + _ == _ = False + +--toEq :: Member (Nil :> a) b -> b :~: a +--toEq Member_Base = Refl +--toEq _ = error "Should not happen! (toEq)" + +-- | Weaken a 'Member' proof by prepending another context to the context it +-- proves membership in +weakenMemberL :: Proxy r1 -> Member r2 a -> Member (r1 :++: r2) a +weakenMemberL _ Member_Base = Member_Base +weakenMemberL tag (Member_Step mem) = Member_Step (weakenMemberL tag mem) + + +------------------------------------------------------------ +-- * Proofs that one list equals the append of two others +------------------------------------------------------------ + +{-| + An @Append ctx1 ctx2 ctx@ is a \"proof\" that @ctx = ctx1 ':++:' ctx2@. +-} +data Append ctx1 ctx2 ctx where + Append_Base :: Append ctx RNil ctx + Append_Step :: Append ctx1 ctx2 ctx -> Append ctx1 (ctx2 :> a) (ctx :> a) + +-- | Make an 'Append' proof from any 'RAssign' vector for the second +-- argument of the append. +mkAppend :: RAssign f c2 -> Append c1 c2 (c1 :++: c2) +mkAppend MNil = Append_Base +mkAppend (c :>: _) = Append_Step (mkAppend c) + +-- | A version of 'mkAppend' that takes in a 'Proxy' argument. +mkMonoAppend :: Proxy c1 -> RAssign f c2 -> Append c1 c2 (c1 :++: c2) +mkMonoAppend _ = mkAppend + +-- | The inverse of 'mkAppend', that builds an 'RAssign' from an 'Append' +proxiesFromAppend :: Append c1 c2 c -> RAssign Proxy c2 +proxiesFromAppend Append_Base = MNil +proxiesFromAppend (Append_Step a) = proxiesFromAppend a :>: Proxy + + +------------------------------------------------------------------------------- +-- * Contexts +------------------------------------------------------------------------------- + +{-| + An @RAssign f r@ an assignment of an @f a@ for each @a@ in the 'RList' @r@ +-} +data RAssign (f :: k -> *) (c :: RList k) where + MNil :: RAssign f RNil + (:>:) :: RAssign f c -> f a -> RAssign f (c :> a) + +-- | Create an empty 'RAssign' vector. +empty :: RAssign f RNil +empty = MNil + +-- | Create a singleton 'RAssign' vector. +singleton :: f a -> RAssign f (RNil :> a) +singleton x = MNil :>: x + +-- | Look up an element of an 'RAssign' vector using a 'Member' proof +get :: Member c a -> RAssign f c -> f a +get Member_Base (_ :>: x) = x +get (Member_Step mem') (mc :>: _) = get mem' mc + +-- | Heterogeneous type application, including a proof that the input kind of +-- the function equals the kind of the type argument +data HApply (f :: k1 -> Type) (a :: k2) where + HApply :: forall k (f :: k -> Type) (a :: k). f a -> HApply f a + +-- | Look up an element of an 'RAssign' vector using a 'Member' proof at what +-- GHC thinks might be a different kind, i.e., heterogeneously +hget :: forall k1 k2 (f :: k1 -> Type) (c :: RList k1) (a :: k2). + Member c a -> RAssign f c -> HApply f a +hget Member_Base (_ :>: x) = HApply x +hget (Member_Step mem') (mc :>: _) = hget mem' mc + +-- | Modify an element of an 'RAssign' vector using a 'Member' proof. +modify :: Member c a -> (f a -> f a) -> RAssign f c -> RAssign f c +modify Member_Base f (xs :>: x) = xs :>: f x +modify (Member_Step mem') f (xs :>: x) = modify mem' f xs :>: x + +-- | Set an element of an 'RAssign' vector using a 'Member' proof. +set :: Member c a -> f a -> RAssign f c -> RAssign f c +set memb x = modify memb (const x) + +-- | Test if an object is in an 'RAssign', returning a 'Member' proof if it is +memberElem :: TestEquality f => f a -> RAssign f ctx -> Maybe (Member ctx a) +memberElem _ MNil = Nothing +memberElem x (_ :>: y) | Just Refl <- testEquality x y = Just Member_Base +memberElem x (xs :>: _) = fmap Member_Step $ memberElem x xs + +-- | Map a function on all elements of an 'RAssign' vector. +map :: (forall x. f x -> g x) -> RAssign f c -> RAssign g c +map _ MNil = MNil +map f (mc :>: x) = map f mc :>: f x + +-- | An alternate name for 'map' that does not clash with the prelude +mapRAssign :: (forall x. f x -> g x) -> RAssign f c -> RAssign g c +mapRAssign = map + +-- | Map a binary function on all pairs of elements of two 'RAssign' vectors. +map2 :: (forall x. f x -> g x -> h x) -> + RAssign f c -> RAssign g c -> RAssign h c +map2 _ MNil MNil = MNil +map2 f (xs :>: x) (ys :>: y) = map2 f xs ys :>: f x y + +-- | Take the tail of an 'RAssign' +tail :: RAssign f (ctx :> a) -> RAssign f ctx +tail (xs :>: _) = xs + +-- | Convert a monomorphic 'RAssign' to a list +toList :: RAssign (Constant a) c -> [a] +toList = mapToList getConstant + +-- | Map a function with monomorphic output type across an 'RAssign' to create a +-- standard list: +-- +-- > mapToList f = toList . map (Constant . f) +mapToList :: (forall a. f a -> b) -> RAssign f ctx -> [b] +mapToList _ MNil = [] +mapToList f (xs :>: x) = mapToList f xs ++ [f x] + +-- | Append two 'RAssign' vectors. +append :: RAssign f c1 -> RAssign f c2 -> RAssign f (c1 :++: c2) +append mc MNil = mc +append mc1 (mc2 :>: x) = append mc1 mc2 :>: x + +-- | Perform a right fold across an 'RAssign' +foldr :: (forall a. f a -> r -> r) -> r -> RAssign f ctx -> r +foldr _ r MNil = r +foldr f r (xs :>: x) = f x $ foldr f r xs + +-- | Split an 'RAssign' vector into two pieces. The first argument is a +-- phantom argument that gives the form of the first list piece. +split :: (c ~ (c1 :++: c2)) => prx c1 -> + RAssign any c2 -> RAssign f c -> (RAssign f c1, RAssign f c2) +split _ MNil mc = (mc, MNil) +split _ (any :>: _) (mc :>: x) = (mc1, mc2 :>: x) + where (mc1, mc2) = split Proxy any mc + +-- | Create a vector of proofs that each type in @c@ is a 'Member' of @c@. +members :: RAssign f c -> RAssign (Member c) c +members MNil = MNil +members (c :>: _) = map Member_Step (members c) :>: Member_Base + +-- | A type-class which ensures that ctx is a valid context, i.e., has +-- | the form (RNil :> t1 :> ... :> tn) for some types t1 through tn +class TypeCtx ctx where + typeCtxProxies :: RAssign Proxy ctx + +instance TypeCtx RNil where + typeCtxProxies = MNil + +instance TypeCtx ctx => TypeCtx (ctx :> a) where + typeCtxProxies = typeCtxProxies :>: Proxy + diff --git a/tests/examples/pre-ghc910/RSA.hs b/tests/examples/pre-ghc910/RSA.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Rae31.hs b/tests/examples/pre-ghc910/Rae31.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Rae31.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds, + TypeFamilies, TypeInType #-} + +module A where + +import Data.Kind + +data family Sing (k :: Type) :: k -> Type +type Sing' (x :: k) = Sing k x +data TyFun' (a :: Type) (b :: Type) :: Type +type TyFun (a :: Type) (b :: Type) = TyFun' a b -> Type +type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2 +data TyPi' (a :: Type) (b :: TyFun a Type) :: Type +type TyPi (a :: Type) (b :: TyFun a Type) = TyPi' a b -> Type +type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b +$(return []) + +data A (a :: Type) (b :: a) (c :: TyFun' a Type) -- A :: forall a -> a -> a ~> Type +type instance (@@) (A a b) c = Type +$(return []) +data B (a :: Type) (b :: TyFun' a Type) -- B :: forall a -> a ~> Type +type instance (@@) (B a) b = TyPi a (A a b) +$(return []) +data C (a :: Type) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) Type) diff --git a/tests/examples/pre-ghc910/RaeBlogPost.hs b/tests/examples/pre-ghc910/RaeBlogPost.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/RaeBlogPost.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies, + TypeInType #-} +{-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-} + +module RaeBlogPost where + +import Data.Kind + +-- a Proxy type with an explicit kind +data Proxy k (a :: k) = P +prox :: Proxy * Bool +prox = P + +prox2 :: Proxy Bool 'True +prox2 = P + +-- implicit kinds still work +data A +data B :: A -> Type +data C :: B a -> Type +data D :: C b -> Type +data E :: D c -> Type +-- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> Type + +-- a kind-indexed GADT +data TypeRep (a :: k) where + TInt :: TypeRep Int + TMaybe :: TypeRep Maybe + TApp :: TypeRep a -> TypeRep b -> TypeRep (a b) + +zero :: TypeRep a -> a +zero TInt = 0 +zero (TApp TMaybe _) = Nothing + +data Nat = Zero | Succ Nat +type family a + b where + 'Zero + b = b + ('Succ a) + b = 'Succ (a + b) + +data Vec :: Type -> Nat -> Type where + Nil :: Vec a 'Zero + (:>) :: a -> Vec a n -> Vec a ('Succ n) +infixr 5 :> + +-- promoted GADT, and using + as a "kind family": +type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where + 'Nil ++ y = y + (h ':> t) ++ y = h ':> (t ++ y) + +-- datatype that mentions Type +data U = Star (Type) + | Bool Bool + +-- kind synonym +type Monadish = Type -> Type +class MonadTrans (t :: Monadish -> Monadish) where + lift :: Monad m => m a -> t m a +data Free :: Monadish where + Return :: a -> Free a + Bind :: Free a -> (a -> Free b) -> Free b + +-- yes, Type really does have type Type. +type Star = (Type :: (Type :: (Type :: Type))) diff --git a/tests/examples/pre-ghc910/RandomPGC1.hs b/tests/examples/pre-ghc910/RandomPGC1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/RandomPGC1.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} + +module RandomPGC where + +#ifdef __GLASGOW_HASKELL__ +#endif + +-- A comment +#ifdef __NHC__ +#else +getTime = 2 +#endif + diff --git a/tests/examples/pre-ghc910/RankNTypes.hs b/tests/examples/pre-ghc910/RankNTypes.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/RdrNames.hs b/tests/examples/pre-ghc910/RdrNames.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/RdrNames.hs @@ -0,0 +1,149 @@ +{-# 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 ( ~ ) 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] } + +-- --------------------------------------------------------------------- + + +{- From #haskell-emacs +gracjan> did you know that this is legal haskell: + (+ 1) ` fmap {- -} ` [1,2,3] +-} +xxx = (+ 1) ` fmap {- -} ` [1,2,3] diff --git a/tests/examples/pre-ghc910/RebindableSyntax.hs b/tests/examples/pre-ghc910/RebindableSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/RecordSemi.hs b/tests/examples/pre-ghc910/RecordSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/RecordUpdate.hs b/tests/examples/pre-ghc910/RecordUpdate.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/RecordWildcard.hs b/tests/examples/pre-ghc910/RecordWildcard.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/RecordWildcard.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RecordWildCards #-} + + +parseArgs = + Args + { equalProb = E `elem` opts + , .. + } diff --git a/tests/examples/pre-ghc910/Records.hs b/tests/examples/pre-ghc910/Records.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Records.hs @@ -0,0 +1,14 @@ +module Records where + +data Record = Record + { rOne :: Int + , rTwo :: String + } + +defR :: Record +defR = Record 1 "record" + +main :: IO () +main = do + print $ defR { rOne = 42 } + print $ Record { rTwo = "foo" } diff --git a/tests/examples/pre-ghc910/Records2.hs b/tests/examples/pre-ghc910/Records2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Records2.hs @@ -0,0 +1,14 @@ +module Records where + +data Record = Record + { rOne :: Int + , rTwo :: String + } + +defR :: Record +defR = Record 1 "record" + +main :: IO () +main = do + print $ defR { rOne = 42 + 12 } + print $ Record { rTwo = "foo" ++ "foo" } diff --git a/tests/examples/pre-ghc910/RecursiveDo.hs b/tests/examples/pre-ghc910/RecursiveDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/RedundantDo.hs b/tests/examples/pre-ghc910/RedundantDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/RedundantDo.hs @@ -0,0 +1,4 @@ +foo = + case x of + True -> foo + False -> foo diff --git a/tests/examples/pre-ghc910/Remorse.hs b/tests/examples/pre-ghc910/Remorse.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/RenamingStar.hs b/tests/examples/pre-ghc910/RenamingStar.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/RenamingStar.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeInType #-} + +module RenamingStar where + +data Foo :: Type diff --git a/tests/examples/pre-ghc910/RepArrow.hs b/tests/examples/pre-ghc910/RepArrow.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Retrie.hs b/tests/examples/pre-ghc910/Retrie.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Retrie.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedSums #-} +module Types4a where + +import Data.Maybe hiding (f1,f2,n1,n2) + +type Foo5 = forall r (a :: Type) (b :: TYPE r). (a -> b) -> a -> b + +foo5 :: forall s (c :: Type) (d :: TYPE s). (c -> d) -> c -> d +foo5 = ($) diff --git a/tests/examples/pre-ghc910/RmDecl4.hs b/tests/examples/pre-ghc910/RmDecl4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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 -- comment + xx = 2 + +-- EOF diff --git a/tests/examples/pre-ghc910/Roles.hs b/tests/examples/pre-ghc910/Roles.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Roles12a.hs b/tests/examples/pre-ghc910/Roles12a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Roles12a.hs @@ -0,0 +1,2 @@ +module Roles12a where +import {-# SOURCE #-} Roles12 diff --git a/tests/examples/pre-ghc910/RuleDefiningPlugin.hs b/tests/examples/pre-ghc910/RuleDefiningPlugin.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/RulePragma.hs b/tests/examples/pre-ghc910/RulePragma.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/RulePragma.hs @@ -0,0 +1,7 @@ +module Data.Text.Internal.Fusion.Common where + +{-# + RULES "STREAM map/map fusion" forall f g s. + map f (map g s) = map (\x -> f (g x)) s + #-} + diff --git a/tests/examples/pre-ghc910/Rules.hs b/tests/examples/pre-ghc910/Rules.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/RulesSemi.hs b/tests/examples/pre-ghc910/RulesSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap1.hs b/tests/examples/pre-ghc910/SH_Overlap1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap10.hs b/tests/examples/pre-ghc910/SH_Overlap10.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap10_A.hs b/tests/examples/pre-ghc910/SH_Overlap10_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap10_B.hs b/tests/examples/pre-ghc910/SH_Overlap10_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap11.hs b/tests/examples/pre-ghc910/SH_Overlap11.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap11_A.hs b/tests/examples/pre-ghc910/SH_Overlap11_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap11_B.hs b/tests/examples/pre-ghc910/SH_Overlap11_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap1_A.hs b/tests/examples/pre-ghc910/SH_Overlap1_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap1_B.hs b/tests/examples/pre-ghc910/SH_Overlap1_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap2.hs b/tests/examples/pre-ghc910/SH_Overlap2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap2_A.hs b/tests/examples/pre-ghc910/SH_Overlap2_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap2_B.hs b/tests/examples/pre-ghc910/SH_Overlap2_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap3.hs b/tests/examples/pre-ghc910/SH_Overlap3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap3_A.hs b/tests/examples/pre-ghc910/SH_Overlap3_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap3_B.hs b/tests/examples/pre-ghc910/SH_Overlap3_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap4.hs b/tests/examples/pre-ghc910/SH_Overlap4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap4_A.hs b/tests/examples/pre-ghc910/SH_Overlap4_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap4_B.hs b/tests/examples/pre-ghc910/SH_Overlap4_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap5.hs b/tests/examples/pre-ghc910/SH_Overlap5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap5_A.hs b/tests/examples/pre-ghc910/SH_Overlap5_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap5_B.hs b/tests/examples/pre-ghc910/SH_Overlap5_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap6.hs b/tests/examples/pre-ghc910/SH_Overlap6.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap6_A.hs b/tests/examples/pre-ghc910/SH_Overlap6_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap6_B.hs b/tests/examples/pre-ghc910/SH_Overlap6_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap7.hs b/tests/examples/pre-ghc910/SH_Overlap7.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap7_A.hs b/tests/examples/pre-ghc910/SH_Overlap7_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap7_B.hs b/tests/examples/pre-ghc910/SH_Overlap7_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap8.hs b/tests/examples/pre-ghc910/SH_Overlap8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap8_A.hs b/tests/examples/pre-ghc910/SH_Overlap8_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap9.hs b/tests/examples/pre-ghc910/SH_Overlap9.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap9_A.hs b/tests/examples/pre-ghc910/SH_Overlap9_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SH_Overlap9_B.hs b/tests/examples/pre-ghc910/SH_Overlap9_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ST.hs b/tests/examples/pre-ghc910/ST.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ST.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnboxedSums #-} + +{-# OPTIONS_GHC -O2 #-} + +module Packed.Bytes.Stream.ST + ( ByteStream(..) + , empty + , unpack + , fromBytes + ) where + +import Data.Primitive (Array,ByteArray(..)) +import Data.Semigroup (Semigroup) +import Data.Word (Word8) +import GHC.Exts (RealWorld,State#,Int#,ByteArray#) +import GHC.Int (Int(I#)) +import GHC.ST (ST(..)) +import Packed.Bytes (Bytes(..)) +import System.IO (Handle) +import qualified Data.Primitive as PM +import qualified Data.Semigroup as SG +import qualified Packed.Bytes as B + +type Bytes# = (# ByteArray#, Int#, Int# #) + +newtype ByteStream s = ByteStream + (State# s -> (# State# s, (# (# #) | (# Bytes# , ByteStream s #) #) #) ) + +fromBytes :: Bytes -> ByteStream s +fromBytes b = ByteStream + (\s0 -> (# s0, (# | (# unboxBytes b, empty #) #) #)) + +nextChunk :: ByteStream s -> ST s (Maybe (Bytes,ByteStream s)) +nextChunk (ByteStream f) = ST $ \s0 -> case f s0 of + (# s1, r #) -> case r of + (# (# #) | #) -> (# s1, Nothing #) + (# | (# theBytes, theStream #) #) -> (# s1, Just (boxBytes theBytes, theStream) #) + +empty :: ByteStream s +empty = ByteStream (\s -> (# s, (# (# #) | #) #) ) + +boxBytes :: Bytes# -> Bytes +boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c) + +unboxBytes :: Bytes -> Bytes# +unboxBytes (Bytes (ByteArray a) (I# b) (I# c)) = (# a,b,c #) + +unpack :: ByteStream s -> ST s [Word8] +unpack stream = ST (unpackInternal stream) + +unpackInternal :: ByteStream s -> State# s -> (# State# s, [Word8] #) +unpackInternal (ByteStream f) s0 = case f s0 of + (# s1, r #) -> case r of + (# (# #) | #) -> (# s1, [] #) + (# | (# bytes, stream #) #) -> case unpackInternal stream s1 of + (# s2, ws #) -> (# s2, B.unpack (boxBytes bytes) ++ ws #) + diff --git a/tests/examples/pre-ghc910/SayAnnNames.hs b/tests/examples/pre-ghc910/SayAnnNames.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ScopedTypeVariables.hs b/tests/examples/pre-ghc910/ScopedTypeVariables.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ScopesBug.hs b/tests/examples/pre-ghc910/ScopesBug.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ScopesBug.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} + +module ScopesBug where + +data Proxy (a :: k) = Proxy +data Con k (a :: k) = Con (Proxy a) + +tyApp :: Con k a -> Proxy a +tyApp (Con @kx @ax (x :: Proxy ax)) = x :: Proxy (ax :: kx) + diff --git a/tests/examples/pre-ghc910/SelfDep.hs b/tests/examples/pre-ghc910/SelfDep.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/SelfDep.hs @@ -0,0 +1,3 @@ +module SelfDep where + +data T :: T -> * diff --git a/tests/examples/pre-ghc910/SemiInstance.hs b/tests/examples/pre-ghc910/SemiInstance.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SemiWorkout.hs b/tests/examples/pre-ghc910/SemiWorkout.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SemicolonIf.hs b/tests/examples/pre-ghc910/SemicolonIf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/SemicolonIf.hs @@ -0,0 +1,15 @@ +module Bar where + +import Data.Text as Text + +replace :: Text -> Text +replace = Text.map (\c -> if c == '_' then '.'; else c) + +replace1 :: Text -> Text +replace1 = Text.map (\c -> if c == '_' ; then '.' else c) + +replace2 :: Text -> Text +replace2 = Text.map (\c -> if c == '_'; then '.'; else c) + +replace4 :: Text -> Text +replace4 = Text.map (\c -> if c == '_' then '.' else c) diff --git a/tests/examples/pre-ghc910/SemigroupWarnings.hs b/tests/examples/pre-ghc910/SemigroupWarnings.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/SemigroupWarnings.hs @@ -0,0 +1,34 @@ +-- Test purpose: +-- Ensure that missing semigroup warnings are issued +-- correctly if the warning flag is enabled + +{-# OPTIONS_GHC -fwarn-semigroup #-} + +module SemigroupWarnings where + + + +import Data.Semigroup + + + +-- Bad instance, should complain about missing Semigroup parent +data LacksSemigroup +instance Monoid LacksSemigroup where + mempty = undefined + mappend = undefined + + + +-- Correct instance, should not warn +data HasSemigroup +instance Semigroup HasSemigroup where + (<>) = undefined +instance Monoid HasSemigroup where + mempty = undefined + mappend = undefined + + + +-- Should issue a Prelude clash warning +(<>) = undefined diff --git a/tests/examples/pre-ghc910/Setup.hs b/tests/examples/pre-ghc910/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/tests/examples/pre-ghc910/Shebang.hs b/tests/examples/pre-ghc910/Shebang.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Shebang.hs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell +{-# LANGUAGE OverloadedStrings #-} +import Aws.SSSP.App + +main = web diff --git a/tests/examples/pre-ghc910/ShiftingLambda.hs b/tests/examples/pre-ghc910/ShiftingLambda.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ShouldFail.hs b/tests/examples/pre-ghc910/ShouldFail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ShouldFail.hs @@ -0,0 +1,1 @@ +import Set diff --git a/tests/examples/pre-ghc910/SigTvKinds.hs b/tests/examples/pre-ghc910/SigTvKinds.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/SigTvKinds.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PolyKinds #-} + +module SigTvKinds where + +data T (a :: k1) x = MkT (S a ()) +data S (b :: k2) y = MkS (T b ()) + -- tests TcTyClsDecls.no_sig_tv diff --git a/tests/examples/pre-ghc910/SigTvKinds2.hs b/tests/examples/pre-ghc910/SigTvKinds2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/SigTvKinds2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PolyKinds #-} + +module SigTvKinds2 where + +data SameKind :: k -> k -> * + +data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) diff --git a/tests/examples/pre-ghc910/Sigs.hs b/tests/examples/pre-ghc910/Sigs.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Simple.hs b/tests/examples/pre-ghc910/Simple.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Simple.hs @@ -0,0 +1,12 @@ + +-- blah +x :: (Int) +x = 1 + +(y) = 1 + +z :: t +z = do + let + a = 1 + return a diff --git a/tests/examples/pre-ghc910/SimpleComplexTuple.hs b/tests/examples/pre-ghc910/SimpleComplexTuple.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/SimpleComplexTuple.hs @@ -0,0 +1,3 @@ + + +foo ((-),(.))= (5,6) diff --git a/tests/examples/pre-ghc910/SimpleDo.hs b/tests/examples/pre-ghc910/SimpleDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/SimpleDo.hs @@ -0,0 +1,4 @@ + +foo = do + let x = 1 -- a comment + return x diff --git a/tests/examples/pre-ghc910/SlidingDataClassDecl.hs b/tests/examples/pre-ghc910/SlidingDataClassDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SlidingDoClause.hs b/tests/examples/pre-ghc910/SlidingDoClause.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SlidingLambda.hs b/tests/examples/pre-ghc910/SlidingLambda.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SlidingListComp.hs b/tests/examples/pre-ghc910/SlidingListComp.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SlidingRecordSetter.hs b/tests/examples/pre-ghc910/SlidingRecordSetter.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SlidingTypeSyn.hs b/tests/examples/pre-ghc910/SlidingTypeSyn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/SlidingTypeSyn.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + + +type ( f :-> g) (r :: Type -> Type) 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/pre-ghc910/SpacesSplice.hs b/tests/examples/pre-ghc910/SpacesSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/SpacesSplice.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TemplateHaskell #-} + +makeLenses '' PostscriptFont diff --git a/tests/examples/pre-ghc910/SpecializePhaseControl.hs b/tests/examples/pre-ghc910/SpecializePhaseControl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/SpecializePhaseControl.hs @@ -0,0 +1,15 @@ +{-# SPECIALISE [1] x :: + Integer -> Integer -> Integer, + Integer -> Int -> Integer, + Int -> Int -> Int #-} +{-# INLINABLE [1] x #-} +x :: (Num a, Integral b) => a -> b -> a +x = undefined + +{-# SPECIALISE INLINE [999] y :: + Integer -> Integer -> Integer, + Integer -> Int -> Integer, + Int -> Int -> Int #-} +{-# INLINABLE [1] y #-} +y :: (Num a, Integral b) => a -> b -> a +y = undefined diff --git a/tests/examples/pre-ghc910/Splice.hs b/tests/examples/pre-ghc910/Splice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Splice.hs @@ -0,0 +1,49 @@ +{-# 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 + +makeLenses '' PostscriptFont + +$(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/pre-ghc910/SpliceSemi.hs b/tests/examples/pre-ghc910/SpliceSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/SpliceSemi.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} + + +$(makePredicates ''TheType) ; $(makePredicatesNot ''TheType) diff --git a/tests/examples/pre-ghc910/Splices.hs b/tests/examples/pre-ghc910/Splices.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/SplicesUsed.hs b/tests/examples/pre-ghc910/SplicesUsed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/StackOverflow.hs b/tests/examples/pre-ghc910/StackOverflow.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/StackOverflow.hs @@ -0,0 +1,4 @@ +main :: IO () +main = main' () + where + main' _ = main >> main' () diff --git a/tests/examples/pre-ghc910/StarBinder.hs b/tests/examples/pre-ghc910/StarBinder.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/StarBinder.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeOperators, TypeFamilies #-} +{-# OPTIONS -Wno-star-is-type #-} + +module X (type (X.*)) where + +type family (*) a b where { (*) a b = Either b a } + diff --git a/tests/examples/pre-ghc910/StaticPointers.hs b/tests/examples/pre-ghc910/StaticPointers.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Stmts.hs b/tests/examples/pre-ghc910/Stmts.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Stmts.hs @@ -0,0 +1,26 @@ +module Stmts where + +-- Make sure we get all the semicolons in statements +;;;; ;; +import Data.List +; ; ; +import Data.Maybe + ; ;; +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/pre-ghc910/StrangeTypeClass.hs b/tests/examples/pre-ghc910/StrangeTypeClass.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Stream.hs b/tests/examples/pre-ghc910/Stream.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/StrictLet.hs b/tests/examples/pre-ghc910/StrictLet.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/StringGap.hs b/tests/examples/pre-ghc910/StringGap.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/StringRef.hs b/tests/examples/pre-ghc910/StringRef.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/StringRef.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances, TypeSynonymInstances #-} +{-# LANGUAGE LambdaCase #-} + +module Data.Binary.StringRef + ( ListOfStringable(..) + , StringReferencingBinary(..) + , IntLen(..) + , ls_encode + , ls_decode + ) where + +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get +import Control.Monad +import Control.Applicative ((<$>)) +import Data.List +import Data.ByteString.Lazy (ByteString) +import qualified Data.MyText as T +import Data.MyText (Text, decodeUtf8, encodeUtf8) +import Debug.Trace + +class StringReferencingBinary a => ListOfStringable a where + listOfStrings :: a -> [Text] + +-- | An extended version of Binary that passes the list of strings of the +-- previous sample +class StringReferencingBinary a where + ls_put :: [Text] -> a -> Put + ls_get :: [Text] -> Get a + +------------------------------------------------------------------------ +-- Instances for the first few tuples + +instance (StringReferencingBinary a, StringReferencingBinary b) => StringReferencingBinary (a,b) where + ls_put strs (a,b) = ls_put strs a >> ls_put strs b + ls_get strs = liftM2 (,) (ls_get strs) (ls_get strs) + +instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c) => StringReferencingBinary (a,b,c) where + ls_put strs (a,b,c) = ls_put strs a >> ls_put strs b >> ls_put strs c + ls_get strs = liftM3 (,,) (ls_get strs) (ls_get strs) (ls_get strs) + +instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c, StringReferencingBinary d) => StringReferencingBinary (a,b,c,d) where + ls_put strs (a,b,c,d) = ls_put strs a >> ls_put strs b >> ls_put strs c >> ls_put strs d + ls_get strs = liftM4 (,,,) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs) + +instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c, StringReferencingBinary d, StringReferencingBinary e) => StringReferencingBinary (a,b,c,d,e) where + ls_put strs (a,b,c,d,e) = ls_put strs a >> ls_put strs b >> ls_put strs c >> ls_put strs d >> ls_put strs e + ls_get strs = liftM5 (,,,,) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs) + + +newtype CompactNum a = CompactNum { fromCompactNum :: a } + +instance (Integral a, Num a, Binary a) => StringReferencingBinary (CompactNum a) where + ls_put _ (CompactNum i) + | 0 <= i && i < 255 = putWord8 (fromIntegral i) + | otherwise = putWord8 255 >> put i + ls_get _ = fmap CompactNum $ getWord8 >>= \case + i | 0 <= i && i < 255 -> return (fromIntegral i) + | otherwise -> get + +instance StringReferencingBinary a => StringReferencingBinary [a] where + ls_put strs l = ls_put strs (CompactNum (length l)) >> mapM_ (ls_put strs) l + ls_get strs = ls_getMany strs . fromCompactNum =<< ls_get strs + +instance StringReferencingBinary Text where + ls_put strs s = case elemIndex s strs of + Just i | 0 <= i && i < 255 -> + putWord8 (fromIntegral (succ i)) + _ -> putWord8 0 >> ls_put strs (T.unpack s) + ls_get strs = getWord8 >>= \case + 0 -> T.pack <$> ls_get strs + i -> return $! strs !! fromIntegral (pred i) + +-- | 'ls_get strsMany n' ls_get strs 'n' elements in order, without blowing the stack. +ls_getMany :: StringReferencingBinary a => [Text] -> Int -> Get [a] +ls_getMany strs n = go [] n + where + go xs 0 = return $! reverse xs + go xs i = do x <- ls_get strs + -- we must seq x to avoid stack overflows due to laziness in + -- (>>=) + x `seq` go (x:xs) (i-1) +{-# INLINE ls_getMany #-} + + +-- compat newtype for deserialization of v2-v4 CaptureData +newtype IntLen a = IntLen { fromIntLen :: a } + +-- compat instance for deserialization of v1 CaptureData +instance Binary a => Binary (IntLen a) where + put = put . fromIntLen + get = IntLen <$> get + +-- compat instance for deserialization of v2-v4 CaptureData +instance StringReferencingBinary a => StringReferencingBinary (IntLen [a]) where + ls_put strs (IntLen l) = ls_put strs (length l) >> mapM_ (ls_put strs) l + ls_get strs = fmap IntLen $ ls_getMany strs =<< ls_get strs + +-- compat instance for deserialization of v2-v4 CaptureData +instance StringReferencingBinary (IntLen Text) where + ls_put strs (IntLen s) = case elemIndex s strs of + Just i | 0 <= i && i < 255 -> + putWord8 (fromIntegral (succ i)) + _ -> putWord8 0 >> ls_put strs (IntLen (T.unpack s)) + ls_get strs = fmap IntLen $ getWord8 >>= \case + 0 -> T.pack . fromIntLen <$> ls_get strs + i -> return $! strs !! fromIntegral (pred i) + +{- +instance Binary a => StringReferencingBinary a where + ls_put _ = put + ls_get _ = get +-} + +instance StringReferencingBinary Char where { ls_put _ = put; ls_get _ = get } +instance StringReferencingBinary Int where { ls_put _ = put; ls_get _ = get } +instance StringReferencingBinary Integer where { ls_put _ = put; ls_get _ = get } +instance StringReferencingBinary Bool where { ls_put _ = put; ls_get _ = get } + +ls_encode :: StringReferencingBinary a => [Text] -> a -> ByteString +ls_encode strs = runPut . ls_put strs +{-# INLINE ls_encode #-} + +-- | Decode a value from a lazy ByteString, reconstructing the original structure. +-- +ls_decode :: StringReferencingBinary a => [Text] -> ByteString -> a +ls_decode strs = runGet (ls_get strs) + diff --git a/tests/examples/pre-ghc910/Structure8.hs b/tests/examples/pre-ghc910/Structure8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Structure8.hs @@ -0,0 +1,1 @@ +foo x | otherwise = y diff --git a/tests/examples/pre-ghc910/Structure8a.hs b/tests/examples/pre-ghc910/Structure8a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Structure8a.hs @@ -0,0 +1,1 @@ +foo x = y diff --git a/tests/examples/pre-ghc910/T10009.hs b/tests/examples/pre-ghc910/T10009.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10030.hs b/tests/examples/pre-ghc910/T10030.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10041.hs b/tests/examples/pre-ghc910/T10041.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10045.hs b/tests/examples/pre-ghc910/T10045.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10045.hs @@ -0,0 +1,8 @@ +module T10045 where + +newtype Meta = Meta () + +foo (Meta ws1) = + let copy :: _ + copy w from = copy w True + in copy ws1 False diff --git a/tests/examples/pre-ghc910/T10047.hs b/tests/examples/pre-ghc910/T10047.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10052-input.hs b/tests/examples/pre-ghc910/T10052-input.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10052-input.hs @@ -0,0 +1,1 @@ +main = let (x :: String) = "hello" in putStrLn x diff --git a/tests/examples/pre-ghc910/T10052.hs b/tests/examples/pre-ghc910/T10052.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10083.hs b/tests/examples/pre-ghc910/T10083.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10083a.hs b/tests/examples/pre-ghc910/T10083a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10100.hs b/tests/examples/pre-ghc910/T10100.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10104.hs b/tests/examples/pre-ghc910/T10104.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10109.hs b/tests/examples/pre-ghc910/T10109.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10110A.hs b/tests/examples/pre-ghc910/T10110A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10110A.hs @@ -0,0 +1,4 @@ +module T10110A (a) where +{-# NOINLINE a #-} +a :: Int +a = 3 diff --git a/tests/examples/pre-ghc910/T10110B.hs b/tests/examples/pre-ghc910/T10110B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10110B.hs @@ -0,0 +1,3 @@ +module T10110B (b) where +b :: Int +b = 5 diff --git a/tests/examples/pre-ghc910/T10110C.hs b/tests/examples/pre-ghc910/T10110C.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10112.hs b/tests/examples/pre-ghc910/T10112.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10134.hs b/tests/examples/pre-ghc910/T10134.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10134a.hs b/tests/examples/pre-ghc910/T10134a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10134a.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module T10134a where + +import GHC.TypeLits + +data Vec :: Nat -> Type -> Type where + Nil :: Vec 0 a + (:>) :: a -> Vec n a -> Vec (n + 1) a diff --git a/tests/examples/pre-ghc910/T10139.hs b/tests/examples/pre-ghc910/T10139.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10141.hs b/tests/examples/pre-ghc910/T10141.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10148.hs b/tests/examples/pre-ghc910/T10148.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10156.hs b/tests/examples/pre-ghc910/T10156.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10180.hs b/tests/examples/pre-ghc910/T10180.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10181.hs b/tests/examples/pre-ghc910/T10181.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10181.hs @@ -0,0 +1,3 @@ +module T10181 where + +t a = t a diff --git a/tests/examples/pre-ghc910/T10182.hs b/tests/examples/pre-ghc910/T10182.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10182.hs @@ -0,0 +1,4 @@ +module T10182 where +import T10182a +instance Show (a -> b) where + show _ = "" diff --git a/tests/examples/pre-ghc910/T10182a.hs b/tests/examples/pre-ghc910/T10182a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10182a.hs @@ -0,0 +1,2 @@ +module T10182a where +import {-# SOURCE #-} T10182 diff --git a/tests/examples/pre-ghc910/T10184.hs b/tests/examples/pre-ghc910/T10184.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10185.hs b/tests/examples/pre-ghc910/T10185.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10188.hs b/tests/examples/pre-ghc910/T10188.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10194.hs b/tests/examples/pre-ghc910/T10194.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10195.hs b/tests/examples/pre-ghc910/T10195.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10196.1.hs b/tests/examples/pre-ghc910/T10196.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10196.1.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/pre-ghc910/T10196.hs b/tests/examples/pre-ghc910/T10196.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10215.hs b/tests/examples/pre-ghc910/T10215.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10215.hs @@ -0,0 +1,9 @@ +testF :: Float -> Bool +testF x = x == 0 && not (isNegativeZero x) + +testD :: Double -> Bool +testD x = x == 0 && not (isNegativeZero x) + +main :: IO () +main = do print $ testF (-0.0) + print $ testD (-0.0) diff --git a/tests/examples/pre-ghc910/T10218.hs b/tests/examples/pre-ghc910/T10218.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10220B.hs b/tests/examples/pre-ghc910/T10220B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10220B.hs @@ -0,0 +1,1 @@ +module T10220B where diff --git a/tests/examples/pre-ghc910/T10226.hs b/tests/examples/pre-ghc910/T10226.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10233.hs b/tests/examples/pre-ghc910/T10233.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10233.hs @@ -0,0 +1,2 @@ +module T10233 where +import T10233a( Constraint, Int ) diff --git a/tests/examples/pre-ghc910/T10233a.hs b/tests/examples/pre-ghc910/T10233a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10233a.hs @@ -0,0 +1,3 @@ +module T10233a ( module GHC.Exts ) where +import GHC.Exts ( Constraint, Int ) + diff --git a/tests/examples/pre-ghc910/T10245.hs b/tests/examples/pre-ghc910/T10245.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10246.hs b/tests/examples/pre-ghc910/T10246.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10251.hs b/tests/examples/pre-ghc910/T10251.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10263.hs b/tests/examples/pre-ghc910/T10263.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10263.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +module T10263 where + +data Maybe a = AF +type role Maybe representational diff --git a/tests/examples/pre-ghc910/T10267.hs b/tests/examples/pre-ghc910/T10267.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10267.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T10267 where + +import Language.Haskell.TH +import T10267a + +[d| i :: a -> a + i = _foo + + j :: a -> a + j x = _ |] + +$(return [ + SigD (mkName "k") + (ForallT [PlainTV (mkName "a")] + [] + (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) + , FunD (mkName "k") + [Clause [] (NormalB (UnboundVarE (mkName "_foo"))) []] + ]) + +$(return [ + SigD (mkName "l") + (ForallT [PlainTV (mkName "a")] + [] + (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) + , FunD (mkName "l") + [Clause [VarP (mkName "x")] (NormalB (UnboundVarE (mkName "_"))) []] + ]) + +foo :: a -> a +foo x = $varX diff --git a/tests/examples/pre-ghc910/T10267a.hs b/tests/examples/pre-ghc910/T10267a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10267a.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T10267a where + +import Language.Haskell.TH + +varX :: Q Exp +varX = [| x |] diff --git a/tests/examples/pre-ghc910/T10279.1.hs b/tests/examples/pre-ghc910/T10279.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10279.1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module T10279 where +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +-- NB: rts-1.0 is used here because it doesn't change. +-- You do need to pick the right version number, otherwise the +-- error message doesn't recognize it as a source package ID, +-- (This is OK, since it will look obviously wrong when they +-- try to find the package in their package database.) +blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A")))) diff --git a/tests/examples/pre-ghc910/T10279.hs b/tests/examples/pre-ghc910/T10279.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10279.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +module T10279 where +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +-- NB: rts-1.0 is used here because it doesn't change. +-- You do need to pick the right version number, otherwise the +-- error message doesn't recognize it as a source package ID, +-- (This is OK, since it will look obviously wrong when they +-- try to find the package in their package database.) +blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A")))) + diff --git a/tests/examples/pre-ghc910/T10283.hs b/tests/examples/pre-ghc910/T10283.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10284.hs b/tests/examples/pre-ghc910/T10284.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10285.hs b/tests/examples/pre-ghc910/T10285.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10285a.hs b/tests/examples/pre-ghc910/T10285a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10294.hs b/tests/examples/pre-ghc910/T10294.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10294.hs @@ -0,0 +1,7 @@ +module T10294 where + +import SayAnnNames + +{-# ANN foo SomeAnn #-} +foo :: () +foo = () diff --git a/tests/examples/pre-ghc910/T10294a.hs b/tests/examples/pre-ghc910/T10294a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10294a.hs @@ -0,0 +1,7 @@ +module T10294a where + +import SayAnnNames +import Data.Data + +baz :: Constr +baz = toConstr SomeAnn diff --git a/tests/examples/pre-ghc910/T10306.hs b/tests/examples/pre-ghc910/T10306.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10318.hs b/tests/examples/pre-ghc910/T10318.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10318.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, + FlexibleInstances, TypeFamilies, + UndecidableSuperClasses #-} + +module T10318 where + +-- | Product of non-zero elements always non-zero. +-- Every integral domain has a field of fractions. +-- The field of fractions of any field is itself. +class (Frac (Frac a) ~ Frac a, Fractional (Frac a), IntegralDomain (Frac a)) + => IntegralDomain a where + type Frac a :: * + embed :: a -> Frac a + +instance IntegralDomain Integer where + type Frac Integer = Rational + embed = fromInteger + +instance IntegralDomain Rational where + type Frac Rational = Rational + embed = id + +g :: IntegralDomain a => a -> a +g x = g x + +h :: a -> Frac a +h x = h x + +-- This is the test function + +f :: IntegralDomain a => a -> Frac a +f x = g (h (h x)) + -- Given: IntegralDomain (Frac a) + -- Wanted: IntegralDomain (Frac (Frac a)) + diff --git a/tests/examples/pre-ghc910/T10321.hs b/tests/examples/pre-ghc910/T10321.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10321.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module T10321 where + +import GHC.TypeLits + +data Vec :: Nat -> Type -> Type where + Nil :: Vec 0 a + (:>) :: a -> Vec n a -> Vec (n + 1) a + +infixr 5 :> diff --git a/tests/examples/pre-ghc910/T10322A.hs b/tests/examples/pre-ghc910/T10322A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10322A.hs @@ -0,0 +1,4 @@ +module T10322A (a) where +{-# NOINLINE a #-} +a :: Int +a = 3 diff --git a/tests/examples/pre-ghc910/T10322B.hs b/tests/examples/pre-ghc910/T10322B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10322B.hs @@ -0,0 +1,4 @@ +module T10322B (b) where +import T10322A (a) +b :: Int +b = a+1 diff --git a/tests/examples/pre-ghc910/T10322C.hs b/tests/examples/pre-ghc910/T10322C.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10335.hs b/tests/examples/pre-ghc910/T10335.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10340.hs b/tests/examples/pre-ghc910/T10340.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10348.hs b/tests/examples/pre-ghc910/T10348.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10351.hs b/tests/examples/pre-ghc910/T10351.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10351.hs @@ -0,0 +1,6 @@ +module T10351 where + +class C a where + op :: a -> () + +f x = op [x] diff --git a/tests/examples/pre-ghc910/T10359.hs b/tests/examples/pre-ghc910/T10359.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10361a.hs b/tests/examples/pre-ghc910/T10361a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10361a.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +module T10361a where + +class C1 a where + type T1 a + type instance T1 a = Char + +class C2 a where -- equivalent to C1 + type T2 a + type instance T2 a = Char + +class C3 a where -- equivalent to C1, C2 + type T3 a + type instance T3 a = Char + +data A = B + deriving C1 + +deriving instance C2 A + +instance C3 A + +test1 :: T1 A +test1 = 'x' + +test2 :: T2 A +test2 = 'x' + +test3 :: T3 A +test3 = 'x' diff --git a/tests/examples/pre-ghc910/T10361b.hs b/tests/examples/pre-ghc910/T10361b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10361b.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module T10361b where + +import GHC.Generics + +--------------------------------------------------------------------- +class Convert a where + type Result a + type instance Result a = GResult (Rep a) + + convert :: a -> Result a + default convert :: (Generic a, GConvert (Rep a)) => a -> GResult (Rep a) + convert x = gconvert (from x) + +instance Convert Float where + type Result Float = Float + convert = id + +instance Convert Int where + type Result Int = Int + convert = id + +--------------------------------------------------------------------- +class GConvert f where + type GResult f + gconvert :: f p -> GResult f + +instance (Convert c) => GConvert (K1 i c) where + type GResult (K1 i c) = Result c + gconvert (K1 x) = convert x + +instance (GConvert f) => GConvert (M1 i t f) where + type GResult (M1 i t f) = GResult f + gconvert (M1 x) = gconvert x + +instance (GConvert f, GConvert g) => GConvert (f :*: g) where + type GResult (f :*: g) = (GResult f, GResult g) + gconvert (x :*: y) = (gconvert x, gconvert y) + +--------------------------------------------------------------------- + +data Data1 = Data1 Int Float + deriving (Generic) + +instance Convert Data1 + +val :: (Int, Float) +val = convert $ Data1 0 0.0 + +data Data2 = Data2 Int Float + deriving (Generic, Convert) diff --git a/tests/examples/pre-ghc910/T10370.hs b/tests/examples/pre-ghc910/T10370.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10370.hs @@ -0,0 +1,1002 @@ +module Out where +import Control.Monad (forever) +a1 :: IO (); a1 = forever $ putStrLn "a1" +a2 :: IO (); a2 = forever $ putStrLn "a2" +a3 :: IO (); a3 = forever $ putStrLn "a3" +a4 :: IO (); a4 = forever $ putStrLn "a4" +a5 :: IO (); a5 = forever $ putStrLn "a5" +a6 :: IO (); a6 = forever $ putStrLn "a6" +a7 :: IO (); a7 = forever $ putStrLn "a7" +a8 :: IO (); a8 = forever $ putStrLn "a8" +a9 :: IO (); a9 = forever $ putStrLn "a9" +a10 :: IO (); a10 = forever $ putStrLn "a10" +a11 :: IO (); a11 = forever $ putStrLn "a11" +a12 :: IO (); a12 = forever $ putStrLn "a12" +a13 :: IO (); a13 = forever $ putStrLn "a13" +a14 :: IO (); a14 = forever $ putStrLn "a14" +a15 :: IO (); a15 = forever $ putStrLn "a15" +a16 :: IO (); a16 = forever $ putStrLn "a16" +a17 :: IO (); a17 = forever $ putStrLn "a17" +a18 :: IO (); a18 = forever $ putStrLn "a18" +a19 :: IO (); a19 = forever $ putStrLn "a19" +a20 :: IO (); a20 = forever $ putStrLn "a20" +a21 :: IO (); a21 = forever $ putStrLn "a21" +a22 :: IO (); a22 = forever $ putStrLn "a22" +a23 :: IO (); a23 = forever $ putStrLn "a23" +a24 :: IO (); a24 = forever $ putStrLn "a24" +a25 :: IO (); a25 = forever $ putStrLn "a25" +a26 :: IO (); a26 = forever $ putStrLn "a26" +a27 :: IO (); a27 = forever $ putStrLn "a27" +a28 :: IO (); a28 = forever $ putStrLn "a28" +a29 :: IO (); a29 = forever $ putStrLn "a29" +a30 :: IO (); a30 = forever $ putStrLn "a30" +a31 :: IO (); a31 = forever $ putStrLn "a31" +a32 :: IO (); a32 = forever $ putStrLn "a32" +a33 :: IO (); a33 = forever $ putStrLn "a33" +a34 :: IO (); a34 = forever $ putStrLn "a34" +a35 :: IO (); a35 = forever $ putStrLn "a35" +a36 :: IO (); a36 = forever $ putStrLn "a36" +a37 :: IO (); a37 = forever $ putStrLn "a37" +a38 :: IO (); a38 = forever $ putStrLn "a38" +a39 :: IO (); a39 = forever $ putStrLn "a39" +a40 :: IO (); a40 = forever $ putStrLn "a40" +a41 :: IO (); a41 = forever $ putStrLn "a41" +a42 :: IO (); a42 = forever $ putStrLn "a42" +a43 :: IO (); a43 = forever $ putStrLn "a43" +a44 :: IO (); a44 = forever $ putStrLn "a44" +a45 :: IO (); a45 = forever $ putStrLn "a45" +a46 :: IO (); a46 = forever $ putStrLn "a46" +a47 :: IO (); a47 = forever $ putStrLn "a47" +a48 :: IO (); a48 = forever $ putStrLn "a48" +a49 :: IO (); a49 = forever $ putStrLn "a49" +a50 :: IO (); a50 = forever $ putStrLn "a50" +a51 :: IO (); a51 = forever $ putStrLn "a51" +a52 :: IO (); a52 = forever $ putStrLn "a52" +a53 :: IO (); a53 = forever $ putStrLn "a53" +a54 :: IO (); a54 = forever $ putStrLn "a54" +a55 :: IO (); a55 = forever $ putStrLn "a55" +a56 :: IO (); a56 = forever $ putStrLn "a56" +a57 :: IO (); a57 = forever $ putStrLn "a57" +a58 :: IO (); a58 = forever $ putStrLn "a58" +a59 :: IO (); a59 = forever $ putStrLn "a59" +a60 :: IO (); a60 = forever $ putStrLn "a60" +a61 :: IO (); a61 = forever $ putStrLn "a61" +a62 :: IO (); a62 = forever $ putStrLn "a62" +a63 :: IO (); a63 = forever $ putStrLn "a63" +a64 :: IO (); a64 = forever $ putStrLn "a64" +a65 :: IO (); a65 = forever $ putStrLn "a65" +a66 :: IO (); a66 = forever $ putStrLn "a66" +a67 :: IO (); a67 = forever $ putStrLn "a67" +a68 :: IO (); a68 = forever $ putStrLn "a68" +a69 :: IO (); a69 = forever $ putStrLn "a69" +a70 :: IO (); a70 = forever $ putStrLn "a70" +a71 :: IO (); a71 = forever $ putStrLn "a71" +a72 :: IO (); a72 = forever $ putStrLn "a72" +a73 :: IO (); a73 = forever $ putStrLn "a73" +a74 :: IO (); a74 = forever $ putStrLn "a74" +a75 :: IO (); a75 = forever $ putStrLn "a75" +a76 :: IO (); a76 = forever $ putStrLn "a76" +a77 :: IO (); a77 = forever $ putStrLn "a77" +a78 :: IO (); a78 = forever $ putStrLn "a78" +a79 :: IO (); a79 = forever $ putStrLn "a79" +a80 :: IO (); a80 = forever $ putStrLn "a80" +a81 :: IO (); a81 = forever $ putStrLn "a81" +a82 :: IO (); a82 = forever $ putStrLn "a82" +a83 :: IO (); a83 = forever $ putStrLn "a83" +a84 :: IO (); a84 = forever $ putStrLn "a84" +a85 :: IO (); a85 = forever $ putStrLn "a85" +a86 :: IO (); a86 = forever $ putStrLn "a86" +a87 :: IO (); a87 = forever $ putStrLn "a87" +a88 :: IO (); a88 = forever $ putStrLn "a88" +a89 :: IO (); a89 = forever $ putStrLn "a89" +a90 :: IO (); a90 = forever $ putStrLn "a90" +a91 :: IO (); a91 = forever $ putStrLn "a91" +a92 :: IO (); a92 = forever $ putStrLn "a92" +a93 :: IO (); a93 = forever $ putStrLn "a93" +a94 :: IO (); a94 = forever $ putStrLn "a94" +a95 :: IO (); a95 = forever $ putStrLn "a95" +a96 :: IO (); a96 = forever $ putStrLn "a96" +a97 :: IO (); a97 = forever $ putStrLn "a97" +a98 :: IO (); a98 = forever $ putStrLn "a98" +a99 :: IO (); a99 = forever $ putStrLn "a99" +a100 :: IO (); a100 = forever $ putStrLn "a100" +a101 :: IO (); a101 = forever $ putStrLn "a101" +a102 :: IO (); a102 = forever $ putStrLn "a102" +a103 :: IO (); a103 = forever $ putStrLn "a103" +a104 :: IO (); a104 = forever $ putStrLn "a104" +a105 :: IO (); a105 = forever $ putStrLn "a105" +a106 :: IO (); a106 = forever $ putStrLn "a106" +a107 :: IO (); a107 = forever $ putStrLn "a107" +a108 :: IO (); a108 = forever $ putStrLn "a108" +a109 :: IO (); a109 = forever $ putStrLn "a109" +a110 :: IO (); a110 = forever $ putStrLn "a110" +a111 :: IO (); a111 = forever $ putStrLn "a111" +a112 :: IO (); a112 = forever $ putStrLn "a112" +a113 :: IO (); a113 = forever $ putStrLn "a113" +a114 :: IO (); a114 = forever $ putStrLn "a114" +a115 :: IO (); a115 = forever $ putStrLn "a115" +a116 :: IO (); a116 = forever $ putStrLn "a116" +a117 :: IO (); a117 = forever $ putStrLn "a117" +a118 :: IO (); a118 = forever $ putStrLn "a118" +a119 :: IO (); a119 = forever $ putStrLn "a119" +a120 :: IO (); a120 = forever $ putStrLn "a120" +a121 :: IO (); a121 = forever $ putStrLn "a121" +a122 :: IO (); a122 = forever $ putStrLn "a122" +a123 :: IO (); a123 = forever $ putStrLn "a123" +a124 :: IO (); a124 = forever $ putStrLn "a124" +a125 :: IO (); a125 = forever $ putStrLn "a125" +a126 :: IO (); a126 = forever $ putStrLn "a126" +a127 :: IO (); a127 = forever $ putStrLn "a127" +a128 :: IO (); a128 = forever $ putStrLn "a128" +a129 :: IO (); a129 = forever $ putStrLn "a129" +a130 :: IO (); a130 = forever $ putStrLn "a130" +a131 :: IO (); a131 = forever $ putStrLn "a131" +a132 :: IO (); a132 = forever $ putStrLn "a132" +a133 :: IO (); a133 = forever $ putStrLn "a133" +a134 :: IO (); a134 = forever $ putStrLn "a134" +a135 :: IO (); a135 = forever $ putStrLn "a135" +a136 :: IO (); a136 = forever $ putStrLn "a136" +a137 :: IO (); a137 = forever $ putStrLn "a137" +a138 :: IO (); a138 = forever $ putStrLn "a138" +a139 :: IO (); a139 = forever $ putStrLn "a139" +a140 :: IO (); a140 = forever $ putStrLn "a140" +a141 :: IO (); a141 = forever $ putStrLn "a141" +a142 :: IO (); a142 = forever $ putStrLn "a142" +a143 :: IO (); a143 = forever $ putStrLn "a143" +a144 :: IO (); a144 = forever $ putStrLn "a144" +a145 :: IO (); a145 = forever $ putStrLn "a145" +a146 :: IO (); a146 = forever $ putStrLn "a146" +a147 :: IO (); a147 = forever $ putStrLn "a147" +a148 :: IO (); a148 = forever $ putStrLn "a148" +a149 :: IO (); a149 = forever $ putStrLn "a149" +a150 :: IO (); a150 = forever $ putStrLn "a150" +a151 :: IO (); a151 = forever $ putStrLn "a151" +a152 :: IO (); a152 = forever $ putStrLn "a152" +a153 :: IO (); a153 = forever $ putStrLn "a153" +a154 :: IO (); a154 = forever $ putStrLn "a154" +a155 :: IO (); a155 = forever $ putStrLn "a155" +a156 :: IO (); a156 = forever $ putStrLn "a156" +a157 :: IO (); a157 = forever $ putStrLn "a157" +a158 :: IO (); a158 = forever $ putStrLn "a158" +a159 :: IO (); a159 = forever $ putStrLn "a159" +a160 :: IO (); a160 = forever $ putStrLn "a160" +a161 :: IO (); a161 = forever $ putStrLn "a161" +a162 :: IO (); a162 = forever $ putStrLn "a162" +a163 :: IO (); a163 = forever $ putStrLn "a163" +a164 :: IO (); a164 = forever $ putStrLn "a164" +a165 :: IO (); a165 = forever $ putStrLn "a165" +a166 :: IO (); a166 = forever $ putStrLn "a166" +a167 :: IO (); a167 = forever $ putStrLn "a167" +a168 :: IO (); a168 = forever $ putStrLn "a168" +a169 :: IO (); a169 = forever $ putStrLn "a169" +a170 :: IO (); a170 = forever $ putStrLn "a170" +a171 :: IO (); a171 = forever $ putStrLn "a171" +a172 :: IO (); a172 = forever $ putStrLn "a172" +a173 :: IO (); a173 = forever $ putStrLn "a173" +a174 :: IO (); a174 = forever $ putStrLn "a174" +a175 :: IO (); a175 = forever $ putStrLn "a175" +a176 :: IO (); a176 = forever $ putStrLn "a176" +a177 :: IO (); a177 = forever $ putStrLn "a177" +a178 :: IO (); a178 = forever $ putStrLn "a178" +a179 :: IO (); a179 = forever $ putStrLn "a179" +a180 :: IO (); a180 = forever $ putStrLn "a180" +a181 :: IO (); a181 = forever $ putStrLn "a181" +a182 :: IO (); a182 = forever $ putStrLn "a182" +a183 :: IO (); a183 = forever $ putStrLn "a183" +a184 :: IO (); a184 = forever $ putStrLn "a184" +a185 :: IO (); a185 = forever $ putStrLn "a185" +a186 :: IO (); a186 = forever $ putStrLn "a186" +a187 :: IO (); a187 = forever $ putStrLn "a187" +a188 :: IO (); a188 = forever $ putStrLn "a188" +a189 :: IO (); a189 = forever $ putStrLn "a189" +a190 :: IO (); a190 = forever $ putStrLn "a190" +a191 :: IO (); a191 = forever $ putStrLn "a191" +a192 :: IO (); a192 = forever $ putStrLn "a192" +a193 :: IO (); a193 = forever $ putStrLn "a193" +a194 :: IO (); a194 = forever $ putStrLn "a194" +a195 :: IO (); a195 = forever $ putStrLn "a195" +a196 :: IO (); a196 = forever $ putStrLn "a196" +a197 :: IO (); a197 = forever $ putStrLn "a197" +a198 :: IO (); a198 = forever $ putStrLn "a198" +a199 :: IO (); a199 = forever $ putStrLn "a199" +a200 :: IO (); a200 = forever $ putStrLn "a200" +a201 :: IO (); a201 = forever $ putStrLn "a201" +a202 :: IO (); a202 = forever $ putStrLn "a202" +a203 :: IO (); a203 = forever $ putStrLn "a203" +a204 :: IO (); a204 = forever $ putStrLn "a204" +a205 :: IO (); a205 = forever $ putStrLn "a205" +a206 :: IO (); a206 = forever $ putStrLn "a206" +a207 :: IO (); a207 = forever $ putStrLn "a207" +a208 :: IO (); a208 = forever $ putStrLn "a208" +a209 :: IO (); a209 = forever $ putStrLn "a209" +a210 :: IO (); a210 = forever $ putStrLn "a210" +a211 :: IO (); a211 = forever $ putStrLn "a211" +a212 :: IO (); a212 = forever $ putStrLn "a212" +a213 :: IO (); a213 = forever $ putStrLn "a213" +a214 :: IO (); a214 = forever $ putStrLn "a214" +a215 :: IO (); a215 = forever $ putStrLn "a215" +a216 :: IO (); a216 = forever $ putStrLn "a216" +a217 :: IO (); a217 = forever $ putStrLn "a217" +a218 :: IO (); a218 = forever $ putStrLn "a218" +a219 :: IO (); a219 = forever $ putStrLn "a219" +a220 :: IO (); a220 = forever $ putStrLn "a220" +a221 :: IO (); a221 = forever $ putStrLn "a221" +a222 :: IO (); a222 = forever $ putStrLn "a222" +a223 :: IO (); a223 = forever $ putStrLn "a223" +a224 :: IO (); a224 = forever $ putStrLn "a224" +a225 :: IO (); a225 = forever $ putStrLn "a225" +a226 :: IO (); a226 = forever $ putStrLn "a226" +a227 :: IO (); a227 = forever $ putStrLn "a227" +a228 :: IO (); a228 = forever $ putStrLn "a228" +a229 :: IO (); a229 = forever $ putStrLn "a229" +a230 :: IO (); a230 = forever $ putStrLn "a230" +a231 :: IO (); a231 = forever $ putStrLn "a231" +a232 :: IO (); a232 = forever $ putStrLn "a232" +a233 :: IO (); a233 = forever $ putStrLn "a233" +a234 :: IO (); a234 = forever $ putStrLn "a234" +a235 :: IO (); a235 = forever $ putStrLn "a235" +a236 :: IO (); a236 = forever $ putStrLn "a236" +a237 :: IO (); a237 = forever $ putStrLn "a237" +a238 :: IO (); a238 = forever $ putStrLn "a238" +a239 :: IO (); a239 = forever $ putStrLn "a239" +a240 :: IO (); a240 = forever $ putStrLn "a240" +a241 :: IO (); a241 = forever $ putStrLn "a241" +a242 :: IO (); a242 = forever $ putStrLn "a242" +a243 :: IO (); a243 = forever $ putStrLn "a243" +a244 :: IO (); a244 = forever $ putStrLn "a244" +a245 :: IO (); a245 = forever $ putStrLn "a245" +a246 :: IO (); a246 = forever $ putStrLn "a246" +a247 :: IO (); a247 = forever $ putStrLn "a247" +a248 :: IO (); a248 = forever $ putStrLn "a248" +a249 :: IO (); a249 = forever $ putStrLn "a249" +a250 :: IO (); a250 = forever $ putStrLn "a250" +a251 :: IO (); a251 = forever $ putStrLn "a251" +a252 :: IO (); a252 = forever $ putStrLn "a252" +a253 :: IO (); a253 = forever $ putStrLn "a253" +a254 :: IO (); a254 = forever $ putStrLn "a254" +a255 :: IO (); a255 = forever $ putStrLn "a255" +a256 :: IO (); a256 = forever $ putStrLn "a256" +a257 :: IO (); a257 = forever $ putStrLn "a257" +a258 :: IO (); a258 = forever $ putStrLn "a258" +a259 :: IO (); a259 = forever $ putStrLn "a259" +a260 :: IO (); a260 = forever $ putStrLn "a260" +a261 :: IO (); a261 = forever $ putStrLn "a261" +a262 :: IO (); a262 = forever $ putStrLn "a262" +a263 :: IO (); a263 = forever $ putStrLn "a263" +a264 :: IO (); a264 = forever $ putStrLn "a264" +a265 :: IO (); a265 = forever $ putStrLn "a265" +a266 :: IO (); a266 = forever $ putStrLn "a266" +a267 :: IO (); a267 = forever $ putStrLn "a267" +a268 :: IO (); a268 = forever $ putStrLn "a268" +a269 :: IO (); a269 = forever $ putStrLn "a269" +a270 :: IO (); a270 = forever $ putStrLn "a270" +a271 :: IO (); a271 = forever $ putStrLn "a271" +a272 :: IO (); a272 = forever $ putStrLn "a272" +a273 :: IO (); a273 = forever $ putStrLn "a273" +a274 :: IO (); a274 = forever $ putStrLn "a274" +a275 :: IO (); a275 = forever $ putStrLn "a275" +a276 :: IO (); a276 = forever $ putStrLn "a276" +a277 :: IO (); a277 = forever $ putStrLn "a277" +a278 :: IO (); a278 = forever $ putStrLn "a278" +a279 :: IO (); a279 = forever $ putStrLn "a279" +a280 :: IO (); a280 = forever $ putStrLn "a280" +a281 :: IO (); a281 = forever $ putStrLn "a281" +a282 :: IO (); a282 = forever $ putStrLn "a282" +a283 :: IO (); a283 = forever $ putStrLn "a283" +a284 :: IO (); a284 = forever $ putStrLn "a284" +a285 :: IO (); a285 = forever $ putStrLn "a285" +a286 :: IO (); a286 = forever $ putStrLn "a286" +a287 :: IO (); a287 = forever $ putStrLn "a287" +a288 :: IO (); a288 = forever $ putStrLn "a288" +a289 :: IO (); a289 = forever $ putStrLn "a289" +a290 :: IO (); a290 = forever $ putStrLn "a290" +a291 :: IO (); a291 = forever $ putStrLn "a291" +a292 :: IO (); a292 = forever $ putStrLn "a292" +a293 :: IO (); a293 = forever $ putStrLn "a293" +a294 :: IO (); a294 = forever $ putStrLn "a294" +a295 :: IO (); a295 = forever $ putStrLn "a295" +a296 :: IO (); a296 = forever $ putStrLn "a296" +a297 :: IO (); a297 = forever $ putStrLn "a297" +a298 :: IO (); a298 = forever $ putStrLn "a298" +a299 :: IO (); a299 = forever $ putStrLn "a299" +a300 :: IO (); a300 = forever $ putStrLn "a300" +a301 :: IO (); a301 = forever $ putStrLn "a301" +a302 :: IO (); a302 = forever $ putStrLn "a302" +a303 :: IO (); a303 = forever $ putStrLn "a303" +a304 :: IO (); a304 = forever $ putStrLn "a304" +a305 :: IO (); a305 = forever $ putStrLn "a305" +a306 :: IO (); a306 = forever $ putStrLn "a306" +a307 :: IO (); a307 = forever $ putStrLn "a307" +a308 :: IO (); a308 = forever $ putStrLn "a308" +a309 :: IO (); a309 = forever $ putStrLn "a309" +a310 :: IO (); a310 = forever $ putStrLn "a310" +a311 :: IO (); a311 = forever $ putStrLn "a311" +a312 :: IO (); a312 = forever $ putStrLn "a312" +a313 :: IO (); a313 = forever $ putStrLn "a313" +a314 :: IO (); a314 = forever $ putStrLn "a314" +a315 :: IO (); a315 = forever $ putStrLn "a315" +a316 :: IO (); a316 = forever $ putStrLn "a316" +a317 :: IO (); a317 = forever $ putStrLn "a317" +a318 :: IO (); a318 = forever $ putStrLn "a318" +a319 :: IO (); a319 = forever $ putStrLn "a319" +a320 :: IO (); a320 = forever $ putStrLn "a320" +a321 :: IO (); a321 = forever $ putStrLn "a321" +a322 :: IO (); a322 = forever $ putStrLn "a322" +a323 :: IO (); a323 = forever $ putStrLn "a323" +a324 :: IO (); a324 = forever $ putStrLn "a324" +a325 :: IO (); a325 = forever $ putStrLn "a325" +a326 :: IO (); a326 = forever $ putStrLn "a326" +a327 :: IO (); a327 = forever $ putStrLn "a327" +a328 :: IO (); a328 = forever $ putStrLn "a328" +a329 :: IO (); a329 = forever $ putStrLn "a329" +a330 :: IO (); a330 = forever $ putStrLn "a330" +a331 :: IO (); a331 = forever $ putStrLn "a331" +a332 :: IO (); a332 = forever $ putStrLn "a332" +a333 :: IO (); a333 = forever $ putStrLn "a333" +a334 :: IO (); a334 = forever $ putStrLn "a334" +a335 :: IO (); a335 = forever $ putStrLn "a335" +a336 :: IO (); a336 = forever $ putStrLn "a336" +a337 :: IO (); a337 = forever $ putStrLn "a337" +a338 :: IO (); a338 = forever $ putStrLn "a338" +a339 :: IO (); a339 = forever $ putStrLn "a339" +a340 :: IO (); a340 = forever $ putStrLn "a340" +a341 :: IO (); a341 = forever $ putStrLn "a341" +a342 :: IO (); a342 = forever $ putStrLn "a342" +a343 :: IO (); a343 = forever $ putStrLn "a343" +a344 :: IO (); a344 = forever $ putStrLn "a344" +a345 :: IO (); a345 = forever $ putStrLn "a345" +a346 :: IO (); a346 = forever $ putStrLn "a346" +a347 :: IO (); a347 = forever $ putStrLn "a347" +a348 :: IO (); a348 = forever $ putStrLn "a348" +a349 :: IO (); a349 = forever $ putStrLn "a349" +a350 :: IO (); a350 = forever $ putStrLn "a350" +a351 :: IO (); a351 = forever $ putStrLn "a351" +a352 :: IO (); a352 = forever $ putStrLn "a352" +a353 :: IO (); a353 = forever $ putStrLn "a353" +a354 :: IO (); a354 = forever $ putStrLn "a354" +a355 :: IO (); a355 = forever $ putStrLn "a355" +a356 :: IO (); a356 = forever $ putStrLn "a356" +a357 :: IO (); a357 = forever $ putStrLn "a357" +a358 :: IO (); a358 = forever $ putStrLn "a358" +a359 :: IO (); a359 = forever $ putStrLn "a359" +a360 :: IO (); a360 = forever $ putStrLn "a360" +a361 :: IO (); a361 = forever $ putStrLn "a361" +a362 :: IO (); a362 = forever $ putStrLn "a362" +a363 :: IO (); a363 = forever $ putStrLn "a363" +a364 :: IO (); a364 = forever $ putStrLn "a364" +a365 :: IO (); a365 = forever $ putStrLn "a365" +a366 :: IO (); a366 = forever $ putStrLn "a366" +a367 :: IO (); a367 = forever $ putStrLn "a367" +a368 :: IO (); a368 = forever $ putStrLn "a368" +a369 :: IO (); a369 = forever $ putStrLn "a369" +a370 :: IO (); a370 = forever $ putStrLn "a370" +a371 :: IO (); a371 = forever $ putStrLn "a371" +a372 :: IO (); a372 = forever $ putStrLn "a372" +a373 :: IO (); a373 = forever $ putStrLn "a373" +a374 :: IO (); a374 = forever $ putStrLn "a374" +a375 :: IO (); a375 = forever $ putStrLn "a375" +a376 :: IO (); a376 = forever $ putStrLn "a376" +a377 :: IO (); a377 = forever $ putStrLn "a377" +a378 :: IO (); a378 = forever $ putStrLn "a378" +a379 :: IO (); a379 = forever $ putStrLn "a379" +a380 :: IO (); a380 = forever $ putStrLn "a380" +a381 :: IO (); a381 = forever $ putStrLn "a381" +a382 :: IO (); a382 = forever $ putStrLn "a382" +a383 :: IO (); a383 = forever $ putStrLn "a383" +a384 :: IO (); a384 = forever $ putStrLn "a384" +a385 :: IO (); a385 = forever $ putStrLn "a385" +a386 :: IO (); a386 = forever $ putStrLn "a386" +a387 :: IO (); a387 = forever $ putStrLn "a387" +a388 :: IO (); a388 = forever $ putStrLn "a388" +a389 :: IO (); a389 = forever $ putStrLn "a389" +a390 :: IO (); a390 = forever $ putStrLn "a390" +a391 :: IO (); a391 = forever $ putStrLn "a391" +a392 :: IO (); a392 = forever $ putStrLn "a392" +a393 :: IO (); a393 = forever $ putStrLn "a393" +a394 :: IO (); a394 = forever $ putStrLn "a394" +a395 :: IO (); a395 = forever $ putStrLn "a395" +a396 :: IO (); a396 = forever $ putStrLn "a396" +a397 :: IO (); a397 = forever $ putStrLn "a397" +a398 :: IO (); a398 = forever $ putStrLn "a398" +a399 :: IO (); a399 = forever $ putStrLn "a399" +a400 :: IO (); a400 = forever $ putStrLn "a400" +a401 :: IO (); a401 = forever $ putStrLn "a401" +a402 :: IO (); a402 = forever $ putStrLn "a402" +a403 :: IO (); a403 = forever $ putStrLn "a403" +a404 :: IO (); a404 = forever $ putStrLn "a404" +a405 :: IO (); a405 = forever $ putStrLn "a405" +a406 :: IO (); a406 = forever $ putStrLn "a406" +a407 :: IO (); a407 = forever $ putStrLn "a407" +a408 :: IO (); a408 = forever $ putStrLn "a408" +a409 :: IO (); a409 = forever $ putStrLn "a409" +a410 :: IO (); a410 = forever $ putStrLn "a410" +a411 :: IO (); a411 = forever $ putStrLn "a411" +a412 :: IO (); a412 = forever $ putStrLn "a412" +a413 :: IO (); a413 = forever $ putStrLn "a413" +a414 :: IO (); a414 = forever $ putStrLn "a414" +a415 :: IO (); a415 = forever $ putStrLn "a415" +a416 :: IO (); a416 = forever $ putStrLn "a416" +a417 :: IO (); a417 = forever $ putStrLn "a417" +a418 :: IO (); a418 = forever $ putStrLn "a418" +a419 :: IO (); a419 = forever $ putStrLn "a419" +a420 :: IO (); a420 = forever $ putStrLn "a420" +a421 :: IO (); a421 = forever $ putStrLn "a421" +a422 :: IO (); a422 = forever $ putStrLn "a422" +a423 :: IO (); a423 = forever $ putStrLn "a423" +a424 :: IO (); a424 = forever $ putStrLn "a424" +a425 :: IO (); a425 = forever $ putStrLn "a425" +a426 :: IO (); a426 = forever $ putStrLn "a426" +a427 :: IO (); a427 = forever $ putStrLn "a427" +a428 :: IO (); a428 = forever $ putStrLn "a428" +a429 :: IO (); a429 = forever $ putStrLn "a429" +a430 :: IO (); a430 = forever $ putStrLn "a430" +a431 :: IO (); a431 = forever $ putStrLn "a431" +a432 :: IO (); a432 = forever $ putStrLn "a432" +a433 :: IO (); a433 = forever $ putStrLn "a433" +a434 :: IO (); a434 = forever $ putStrLn "a434" +a435 :: IO (); a435 = forever $ putStrLn "a435" +a436 :: IO (); a436 = forever $ putStrLn "a436" +a437 :: IO (); a437 = forever $ putStrLn "a437" +a438 :: IO (); a438 = forever $ putStrLn "a438" +a439 :: IO (); a439 = forever $ putStrLn "a439" +a440 :: IO (); a440 = forever $ putStrLn "a440" +a441 :: IO (); a441 = forever $ putStrLn "a441" +a442 :: IO (); a442 = forever $ putStrLn "a442" +a443 :: IO (); a443 = forever $ putStrLn "a443" +a444 :: IO (); a444 = forever $ putStrLn "a444" +a445 :: IO (); a445 = forever $ putStrLn "a445" +a446 :: IO (); a446 = forever $ putStrLn "a446" +a447 :: IO (); a447 = forever $ putStrLn "a447" +a448 :: IO (); a448 = forever $ putStrLn "a448" +a449 :: IO (); a449 = forever $ putStrLn "a449" +a450 :: IO (); a450 = forever $ putStrLn "a450" +a451 :: IO (); a451 = forever $ putStrLn "a451" +a452 :: IO (); a452 = forever $ putStrLn "a452" +a453 :: IO (); a453 = forever $ putStrLn "a453" +a454 :: IO (); a454 = forever $ putStrLn "a454" +a455 :: IO (); a455 = forever $ putStrLn "a455" +a456 :: IO (); a456 = forever $ putStrLn "a456" +a457 :: IO (); a457 = forever $ putStrLn "a457" +a458 :: IO (); a458 = forever $ putStrLn "a458" +a459 :: IO (); a459 = forever $ putStrLn "a459" +a460 :: IO (); a460 = forever $ putStrLn "a460" +a461 :: IO (); a461 = forever $ putStrLn "a461" +a462 :: IO (); a462 = forever $ putStrLn "a462" +a463 :: IO (); a463 = forever $ putStrLn "a463" +a464 :: IO (); a464 = forever $ putStrLn "a464" +a465 :: IO (); a465 = forever $ putStrLn "a465" +a466 :: IO (); a466 = forever $ putStrLn "a466" +a467 :: IO (); a467 = forever $ putStrLn "a467" +a468 :: IO (); a468 = forever $ putStrLn "a468" +a469 :: IO (); a469 = forever $ putStrLn "a469" +a470 :: IO (); a470 = forever $ putStrLn "a470" +a471 :: IO (); a471 = forever $ putStrLn "a471" +a472 :: IO (); a472 = forever $ putStrLn "a472" +a473 :: IO (); a473 = forever $ putStrLn "a473" +a474 :: IO (); a474 = forever $ putStrLn "a474" +a475 :: IO (); a475 = forever $ putStrLn "a475" +a476 :: IO (); a476 = forever $ putStrLn "a476" +a477 :: IO (); a477 = forever $ putStrLn "a477" +a478 :: IO (); a478 = forever $ putStrLn "a478" +a479 :: IO (); a479 = forever $ putStrLn "a479" +a480 :: IO (); a480 = forever $ putStrLn "a480" +a481 :: IO (); a481 = forever $ putStrLn "a481" +a482 :: IO (); a482 = forever $ putStrLn "a482" +a483 :: IO (); a483 = forever $ putStrLn "a483" +a484 :: IO (); a484 = forever $ putStrLn "a484" +a485 :: IO (); a485 = forever $ putStrLn "a485" +a486 :: IO (); a486 = forever $ putStrLn "a486" +a487 :: IO (); a487 = forever $ putStrLn "a487" +a488 :: IO (); a488 = forever $ putStrLn "a488" +a489 :: IO (); a489 = forever $ putStrLn "a489" +a490 :: IO (); a490 = forever $ putStrLn "a490" +a491 :: IO (); a491 = forever $ putStrLn "a491" +a492 :: IO (); a492 = forever $ putStrLn "a492" +a493 :: IO (); a493 = forever $ putStrLn "a493" +a494 :: IO (); a494 = forever $ putStrLn "a494" +a495 :: IO (); a495 = forever $ putStrLn "a495" +a496 :: IO (); a496 = forever $ putStrLn "a496" +a497 :: IO (); a497 = forever $ putStrLn "a497" +a498 :: IO (); a498 = forever $ putStrLn "a498" +a499 :: IO (); a499 = forever $ putStrLn "a499" +a500 :: IO (); a500 = forever $ putStrLn "a500" +a501 :: IO (); a501 = forever $ putStrLn "a501" +a502 :: IO (); a502 = forever $ putStrLn "a502" +a503 :: IO (); a503 = forever $ putStrLn "a503" +a504 :: IO (); a504 = forever $ putStrLn "a504" +a505 :: IO (); a505 = forever $ putStrLn "a505" +a506 :: IO (); a506 = forever $ putStrLn "a506" +a507 :: IO (); a507 = forever $ putStrLn "a507" +a508 :: IO (); a508 = forever $ putStrLn "a508" +a509 :: IO (); a509 = forever $ putStrLn "a509" +a510 :: IO (); a510 = forever $ putStrLn "a510" +a511 :: IO (); a511 = forever $ putStrLn "a511" +a512 :: IO (); a512 = forever $ putStrLn "a512" +a513 :: IO (); a513 = forever $ putStrLn "a513" +a514 :: IO (); a514 = forever $ putStrLn "a514" +a515 :: IO (); a515 = forever $ putStrLn "a515" +a516 :: IO (); a516 = forever $ putStrLn "a516" +a517 :: IO (); a517 = forever $ putStrLn "a517" +a518 :: IO (); a518 = forever $ putStrLn "a518" +a519 :: IO (); a519 = forever $ putStrLn "a519" +a520 :: IO (); a520 = forever $ putStrLn "a520" +a521 :: IO (); a521 = forever $ putStrLn "a521" +a522 :: IO (); a522 = forever $ putStrLn "a522" +a523 :: IO (); a523 = forever $ putStrLn "a523" +a524 :: IO (); a524 = forever $ putStrLn "a524" +a525 :: IO (); a525 = forever $ putStrLn "a525" +a526 :: IO (); a526 = forever $ putStrLn "a526" +a527 :: IO (); a527 = forever $ putStrLn "a527" +a528 :: IO (); a528 = forever $ putStrLn "a528" +a529 :: IO (); a529 = forever $ putStrLn "a529" +a530 :: IO (); a530 = forever $ putStrLn "a530" +a531 :: IO (); a531 = forever $ putStrLn "a531" +a532 :: IO (); a532 = forever $ putStrLn "a532" +a533 :: IO (); a533 = forever $ putStrLn "a533" +a534 :: IO (); a534 = forever $ putStrLn "a534" +a535 :: IO (); a535 = forever $ putStrLn "a535" +a536 :: IO (); a536 = forever $ putStrLn "a536" +a537 :: IO (); a537 = forever $ putStrLn "a537" +a538 :: IO (); a538 = forever $ putStrLn "a538" +a539 :: IO (); a539 = forever $ putStrLn "a539" +a540 :: IO (); a540 = forever $ putStrLn "a540" +a541 :: IO (); a541 = forever $ putStrLn "a541" +a542 :: IO (); a542 = forever $ putStrLn "a542" +a543 :: IO (); a543 = forever $ putStrLn "a543" +a544 :: IO (); a544 = forever $ putStrLn "a544" +a545 :: IO (); a545 = forever $ putStrLn "a545" +a546 :: IO (); a546 = forever $ putStrLn "a546" +a547 :: IO (); a547 = forever $ putStrLn "a547" +a548 :: IO (); a548 = forever $ putStrLn "a548" +a549 :: IO (); a549 = forever $ putStrLn "a549" +a550 :: IO (); a550 = forever $ putStrLn "a550" +a551 :: IO (); a551 = forever $ putStrLn "a551" +a552 :: IO (); a552 = forever $ putStrLn "a552" +a553 :: IO (); a553 = forever $ putStrLn "a553" +a554 :: IO (); a554 = forever $ putStrLn "a554" +a555 :: IO (); a555 = forever $ putStrLn "a555" +a556 :: IO (); a556 = forever $ putStrLn "a556" +a557 :: IO (); a557 = forever $ putStrLn "a557" +a558 :: IO (); a558 = forever $ putStrLn "a558" +a559 :: IO (); a559 = forever $ putStrLn "a559" +a560 :: IO (); a560 = forever $ putStrLn "a560" +a561 :: IO (); a561 = forever $ putStrLn "a561" +a562 :: IO (); a562 = forever $ putStrLn "a562" +a563 :: IO (); a563 = forever $ putStrLn "a563" +a564 :: IO (); a564 = forever $ putStrLn "a564" +a565 :: IO (); a565 = forever $ putStrLn "a565" +a566 :: IO (); a566 = forever $ putStrLn "a566" +a567 :: IO (); a567 = forever $ putStrLn "a567" +a568 :: IO (); a568 = forever $ putStrLn "a568" +a569 :: IO (); a569 = forever $ putStrLn "a569" +a570 :: IO (); a570 = forever $ putStrLn "a570" +a571 :: IO (); a571 = forever $ putStrLn "a571" +a572 :: IO (); a572 = forever $ putStrLn "a572" +a573 :: IO (); a573 = forever $ putStrLn "a573" +a574 :: IO (); a574 = forever $ putStrLn "a574" +a575 :: IO (); a575 = forever $ putStrLn "a575" +a576 :: IO (); a576 = forever $ putStrLn "a576" +a577 :: IO (); a577 = forever $ putStrLn "a577" +a578 :: IO (); a578 = forever $ putStrLn "a578" +a579 :: IO (); a579 = forever $ putStrLn "a579" +a580 :: IO (); a580 = forever $ putStrLn "a580" +a581 :: IO (); a581 = forever $ putStrLn "a581" +a582 :: IO (); a582 = forever $ putStrLn "a582" +a583 :: IO (); a583 = forever $ putStrLn "a583" +a584 :: IO (); a584 = forever $ putStrLn "a584" +a585 :: IO (); a585 = forever $ putStrLn "a585" +a586 :: IO (); a586 = forever $ putStrLn "a586" +a587 :: IO (); a587 = forever $ putStrLn "a587" +a588 :: IO (); a588 = forever $ putStrLn "a588" +a589 :: IO (); a589 = forever $ putStrLn "a589" +a590 :: IO (); a590 = forever $ putStrLn "a590" +a591 :: IO (); a591 = forever $ putStrLn "a591" +a592 :: IO (); a592 = forever $ putStrLn "a592" +a593 :: IO (); a593 = forever $ putStrLn "a593" +a594 :: IO (); a594 = forever $ putStrLn "a594" +a595 :: IO (); a595 = forever $ putStrLn "a595" +a596 :: IO (); a596 = forever $ putStrLn "a596" +a597 :: IO (); a597 = forever $ putStrLn "a597" +a598 :: IO (); a598 = forever $ putStrLn "a598" +a599 :: IO (); a599 = forever $ putStrLn "a599" +a600 :: IO (); a600 = forever $ putStrLn "a600" +a601 :: IO (); a601 = forever $ putStrLn "a601" +a602 :: IO (); a602 = forever $ putStrLn "a602" +a603 :: IO (); a603 = forever $ putStrLn "a603" +a604 :: IO (); a604 = forever $ putStrLn "a604" +a605 :: IO (); a605 = forever $ putStrLn "a605" +a606 :: IO (); a606 = forever $ putStrLn "a606" +a607 :: IO (); a607 = forever $ putStrLn "a607" +a608 :: IO (); a608 = forever $ putStrLn "a608" +a609 :: IO (); a609 = forever $ putStrLn "a609" +a610 :: IO (); a610 = forever $ putStrLn "a610" +a611 :: IO (); a611 = forever $ putStrLn "a611" +a612 :: IO (); a612 = forever $ putStrLn "a612" +a613 :: IO (); a613 = forever $ putStrLn "a613" +a614 :: IO (); a614 = forever $ putStrLn "a614" +a615 :: IO (); a615 = forever $ putStrLn "a615" +a616 :: IO (); a616 = forever $ putStrLn "a616" +a617 :: IO (); a617 = forever $ putStrLn "a617" +a618 :: IO (); a618 = forever $ putStrLn "a618" +a619 :: IO (); a619 = forever $ putStrLn "a619" +a620 :: IO (); a620 = forever $ putStrLn "a620" +a621 :: IO (); a621 = forever $ putStrLn "a621" +a622 :: IO (); a622 = forever $ putStrLn "a622" +a623 :: IO (); a623 = forever $ putStrLn "a623" +a624 :: IO (); a624 = forever $ putStrLn "a624" +a625 :: IO (); a625 = forever $ putStrLn "a625" +a626 :: IO (); a626 = forever $ putStrLn "a626" +a627 :: IO (); a627 = forever $ putStrLn "a627" +a628 :: IO (); a628 = forever $ putStrLn "a628" +a629 :: IO (); a629 = forever $ putStrLn "a629" +a630 :: IO (); a630 = forever $ putStrLn "a630" +a631 :: IO (); a631 = forever $ putStrLn "a631" +a632 :: IO (); a632 = forever $ putStrLn "a632" +a633 :: IO (); a633 = forever $ putStrLn "a633" +a634 :: IO (); a634 = forever $ putStrLn "a634" +a635 :: IO (); a635 = forever $ putStrLn "a635" +a636 :: IO (); a636 = forever $ putStrLn "a636" +a637 :: IO (); a637 = forever $ putStrLn "a637" +a638 :: IO (); a638 = forever $ putStrLn "a638" +a639 :: IO (); a639 = forever $ putStrLn "a639" +a640 :: IO (); a640 = forever $ putStrLn "a640" +a641 :: IO (); a641 = forever $ putStrLn "a641" +a642 :: IO (); a642 = forever $ putStrLn "a642" +a643 :: IO (); a643 = forever $ putStrLn "a643" +a644 :: IO (); a644 = forever $ putStrLn "a644" +a645 :: IO (); a645 = forever $ putStrLn "a645" +a646 :: IO (); a646 = forever $ putStrLn "a646" +a647 :: IO (); a647 = forever $ putStrLn "a647" +a648 :: IO (); a648 = forever $ putStrLn "a648" +a649 :: IO (); a649 = forever $ putStrLn "a649" +a650 :: IO (); a650 = forever $ putStrLn "a650" +a651 :: IO (); a651 = forever $ putStrLn "a651" +a652 :: IO (); a652 = forever $ putStrLn "a652" +a653 :: IO (); a653 = forever $ putStrLn "a653" +a654 :: IO (); a654 = forever $ putStrLn "a654" +a655 :: IO (); a655 = forever $ putStrLn "a655" +a656 :: IO (); a656 = forever $ putStrLn "a656" +a657 :: IO (); a657 = forever $ putStrLn "a657" +a658 :: IO (); a658 = forever $ putStrLn "a658" +a659 :: IO (); a659 = forever $ putStrLn "a659" +a660 :: IO (); a660 = forever $ putStrLn "a660" +a661 :: IO (); a661 = forever $ putStrLn "a661" +a662 :: IO (); a662 = forever $ putStrLn "a662" +a663 :: IO (); a663 = forever $ putStrLn "a663" +a664 :: IO (); a664 = forever $ putStrLn "a664" +a665 :: IO (); a665 = forever $ putStrLn "a665" +a666 :: IO (); a666 = forever $ putStrLn "a666" +a667 :: IO (); a667 = forever $ putStrLn "a667" +a668 :: IO (); a668 = forever $ putStrLn "a668" +a669 :: IO (); a669 = forever $ putStrLn "a669" +a670 :: IO (); a670 = forever $ putStrLn "a670" +a671 :: IO (); a671 = forever $ putStrLn "a671" +a672 :: IO (); a672 = forever $ putStrLn "a672" +a673 :: IO (); a673 = forever $ putStrLn "a673" +a674 :: IO (); a674 = forever $ putStrLn "a674" +a675 :: IO (); a675 = forever $ putStrLn "a675" +a676 :: IO (); a676 = forever $ putStrLn "a676" +a677 :: IO (); a677 = forever $ putStrLn "a677" +a678 :: IO (); a678 = forever $ putStrLn "a678" +a679 :: IO (); a679 = forever $ putStrLn "a679" +a680 :: IO (); a680 = forever $ putStrLn "a680" +a681 :: IO (); a681 = forever $ putStrLn "a681" +a682 :: IO (); a682 = forever $ putStrLn "a682" +a683 :: IO (); a683 = forever $ putStrLn "a683" +a684 :: IO (); a684 = forever $ putStrLn "a684" +a685 :: IO (); a685 = forever $ putStrLn "a685" +a686 :: IO (); a686 = forever $ putStrLn "a686" +a687 :: IO (); a687 = forever $ putStrLn "a687" +a688 :: IO (); a688 = forever $ putStrLn "a688" +a689 :: IO (); a689 = forever $ putStrLn "a689" +a690 :: IO (); a690 = forever $ putStrLn "a690" +a691 :: IO (); a691 = forever $ putStrLn "a691" +a692 :: IO (); a692 = forever $ putStrLn "a692" +a693 :: IO (); a693 = forever $ putStrLn "a693" +a694 :: IO (); a694 = forever $ putStrLn "a694" +a695 :: IO (); a695 = forever $ putStrLn "a695" +a696 :: IO (); a696 = forever $ putStrLn "a696" +a697 :: IO (); a697 = forever $ putStrLn "a697" +a698 :: IO (); a698 = forever $ putStrLn "a698" +a699 :: IO (); a699 = forever $ putStrLn "a699" +a700 :: IO (); a700 = forever $ putStrLn "a700" +a701 :: IO (); a701 = forever $ putStrLn "a701" +a702 :: IO (); a702 = forever $ putStrLn "a702" +a703 :: IO (); a703 = forever $ putStrLn "a703" +a704 :: IO (); a704 = forever $ putStrLn "a704" +a705 :: IO (); a705 = forever $ putStrLn "a705" +a706 :: IO (); a706 = forever $ putStrLn "a706" +a707 :: IO (); a707 = forever $ putStrLn "a707" +a708 :: IO (); a708 = forever $ putStrLn "a708" +a709 :: IO (); a709 = forever $ putStrLn "a709" +a710 :: IO (); a710 = forever $ putStrLn "a710" +a711 :: IO (); a711 = forever $ putStrLn "a711" +a712 :: IO (); a712 = forever $ putStrLn "a712" +a713 :: IO (); a713 = forever $ putStrLn "a713" +a714 :: IO (); a714 = forever $ putStrLn "a714" +a715 :: IO (); a715 = forever $ putStrLn "a715" +a716 :: IO (); a716 = forever $ putStrLn "a716" +a717 :: IO (); a717 = forever $ putStrLn "a717" +a718 :: IO (); a718 = forever $ putStrLn "a718" +a719 :: IO (); a719 = forever $ putStrLn "a719" +a720 :: IO (); a720 = forever $ putStrLn "a720" +a721 :: IO (); a721 = forever $ putStrLn "a721" +a722 :: IO (); a722 = forever $ putStrLn "a722" +a723 :: IO (); a723 = forever $ putStrLn "a723" +a724 :: IO (); a724 = forever $ putStrLn "a724" +a725 :: IO (); a725 = forever $ putStrLn "a725" +a726 :: IO (); a726 = forever $ putStrLn "a726" +a727 :: IO (); a727 = forever $ putStrLn "a727" +a728 :: IO (); a728 = forever $ putStrLn "a728" +a729 :: IO (); a729 = forever $ putStrLn "a729" +a730 :: IO (); a730 = forever $ putStrLn "a730" +a731 :: IO (); a731 = forever $ putStrLn "a731" +a732 :: IO (); a732 = forever $ putStrLn "a732" +a733 :: IO (); a733 = forever $ putStrLn "a733" +a734 :: IO (); a734 = forever $ putStrLn "a734" +a735 :: IO (); a735 = forever $ putStrLn "a735" +a736 :: IO (); a736 = forever $ putStrLn "a736" +a737 :: IO (); a737 = forever $ putStrLn "a737" +a738 :: IO (); a738 = forever $ putStrLn "a738" +a739 :: IO (); a739 = forever $ putStrLn "a739" +a740 :: IO (); a740 = forever $ putStrLn "a740" +a741 :: IO (); a741 = forever $ putStrLn "a741" +a742 :: IO (); a742 = forever $ putStrLn "a742" +a743 :: IO (); a743 = forever $ putStrLn "a743" +a744 :: IO (); a744 = forever $ putStrLn "a744" +a745 :: IO (); a745 = forever $ putStrLn "a745" +a746 :: IO (); a746 = forever $ putStrLn "a746" +a747 :: IO (); a747 = forever $ putStrLn "a747" +a748 :: IO (); a748 = forever $ putStrLn "a748" +a749 :: IO (); a749 = forever $ putStrLn "a749" +a750 :: IO (); a750 = forever $ putStrLn "a750" +a751 :: IO (); a751 = forever $ putStrLn "a751" +a752 :: IO (); a752 = forever $ putStrLn "a752" +a753 :: IO (); a753 = forever $ putStrLn "a753" +a754 :: IO (); a754 = forever $ putStrLn "a754" +a755 :: IO (); a755 = forever $ putStrLn "a755" +a756 :: IO (); a756 = forever $ putStrLn "a756" +a757 :: IO (); a757 = forever $ putStrLn "a757" +a758 :: IO (); a758 = forever $ putStrLn "a758" +a759 :: IO (); a759 = forever $ putStrLn "a759" +a760 :: IO (); a760 = forever $ putStrLn "a760" +a761 :: IO (); a761 = forever $ putStrLn "a761" +a762 :: IO (); a762 = forever $ putStrLn "a762" +a763 :: IO (); a763 = forever $ putStrLn "a763" +a764 :: IO (); a764 = forever $ putStrLn "a764" +a765 :: IO (); a765 = forever $ putStrLn "a765" +a766 :: IO (); a766 = forever $ putStrLn "a766" +a767 :: IO (); a767 = forever $ putStrLn "a767" +a768 :: IO (); a768 = forever $ putStrLn "a768" +a769 :: IO (); a769 = forever $ putStrLn "a769" +a770 :: IO (); a770 = forever $ putStrLn "a770" +a771 :: IO (); a771 = forever $ putStrLn "a771" +a772 :: IO (); a772 = forever $ putStrLn "a772" +a773 :: IO (); a773 = forever $ putStrLn "a773" +a774 :: IO (); a774 = forever $ putStrLn "a774" +a775 :: IO (); a775 = forever $ putStrLn "a775" +a776 :: IO (); a776 = forever $ putStrLn "a776" +a777 :: IO (); a777 = forever $ putStrLn "a777" +a778 :: IO (); a778 = forever $ putStrLn "a778" +a779 :: IO (); a779 = forever $ putStrLn "a779" +a780 :: IO (); a780 = forever $ putStrLn "a780" +a781 :: IO (); a781 = forever $ putStrLn "a781" +a782 :: IO (); a782 = forever $ putStrLn "a782" +a783 :: IO (); a783 = forever $ putStrLn "a783" +a784 :: IO (); a784 = forever $ putStrLn "a784" +a785 :: IO (); a785 = forever $ putStrLn "a785" +a786 :: IO (); a786 = forever $ putStrLn "a786" +a787 :: IO (); a787 = forever $ putStrLn "a787" +a788 :: IO (); a788 = forever $ putStrLn "a788" +a789 :: IO (); a789 = forever $ putStrLn "a789" +a790 :: IO (); a790 = forever $ putStrLn "a790" +a791 :: IO (); a791 = forever $ putStrLn "a791" +a792 :: IO (); a792 = forever $ putStrLn "a792" +a793 :: IO (); a793 = forever $ putStrLn "a793" +a794 :: IO (); a794 = forever $ putStrLn "a794" +a795 :: IO (); a795 = forever $ putStrLn "a795" +a796 :: IO (); a796 = forever $ putStrLn "a796" +a797 :: IO (); a797 = forever $ putStrLn "a797" +a798 :: IO (); a798 = forever $ putStrLn "a798" +a799 :: IO (); a799 = forever $ putStrLn "a799" +a800 :: IO (); a800 = forever $ putStrLn "a800" +a801 :: IO (); a801 = forever $ putStrLn "a801" +a802 :: IO (); a802 = forever $ putStrLn "a802" +a803 :: IO (); a803 = forever $ putStrLn "a803" +a804 :: IO (); a804 = forever $ putStrLn "a804" +a805 :: IO (); a805 = forever $ putStrLn "a805" +a806 :: IO (); a806 = forever $ putStrLn "a806" +a807 :: IO (); a807 = forever $ putStrLn "a807" +a808 :: IO (); a808 = forever $ putStrLn "a808" +a809 :: IO (); a809 = forever $ putStrLn "a809" +a810 :: IO (); a810 = forever $ putStrLn "a810" +a811 :: IO (); a811 = forever $ putStrLn "a811" +a812 :: IO (); a812 = forever $ putStrLn "a812" +a813 :: IO (); a813 = forever $ putStrLn "a813" +a814 :: IO (); a814 = forever $ putStrLn "a814" +a815 :: IO (); a815 = forever $ putStrLn "a815" +a816 :: IO (); a816 = forever $ putStrLn "a816" +a817 :: IO (); a817 = forever $ putStrLn "a817" +a818 :: IO (); a818 = forever $ putStrLn "a818" +a819 :: IO (); a819 = forever $ putStrLn "a819" +a820 :: IO (); a820 = forever $ putStrLn "a820" +a821 :: IO (); a821 = forever $ putStrLn "a821" +a822 :: IO (); a822 = forever $ putStrLn "a822" +a823 :: IO (); a823 = forever $ putStrLn "a823" +a824 :: IO (); a824 = forever $ putStrLn "a824" +a825 :: IO (); a825 = forever $ putStrLn "a825" +a826 :: IO (); a826 = forever $ putStrLn "a826" +a827 :: IO (); a827 = forever $ putStrLn "a827" +a828 :: IO (); a828 = forever $ putStrLn "a828" +a829 :: IO (); a829 = forever $ putStrLn "a829" +a830 :: IO (); a830 = forever $ putStrLn "a830" +a831 :: IO (); a831 = forever $ putStrLn "a831" +a832 :: IO (); a832 = forever $ putStrLn "a832" +a833 :: IO (); a833 = forever $ putStrLn "a833" +a834 :: IO (); a834 = forever $ putStrLn "a834" +a835 :: IO (); a835 = forever $ putStrLn "a835" +a836 :: IO (); a836 = forever $ putStrLn "a836" +a837 :: IO (); a837 = forever $ putStrLn "a837" +a838 :: IO (); a838 = forever $ putStrLn "a838" +a839 :: IO (); a839 = forever $ putStrLn "a839" +a840 :: IO (); a840 = forever $ putStrLn "a840" +a841 :: IO (); a841 = forever $ putStrLn "a841" +a842 :: IO (); a842 = forever $ putStrLn "a842" +a843 :: IO (); a843 = forever $ putStrLn "a843" +a844 :: IO (); a844 = forever $ putStrLn "a844" +a845 :: IO (); a845 = forever $ putStrLn "a845" +a846 :: IO (); a846 = forever $ putStrLn "a846" +a847 :: IO (); a847 = forever $ putStrLn "a847" +a848 :: IO (); a848 = forever $ putStrLn "a848" +a849 :: IO (); a849 = forever $ putStrLn "a849" +a850 :: IO (); a850 = forever $ putStrLn "a850" +a851 :: IO (); a851 = forever $ putStrLn "a851" +a852 :: IO (); a852 = forever $ putStrLn "a852" +a853 :: IO (); a853 = forever $ putStrLn "a853" +a854 :: IO (); a854 = forever $ putStrLn "a854" +a855 :: IO (); a855 = forever $ putStrLn "a855" +a856 :: IO (); a856 = forever $ putStrLn "a856" +a857 :: IO (); a857 = forever $ putStrLn "a857" +a858 :: IO (); a858 = forever $ putStrLn "a858" +a859 :: IO (); a859 = forever $ putStrLn "a859" +a860 :: IO (); a860 = forever $ putStrLn "a860" +a861 :: IO (); a861 = forever $ putStrLn "a861" +a862 :: IO (); a862 = forever $ putStrLn "a862" +a863 :: IO (); a863 = forever $ putStrLn "a863" +a864 :: IO (); a864 = forever $ putStrLn "a864" +a865 :: IO (); a865 = forever $ putStrLn "a865" +a866 :: IO (); a866 = forever $ putStrLn "a866" +a867 :: IO (); a867 = forever $ putStrLn "a867" +a868 :: IO (); a868 = forever $ putStrLn "a868" +a869 :: IO (); a869 = forever $ putStrLn "a869" +a870 :: IO (); a870 = forever $ putStrLn "a870" +a871 :: IO (); a871 = forever $ putStrLn "a871" +a872 :: IO (); a872 = forever $ putStrLn "a872" +a873 :: IO (); a873 = forever $ putStrLn "a873" +a874 :: IO (); a874 = forever $ putStrLn "a874" +a875 :: IO (); a875 = forever $ putStrLn "a875" +a876 :: IO (); a876 = forever $ putStrLn "a876" +a877 :: IO (); a877 = forever $ putStrLn "a877" +a878 :: IO (); a878 = forever $ putStrLn "a878" +a879 :: IO (); a879 = forever $ putStrLn "a879" +a880 :: IO (); a880 = forever $ putStrLn "a880" +a881 :: IO (); a881 = forever $ putStrLn "a881" +a882 :: IO (); a882 = forever $ putStrLn "a882" +a883 :: IO (); a883 = forever $ putStrLn "a883" +a884 :: IO (); a884 = forever $ putStrLn "a884" +a885 :: IO (); a885 = forever $ putStrLn "a885" +a886 :: IO (); a886 = forever $ putStrLn "a886" +a887 :: IO (); a887 = forever $ putStrLn "a887" +a888 :: IO (); a888 = forever $ putStrLn "a888" +a889 :: IO (); a889 = forever $ putStrLn "a889" +a890 :: IO (); a890 = forever $ putStrLn "a890" +a891 :: IO (); a891 = forever $ putStrLn "a891" +a892 :: IO (); a892 = forever $ putStrLn "a892" +a893 :: IO (); a893 = forever $ putStrLn "a893" +a894 :: IO (); a894 = forever $ putStrLn "a894" +a895 :: IO (); a895 = forever $ putStrLn "a895" +a896 :: IO (); a896 = forever $ putStrLn "a896" +a897 :: IO (); a897 = forever $ putStrLn "a897" +a898 :: IO (); a898 = forever $ putStrLn "a898" +a899 :: IO (); a899 = forever $ putStrLn "a899" +a900 :: IO (); a900 = forever $ putStrLn "a900" +a901 :: IO (); a901 = forever $ putStrLn "a901" +a902 :: IO (); a902 = forever $ putStrLn "a902" +a903 :: IO (); a903 = forever $ putStrLn "a903" +a904 :: IO (); a904 = forever $ putStrLn "a904" +a905 :: IO (); a905 = forever $ putStrLn "a905" +a906 :: IO (); a906 = forever $ putStrLn "a906" +a907 :: IO (); a907 = forever $ putStrLn "a907" +a908 :: IO (); a908 = forever $ putStrLn "a908" +a909 :: IO (); a909 = forever $ putStrLn "a909" +a910 :: IO (); a910 = forever $ putStrLn "a910" +a911 :: IO (); a911 = forever $ putStrLn "a911" +a912 :: IO (); a912 = forever $ putStrLn "a912" +a913 :: IO (); a913 = forever $ putStrLn "a913" +a914 :: IO (); a914 = forever $ putStrLn "a914" +a915 :: IO (); a915 = forever $ putStrLn "a915" +a916 :: IO (); a916 = forever $ putStrLn "a916" +a917 :: IO (); a917 = forever $ putStrLn "a917" +a918 :: IO (); a918 = forever $ putStrLn "a918" +a919 :: IO (); a919 = forever $ putStrLn "a919" +a920 :: IO (); a920 = forever $ putStrLn "a920" +a921 :: IO (); a921 = forever $ putStrLn "a921" +a922 :: IO (); a922 = forever $ putStrLn "a922" +a923 :: IO (); a923 = forever $ putStrLn "a923" +a924 :: IO (); a924 = forever $ putStrLn "a924" +a925 :: IO (); a925 = forever $ putStrLn "a925" +a926 :: IO (); a926 = forever $ putStrLn "a926" +a927 :: IO (); a927 = forever $ putStrLn "a927" +a928 :: IO (); a928 = forever $ putStrLn "a928" +a929 :: IO (); a929 = forever $ putStrLn "a929" +a930 :: IO (); a930 = forever $ putStrLn "a930" +a931 :: IO (); a931 = forever $ putStrLn "a931" +a932 :: IO (); a932 = forever $ putStrLn "a932" +a933 :: IO (); a933 = forever $ putStrLn "a933" +a934 :: IO (); a934 = forever $ putStrLn "a934" +a935 :: IO (); a935 = forever $ putStrLn "a935" +a936 :: IO (); a936 = forever $ putStrLn "a936" +a937 :: IO (); a937 = forever $ putStrLn "a937" +a938 :: IO (); a938 = forever $ putStrLn "a938" +a939 :: IO (); a939 = forever $ putStrLn "a939" +a940 :: IO (); a940 = forever $ putStrLn "a940" +a941 :: IO (); a941 = forever $ putStrLn "a941" +a942 :: IO (); a942 = forever $ putStrLn "a942" +a943 :: IO (); a943 = forever $ putStrLn "a943" +a944 :: IO (); a944 = forever $ putStrLn "a944" +a945 :: IO (); a945 = forever $ putStrLn "a945" +a946 :: IO (); a946 = forever $ putStrLn "a946" +a947 :: IO (); a947 = forever $ putStrLn "a947" +a948 :: IO (); a948 = forever $ putStrLn "a948" +a949 :: IO (); a949 = forever $ putStrLn "a949" +a950 :: IO (); a950 = forever $ putStrLn "a950" +a951 :: IO (); a951 = forever $ putStrLn "a951" +a952 :: IO (); a952 = forever $ putStrLn "a952" +a953 :: IO (); a953 = forever $ putStrLn "a953" +a954 :: IO (); a954 = forever $ putStrLn "a954" +a955 :: IO (); a955 = forever $ putStrLn "a955" +a956 :: IO (); a956 = forever $ putStrLn "a956" +a957 :: IO (); a957 = forever $ putStrLn "a957" +a958 :: IO (); a958 = forever $ putStrLn "a958" +a959 :: IO (); a959 = forever $ putStrLn "a959" +a960 :: IO (); a960 = forever $ putStrLn "a960" +a961 :: IO (); a961 = forever $ putStrLn "a961" +a962 :: IO (); a962 = forever $ putStrLn "a962" +a963 :: IO (); a963 = forever $ putStrLn "a963" +a964 :: IO (); a964 = forever $ putStrLn "a964" +a965 :: IO (); a965 = forever $ putStrLn "a965" +a966 :: IO (); a966 = forever $ putStrLn "a966" +a967 :: IO (); a967 = forever $ putStrLn "a967" +a968 :: IO (); a968 = forever $ putStrLn "a968" +a969 :: IO (); a969 = forever $ putStrLn "a969" +a970 :: IO (); a970 = forever $ putStrLn "a970" +a971 :: IO (); a971 = forever $ putStrLn "a971" +a972 :: IO (); a972 = forever $ putStrLn "a972" +a973 :: IO (); a973 = forever $ putStrLn "a973" +a974 :: IO (); a974 = forever $ putStrLn "a974" +a975 :: IO (); a975 = forever $ putStrLn "a975" +a976 :: IO (); a976 = forever $ putStrLn "a976" +a977 :: IO (); a977 = forever $ putStrLn "a977" +a978 :: IO (); a978 = forever $ putStrLn "a978" +a979 :: IO (); a979 = forever $ putStrLn "a979" +a980 :: IO (); a980 = forever $ putStrLn "a980" +a981 :: IO (); a981 = forever $ putStrLn "a981" +a982 :: IO (); a982 = forever $ putStrLn "a982" +a983 :: IO (); a983 = forever $ putStrLn "a983" +a984 :: IO (); a984 = forever $ putStrLn "a984" +a985 :: IO (); a985 = forever $ putStrLn "a985" +a986 :: IO (); a986 = forever $ putStrLn "a986" +a987 :: IO (); a987 = forever $ putStrLn "a987" +a988 :: IO (); a988 = forever $ putStrLn "a988" +a989 :: IO (); a989 = forever $ putStrLn "a989" +a990 :: IO (); a990 = forever $ putStrLn "a990" +a991 :: IO (); a991 = forever $ putStrLn "a991" +a992 :: IO (); a992 = forever $ putStrLn "a992" +a993 :: IO (); a993 = forever $ putStrLn "a993" +a994 :: IO (); a994 = forever $ putStrLn "a994" +a995 :: IO (); a995 = forever $ putStrLn "a995" +a996 :: IO (); a996 = forever $ putStrLn "a996" +a997 :: IO (); a997 = forever $ putStrLn "a997" +a998 :: IO (); a998 = forever $ putStrLn "a998" +a999 :: IO (); a999 = forever $ putStrLn "a999" +a1000 :: IO (); a1000 = forever $ putStrLn "a1000" diff --git a/tests/examples/pre-ghc910/T10384.hs b/tests/examples/pre-ghc910/T10384.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10390.hs b/tests/examples/pre-ghc910/T10390.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10398.hs b/tests/examples/pre-ghc910/T10398.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10403.hs b/tests/examples/pre-ghc910/T10403.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10414.hs b/tests/examples/pre-ghc910/T10414.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10420.hs b/tests/examples/pre-ghc910/T10420.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10420a.hs b/tests/examples/pre-ghc910/T10420a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10420a.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -fplugin RuleDefiningPlugin #-} +module T10420a where diff --git a/tests/examples/pre-ghc910/T10423.hs b/tests/examples/pre-ghc910/T10423.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10428.hs b/tests/examples/pre-ghc910/T10428.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10438.hs b/tests/examples/pre-ghc910/T10438.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10447.hs b/tests/examples/pre-ghc910/T10447.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10451.hs b/tests/examples/pre-ghc910/T10451.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10460.hs b/tests/examples/pre-ghc910/T10460.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10461.hs b/tests/examples/pre-ghc910/T10461.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10463.hs b/tests/examples/pre-ghc910/T10463.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10463.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables, PartialTypeSignatures #-} + +module T10463 where + +f (x :: _) = x ++ "" diff --git a/tests/examples/pre-ghc910/T10481.hs b/tests/examples/pre-ghc910/T10481.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10482.hs b/tests/examples/pre-ghc910/T10482.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10482a.hs b/tests/examples/pre-ghc910/T10482a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10487.hs b/tests/examples/pre-ghc910/T10487.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10487.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-} + +module T10487 where + +import GHC.Generics + +import qualified T10487_M as M + +data Name = Name + +deriving instance Generic Name +deriving instance Generic M.Name diff --git a/tests/examples/pre-ghc910/T10487_M.hs b/tests/examples/pre-ghc910/T10487_M.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10487_M.hs @@ -0,0 +1,3 @@ +module T10487_M where + +data Name = Name diff --git a/tests/examples/pre-ghc910/T10489.hs b/tests/examples/pre-ghc910/T10489.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10493.hs b/tests/examples/pre-ghc910/T10493.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10494.hs b/tests/examples/pre-ghc910/T10494.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10495.hs b/tests/examples/pre-ghc910/T10495.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10495.hs @@ -0,0 +1,5 @@ +module T10495 where + +import Data.Coerce + +foo = coerce diff --git a/tests/examples/pre-ghc910/T10503.hs b/tests/examples/pre-ghc910/T10503.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10507.hs b/tests/examples/pre-ghc910/T10507.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10508_api.hs b/tests/examples/pre-ghc910/T10508_api.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10516.hs b/tests/examples/pre-ghc910/T10516.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10519.hs b/tests/examples/pre-ghc910/T10519.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10521.hs b/tests/examples/pre-ghc910/T10521.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10521b.hs b/tests/examples/pre-ghc910/T10521b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10524.hs b/tests/examples/pre-ghc910/T10524.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10524.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +module T10524 where + +import Data.Data + +newtype WrappedFunctor f a = WrapFunctor (f a) deriving (Data, Typeable) + +-- WrappedFunctor :: forall k. (k -> *) -> k -> * diff --git a/tests/examples/pre-ghc910/T10534.hs b/tests/examples/pre-ghc910/T10534.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10534a.hs b/tests/examples/pre-ghc910/T10534a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10549.hs b/tests/examples/pre-ghc910/T10549.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10549a.hs b/tests/examples/pre-ghc910/T10549a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10549a.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -O #-} +module Main(main) where +import GHC.Exts +main = print 1 +go (Ptr a) = a diff --git a/tests/examples/pre-ghc910/T10561.hs b/tests/examples/pre-ghc910/T10561.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10562.hs b/tests/examples/pre-ghc910/T10562.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10564.hs b/tests/examples/pre-ghc910/T10564.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10570.hs b/tests/examples/pre-ghc910/T10570.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10590.hs b/tests/examples/pre-ghc910/T10590.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10596.hs b/tests/examples/pre-ghc910/T10596.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10602.hs b/tests/examples/pre-ghc910/T10602.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10602b.hs b/tests/examples/pre-ghc910/T10602b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10615.hs b/tests/examples/pre-ghc910/T10615.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10615.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes #-} +module T10615 where + +f1 :: _ -> f +f1 = const + +f2 :: _ -> _f +f2 = const diff --git a/tests/examples/pre-ghc910/T10618.hs b/tests/examples/pre-ghc910/T10618.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10618.hs @@ -0,0 +1,3 @@ +module T10618 where + +foo = Just $ Nothing <> Nothing diff --git a/tests/examples/pre-ghc910/T10620.hs b/tests/examples/pre-ghc910/T10620.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10627.hs b/tests/examples/pre-ghc910/T10627.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10632.hs b/tests/examples/pre-ghc910/T10632.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10634.hs b/tests/examples/pre-ghc910/T10634.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10637.hs b/tests/examples/pre-ghc910/T10637.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10637.hs @@ -0,0 +1,4 @@ +module T10637 where + +import {-# SOURCE #-} A () +data B = B diff --git a/tests/examples/pre-ghc910/T10638.1.hs b/tests/examples/pre-ghc910/T10638.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10638.1.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-} + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import GHC.Exts + +{- + the prim and javascript calling conventions do not support + headers and the static keyword. +-} + +-- check that quasiquoting roundtrips succesfully and that the declaration +-- does not include the static keyword +test1 :: String +test1 = $(do (ds@[ForeignD (ImportF _ _ p _ _)]) <- + [d| foreign import prim "test1" cmm_test1 :: Int# -> Int# |] + addTopDecls ds + case p of + "test1" -> return (LitE . stringL $ p) + _ -> error $ "unexpected value: " ++ show p + ) + +-- check that constructed prim imports with the static keyword are rejected +test2 :: String +test2 = $(do t <- [t| Int# -> Int# |] + cmm_test2 <- newName "cmm_test2" + addTopDecls + [ForeignD (ImportF Prim Safe "static test2" cmm_test2 t)] + [| test1 |] + ) diff --git a/tests/examples/pre-ghc910/T10638.hs b/tests/examples/pre-ghc910/T10638.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10638.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} + +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 successfully 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/pre-ghc910/T10642.hs b/tests/examples/pre-ghc910/T10642.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10662.hs b/tests/examples/pre-ghc910/T10662.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10662.hs @@ -0,0 +1,4 @@ +main :: IO () +main = do + return $ let a = "hello" in a + return () diff --git a/tests/examples/pre-ghc910/T10667.hs b/tests/examples/pre-ghc910/T10667.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10667.hs @@ -0,0 +1,6 @@ +module A where + +-- when used with '-g' debug generation option +-- '*/*' leaked into a /* comment */ and broke +-- GNU as. +x */* y = 42 diff --git a/tests/examples/pre-ghc910/T10668.hs b/tests/examples/pre-ghc910/T10668.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10668.hs @@ -0,0 +1,3 @@ +module T10668 where + +import Data.Type.Equality(Refl) diff --git a/tests/examples/pre-ghc910/T10670.hs b/tests/examples/pre-ghc910/T10670.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10670a.hs b/tests/examples/pre-ghc910/T10670a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10678.hs b/tests/examples/pre-ghc910/T10678.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10678.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE MagicHash #-} + +import GHC.Prim + +main :: IO () +main = go 1000000# 10 (2^100) + +go :: Int# -> Integer -> Integer -> IO () +go 0# _ _ = return () +go n# a b = (a + b) `seq` go (n# -# 1#) a b +{-# NOINLINE go #-} + +{- +This test is based on a strategy from rwbarton relying on the inefficiency +of `Integer` addition as defined by `integer-gmp` without `runRW#`. + + When I was testing the patch interactively, I measured allocations for, + say, a million (large Integer) + (small Integer) additions. If that + addition allocates, say, 6 words, then one can fairly reliably write the + program so that it will allocate between 6 million and 7 million words, + total. +-} diff --git a/tests/examples/pre-ghc910/T10689.hs b/tests/examples/pre-ghc910/T10689.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10689a.hs b/tests/examples/pre-ghc910/T10689a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10689a.hs @@ -0,0 +1,115 @@ +{-# 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 :: Type) (b :: Type) + +type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2 + +data instance Sing (f :: TyFun k1 k2 -> Type) = + 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)) +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 -> Type) + -> Type) + (t_afdZ :: [a_afdP]) = + Foldr1 t_afdY t_afdZ +data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) + -> Type) + (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 + -> Type) + -> Type) (TyFun [a_afdP] a_afdP -> Type)) +type instance Apply Foldr1Sym0 l = Foldr1Sym1 l + +type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP + -> Type) + -> Type) + (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 -> Type) -> Type) + (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/pre-ghc910/T10694.hs b/tests/examples/pre-ghc910/T10694.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10698.hs b/tests/examples/pre-ghc910/T10698.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10704.hs b/tests/examples/pre-ghc910/T10704.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10704a.hs b/tests/examples/pre-ghc910/T10704a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10713.hs b/tests/examples/pre-ghc910/T10713.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10734.hs b/tests/examples/pre-ghc910/T10734.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10734.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +main :: IO () +main = do + pprint <$> runQ [| do { let { }; return (); } |] >>= putStrLn + pprint <$> runQ [| do { let { x = 5 }; return x; } |] >>= putStrLn + pprint <$> runQ [| do { let { x = 5; y = 3 }; return x; } |] >>= putStrLn diff --git a/tests/examples/pre-ghc910/T10742.hs b/tests/examples/pre-ghc910/T10742.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10744.hs b/tests/examples/pre-ghc910/T10744.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10747.hs b/tests/examples/pre-ghc910/T10747.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10747.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + +module T10747 where + +pattern head `Cons` tail = head : tail diff --git a/tests/examples/pre-ghc910/T10753.hs b/tests/examples/pre-ghc910/T10753.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10767.hs b/tests/examples/pre-ghc910/T10767.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10767.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} + +module Main where + +{- ghc-7.8.4 and ghc-7.10.2 showed a confusing warning: + +T10767.hs:43:1: Warning: + RULE left-hand side too complicated to desugar + Optimised lhs: case cobox_aWY + of _ [Occ=Dead] { GHC.Types.Eq# cobox -> + genLength @ Int $dSpecList_aWX + } + Orig lhs: case cobox_aWY of cobox_aWY { GHC.Types.Eq# cobox -> + genLength @ Int $dSpecList_aWX + } +-} + +import Data.Proxy + +class SpecList a where + type List a :: * + + slCase :: List a -> b -> (a -> List a -> b) -> b + +data IntList + = ILNil + | ILCons {-# UNPACK #-} !Int IntList + deriving (Show) + +instance SpecList Int where + type List Int = IntList + + slCase ILNil n _ = n + slCase (ILCons i t) _ c = c i t + +fromList :: [Int] -> IntList +fromList [] = ILNil +fromList (h : t) = ILCons h (fromList t) + +lst1 :: IntList +lst1 = fromList [1..10] + +{-# SPECIALIZE genLength :: Proxy Int -> List Int -> Int #-} +genLength :: forall a . SpecList a => Proxy a -> List a -> Int +genLength p lst = slCase lst 0 (\(_ :: a) tail -> 1 + genLength p tail) + +main :: IO () +main = print (genLength (Proxy :: Proxy Int) lst1) diff --git a/tests/examples/pre-ghc910/T10781.hs b/tests/examples/pre-ghc910/T10781.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10796a.hs b/tests/examples/pre-ghc910/T10796a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10796a.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +module T10796a where + +import Data.Ratio +import Data.Set (Set, fromList) +import Language.Haskell.TH.Syntax (liftData) + +-- Data instance with toConstr implemented using a variable, +-- not a data constructor +splicedSet :: Set Char +splicedSet = $(liftData (fromList "test")) + +-- Infix data constructor +splicedRatio :: Ratio Int +splicedRatio = $(liftData (1 % 2 :: Ratio Int)) diff --git a/tests/examples/pre-ghc910/T10796b.hs b/tests/examples/pre-ghc910/T10796b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10796b.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module T10796b where + +import Data.Set (Set, fromList) +import Language.Haskell.TH.Quote (dataToPatQ) + +badPattern :: Set Char -> Set Char +badPattern s@($(dataToPatQ (const Nothing) (fromList "test"))) = s diff --git a/tests/examples/pre-ghc910/T10806.hs b/tests/examples/pre-ghc910/T10806.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10815.hs b/tests/examples/pre-ghc910/T10815.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10819.1.hs b/tests/examples/pre-ghc910/T10819.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10819.1.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module T10819 where + +import T10819_Lib + +import Language.Haskell.TH.Syntax + +class C a b | b -> a where + f :: b -> a + +data D = X + +instance C Int D where + f X = 2 + +$(doSomeTH "N" (mkName "D") [ConT (mkName "C") `AppT` ConT (mkName "Int")]) + +thing :: N +thing = N X + +thing1 :: Int +thing1 = f thing diff --git a/tests/examples/pre-ghc910/T10819.hs b/tests/examples/pre-ghc910/T10819.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10819.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module T10819 where + +import T10819_Lib + +import Language.Haskell.TH.Syntax + +class C a b | b -> a where + f :: b -> a + +data D = X + +instance C Int D where + f X = 2 + +$(doSomeTH "N" (mkName "D") + [DerivClause Nothing [ConT (mkName "C") `AppT` ConT (mkName "Int")]]) + +thing :: N +thing = N X + +thing1 :: Int +thing1 = f thing + diff --git a/tests/examples/pre-ghc910/T10819_Lib.hs b/tests/examples/pre-ghc910/T10819_Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10819_Lib.hs @@ -0,0 +1,7 @@ +module T10819_Lib where + +import Language.Haskell.TH.Syntax + +doSomeTH s tp drv = return [NewtypeD [] n [] Nothing (NormalC n + [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) drv] + where n = mkName s diff --git a/tests/examples/pre-ghc910/T10820.hs b/tests/examples/pre-ghc910/T10820.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10820.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import Language.Haskell.TH.Syntax +import GHC.LanguageExtensions + +main = do + print $(isExtEnabled Cpp >>= lift) + print $(isExtEnabled LiberalTypeSynonyms >>= lift) + print $(isExtEnabled RankNTypes >>= lift) + print $(isExtEnabled TypeSynonymInstances >>= lift) + print $(isExtEnabled MagicHash >>= lift) diff --git a/tests/examples/pre-ghc910/T10826.hs b/tests/examples/pre-ghc910/T10826.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10830.hs b/tests/examples/pre-ghc910/T10830.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10830.hs @@ -0,0 +1,3 @@ +import GHC.OldList +main :: IO () +main = maximumBy compare [1..10000] `seq` return () diff --git a/tests/examples/pre-ghc910/T10836.hs b/tests/examples/pre-ghc910/T10836.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T10845.hs b/tests/examples/pre-ghc910/T10845.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10845.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ImplicitParams #-} +{-# OPTIONS_GHC -dcore-lint #-} + +import GHC.Stack + +f1 :: (?loc :: CallStack) => CallStack +-- we can infer a CallStack for let-binders +f1 = let y x = (?loc :: CallStack) + in y 0 + +f2 :: (?loc :: CallStack) => CallStack +-- but only when we would infer an IP. +-- i.e. the monomorphism restriction prevents us +-- from inferring a CallStack. +f2 = let y = (?loc :: CallStack) + in y + +main :: IO () +main = do putStrLn $ prettyCallStack f1 + putStrLn $ prettyCallStack f2 diff --git a/tests/examples/pre-ghc910/T10846.hs b/tests/examples/pre-ghc910/T10846.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10846.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-} + +module Main where + +import GHC.Stack + +f1 :: (?loc :: CallStack) => String +f1 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc + +f2 :: (?loc :: CallStack) => _ +f2 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc + +f3 :: (?loc :: CallStack, _) => String +f3 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc + +main :: IO () +main = do + putStrLn f1 + putStrLn f2 + putStrLn f3 diff --git a/tests/examples/pre-ghc910/T10870.hs b/tests/examples/pre-ghc910/T10870.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10870.hs @@ -0,0 +1,12 @@ +import Data.Bits +import Data.Int +import Data.Word + +unsafeShift32R :: (Bits a, Num a) => a -> a +unsafeShift32R x = unsafeShiftR x 32 + +main :: IO () +main = do + print $ map unsafeShift32R [ 123456, 0x7fffffff :: Int ] + print $ map unsafeShift32R [ -123456, -0x80000000 :: Int ] + print $ map unsafeShift32R [ 123456, 0xffffffff :: Word ] diff --git a/tests/examples/pre-ghc910/T10890.hs b/tests/examples/pre-ghc910/T10890.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10890.hs @@ -0,0 +1,23 @@ +module Main where + +-- Previously GHC was printing this warning: +-- +-- Main.hs:5:1: Warning: +-- The import of ‘A.has’ from module ‘A’ is redundant +-- +-- Main.hs:6:1: Warning: +-- The import of ‘B.has’ from module ‘B’ is redundant + +import A (A (has)) +import B (B (has)) + +data Blah = Blah + +instance A Blah where + has = Blah + +instance B Blah where + has = Blah + +main :: IO () +main = return () diff --git a/tests/examples/pre-ghc910/T10890_1.hs b/tests/examples/pre-ghc910/T10890_1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10890_1.hs @@ -0,0 +1,22 @@ +module Main where + +import Base +import Extends + +-- Previously GHC was giving this false positive: +-- +-- T10890_1.hs:4:1: Warning: +-- The import of ‘Extends’ is redundant +-- except perhaps to import instances from ‘Extends’ +-- To import instances alone, use: import Extends() + +data Bar = Bar + +instance AClass Bar where + has = Bar + +instance BClass Bar where + has = Bar + +main :: IO () +main = return () diff --git a/tests/examples/pre-ghc910/T10890_2.hs b/tests/examples/pre-ghc910/T10890_2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10890_2.hs @@ -0,0 +1,17 @@ +module T10890_2 where + +-- Previously GHC was printing this warning: +-- +-- Main.hs:5:1: Warning: +-- The import of ‘A.has’ from module ‘A’ is redundant +-- +-- Main.hs:6:1: Warning: +-- The import of ‘B.has’ from module ‘B’ is redundant + +import T10890_2A (A (has)) +import T10890_2B (B (has)) + +data Blah = Blah + +instance A Blah where + has = Blah diff --git a/tests/examples/pre-ghc910/T10890_2A.hs b/tests/examples/pre-ghc910/T10890_2A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10890_2A.hs @@ -0,0 +1,4 @@ +module T10890_2A where + +class A a where + has :: a diff --git a/tests/examples/pre-ghc910/T10890_2B.hs b/tests/examples/pre-ghc910/T10890_2B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10890_2B.hs @@ -0,0 +1,4 @@ +module T10890_2B where + +class B a where + has :: a diff --git a/tests/examples/pre-ghc910/T10891.1.hs b/tests/examples/pre-ghc910/T10891.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10891.1.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} + +module T10891 where + +import Language.Haskell.TH +import System.IO + +class C a where + f :: a -> Int + +class C' a where + type F a :: * + type F a = a + f' :: a -> Int + +class C'' a where + data Fd a :: * + +instance C' Int where + type F Int = Bool + f' = id + +instance C'' Int where + data Fd Int = B Bool | C Char + +$(return []) + +test :: () +test = + $(let + display :: Name -> Q () + display q = do + i <- reify q + runIO (hPutStrLn stderr (pprint i) >> hFlush stderr) + in do + display ''C + display ''C' + display ''C'' + [| () |]) diff --git a/tests/examples/pre-ghc910/T10891.hs b/tests/examples/pre-ghc910/T10891.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10891.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} + +module T10891 where + +import Language.Haskell.TH +import System.IO + +class C a where + f :: a -> Int + +class C' a where + type F a :: * + type F a = a + f' :: a -> Int + +class C'' a where + data Fd a :: * + +instance C' Int where + type F Int = Bool + f' = id + +instance C'' Int where + data Fd Int = B Bool | C Char + +$(return []) + +test :: () +test = + $(let + display :: Name -> Q () + display q = do + i <- reify q + runIO (hPutStrLn stderr (pprint i) >> hFlush stderr) + in do + display ''C + display ''C' + display ''C'' + [| () |]) + diff --git a/tests/examples/pre-ghc910/T10895.hs b/tests/examples/pre-ghc910/T10895.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10895.hs @@ -0,0 +1,1 @@ +module NotMain where diff --git a/tests/examples/pre-ghc910/T10897a.hs b/tests/examples/pre-ghc910/T10897a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10897a.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} +module T10897a where +pattern Single :: a -> a +pattern Single x = x diff --git a/tests/examples/pre-ghc910/T10897b.hs b/tests/examples/pre-ghc910/T10897b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10897b.hs @@ -0,0 +1,4 @@ +module B where +import T10897a + +Single y = True diff --git a/tests/examples/pre-ghc910/T10904.hs b/tests/examples/pre-ghc910/T10904.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10904.hs @@ -0,0 +1,28 @@ +import Control.Concurrent +import Control.Monad +import Foreign +import Foreign.C.Types +import System.Environment + + +foreign import ccall safe "finalizerlib.h init_value" + init_value :: Ptr CInt -> IO () + +foreign import ccall safe "finalizerlib.h &finalize_value" + finalize_value :: FinalizerPtr CInt + + +allocateValue :: IO () +allocateValue = do + fp <- mallocForeignPtrBytes 10000 + withForeignPtr fp init_value + addForeignPtrFinalizer finalize_value fp + + +main :: IO () +main = do + [n] <- fmap (fmap read) getArgs + _ <- forkIO (loop n) + loop n + where + loop n = replicateM_ n allocateValue diff --git a/tests/examples/pre-ghc910/T10908.hs b/tests/examples/pre-ghc910/T10908.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10908.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fwarn-missing-exported-sigs #-} + +module Bug (Data.List.intercalate, x) where + +import qualified Data.List + +intercalate = True + +x :: Bool +x = intercalate diff --git a/tests/examples/pre-ghc910/T10929.hs b/tests/examples/pre-ghc910/T10929.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10929.hs @@ -0,0 +1,31 @@ +module T10929 where + +x1 :: [Integer] +x1 = [5 .. 3] + +x2 :: [Integer] +x2 = [3 .. 5] + +x3 :: [Integer] +x3 = [5, 3 .. 1] + +x4 :: [Integer] +x4 = [5, (3+0) .. 1] + +x5 :: [Integer] +x5 = [1, 3 .. 5] + +x6 :: [Integer] +x6 = [1, (3+0) .. 5] + +x7 :: [Integer] +x7 = [5, 7 .. 1] + +x8 :: [Integer] +x8 = [5, (7+0) .. 1] + +x9 :: [Integer] +x9 = [3, 1 .. 5] + +x10 :: [Integer] +x10 = [3, (1+0) .. 5] diff --git a/tests/examples/pre-ghc910/T10931.hs b/tests/examples/pre-ghc910/T10931.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10931.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} + +{-# OPTIONS_GHC -Wall #-} + +module T10931 ( BugC(..) ) where + +data IdT f a = IdC (f a) + +class ( m ~ Outer m (Inner m) ) => BugC (m :: * -> *) where + type Inner m :: * -> * + type Outer m :: (* -> *) -> * -> * + + bug :: ( forall n. ( n ~ Outer n (Inner n) + , Outer n ~ Outer m + ) + => Inner n a) + -> m a + +instance BugC (IdT m) where + type Inner (IdT m) = m + type Outer (IdT m) = IdT + + bug f = IdC f diff --git a/tests/examples/pre-ghc910/T10934.hs b/tests/examples/pre-ghc910/T10934.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10934.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE + ScopedTypeVariables + , DataKinds + , GADTs + , RankNTypes + , TypeOperators + , PolyKinds -- Comment out PolyKinds and the bug goes away. + #-} +{-# OPTIONS_GHC -O #-} + -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it + +module KeyValue where + +data AccValidation err a = AccFailure err | AccSuccess a + +data KeyValueError = MissingValue + +type WithKeyValueError = AccValidation [KeyValueError] + +missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs +missing = rpure missingField + where + missingField :: forall x. (WithKeyValueError :. f) x + missingField = Compose $ AccFailure [MissingValue] + +data Rec :: (u -> Type) -> [u] -> Type where + RNil :: Rec f '[] + (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) + +newtype Compose (f :: l -> Type) (g :: k -> l) (x :: k) + = Compose { getCompose :: f (g x) } + +type (:.) f g = Compose f g + +class RecApplicative rs where + rpure + :: (forall x. f x) + -> Rec f rs diff --git a/tests/examples/pre-ghc910/T10935.hs b/tests/examples/pre-ghc910/T10935.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10935.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -fwarn-monomorphism-restriction #-} + +module T10935 where + +f x = let y = x+1 in (y,y) diff --git a/tests/examples/pre-ghc910/T10942.1.hs b/tests/examples/pre-ghc910/T10942.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10942.1.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/pre-ghc910/T10942.hs b/tests/examples/pre-ghc910/T10942.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10942.hs @@ -0,0 +1,22 @@ +module Main where + +import DynFlags +import GHC + +import Control.Monad.IO.Class (liftIO) +import System.Environment +import HeaderInfo +import Outputable +import StringBuffer + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + let dflags' = dflags `gopt_set` Opt_KeepRawTokenStream + `gopt_set` Opt_Haddock + filename = "T10942_A.hs" + setSessionDynFlags dflags' + stringBuffer <- liftIO $ hGetStringBuffer filename + liftIO $ print (map unLoc (getOptions dflags' stringBuffer filename)) diff --git a/tests/examples/pre-ghc910/T10942_A.hs b/tests/examples/pre-ghc910/T10942_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10942_A.hs @@ -0,0 +1,16 @@ +{- + +A normal comment, to check if we can still pick up the CPP directive after it. + +-} +-- Check that we can parse a file with leading comments + +-- ^ haddock +-- * haddock +-- | haddock +-- $ haddock +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +module T10942 where + +main = return () diff --git a/tests/examples/pre-ghc910/T10945.hs b/tests/examples/pre-ghc910/T10945.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10945.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T10945 where + +import Language.Haskell.TH + +$$(return [ + SigD (mkName "m") + (ForallT [PlainTV (mkName "a")] + [] + (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) + , FunD (mkName "m") + [Clause [VarP (mkName "x")] (NormalB (VarE (mkName "x"))) []] + ]) diff --git a/tests/examples/pre-ghc910/T10946.hs b/tests/examples/pre-ghc910/T10946.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10946.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T10946 where + +import Language.Haskell.TH + +m :: a -> a +m x = $$([||_||]) diff --git a/tests/examples/pre-ghc910/T10955dyn.hs b/tests/examples/pre-ghc910/T10955dyn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10955dyn.hs @@ -0,0 +1,7 @@ +module Main where + +import Foreign +import Foreign.C.Types +foreign import ccall "bar" dle :: IO CInt + +main = dle >>= print diff --git a/tests/examples/pre-ghc910/T10962.hs b/tests/examples/pre-ghc910/T10962.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10962.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +import GHC.Base + +main :: IO () +main = do + -- Overflow. + let (# w1, i1 #) = subWordC# 1## 3## + print (W# w1, I# i1) + + -- No overflow. + let (# w2, i2 #) = subWordC# 3## 1## + print (W# w2, I# i2) diff --git a/tests/examples/pre-ghc910/T10971a.hs b/tests/examples/pre-ghc910/T10971a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10971a.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-} +module T10971a where + +import Data.Traversable (fmapDefault) + +f = \x -> length x +g = \f x -> fmapDefault f x +h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/pre-ghc910/T10971b.hs b/tests/examples/pre-ghc910/T10971b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10971b.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE MonomorphismRestriction, NoExtendedDefaultRules #-} +module T10971b where +import Data.Traversable (fmapDefault) +f = \x -> length x +g = \f x -> fmapDefault f x +h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/pre-ghc910/T10971c.hs b/tests/examples/pre-ghc910/T10971c.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10971c.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-} +module T10971c where + +import Data.Traversable (fmapDefault) + +f = \x -> length x +g = \f x -> fmapDefault f x +h = \f x -> (fmapDefault f x, length x) diff --git a/tests/examples/pre-ghc910/T10971d.hs b/tests/examples/pre-ghc910/T10971d.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10971d.hs @@ -0,0 +1,6 @@ +import T10971c + +main = do + print $ f (Just 1) + print $ g (+1) (Just 5) + print $ h (const 5) Nothing diff --git a/tests/examples/pre-ghc910/T10997.hs b/tests/examples/pre-ghc910/T10997.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10997.hs @@ -0,0 +1,6 @@ +module T10997 where + +import T10997a + +foo :: Exp a -> String +foo Tru = "True" diff --git a/tests/examples/pre-ghc910/T10997_1.hs b/tests/examples/pre-ghc910/T10997_1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10997_1.hs @@ -0,0 +1,15 @@ +module T10997_1 where + +import T10997_1a + +{- With ghc-7.10.2: + + The interface for ‘T10997a’ + Declaration for Just' + Pattern synonym Just': + Iface type variable out of scope: k + Cannot continue after interface file error +-} + +bar :: (Showable a) => Maybe a -> Maybe a +bar (Just' a) = Just' a diff --git a/tests/examples/pre-ghc910/T10997_1a.hs b/tests/examples/pre-ghc910/T10997_1a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10997_1a.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns, ConstraintKinds, TypeFamilies, PolyKinds, KindSignatures #-} +module T10997_1a where + +import GHC.Exts + +type family Showable (a :: k) :: Constraint where + Showable (a :: *) = (Show a) + Showable a = () + +extractJust :: Maybe a -> (Bool, a) +extractJust (Just a) = (True, a) +extractJust _ = (False, undefined) + +pattern Just' :: Showable a => a -> (Maybe a) +pattern Just' a <- (extractJust -> (True, a)) where + Just' a = Just a + diff --git a/tests/examples/pre-ghc910/T10997a.hs b/tests/examples/pre-ghc910/T10997a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10997a.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTs, PatternSynonyms #-} + +module T10997a where + +data Exp ty where + LitB :: Bool -> Exp Bool + +pattern Tru :: () => b ~ Bool => Exp b +pattern Tru = LitB True + + diff --git a/tests/examples/pre-ghc910/T10999.hs b/tests/examples/pre-ghc910/T10999.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T10999.hs @@ -0,0 +1,8 @@ +module T10999 where + +import qualified Data.Set as Set + +f :: _ => () -> _ +f _ = Set.fromList undefined + +g = map fst $ Set.toList $ f () diff --git a/tests/examples/pre-ghc910/T11010.hs b/tests/examples/pre-ghc910/T11010.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11010.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE PatternSynonyms, ExistentialQuantification, GADTSyntax #-} +{-# LANGUAGE TypeFamilies #-} + +module T11010 where + +data Expr a where + Fun :: String -> (a -> b) -> (Expr a -> Expr b) + +ggFun :: String -> (a -> b) -> (Expr a -> Expr b) +ggFun = undefined + +pattern IntFun :: (a ~ Int) => String -> (a -> b) -> (Expr a -> Expr b) +pattern IntFun str f x = Fun str f x + +-- Alternative syntax for pattern synonyms: +-- pattern +-- Suc :: () => (a ~ Int) => Expr a -> Expr Int +-- Suc n <- IntFun _ _ n where +-- Suc n = IntFun "suc" (+ 1) n +pattern Suc :: (a ~ Int) => Expr a -> Expr Int +pattern Suc n <- IntFun _ _ n where + Suc n = IntFun "suc" (+ 1) n diff --git a/tests/examples/pre-ghc910/T11016.hs b/tests/examples/pre-ghc910/T11016.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11016.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-} + +module T11016 where + +f1 :: (?x :: Int, _) => Int +f1 = ?x + +f2 :: (?x :: Int) => _ +f2 = ?x diff --git a/tests/examples/pre-ghc910/T11039.hs b/tests/examples/pre-ghc910/T11039.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11039.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module Foo () where + +data A a = A a + +pattern Q :: () => (A ~ f) => a -> f a +pattern Q a = A a diff --git a/tests/examples/pre-ghc910/T11053.hs b/tests/examples/pre-ghc910/T11053.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11053.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE PatternSynonyms #-} +-- turn on with -fwarn-missing-pat-syn-sigs + +module Foo where + +-- Should warn because of missing signature +pattern T = True + +pattern J a = Just a + +pattern J1 a <- Just a + +pattern J2{b} = Just b + +pattern J3{c} <- Just c + +pattern F :: Bool +pattern F = False diff --git a/tests/examples/pre-ghc910/T11067.hs b/tests/examples/pre-ghc910/T11067.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11067.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +module T11067 where + +import Data.Monoid +import GHC.Exts (Constraint) + +type family Skolem (p :: k -> Constraint) :: k +type family SkolemF (p :: k2 -> Constraint) (f :: k1 -> k2) :: k1 + +-- | A quantified constraint +type Forall (p :: k -> Constraint) = p (Skolem p) +type ForallF (p :: k2 -> Constraint) (f :: k1 -> k2) = p (f (SkolemF p f)) + +-- These work +class ForallF Monoid t => Monoid1 t +instance ForallF Monoid t => Monoid1 t + +class ForallF Monoid1 t => Monoid2 t +instance ForallF Monoid1 t => Monoid2 t + +-- Changing f a ~ g a to, (Ord (f a), Ord (g a)), say, removes the error +class (f a ~ g a) => H f g a +instance (f a ~ g a) => H f g a + +-- This one gives a superclass cycle error. +class Forall (H f g) => H1 f g +instance Forall (H f g) => H1 f g diff --git a/tests/examples/pre-ghc910/T11071.hs b/tests/examples/pre-ghc910/T11071.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11071.hs @@ -0,0 +1,28 @@ +module T11071 where + +import Data.List (lines) +import qualified Data.Map as M () +import qualified Data.IntMap as M () +import qualified Data.IntMap as M () -- just to see if this confused the code + +import qualified Data.Ord as Ord hiding (Down) + +import qualified Data.Map as M' hiding (size, filter) +import qualified Data.Map as M' hiding (size) +import qualified Data.IntMap as M' hiding (size) +import qualified System.IO as M' () -- unrelated + +ignore :: a -> IO () +ignore = const (return ()) + +main = do + ignore NoSuchModule.foo -- no such module + ignore Data.List.foobar -- does not exist (one import) + ignore M.foobar -- does not exist (two imports) + ignore M'.foobar -- does not exist (three imports) + ignore Data.List.sort -- needs import + ignore Data.List.unlines -- needs import, similar to imported + ignore M.size -- multiple modules to import from + ignore M.valid -- only one module to import from + ignore Ord.Down -- explicit hiding + ignore M'.size -- hidden and/or missing in import list diff --git a/tests/examples/pre-ghc910/T11071a.hs b/tests/examples/pre-ghc910/T11071a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11071a.hs @@ -0,0 +1,16 @@ +module T11071 where + +import Data.List (lines) +import Data.IntMap () +import Data.Ord hiding (Down) +import Prelude hiding (True) + +ignore :: a -> IO () +ignore = const (return ()) + +main = do + ignore intersperse -- missing in import list (one import) + ignore foldl' -- missing in import list (two imports) + ignore Down -- explicitly hidden + ignore True -- explicitly hidden from prelude (not really special) + ignore foobar -- genuinely out of scope diff --git a/tests/examples/pre-ghc910/T11076.hs b/tests/examples/pre-ghc910/T11076.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11076.hs @@ -0,0 +1,15 @@ +{- + Test case for a problem where GHC had incorrect strictness + information for foreign calls with lifted arguments + -} +{-# OPTIONS_GHC -O0 #-} +module Main where + +import T11076A +import Control.Exception +x :: Bool +x = error "OK: x has been forced" + +main :: IO () +main = print (testBool x) `catch` + \(ErrorCall e) -> putStrLn e -- x should be forced diff --git a/tests/examples/pre-ghc910/T11076A.hs b/tests/examples/pre-ghc910/T11076A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11076A.hs @@ -0,0 +1,21 @@ +{-# OPTIONS_GHC -O #-} +{-# LANGUAGE MagicHash, + ForeignFunctionInterface, + UnliftedFFITypes, + GHCForeignImportPrim, + BangPatterns + #-} +module T11076A where + +import GHC.Exts +import Unsafe.Coerce + +{- + If the demand type for the foreign call argument is incorrectly strict, + the bang pattern can be optimized out + -} +testBool :: Bool -> Int +testBool !x = I# (cmm_testPrim (unsafeCoerce x)) +{-# INLINE testBool #-} + +foreign import prim "testPrim" cmm_testPrim :: Any -> Int# diff --git a/tests/examples/pre-ghc910/T11077.hs b/tests/examples/pre-ghc910/T11077.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11077.hs @@ -0,0 +1,3 @@ +module T11077 (module X, foo) where +import Data.List as X +foo = undefined diff --git a/tests/examples/pre-ghc910/T11103.hs b/tests/examples/pre-ghc910/T11103.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11103.hs @@ -0,0 +1,20 @@ +-- When using DuplicateRecordFields with TemplateHaskell, it is not possible to +-- reify ambiguous names that are output by reifying field labels. +-- See also overloadedrecflds/should_run/overloadedrecfldsrun04.hs + +{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +data R = MkR { foo :: Int, bar :: Int } +data S = MkS { foo :: Int } + +$(do info <- reify ''R + case info of + TyConI (DataD _ _ _ [RecC _ [(foo_n, _, _), (bar_n, _, _)]] _) + -> do { reify bar_n -- This is unambiguous + ; reify foo_n -- This is ambiguous + ; return [] + } + _ -> error "unexpected result of reify") diff --git a/tests/examples/pre-ghc910/T11112.hs b/tests/examples/pre-ghc910/T11112.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11112.hs @@ -0,0 +1,4 @@ +module T11112 where + +sort :: Ord s -> [s] -> [s] +sort xs = xs diff --git a/tests/examples/pre-ghc910/T11128.hs b/tests/examples/pre-ghc910/T11128.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11128.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -fwarn-noncanonical-monad-instances #-} + +-- | Test noncanonical-monad-instances warnings +module T11128 where + +import Control.Applicative as A +import Control.Monad as M + +---------------------------------------------------------------------------- +-- minimal definition + +data T0 a = T0 a deriving Functor + +instance A.Applicative T0 where + pure = T0 + (<*>) = M.ap + +instance M.Monad T0 where + (>>=) = undefined + +---------------------------------------------------------------------------- +-- trigger all 4 warnings + +data T1 a = T1 a deriving Functor + +instance A.Applicative T1 where + pure = return + (<*>) = M.ap + (*>) = (M.>>) + +instance M.Monad T1 where + (>>=) = undefined + return = T1 + (>>) = undefined + +---------------------------------------------------------------------------- +-- backward compat canonical defintion + +data T2 a = T2 a deriving Functor + +instance Applicative T2 where + pure = T2 + (<*>) = ap + (*>) = undefined + +instance M.Monad T2 where + (>>=) = undefined + return = pure + (>>) = (*>) diff --git a/tests/examples/pre-ghc910/T11136.hs b/tests/examples/pre-ghc910/T11136.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11136.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +module T11136 where + +class C a where + type D a + type instance D a x = x diff --git a/tests/examples/pre-ghc910/T11142.hs b/tests/examples/pre-ghc910/T11142.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11142.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeInType, RankNTypes #-} + +module T11142 where + +import Data.Kind + +data SameKind :: k -> k -> Type + +foo :: forall b. (forall k (a :: k). SameKind a b) -> () +foo = undefined diff --git a/tests/examples/pre-ghc910/T11148.hs b/tests/examples/pre-ghc910/T11148.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11148.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} + +module T11148 where + +data family G a b c d +data instance G Int b Float d = G deriving Functor + +data family H a b c d +data instance H [b] b d c = H deriving Functor diff --git a/tests/examples/pre-ghc910/T11155.hs b/tests/examples/pre-ghc910/T11155.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11155.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -O -fno-full-laziness #-} +module T11155 where + +foo :: Bool +{-# NOINLINE foo #-} +foo = error "rk" + +bar x = let t :: Char + t = case foo of { True -> 'v'; False -> 'y' } + in [t] + diff --git a/tests/examples/pre-ghc910/T11164.hs b/tests/examples/pre-ghc910/T11164.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11164.hs @@ -0,0 +1,3 @@ +module T11164 where + +import T11164b (T) diff --git a/tests/examples/pre-ghc910/T11164a.hs b/tests/examples/pre-ghc910/T11164a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11164a.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} +module T11164a where + +data family T a diff --git a/tests/examples/pre-ghc910/T11164b.hs b/tests/examples/pre-ghc910/T11164b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11164b.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeFamilies #-} +module T11164b where + +import T11164a + +data instance T Int = MkT diff --git a/tests/examples/pre-ghc910/T11167.hs b/tests/examples/pre-ghc910/T11167.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11167.hs @@ -0,0 +1,21 @@ +module T11167 where + +data SomeException + +newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r} + +runContT' :: ContT r m a -> (a -> m r) -> m r +runContT' = runContT + +catch_ :: IO a -> (SomeException -> IO a) -> IO a +catch_ = undefined + +foo :: IO () +foo = (undefined :: ContT () IO a) + `runContT` (undefined :: a -> IO ()) + `catch_` (undefined :: SomeException -> IO ()) + +foo' :: IO () +foo' = (undefined :: ContT () IO a) + `runContT'` (undefined :: a -> IO ()) + `catch_` (undefined :: SomeException -> IO ()) diff --git a/tests/examples/pre-ghc910/T11167_ambig.hs b/tests/examples/pre-ghc910/T11167_ambig.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11167_ambig.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T11167_ambig where + +data SomeException + +newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r} +newtype ContT' r m a = ContT' {runContT :: (a -> m r) -> m r} + +runContT' :: ContT r m a -> (a -> m r) -> m r +runContT' = runContT + +catch_ :: IO a -> (SomeException -> IO a) -> IO a +catch_ = undefined + +foo :: IO () +foo = (undefined :: ContT () IO a) + `runContT` (undefined :: a -> IO ()) + `catch_` (undefined :: SomeException -> IO ()) + +foo' :: IO () +foo' = (undefined :: ContT () IO a) + `runContT'` (undefined :: a -> IO ()) + `catch_` (undefined :: SomeException -> IO ()) diff --git a/tests/examples/pre-ghc910/T11167_ambiguous_fixity.hs b/tests/examples/pre-ghc910/T11167_ambiguous_fixity.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11167_ambiguous_fixity.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T11167_ambiguous_fixity where +import T11167_ambiguous_fixity_A +import T11167_ambiguous_fixity_B + +x a = (a :: A) `foo` 0 diff --git a/tests/examples/pre-ghc910/T11167_ambiguous_fixity_A.hs b/tests/examples/pre-ghc910/T11167_ambiguous_fixity_A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11167_ambiguous_fixity_A.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T11167_ambiguous_fixity_A where +data A = MkA { foo :: Int -> Int } +data C = MkC { foo :: Int -> Int } +infixr 3 `foo` diff --git a/tests/examples/pre-ghc910/T11167_ambiguous_fixity_B.hs b/tests/examples/pre-ghc910/T11167_ambiguous_fixity_B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11167_ambiguous_fixity_B.hs @@ -0,0 +1,3 @@ +module T11167_ambiguous_fixity_B where +data B = MkB { foo :: Int -> Int } +infixl 5 `foo` diff --git a/tests/examples/pre-ghc910/T11173.hs b/tests/examples/pre-ghc910/T11173.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11173.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T11173 where +import T11173a (A(..)) + +-- Check that the fixity declaration applied to the field 'foo' is used +x b = b `foo` b `foo` 0 diff --git a/tests/examples/pre-ghc910/T11173a.hs b/tests/examples/pre-ghc910/T11173a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11173a.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module T11173a where + +data A = A { foo :: Int -> Int, bar :: Int -> Int } +newtype B = B { foo :: Int -> Int } +infixr 5 `foo` +infixr 5 `bar` + +-- This is well-typed only if the fixity is correctly applied +y b = b `bar` b `bar` 0 diff --git a/tests/examples/pre-ghc910/T11182.hs b/tests/examples/pre-ghc910/T11182.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11182.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Strict #-} +-- | Strict should imply StrictData +module Main where + +data Lazy a = Lazy ~a + +main :: IO () +main = + case Lazy undefined of + Lazy _ -> putStrLn "Lazy" diff --git a/tests/examples/pre-ghc910/T11187.hs b/tests/examples/pre-ghc910/T11187.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11187.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module T11187 where +import Data.Type.Coercion + +type family X + +coercionXX :: Coercion X X +coercionXX = Coercion + +coercionXX1 :: Coercion X X +coercionXX1 = c where + c :: x ~ X => Coercion x x + c = Coercion + +coercionXX2 :: Coercion X X +coercionXX2 = c where c = Coercion diff --git a/tests/examples/pre-ghc910/T11192.hs b/tests/examples/pre-ghc910/T11192.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11192.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PartialTypeSignatures #-} + +module T11192 where + +fails :: a +fails = + let go :: _ + go 0 a = a + in go (0 :: Int) undefined + +succeeds :: a +succeeds = + let go :: _ + go _ a = a + in go (0 :: Int) undefined diff --git a/tests/examples/pre-ghc910/T11193.hs b/tests/examples/pre-ghc910/T11193.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11193.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Strict #-} + +module Main where + +main = do + ~a <- return (error "don't error here!") + b <- return (error "error here!") -- this binding should be strict + print "should never reach here" diff --git a/tests/examples/pre-ghc910/T11208.hs b/tests/examples/pre-ghc910/T11208.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11208.hs @@ -0,0 +1,8 @@ +module T11208 where + +import qualified Prelude as P + +f n = n P.+ 1 + +g h (P.Just x) = P.Just (h x) +g _ P.Nothing = P.Nothing diff --git a/tests/examples/pre-ghc910/T11216.hs b/tests/examples/pre-ghc910/T11216.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11216.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RebindableSyntax #-} + +module Bug where + +foo :: (a, b) -> () +foo x | (_,_) <- x = () diff --git a/tests/examples/pre-ghc910/T11224.hs b/tests/examples/pre-ghc910/T11224.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11224.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE PatternSynonyms , ViewPatterns #-} + +-- inlining a pattern synonym shouldn't change semantics + +import Text.Read + +-- pattern PRead :: () => Read a => a -> String +pattern PRead a <- (readMaybe -> Just a) + +foo :: String -> Int +foo (PRead x) = (x::Int) +foo (PRead xs) = sum (xs::[Int]) +foo _ = 666 + +bar :: String -> Int +bar (readMaybe -> Just x) = (x::Int) +bar (readMaybe -> Just xs) = sum (xs::[Int]) +bar _ = 666 + +main :: IO () +main = do + print $ foo "1" -- 1 + print $ foo "[1,2,3]" -- 666 -- ??? + print $ foo "xxx" -- 666 + + print $ bar "1" -- 1 + print $ bar "[1,2,3]" -- 6 + print $ bar "xxx" -- 666 diff --git a/tests/examples/pre-ghc910/T11232.hs b/tests/examples/pre-ghc910/T11232.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11232.hs @@ -0,0 +1,15 @@ +module T11232 where + +import Control.Monad +import Data.Data + +mkMp :: ( MonadPlus m + , Typeable a + , Typeable b + ) + => (b -> m b) + -> a + -> m a +mkMp ext = unM (maybe (M (const mzero)) id (gcast (M ext))) + +newtype M m x = M { unM :: x -> m x } diff --git a/tests/examples/pre-ghc910/T11237.hs b/tests/examples/pre-ghc910/T11237.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11237.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE GADTs #-} +module TypeInTypeBug where + +import qualified Data.Kind + +data Works :: Data.Kind.Type where + WorksConstr :: Works + +type Set = Data.Kind.Type + +data ShouldWork :: Set where + ShouldWorkConstr :: ShouldWork diff --git a/tests/examples/pre-ghc910/T1133Aa.hs b/tests/examples/pre-ghc910/T1133Aa.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T1133Aa.hs @@ -0,0 +1,3 @@ +module T1133Aa where + +import {-# SOURCE #-} T1133A diff --git a/tests/examples/pre-ghc910/T1133a.hs b/tests/examples/pre-ghc910/T1133a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T1133a.hs @@ -0,0 +1,3 @@ +module T1133a where + +import {-# SOURCE #-} T1133 diff --git a/tests/examples/pre-ghc910/T11381.hs b/tests/examples/pre-ghc910/T11381.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11381.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} + +module T11381 where + +-- ensure that this code does not compile without InjectiveTypeFamilies and that +-- injectivity error is not reported. +type family F a = r | r -> a +type instance F Int = Bool +type instance F Int = Char diff --git a/tests/examples/pre-ghc910/T11484.hs b/tests/examples/pre-ghc910/T11484.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11484.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module T11484 where + +import Data.Kind + +type TySyn (k :: *) (a :: k) = () + +$([d| type TySyn2 (k :: *) (a :: k) = () |]) + diff --git a/tests/examples/pre-ghc910/T11671_run.hs b/tests/examples/pre-ghc910/T11671_run.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11671_run.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE MagicHash #-} + +import Data.Foldable (traverse_) +import Data.Proxy (Proxy(..)) +import GHC.OverloadedLabels (IsLabel(..)) +import GHC.TypeLits (KnownSymbol, symbolVal) +import GHC.Prim (Addr#) + +instance KnownSymbol symbol => IsLabel symbol String where + fromLabel = symbolVal (Proxy :: Proxy symbol) + +(#), (#.) :: String -> Int -> String +(#) _ i = show i +_ #. i = show i + +f :: Addr# -> Int -> String +f _ i = show i + +main :: IO () +main = traverse_ putStrLn + [ #a + , #number17 + , #do + , #type + , #Foo + , #3 + , #"199.4" + , #17a23b + , #f'a' + , #'a' + , #' + , #''notTHSplice + , #"..." + , #привет + , #こんにちは + , #"3" + , #":" + , #"Foo" + , #"The quick brown fox" + , #"\"" + , (++) #hello#world + , (++) #"hello"#"world" + , #"hello"# 1 -- equivalent to `(fromLabel @"hello") # 1` + , f "hello"#2 -- equivalent to `f ("hello"# :: Addr#) 2` + ] diff --git a/tests/examples/pre-ghc910/T11727.hs b/tests/examples/pre-ghc910/T11727.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11727.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} + +module T11727 where + +pattern A,B :: Int +pattern A = 5 +pattern B = 5 + diff --git a/tests/examples/pre-ghc910/T11959.hs b/tests/examples/pre-ghc910/T11959.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T11959.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PatternSynonyms #-} +module Main where + +import T11959Lib (Vec2(..), pattern (:>)) + +main = return () diff --git a/tests/examples/pre-ghc910/T12045TH1.hs b/tests/examples/pre-ghc910/T12045TH1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T12045TH1.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds + , TypeInType, TypeApplications, TypeFamilies #-} + +module T12045TH1 where +import Data.Kind +import Language.Haskell.TH hiding (Type) + +$([d| type family F (a :: k) :: Type where + F @Type Int = Bool + F @(Type->Type) Maybe = Char |]) + + +$([d| data family D (a :: k) |]) + +$([d| data instance D @Type a = DBool |]) + +$([d| data instance D @(Type -> Type) b = DChar |]) + diff --git a/tests/examples/pre-ghc910/T12045TH2.hs b/tests/examples/pre-ghc910/T12045TH2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T12045TH2.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell, TypeApplications, PolyKinds + , TypeFamilies, DataKinds #-} + +module T12045TH2 where + +import Data.Kind +import Language.Haskell.TH hiding (Type) +import System.IO + +type family Foo (a :: k) :: Type where + Foo @Type a = Bool + +type family Baz (a :: k) +type instance Baz @(Type->Type->Type) a = Char + +$( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1) + [TySynEqn (Just bndrs1) (AppT _ lhs1) rhs1]) + [] <- reify ''Foo + FamilyI baz@(OpenTypeFamilyD (TypeFamilyHead _ tvbs2 res2 m_kind2)) + [inst@(TySynInstD (TySynEqn (Just bndrs2) (AppT _ lhs2) rhs2))] <- reify ''Baz + runIO $ putStrLn $ pprint foo + runIO $ putStrLn $ pprint baz + runIO $ putStrLn $ pprint inst + runIO $ hFlush stdout + return [ ClosedTypeFamilyD + (TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1) + [TySynEqn (Just bndrs1) (AppT (ConT (mkName "Foo'")) lhs1) rhs1] + , OpenTypeFamilyD + (TypeFamilyHead (mkName "Baz'") tvbs2 res2 m_kind2) + , TySynInstD (TySynEqn (Just bndrs2) (AppT (ConT (mkName "Baz'")) lhs2) rhs2)] ) + diff --git a/tests/examples/pre-ghc910/T12045a.hs b/tests/examples/pre-ghc910/T12045a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T12045a.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE PolyKinds, GADTs, TypeApplications, TypeInType, DataKinds, + RankNTypes, ConstraintKinds, TypeFamilies #-} + +module T12045a where + +import Data.Kind +import Data.Typeable + +data T (f :: k -> Type) a = MkT (f a) + +newtype TType f a= MkTType (T @Type f a) + +t1 :: TType Maybe Bool +t1 = MkTType (MkT (Just True)) + +t2 :: TType Maybe a +t2 = MkTType (MkT Nothing) + +data Nat = O | S Nat + +data T1 :: forall k1 k2. k1 -> k2 -> Type where + MkT1 :: T1 a b + +x :: T1 @_ @Nat False n +x = MkT1 + +-- test from trac 12045 +type Cat k = k -> k -> Type + +data FreeCat :: Cat k -> Cat k where + Nil :: FreeCat f a a + Cons :: f a b -> FreeCat f b c -> FreeCat f a c + +liftCat :: f a b -> FreeCat f a b +liftCat x = Cons x Nil + +data Node = Unit | N + +data NatGraph :: Cat Node where + One :: NatGraph Unit N + Succ :: NatGraph N N + +one :: (FreeCat @Node NatGraph) Unit N +one = liftCat One + +type Typeable1 = Typeable @(Type -> Type) +type Typeable2 = Typeable @(Type -> Type -> Type) +type Typeable3 = Typeable @(Cat Bool) + +type family F a where + F Type = Type -> Type + F (Type -> Type) = Type + F other = other + +data T2 :: F k -> Type + +foo :: T2 @Type Maybe -> T2 @(Type -> Type) Int -> Type +foo a b = undefined + +data family D (a :: k) +data instance D @Type a = DBool +data instance D @(Type -> Type) b = DChar + +class C a where + tc :: (D a) -> Int + +instance C Int where + tc DBool = 5 + +instance C Bool where + tc DBool = 6 + +instance C Maybe where + tc DChar = 7 + +-- Tests from D5229 +data P a = MkP +type MkPTrue = MkP @Bool + +type BoolEmpty = '[] @Bool + +type family F1 (a :: k) :: Type +type G2 (a :: Bool) = F1 @Bool a + diff --git a/tests/examples/pre-ghc910/T12478_5.hs b/tests/examples/pre-ghc910/T12478_5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T12478_5.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnboxedSums #-} +module T12478_5 where + +import Language.Haskell.TH + +foo :: $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) + -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) +foo $(conP (unboxedSumDataName 1 2) [conP '() []]) + = $(conE (unboxedSumDataName 2 2) `appE` conE '()) +foo $(conP (unboxedSumDataName 2 2) [conP '() []]) + = $(conE (unboxedSumDataName 2 2) `appE` conE '()) + +foo2 :: (# () | () #) + -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) +foo2 (# () | #) = $(conE (unboxedSumDataName 2 2) `appE` conE '()) +foo2 $(conP (unboxedSumDataName 2 2) [conP '() []]) = (# | () #) + diff --git a/tests/examples/pre-ghc910/T13050.hs b/tests/examples/pre-ghc910/T13050.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T13050.hs @@ -0,0 +1,7 @@ +module HolesInfix where + +f, g, q :: Int -> Int -> Int +f x y = _ x y +g x y = x `_` y +q x y = x `_a` y + diff --git a/tests/examples/pre-ghc910/T13087.hs b/tests/examples/pre-ghc910/T13087.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T13087.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE AlternativeLayoutRule #-} +{-# LANGUAGE LambdaCase #-} + +isOne :: Int -> Bool +isOne = \case 1 -> True + _ -> False + +main = return () + diff --git a/tests/examples/pre-ghc910/T13343.hs b/tests/examples/pre-ghc910/T13343.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T13343.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} +module Bug where + +import GHC.Exts + +type Bad :: forall v . TYPE v +type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v + +-- Note v /= v1. + diff --git a/tests/examples/pre-ghc910/T13594.hs b/tests/examples/pre-ghc910/T13594.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T13594.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +module Bug where + +x :: forall a b. (a ~ Integer, b ~ Integer) => (a, b) +!x = (1, 2) +~y = (1, 2) diff --git a/tests/examples/pre-ghc910/T13747.hs b/tests/examples/pre-ghc910/T13747.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T13747.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +module T13747 where + +class C a where + type family TC a :: * + +class D a where + data family TD a :: * + +instance C Int where + type instance TC Int = Int + +instance D Double where + data instance TD Double = TDDouble + +instance D Int where + newtype instance TD Int = TDInt Int + +instance D Char where + data instance TD Char where + C1 :: TD Char + C2 :: TD Char + diff --git a/tests/examples/pre-ghc910/T14164.hs b/tests/examples/pre-ghc910/T14164.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T14164.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +module T14164 where + +data G (x :: a) = GNil | GCons (G x) + +type family F (xs :: [a]) (g :: G (z :: a)) = (res :: [a]) | res -> a where + F (x:xs) GNil = x:xs + F (x:xs) (GCons rest) = x:F xs rest + diff --git a/tests/examples/pre-ghc910/T14650.hs b/tests/examples/pre-ghc910/T14650.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T14650.hs @@ -0,0 +1,77 @@ +module MergeSort ( + msortBy + ) where + +infixl 7 :% +infixr 6 :& + +data LenList a = LL {-# UNPACK #-} !Int Bool [a] + +data LenListAnd a b = {-# UNPACK #-} !(LenList a) :% b + +data Stack a + = End + | {-# UNPACK #-} !(LenList a) :& (Stack a) + +msortBy :: (a -> a -> Ordering) -> [a] -> [a] +msortBy cmp = mergeSplit End where + splitAsc n _ _ _ | n `seq` False = undefined + splitAsc n as _ [] = LL n True as :% [] + splitAsc n as a bs@(b:bs') = case cmp a b of + GT -> LL n False as :% bs + _ -> splitAsc (n + 1) as b bs' + + splitDesc n _ _ _ | n `seq` False = undefined + splitDesc n rs a [] = LL n True (a:rs) :% [] + splitDesc n rs a bs@(b:bs') = case cmp a b of + GT -> splitDesc (n + 1) (a:rs) b bs' + _ -> LL n True (a:rs) :% bs + + mergeLL (LL na fa as) (LL nb fb bs) = LL (na + nb) True $ mergeLs na as nb bs where + mergeLs nx _ ny _ | nx `seq` ny `seq` False = undefined + mergeLs 0 _ ny ys = if fb then ys else take ny ys + mergeLs _ [] ny ys = if fb then ys else take ny ys + mergeLs nx xs 0 _ = if fa then xs else take nx xs + mergeLs nx xs _ [] = if fa then xs else take nx xs + mergeLs nx xs@(x:xs') ny ys@(y:ys') = case cmp x y of + GT -> y:mergeLs nx xs (ny - 1) ys' + _ -> x:mergeLs (nx - 1) xs' ny ys + + push ssx px@(LL nx _ _) = case ssx of + End -> px :% ssx + py@(LL ny _ _) :& ssy -> case ssy of + End + | nx >= ny -> mergeLL py px :% ssy + pz@(LL nz _ _) :& ssz + | nx >= ny || nx + ny >= nz -> case nx > nz of + False -> push ssy $ mergeLL py px + _ -> case push ssz $ mergeLL pz py of + pz' :% ssz' -> push (pz' :& ssz') px + _ -> px :% ssx + + mergeAll _ px | px `seq` False = undefined + mergeAll ssx px@(LL nx _ xs) = case ssx of + End -> xs + py@(LL _ _ _) :& ssy -> case ssy of + End -> case mergeLL py px of + LL _ _ xys -> xys + pz@(LL nz _ _) :& ssz -> case nx > nz of + False -> mergeAll ssy $ mergeLL py px + _ -> case push ssz $ mergeLL pz py of + pz' :% ssz' -> mergeAll (pz' :& ssz') px + + mergeSplit ss _ | ss `seq` False = undefined + mergeSplit ss [] = case ss of + End -> [] + px :& ss' -> mergeAll ss' px + mergeSplit ss as@(a:as') = case as' of + [] -> mergeAll ss $ LL 1 True as + b:bs -> case cmp a b of + GT -> case splitDesc 2 [a] b bs of + px :% rs -> case push ss px of + px' :% ss' -> mergeSplit (px' :& ss') rs + _ -> case splitAsc 2 as b bs of + px :% rs -> case push ss px of + px' :% ss' -> mergeSplit (px' :& ss') rs + {-# INLINABLE mergeSplit #-} + diff --git a/tests/examples/pre-ghc910/T15365.hs b/tests/examples/pre-ghc910/T15365.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T15365.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module T15365 where + +$([d| type (|||) = Either + + (&&&) :: Bool -> Bool -> Bool + (&&&) = (&&) + + type role (***) + data (***) + + class (???) + instance (???) + + data family ($$$) + data instance ($$$) + + type family (^^^) + type instance (^^^) = Int + + type family (###) where + (###) = Int + + pattern (:!!!) :: Bool + pattern (:!!!) = True + |]) + diff --git a/tests/examples/pre-ghc910/T16326_Compile1.hs b/tests/examples/pre-ghc910/T16326_Compile1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T16326_Compile1.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnicodeSyntax #-} +module T16326_Compile1 where + +import Data.Kind + +type DApply a (b :: a -> Type) (f :: forall (x :: a) -> b x) (x :: a) = + f x + +type DComp a + (b :: a -> Type) + (c :: forall (x :: a). b x -> Type) + (f :: forall (x :: a). forall (y :: b x) -> c y) + (g :: forall (x :: a) -> b x) + (x :: a) = + f (g x) + +-- Ensure that ElimList has a CUSK, beuas it is +-- is used polymorphically its RHS (c.f. #16344) +type family ElimList (a :: Type) + (p :: [a] -> Type) + (s :: [a]) + (pNil :: p '[]) + (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)) + :: p s where + forall a p pNil (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)). + ElimList a p '[] pNil pCons = + pNil + forall a p x xs pNil (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)). + ElimList a p (x:xs) pNil pCons = + pCons x xs (ElimList a p xs pNil pCons) + +data Proxy' :: forall k -> k -> Type where + MkProxy' :: forall k (a :: k). Proxy' k a + +type family Proxy2' ∷ ∀ k → k → Type where + Proxy2' = Proxy' + diff --git a/tests/examples/pre-ghc910/T17296.hs b/tests/examples/pre-ghc910/T17296.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T17296.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module T17296 where + +import Data.Foldable +import Data.Kind +import Language.Haskell.TH hiding (Type) +import System.IO + +data family Foo1 :: Type -> Type +data instance Foo1 Bool = Foo1Bool +data instance Foo1 (Maybe a) + +data family Foo2 :: k -> Type +data instance Foo2 Bool = Foo2Bool +data instance Foo2 (Maybe a) +data instance Foo2 :: Char -> Type +data instance Foo2 :: (Char -> Char) -> Type where + +data family Foo3 :: k +data instance Foo3 +data instance Foo3 Bool = Foo3Bool +data instance Foo3 (Maybe a) +data instance Foo3 :: Char -> Type +data instance Foo3 :: (Char -> Char) -> Type where + +$(do let test :: Name -> Q () + test n = do i <- reify n + runIO $ do hPutStrLn stderr $ pprint i + hPutStrLn stderr "" + hFlush stderr + + traverse_ test [''Foo1, ''Foo2, ''Foo3] + pure []) + diff --git a/tests/examples/pre-ghc910/T17544_kw.hs b/tests/examples/pre-ghc910/T17544_kw.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T17544_kw.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GADTs #-} + +-- Haddock comments in this test case should all be rejected, but they are not. +-- +-- This is a known issue. Users should avoid writing comments in such +-- positions, as a future fix will disallow them. +-- +-- See Note [Register keyword location] in GHC.Parser.PostProcess.Haddock + +module + -- | Bad comment for the module + T17544_kw where + +data Foo -- | Bad comment for MkFoo + where MkFoo :: Foo + +newtype Bar -- | Bad comment for MkBar + where MkBar :: () -> Bar + +class Cls a + -- | Bad comment for clsmethod + where + clsmethod :: a + diff --git a/tests/examples/pre-ghc910/T17a.hs b/tests/examples/pre-ghc910/T17a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T17b.hs b/tests/examples/pre-ghc910/T17b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T17c.hs b/tests/examples/pre-ghc910/T17c.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T17d.hs b/tests/examples/pre-ghc910/T17d.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T17e.hs b/tests/examples/pre-ghc910/T17e.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T18023.hs b/tests/examples/pre-ghc910/T18023.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T18023.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +module T18023 where + +import Data.Kind +import Data.Proxy + +newtype N :: Type -> Type -> Type where + MkN :: forall b a. { unN :: Either a b } -> N a b + +toN :: Either Int Bool -> N Int Bool +toN = MkN @Bool @Int + +fromN :: N Int Bool -> Either Int Bool +fromN = unN @Bool @Int + +newtype P a = MkP { unP :: Proxy a } + +toPTrue :: Proxy True -> P True +toPTrue = MkP @True + +fromPTrue :: P True -> Proxy True +fromPTrue = unP @True + +newtype P2 a b = MkP2 { unP2 :: (Proxy a, Proxy b) } + +toP2True :: (Proxy True, Proxy True) -> P2 True True +toP2True = MkP2 @True @True + +fromP2True :: P2 True True -> (Proxy True, Proxy True) +fromP2True = unP2 @True @True + +type P3 :: forall {k}. k -> Type +newtype P3 a = MkP3 { unP3 :: Proxy a } + +toP3True :: Proxy True -> P3 True +toP3True = MkP3 @True + +fromP3True :: P3 True -> Proxy True +fromP3True = unP3 @True + diff --git a/tests/examples/pre-ghc910/T1830_1.hs b/tests/examples/pre-ghc910/T1830_1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T1830_1.hs @@ -0,0 +1,5 @@ +module T1830_1 where + +import Language.Haskell.TH.Syntax (Lift) + +data Foo a = Foo a deriving Lift diff --git a/tests/examples/pre-ghc910/T1830_2.hs b/tests/examples/pre-ghc910/T1830_2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T1830_2.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DeriveLift #-} +module T1830_2 where + +import Language.Haskell.TH.Syntax (Lift) + +data Nothing deriving Lift diff --git a/tests/examples/pre-ghc910/T1830_3.hs b/tests/examples/pre-ghc910/T1830_3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T1830_3.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH.Syntax (lift) +import T1830_3a + +main :: IO () +main = do + print ($(lift algDT1) == algDT1) + print ($(lift algDT2) == algDT2) + print ($(lift algDT3) == algDT3) + print ($(lift prim) == prim) + print ($(lift df1) == df1) + print ($(lift df2) == df2) + print ($(lift df3) == df3) diff --git a/tests/examples/pre-ghc910/T1830_3a.hs b/tests/examples/pre-ghc910/T1830_3a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T1830_3a.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +module T1830_3a where + +import GHC.Exts +import Language.Haskell.TH.Syntax (Lift(..)) + +data AlgDT a b c = NormalCon a b + | RecCon { recCon1 :: a, recCon2 :: b} + | a :^: b + deriving (Eq, Lift) + +data Prim = Prim Char# Double# Int# Float# Word# + deriving (Eq, Lift) + +-- We can't test this for equality easily due to the unstable nature of +-- primitive string literal equality. We include this anyway to ensure that +-- deriving Lift for datatypes with Addr# in them does in fact work. +data AddrHash = AddrHash Addr# + deriving Lift + +data Empty deriving Lift + +data family DataFam a b c + +data instance DataFam Int b c = DF1 Int | DF2 b + deriving (Eq, Lift) + +newtype instance DataFam Char b c = DF3 Char + deriving (Eq, Lift) + +algDT1, algDT2, algDT3 :: AlgDT Int String () +algDT1 = NormalCon 1 "foo" +algDT2 = RecCon 2 "bar" +algDT3 = 3 :^: "baz" + +prim :: Prim +prim = Prim 'a'# 1.0## 1# 1.0# 1## + +df1, df2 :: DataFam Int Char () +df1 = DF1 1 +df2 = DF2 'a' + +df3 :: DataFam Char () () +df3 = DF3 'b' diff --git a/tests/examples/pre-ghc910/T18432.hs b/tests/examples/pre-ghc910/T18432.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T18432.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE QuantifiedConstraints #-} +module Bug where + +import Data.Proxy + +class C a where + m :: Proxy a + +f :: (forall {a}. C a) => Proxy Int +f = m + diff --git a/tests/examples/pre-ghc910/T18522-dbg-ppr.hs b/tests/examples/pre-ghc910/T18522-dbg-ppr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T18522-dbg-ppr.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell, ExplicitForAll, PolyKinds #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Language.Haskell.TH (runQ) +import GHC.Types.Basic +import GHC.ThToHs +import GHC.Driver.Session +import GHC.Core.TyCo.Ppr +import GHC.Utils.Outputable +import GHC.Tc.Module +import GHC.Tc.Utils.Zonk +import GHC.Utils.Error +import GHC.Driver.Types +import GHC +import qualified GHC.LanguageExtensions as LangExt + +import Data.Either (fromRight) +import Control.Monad.IO.Class (liftIO) +import System.Environment (getArgs) + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ do + initial_dflags <- getSessionDynFlags + setSessionDynFlags $ initial_dflags + `dopt_set` Opt_D_ppr_debug + `gopt_set` Opt_SuppressUniques + `gopt_set` Opt_SuppressModulePrefixes + `gopt_set` Opt_SuppressVarKinds + `xopt_set` LangExt.KindSignatures + `xopt_set` LangExt.PolyKinds + `xopt_set` LangExt.RankNTypes + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + liftIO $ do + th_t <- runQ [t| forall k {j}. + forall (a :: k) (b :: j) -> + () |] + let hs_t = fromRight (error "convertToHsType") $ + convertToHsType Generated noSrcSpan th_t + ((warnings, errors), mres) <- + tcRnType hsc_env SkolemiseFlexi True hs_t + case mres of + Nothing -> do + printBagOfErrors dflags warnings + printBagOfErrors dflags errors + Just (t, _) -> do + putStrLn $ showSDoc dflags (debugPprType t) + diff --git a/tests/examples/pre-ghc910/T2006.hs b/tests/examples/pre-ghc910/T2006.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T2006.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} +{-# LANGUAGE GADTs #-} + +module T2006 where + +data Expr a vs where + EPrim :: String -> a -> Expr a vs + EVar :: Expr a (a,vs) + +interpret :: Expr a () -> a +interpret (EPrim _ a) = a +-- interpret EVar = error "unreachable" + diff --git a/tests/examples/pre-ghc910/T2204.hs b/tests/examples/pre-ghc910/T2204.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T2204.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T2204 where + +f :: String -> Int +f "01" = 0 + +g :: Int -> Int +g 0 = 0 diff --git a/tests/examples/pre-ghc910/T22315b.hs b/tests/examples/pre-ghc910/T22315b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T22315b.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeData #-} +module T22315b where + +data TermLevel = Mk +type data TypeLevel = Mk + +mk = Mk + +type Mk2 = Mk + diff --git a/tests/examples/pre-ghc910/T22332a.hs b/tests/examples/pre-ghc910/T22332a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T22332a.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeData, DataKinds, TypeFamilies #-} +module Main where + +import Type.Reflection +import Data.Type.Equality + +data Proxy a +type data X1 = T -- defines type constructor T +data X2 = T -- defines type constructor 'T + +data family F p + +newtype instance F (Proxy T) = ID (forall a. a -> a) +newtype instance F (Proxy 'T) = UC (forall a b. a -> b) + +-- This should fail at runtime because these are different types +eq :: T :~~: 'T +Just eq = eqTypeRep typeRep typeRep + +p :: a :~~: b -> F (Proxy a) :~: F (Proxy b) +p HRefl = Refl + +uc :: a -> b +uc = case castWith (p eq) (ID id) of UC a -> a + +main :: IO () +main = print (uc 'a' :: Int) + diff --git a/tests/examples/pre-ghc910/T22500.hs b/tests/examples/pre-ghc910/T22500.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T22500.hs @@ -0,0 +1,10 @@ +-- Check that a quoted data type declaration is printed correctly +{-# LANGUAGE TemplateHaskellQuotes, TypeData #-} + +module Main where + +import Language.Haskell.TH +import Language.Haskell.TH.Ppr + +main = putStrLn . pprint =<< runQ [d| type data Nat = Zero | Succ Nat |] + diff --git a/tests/examples/pre-ghc910/T23465.hs b/tests/examples/pre-ghc910/T23465.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T23465.hs @@ -0,0 +1,14 @@ +module T23465 {-# WaRNING in "x-a" "b" #-} where + +{-# WARNInG in "x-c" e "d" #-} +e = e + +{-# WARNInG + in "x-f" f "fw" ; + in "x-f" g "gw" +#-} +f = f +g = g + +{-# WARNinG h "hw" #-} +h = h diff --git a/tests/examples/pre-ghc910/T2388.hs b/tests/examples/pre-ghc910/T2388.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T2632.1.hs b/tests/examples/pre-ghc910/T2632.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T2632.1.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- Trac #2632 + +module MkData where + +import Language.Haskell.TH + +op :: Num v => v -> v -> v +op a b = a + b + +decl1 = [d| func = 0 `op` 3 |] + +decl2 = [d| op x y = x + func = 0 `op` 3 |] + diff --git a/tests/examples/pre-ghc910/T2632.hs b/tests/examples/pre-ghc910/T2632.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T2632.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +-- 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/pre-ghc910/T2931.hs b/tests/examples/pre-ghc910/T2931.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T2991.hs b/tests/examples/pre-ghc910/T2991.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T3078.hs b/tests/examples/pre-ghc910/T3078.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T3078.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T3078 where + +data T = A Int | B Int + +funny :: T -> Int +funny t = n + where + n | A x <- t = x + | B x <- t = x diff --git a/tests/examples/pre-ghc910/T3132.hs b/tests/examples/pre-ghc910/T3132.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T322.hs b/tests/examples/pre-ghc910/T322.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T322.hs @@ -0,0 +1,29 @@ +{-# OPTIONS -fwarn-incomplete-patterns -fwarn-overlapping-patterns -Werror #-} + +module T322 where + +instance (Num a) => Num (Maybe a) where + (Just a) + (Just b) = Just (a + b) + _ + _ = Nothing + + (Just a) - (Just b) = Just (a - b) + _ - _ = Nothing + + (Just a) * (Just b) = Just (a * b) + _ * _ = Nothing + + negate (Just a) = Just (negate a) + negate _ = Nothing + + abs (Just a) = Just (abs a) + abs _ = Nothing + + signum (Just a) = Just (signum a) + signum _ = Nothing + + fromInteger = Just . fromInteger + +f :: Maybe Int -> Int +f 1 = 1 +f Nothing = 2 +f _ = 3 diff --git a/tests/examples/pre-ghc910/T3263-2.hs b/tests/examples/pre-ghc910/T3263-2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T3263-2.hs @@ -0,0 +1,39 @@ +-- Trac #3263. New kind of warning on monadic bindings that discard a monadic result +{-# LANGUAGE RankNTypes #-} + +module T3263 where + +import Control.Monad.Fix + +-- No warning +t1 :: Monad m => m Int +t1 = do + return 10 + +-- No warning +t2 :: Monad m => m (m Int) +t2 = return (return 10) + +-- No warning +t3 :: Monad m => m (m Int) +t3 = do + return 10 + return (return 10) + +-- Warning +t4 :: forall m. Monad m => m Int +t4 = do + return (return 10 :: m Int) + return 10 + +-- No warning +t5 :: forall m. Monad m => m Int +t5 = do + _ <- return (return 10 :: m Int) + return 10 + +-- Warning +t6 :: forall m. MonadFix m => m Int +t6 = mdo + return (return 10 :: m Int) + return 10 diff --git a/tests/examples/pre-ghc910/T3391.1.hs b/tests/examples/pre-ghc910/T3391.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T3391.1.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -v0 #-} + +-- We should only generate one set of generic to/from functions +-- for T, despite the multiple chunks caused by the TH splices +-- See #3391 + +module T3391 where + +data T = MkT + +$(return []) + +$(return []) + diff --git a/tests/examples/pre-ghc910/T3391.hs b/tests/examples/pre-ghc910/T3391.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T3391.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -v0 #-} + +-- We should only generate one set of generic to/from functions +-- for T, despite the multiple chunks caused by the TH splices +-- See Trac #3391 + +module T3391 where + +data T = MkT + +$(return []) + +$(return []) + diff --git a/tests/examples/pre-ghc910/T3468a.hs b/tests/examples/pre-ghc910/T3468a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T3468a.hs @@ -0,0 +1,3 @@ +module T3468a where + +import {-# SOURCE #-} T3468 diff --git a/tests/examples/pre-ghc910/T3572.1.hs b/tests/examples/pre-ghc910/T3572.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T3572.1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- Trac #3572 + +module Main where + +import Language.Haskell.TH +import Language.Haskell.TH.Ppr + +main = putStrLn . pprint =<< runQ [d| data Void |] diff --git a/tests/examples/pre-ghc910/T3572.hs b/tests/examples/pre-ghc910/T3572.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T3572.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TemplateHaskell #-} + +-- 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/pre-ghc910/T365.hs b/tests/examples/pre-ghc910/T365.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T365.hs @@ -0,0 +1,4 @@ +{-# OPTIONS_GHC -F -pgmF ./test_preprocessor.txt #-} +module Main where + +main = print "Hello World" diff --git a/tests/examples/pre-ghc910/T366.hs b/tests/examples/pre-ghc910/T366.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T366.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -XGADTs -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T366 where + +data T a where + C1 :: T Char + C2 :: T Float + +exhaustive :: T Char -> Char +exhaustive C1 = ' ' diff --git a/tests/examples/pre-ghc910/T3927.hs b/tests/examples/pre-ghc910/T3927.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T3927.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T3927 where + +data T a where + T1 :: T Int + T2 :: T Bool + +-- f1 is exhaustive +f1 :: T a -> T a -> Bool +f1 T1 T1 = True +f1 T2 T2 = False diff --git a/tests/examples/pre-ghc910/T3927a.hs b/tests/examples/pre-ghc910/T3927a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T3927a.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} +{-# LANGUAGE GADTs, TypeFamilies #-} + +module T3927a where + +type family F a +type instance F a = () + +data Foo a where + FooA :: Foo () + FooB :: Foo Int + +f :: a -> Foo (F a) -> () -- F a can only be () so only FooA is accepted +f _ FooA = () + diff --git a/tests/examples/pre-ghc910/T3927b.hs b/tests/examples/pre-ghc910/T3927b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T3927b.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T3927b where + +import Data.Proxy +import GHC.Exts + +data Message + +data SocketType = Dealer | Push | Pull + +data SocketOperation = Read | Write + +type family Restrict (a :: SocketOperation) (as :: [SocketOperation]) :: Constraint where + Restrict a (a ': as) = () + Restrict x (a ': as) = Restrict x as + Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!") + +type family Implements (t :: SocketType) :: [SocketOperation] where + Implements Dealer = ['Read, Write] + Implements Push = '[Write] + Implements Pull = '[ 'Read] + +data SockOp :: SocketType -> SocketOperation -> Type where + SRead :: SockOp sock 'Read + SWrite :: SockOp sock Write + +data Socket :: SocketType -> Type where + Socket :: proxy sock + -> (forall op . Restrict op (Implements sock) => SockOp sock op -> Operation op) + -> Socket sock + +type family Operation (op :: SocketOperation) :: Type where + Operation 'Read = IO Message + Operation Write = Message -> IO () + +class Restrict 'Read (Implements t) => Readable t where + readSocket :: Socket t -> Operation 'Read + readSocket (Socket _ f) = f (SRead :: SockOp t 'Read) + +instance Readable Dealer + +type family Writable (t :: SocketType) :: Constraint where + Writable Dealer = () + Writable Push = () + +dealer :: Socket Dealer +dealer = Socket (Proxy :: Proxy Dealer) f + where + f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op + f SRead = undefined + f SWrite = undefined + +push :: Socket Push +push = Socket (Proxy :: Proxy Push) f + where + f :: Restrict op (Implements Push) => SockOp Push op -> Operation op + f SWrite = undefined + +pull :: Socket Pull +pull = Socket (Proxy :: Proxy Pull) f + where + f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op + f SRead = undefined + +foo :: IO Message +foo = readSocket dealer diff --git a/tests/examples/pre-ghc910/T4056.1.hs b/tests/examples/pre-ghc910/T4056.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T4056.1.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module T4056 where +import Language.Haskell.TH + +astTest :: Q [Dec] +astTest = [d| + class C t where + op :: [t] -> [t] + op = undefined + |] + +class D t where + bop :: [t] -> [t] + bop = undefined diff --git a/tests/examples/pre-ghc910/T4056.hs b/tests/examples/pre-ghc910/T4056.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T4056.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} + +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/pre-ghc910/T4139.hs b/tests/examples/pre-ghc910/T4139.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T4139.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module T4139 where + +data F a where + FInt :: F Int + FBool :: F Bool + +class Baz a where + baz :: F a -> G a +instance Baz Int where + baz _ = GInt +instance Baz Bool where + baz _ = GBool + +data G a where + GInt :: G Int + GBool :: G Bool + +bar :: Baz a => F a -> () +bar a@(FInt) = + case baz a of + GInt -> () + -- GBool -> () +bar _ = () + + diff --git a/tests/examples/pre-ghc910/T4169.1.hs b/tests/examples/pre-ghc910/T4169.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T4169.1.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- Crashed GHC 6.12 + +module T4165 where + +import Language.Haskell.TH +class Numeric a where + fromIntegerNum :: a + fromIntegerNum = undefined + +ast :: Q [Dec] +ast = [d| + instance Numeric Int + |] diff --git a/tests/examples/pre-ghc910/T4169.hs b/tests/examples/pre-ghc910/T4169.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T4169.hs @@ -0,0 +1,15 @@ +-- Crashed GHC 6.12 +{-# LANGUAGE TemplateHaskell #-} + +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/pre-ghc910/T4170.1.hs b/tests/examples/pre-ghc910/T4170.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T4170.1.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module T4170 where + +import Language.Haskell.TH + +class LOL a + +lol :: Q [Dec] +lol = [d| + instance LOL Int + |] + +instance LOL Int diff --git a/tests/examples/pre-ghc910/T4170.hs b/tests/examples/pre-ghc910/T4170.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T4170.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +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/pre-ghc910/T4437.hs b/tests/examples/pre-ghc910/T4437.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T4437.hs @@ -0,0 +1,57 @@ +-- | A test for ensuring that GHC's supporting language extensions remains in +-- sync with Cabal's own extension list. +-- +-- If you have ended up here due to a test failure, please see +-- Note [Adding a language extension] in compiler/main/DynFlags.hs. + +module Main (main) where + +import Control.Monad +import Data.List +import DynFlags +import Language.Haskell.Extension + +main :: IO () +main = do + let ghcExtensions = map flagSpecName xFlags + cabalExtensions = map show [ toEnum 0 :: KnownExtension .. ] + ghcOnlyExtensions = ghcExtensions \\ cabalExtensions + cabalOnlyExtensions = cabalExtensions \\ ghcExtensions + check "GHC-only flags" expectedGhcOnlyExtensions ghcOnlyExtensions + check "Cabal-only flags" expectedCabalOnlyExtensions cabalOnlyExtensions + +check :: String -> [String] -> [String] -> IO () +check title expected got + = do let unexpected = got \\ expected + missing = expected \\ got + showProblems problemType problems + = unless (null problems) $ + do putStrLn (title ++ ": " ++ problemType) + putStrLn "-----" + mapM_ putStrLn problems + putStrLn "-----" + putStrLn "" + showProblems "Unexpected flags" unexpected + showProblems "Missing flags" missing + +-- See Note [Adding a language extension] in compiler/main/DynFlags.hs. +expectedGhcOnlyExtensions :: [String] +expectedGhcOnlyExtensions = ["RelaxedLayout", + "AlternativeLayoutRule", + "AlternativeLayoutRuleTransitional", + "EmptyDataDeriving", + "GeneralisedNewtypeDeriving"] + +expectedCabalOnlyExtensions :: [String] +expectedCabalOnlyExtensions = ["Generics", + "ExtensibleRecords", + "RestrictedTypeSynonyms", + "HereDocuments", + "NewQualifiedOperators", + "XmlSyntax", + "RegularPatterns", + "SafeImports", + "Safe", + "Unsafe", + "Trustworthy"] + diff --git a/tests/examples/pre-ghc910/T5001b.hs b/tests/examples/pre-ghc910/T5001b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T5217.hs b/tests/examples/pre-ghc910/T5217.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T5217.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} + +module T5217 where +import Language.Haskell.TH + +$([d| data T a b where { T1 :: Int -> T Int Char + ; T2 :: a -> T a a + ; T3 :: a -> T [a] a + ; T4 :: a -> b -> T b [a] } |]) + diff --git a/tests/examples/pre-ghc910/T5333.hs b/tests/examples/pre-ghc910/T5333.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T5721.hs b/tests/examples/pre-ghc910/T5721.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T5821.hs b/tests/examples/pre-ghc910/T5821.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T5884Other.hs b/tests/examples/pre-ghc910/T5884Other.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T5884Other.hs @@ -0,0 +1,3 @@ +module T5884Other where + +data Pair a = Pair a a diff --git a/tests/examples/pre-ghc910/T5908.hs b/tests/examples/pre-ghc910/T5908.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T5951.hs b/tests/examples/pre-ghc910/T5951.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T6018.hs b/tests/examples/pre-ghc910/T6018.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T6018.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module T6018 where + +import T6018a -- defines G, identical to F + +type family F a b c = (result :: k) | result -> a b c +type instance F Int Char Bool = Bool +type instance F Char Bool Int = Int +type instance F Bool Int Char = Char + + +type instance G Bool Int Char = Char + +type family I (a :: k) b (c :: k) = r | r -> a b +type instance I Int Char Bool = Bool +type instance I Int Char Int = Bool +type instance I Bool Int Int = Int + +-- this is injective - a type variable introduced in the LHS is not mentioned on +-- RHS but we don't claim injectivity in that argument. +type family J a (b :: k) = r | r -> a +type instance J Int b = Char + +type MaybeSyn a = Maybe a +newtype MaybeNew a = MaybeNew (Maybe a) + +-- make sure we look through type synonyms... +type family K a = r | r -> a +type instance K a = MaybeSyn a + +-- .. but not newtypes +type family M a = r | r -> a +type instance M (Maybe a) = MaybeSyn a +type instance M (MaybeNew a) = MaybeNew a + +-- Closed type families + +-- these are simple conversions from open type families. They should behave the +-- same +type family FClosed a b c = result | result -> a b c where + FClosed Int Char Bool = Bool + FClosed Char Bool Int = Int + FClosed Bool Int Char = Char + +type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where + IClosed Int Char Bool = Bool + IClosed Int Char Int = Bool + IClosed Bool Int Int = Int + +type family JClosed a (b :: k) = r | r -> a where + JClosed Int b = Char + +type family KClosed a = r | r -> a where + KClosed a = MaybeSyn a + +-- Here the last equation might return both Int and Char but we have to +-- recognize that it is not possible due to equation overlap +type family Bak a = r | r -> a where + Bak Int = Char + Bak Char = Int + Bak a = a + +-- This is similar, except that the last equation contains concrete type. Since +-- it is overlapped it should be dropped with a warning +type family Foo a = r | r -> a where + Foo Int = Bool + Foo Bool = Int + Foo Bool = Bool + +-- this one was tricky in the early implementation of injectivity. Now it is +-- identical to the above but we still keep it as a regression test. +type family Bar a = r | r -> a where + Bar Int = Bool + Bar Bool = Int + Bar Bool = Char + +-- Now let's use declared type families. All the below definitions should work + +-- No ambiguity for any of the arguments - all are injective +f :: F a b c -> F a b c +f x = x + +-- From 1st instance of F: a ~ Int, b ~ Char, c ~ Bool +fapp :: Bool +fapp = f True + +-- now the closed variant of F +fc :: FClosed a b c -> FClosed a b c +fc x = x + +fcapp :: Bool +fcapp = fc True + +-- The last argument is not injective so it must be instantiated +i :: I a b Int -> I a b Int +i x = x + +-- From 1st instance of I: a ~ Int, b ~ Char +iapp :: Bool +iapp = i True + +-- again, closed variant of I +ic :: IClosed a b Int -> IClosed a b Int +ic x = x + +icapp :: Bool +icapp = ic True + +-- Now we have to test weird closed type families: +bak :: Bak a -> Bak a +bak x = x + +bakapp1 :: Char +bakapp1 = bak 'c' + +bakapp2 :: Double +bakapp2 = bak 1.0 + +bakapp3 :: () +bakapp3 = bak () + +foo :: Foo a -> Foo a +foo x = x + +fooapp1 :: Bool +fooapp1 = foo True + +bar :: Bar a -> Bar a +bar x = x + +barapp1 :: Bool +barapp1 = bar True + +barapp2 :: Int +barapp2 = bar 1 + +-- Declarations below test more liberal RHSs of injectivity annotations: +-- permiting variables to appear in different order than the one in which they +-- were declared. +type family H a b = r | r -> b a +type family Hc a b = r | r -> b a where + Hc a b = a b +class Hcl a b where + type Ht a b = r | r -> b a + +-- repeated tyvars in the RHS of injectivity annotation: no warnings or errors +-- (consistent with behaviour for functional dependencies) +type family Jx a b = r | r -> a a +type family Jcx a b = r | r -> a a where + Jcx a b = a b +class Jcl a b where + type Jt a b = r | r -> a a + +type family Kx a b = r | r -> a b b +type family Kcx a b = r | r -> a b b where + Kcx a b = a b +class Kcl a b where + type Kt a b = r | r -> a b b + +-- Declaring kind injectivity. Here we only claim that knowing the RHS +-- determines the LHS kind but not the type. +type family L (a :: k1) = (r :: k2) | r -> k1 where + L 'True = Int + L 'False = Int + L Maybe = 3 + L IO = 3 + +data KProxy (a :: *) = KProxy +type family KP (kproxy :: KProxy k) = r | r -> k +type instance KP ('KProxy :: KProxy Bool) = Int +type instance KP ('KProxy :: KProxy *) = Char + +kproxy_id :: KP ('KProxy :: KProxy k) -> KP ('KProxy :: KProxy k) +kproxy_id x = x + +kproxy_id_use = kproxy_id 'a' + +-- Now test some awkward cases from The Injectivity Paper. All should be +-- accepted. +type family Gx a +type family Hx a +type family Gi a = r | r -> a +type instance Gi Int = Char +type family Hi a = r | r -> a + +type family F2 a = r | r -> a +type instance F2 [a] = [Gi a] +type instance F2 (Maybe a) = Hi a -> Int + +type family F4 a = r | r -> a +type instance F4 [a] = (Gx a, a, a, a) +type instance F4 (Maybe a) = (Hx a, a, Int, Bool) + +type family G2 a b = r | r -> a b +type instance G2 a Bool = (a, a) +type instance G2 Bool b = (b, Bool) + +type family G6 a = r | r -> a +type instance G6 [a] = [Gi a] +type instance G6 Bool = Int + +g6_id :: G6 a -> G6 a +g6_id x = x + +g6_use :: [Char] +g6_use = g6_id "foo" + +-- A sole exception to "bare variables in the RHS" rule +type family Id (a :: k) = (result :: k) | result -> a +type instance Id a = a + +-- This makes sure that over-saturated type family applications at the top-level +-- are accepted. +type family IdProxy (a :: k) b = r | r -> a +type instance IdProxy a b = (Id a) b + +-- make sure we look through type synonyms properly +type IdSyn a = Id a +type family IdProxySyn (a :: k) b = r | r -> a +type instance IdProxySyn a b = (IdSyn a) b + +-- this has bare variable in the RHS but all LHS varaiables are also bare so it +-- should be accepted +type family Fa (a :: k) (b :: k) = (r :: k2) | r -> k +type instance Fa a b = a + +-- Taken from #9587. This exposed a bug in the solver. +type family Arr (repr :: * -> *) (a :: *) (b :: *) = (r :: *) | r -> repr a b + +class ESymantics repr where + int :: Int -> repr Int + add :: repr Int -> repr Int -> repr Int + + lam :: (repr a -> repr b) -> repr (Arr repr a b) + app :: repr (Arr repr a b) -> repr a -> repr b + +te4 = let c3 = lam (\f -> lam (\x -> f `app` (f `app` (f `app` x)))) + in (c3 `app` (lam (\x -> x `add` int 14))) `app` (int 0) + +-- This used to fail during development +class Manifold' a where + type Base a = r | r -> a + project :: a -> Base a + unproject :: Base a -> a + +id' :: forall a. ( Manifold' a ) => Base a -> Base a +id' = project . unproject diff --git a/tests/examples/pre-ghc910/T6018Afail.hs b/tests/examples/pre-ghc910/T6018Afail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T6018Bfail.hs b/tests/examples/pre-ghc910/T6018Bfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T6018Cfail.hs b/tests/examples/pre-ghc910/T6018Cfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T6018Dfail.hs b/tests/examples/pre-ghc910/T6018Dfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T6018a.hs b/tests/examples/pre-ghc910/T6018a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T6018fail.hs b/tests/examples/pre-ghc910/T6018fail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T6018failclosed.hs b/tests/examples/pre-ghc910/T6018failclosed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T6018failclosed2.hs b/tests/examples/pre-ghc910/T6018failclosed2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T6018rnfail.hs b/tests/examples/pre-ghc910/T6018rnfail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T6018th.1.hs b/tests/examples/pre-ghc910/T6018th.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T6018th.1.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds #-} + +module T6018th where + +import Language.Haskell.TH + +-- Test that injectivity works correct with TH. This test is not as exhaustive +-- as the original T6018 test. + +-- type family F a b c = (result :: k) | result -> a b c +-- type instance F Int Char Bool = Bool +-- type instance F Char Bool Int = Int +-- type instance F Bool Int Char = Char +$( return + [ OpenTypeFamilyD + (mkName "F") + [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] + (TyVarSig (KindedTV (mkName "result") (VarT (mkName "k")))) + (Just $ InjectivityAnn (mkName "result") + [(mkName "a"), (mkName "b"), (mkName "c") ]) + , TySynInstD + (mkName "F") + (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Bool")] + ( ConT (mkName "Bool"))) + , TySynInstD + (mkName "F") + (TySynEqn [ ConT (mkName "Char"), ConT (mkName "Bool") + , ConT (mkName "Int")] + ( ConT (mkName "Int"))) + , TySynInstD + (mkName "F") + (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") + , ConT (mkName "Char")] + ( ConT (mkName "Char"))) + ] ) + +-- this is injective - a type variables mentioned on LHS is not mentioned on RHS +-- but we don't claim injectivity in that argument. +-- +-- type family J a (b :: k) = r | r -> a +---type instance J Int b = Char +$( return + [ OpenTypeFamilyD + (mkName "J") + [ PlainTV (mkName "a"), KindedTV (mkName "b") (VarT (mkName "k")) ] + (TyVarSig (PlainTV (mkName "r"))) + (Just $ InjectivityAnn (mkName "r") [mkName "a"]) + , TySynInstD + (mkName "J") + (TySynEqn [ ConT (mkName "Int"), VarT (mkName "b") ] + ( ConT (mkName "Int"))) + ] ) + +-- Closed type families + +-- type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where +-- IClosed Int Char Bool = Bool +-- IClosed Int Char Int = Bool +-- IClosed Bool Int Int = Int + +$( return + [ ClosedTypeFamilyD + (mkName "I") + [ KindedTV (mkName "a") StarT, KindedTV (mkName "b") StarT + , KindedTV (mkName "c") StarT ] + (TyVarSig (PlainTV (mkName "r"))) + (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")]) + [ TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Bool")] + ( ConT (mkName "Bool")) + , TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Int")] + ( ConT (mkName "Bool")) + , TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") + , ConT (mkName "Int")] + ( ConT (mkName "Int")) + ] + ] ) + +-- reification test +$( do { decl@([ClosedTypeFamilyD _ _ _ (Just inj) _]) <- + [d| type family Bak a = r | r -> a where + Bak Int = Char + Bak Char = Int + Bak a = a |] + ; return decl + } + ) + +-- Check whether incorrect injectivity declarations are caught + +-- type family I a b c = r | r -> a b +-- type instance I Int Char Bool = Bool +-- type instance I Int Int Int = Bool +-- type instance I Bool Int Int = Int +$( return + [ OpenTypeFamilyD + (mkName "H") + [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] + (TyVarSig (PlainTV (mkName "r"))) + (Just $ InjectivityAnn (mkName "r") + [(mkName "a"), (mkName "b") ]) + , TySynInstD + (mkName "H") + (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") + , ConT (mkName "Bool")] + ( ConT (mkName "Bool"))) + , TySynInstD + (mkName "H") + (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Int") + , ConT (mkName "Int")] + ( ConT (mkName "Bool"))) + , TySynInstD + (mkName "H") + (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") + , ConT (mkName "Int")] + ( ConT (mkName "Int"))) + ] ) diff --git a/tests/examples/pre-ghc910/T6018th.hs b/tests/examples/pre-ghc910/T6018th.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T6018th.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE TypeFamilyDependencies, DataKinds, UndecidableInstances, + PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +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 (TypeFamilyHead + (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 (TypeFamilyHead + (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 (TypeFamilyHead + (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 (TypeFamilyHead _ _ _ (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 (TypeFamilyHead + (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/pre-ghc910/T6062.1.hs b/tests/examples/pre-ghc910/T6062.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T6062.1.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module T6062 where +x = [| False True |] diff --git a/tests/examples/pre-ghc910/T6062.hs b/tests/examples/pre-ghc910/T6062.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T6062.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module T6062 where +x = [| False True |] + diff --git a/tests/examples/pre-ghc910/T6124.hs b/tests/examples/pre-ghc910/T6124.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T6124.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module T6124 where + +newtype A = MkA Int +newtype B = MkB Char + +data T a where + A :: T A + B :: T B + +f :: T A -> A +f A = undefined diff --git a/tests/examples/pre-ghc910/T7411.hs b/tests/examples/pre-ghc910/T7411.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T7411.hs @@ -0,0 +1,3 @@ +import Control.Exception +import Control.DeepSeq +main = evaluate (('a' : undefined) `deepseq` return () :: IO ()) diff --git a/tests/examples/pre-ghc910/T7669a.hs b/tests/examples/pre-ghc910/T7669a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T7669a.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE EmptyCase #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + +module T7669 where + +data Void + +foo :: Void -> () +foo x = case x of {} diff --git a/tests/examples/pre-ghc910/T7672.hs b/tests/examples/pre-ghc910/T7672.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T7672.hs @@ -0,0 +1,3 @@ +module T7672 where +import qualified T7672a as XX +data T = S XX.T diff --git a/tests/examples/pre-ghc910/T7672a.hs b/tests/examples/pre-ghc910/T7672a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T7672a.hs @@ -0,0 +1,2 @@ +module T7672a(Decl.T) where +import {-# SOURCE #-} qualified T7672 as Decl diff --git a/tests/examples/pre-ghc910/T7765.hs b/tests/examples/pre-ghc910/T7765.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T7765.hs @@ -0,0 +1,1 @@ +module Main where diff --git a/tests/examples/pre-ghc910/T7788.hs b/tests/examples/pre-ghc910/T7788.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T7918A.hs b/tests/examples/pre-ghc910/T7918A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T8030.hs b/tests/examples/pre-ghc910/T8030.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T8034.hs b/tests/examples/pre-ghc910/T8034.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T8101b.hs b/tests/examples/pre-ghc910/T8101b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T8131b.hs b/tests/examples/pre-ghc910/T8131b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T8274.hs b/tests/examples/pre-ghc910/T8274.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T8455.1.hs b/tests/examples/pre-ghc910/T8455.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T8455.1.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE DataKinds #-} + +module T8455 where + +ty = [t| 5 |] diff --git a/tests/examples/pre-ghc910/T8455.hs b/tests/examples/pre-ghc910/T8455.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T8455.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module T8455 where + +ty = [t| 5 |] + diff --git a/tests/examples/pre-ghc910/T8550.hs b/tests/examples/pre-ghc910/T8550.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T8555.hs b/tests/examples/pre-ghc910/T8555.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T8633.hs b/tests/examples/pre-ghc910/T8633.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T8743a.hs b/tests/examples/pre-ghc910/T8743a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T8743a.hs @@ -0,0 +1,3 @@ +module T8743a where + +import {-# SOURCE #-} T8743 () diff --git a/tests/examples/pre-ghc910/T8759a.1.hs b/tests/examples/pre-ghc910/T8759a.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T8759a.1.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE PatternSynonyms #-} + +module T8759a where + +foo = [d| pattern Q = False |] diff --git a/tests/examples/pre-ghc910/T8759a.hs b/tests/examples/pre-ghc910/T8759a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T8759a.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} + +module T8759a where + +foo = [d| pattern Q = False |] + diff --git a/tests/examples/pre-ghc910/T8799.hs b/tests/examples/pre-ghc910/T8799.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T8807.hs b/tests/examples/pre-ghc910/T8807.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T8807.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE ConstraintKinds, RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module T8807 where + +import Data.Proxy + +foo :: $( [t| forall a b. a b => Proxy a -> b -> b |] ) +foo = undefined + diff --git a/tests/examples/pre-ghc910/T8970.hs b/tests/examples/pre-ghc910/T8970.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T8970.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T8970 where + +data K = Foo + | Bar + +data D1 :: K -> * where + F1 :: D1 Foo + B1 :: D1 Bar + +class C (a :: K -> *) where + data D2 a :: K -> * + foo :: a k -> D2 a k -> Bool + +instance C D1 where + data D2 D1 k where + F2 :: D2 D1 Foo + B2 :: D2 D1 Bar + foo F1 F2 = True + foo B1 B2 = True diff --git a/tests/examples/pre-ghc910/T9015.hs b/tests/examples/pre-ghc910/T9015.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9015.hs @@ -0,0 +1,59 @@ +module Main where + +import GHC +import DynFlags +import System.Environment +import GhcMonad + +testStrings = [ + "import Data.Maybe" + , "import qualified Data.Maybe" + , "import Data.Maybe (isJust)" + + , "add a b = a+b" + , "data Foo = Foo String" + , "deriving instance Show Foo" + , "{-# NOVECTORISE foo #-}" + , "{-# WARNING Foo \"Just a warning\" #-}" + , "{-# ANN foo (Just \"Hello\") #-}" + , "{-# RULES \"map/map\" forall f g xs. map f (map g xs) = map (f.g) xs #-}" + , "class HasString a where\n\ + \ update :: a -> (String -> String) -> a\n\ + \ upcase :: a -> a\n\ + \ upcase x = update x (fmap toUpper)\n\ + \ content :: a -> String\n\ + \ default content :: Show a => a -> String\n\ + \ content = show" + , "instance HasString Foo where\n\ + \ update (Foo s) f = Foo (f s)\n\ + \ content (Foo s) = s" + + , "add a b" + , "let foo = add a b" + , "x <- foo y" + , "5 + 8" + + , "a <-" + , "2 +" + , "@#" + ] + +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ do + liftIO (putStrLn "Is import:") + testWithParser isImport + + liftIO (putStrLn "Is declaration:") + testWithParser isDecl + + liftIO (putStrLn "Is statement:") + testWithParser isStmt + + where + testWithParser parser = do + dflags <- getSessionDynFlags + liftIO . putStrLn . unlines $ map (testExpr (parser dflags)) testStrings + + testExpr parser expr = do + expr ++ ": " ++ show (parser expr) diff --git a/tests/examples/pre-ghc910/T9017.hs b/tests/examples/pre-ghc910/T9017.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9017.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PolyKinds #-} + +module T9017 where + +import Control.Arrow + +foo :: a b (m b) +foo = arr return diff --git a/tests/examples/pre-ghc910/T9177a.hs b/tests/examples/pre-ghc910/T9177a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9177a.hs @@ -0,0 +1,6 @@ +module T9177a where + +foo3 = bar +foo4 = Fun + + diff --git a/tests/examples/pre-ghc910/T9204a.hs b/tests/examples/pre-ghc910/T9204a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9204a.hs @@ -0,0 +1,2 @@ +module T9204a where +import {-# SOURCE #-} T9204 diff --git a/tests/examples/pre-ghc910/T9204b.hs b/tests/examples/pre-ghc910/T9204b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9204b.hs @@ -0,0 +1,5 @@ +module T9204b where + +import T9204b2 + +data P a = P diff --git a/tests/examples/pre-ghc910/T9204b2.hs b/tests/examples/pre-ghc910/T9204b2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9204b2.hs @@ -0,0 +1,3 @@ +module T9204b2 where + +import {-# SOURCE #-} T9204b diff --git a/tests/examples/pre-ghc910/T9233.hs b/tests/examples/pre-ghc910/T9233.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9233a.hs b/tests/examples/pre-ghc910/T9233a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9238.hs b/tests/examples/pre-ghc910/T9238.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9238.hs @@ -0,0 +1,16 @@ +compareDouble :: Double -> Double -> Ordering +compareDouble x y = + case (isNaN x, isNaN y) of + (True, True) -> EQ + (True, False) -> LT + (False, True) -> GT + (False, False) -> + -- Make -0 less than 0 + case (x == 0, y == 0, isNegativeZero x, isNegativeZero y) of + (True, True, True, False) -> LT + (True, True, False, True) -> GT + _ -> x `compare` y + +main = do + let l = [-0, 0] + print [ (x, y, compareDouble x y) | x <- l, y <- l ] diff --git a/tests/examples/pre-ghc910/T9260.hs b/tests/examples/pre-ghc910/T9260.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9367.hs b/tests/examples/pre-ghc910/T9367.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9367.hs @@ -0,0 +1,5 @@ +x = "abc" +main = print x +-- This file has Windows line endings (CRLF) on purpose. Do not remove. +-- See #9367. + diff --git a/tests/examples/pre-ghc910/T9430.hs b/tests/examples/pre-ghc910/T9430.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9554.hs b/tests/examples/pre-ghc910/T9554.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9600-1.hs b/tests/examples/pre-ghc910/T9600-1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9600.hs b/tests/examples/pre-ghc910/T9600.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9600.hs @@ -0,0 +1,3 @@ +import Control.Applicative + +newtype Foo a = Foo (a -> a) deriving Applicative diff --git a/tests/examples/pre-ghc910/T9632.hs b/tests/examples/pre-ghc910/T9632.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9632.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeInType #-} + +module T9632 where + +import Data.Kind + +data B = T | F +data P :: B -> Type + +type B' = B +data P' :: B' -> Type diff --git a/tests/examples/pre-ghc910/T9662.hs b/tests/examples/pre-ghc910/T9662.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9662.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +module T9662 where + +data Exp a = Exp +data (a:.b) = a:.b + +type family Plain e :: Type +type instance Plain (Exp a) = a +type instance Plain (a:.b) = Plain a :. Plain b + +class (Plain (Unlifted pattern) ~ Tuple pattern) => Unlift pattern where + type Unlifted pattern + type Tuple pattern + +modify :: (Unlift pattern) => + pattern -> + (Unlifted pattern -> a) -> + Exp (Tuple pattern) -> Exp (Plain a) +modify p f = undefined + + +data Atom a = Atom + +atom :: Atom a +atom = Atom + + +instance (Unlift pa, int ~ Atom Int) => Unlift (pa :. int) where + type Unlifted (pa :. int) = Unlifted pa :. Exp Int + type Tuple (pa :. int) = Tuple pa :. Int + + +data Shape sh = Shape + +backpermute :: + (Exp sh -> Exp sh') -> + (Exp sh' -> Exp sh) -> + Shape sh -> Shape sh' +backpermute = undefined + +test :: Shape (sh:.k:.m:.n) -> Shape (sh:.m:.n:.k) +test = + backpermute + (modify (atom:.atom:.atom:.atom) + (\(sh:.k:.m:.n) -> (sh:.m:.n:.k))) + id + +-- With this arg instead of just 'id', it worked +-- (modify (atom:.atom:.atom:.atom) +-- (\(ix:.m:.n:.k) -> (ix:.k:.m:.n))) + diff --git a/tests/examples/pre-ghc910/T9824.1.hs b/tests/examples/pre-ghc910/T9824.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9824.1.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# OPTIONS_GHC -fwarn-unused-matches #-} + +module T9824 where + +foo = [p| (x, y) |] diff --git a/tests/examples/pre-ghc910/T9824.hs b/tests/examples/pre-ghc910/T9824.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9824.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fwarn-unused-matches #-} +{-# LANGUAGE TemplateHaskell #-} + +module T9824 where + +foo = [p| (x, y) |] + diff --git a/tests/examples/pre-ghc910/T9839_02.hs b/tests/examples/pre-ghc910/T9839_02.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9839_02.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/pre-ghc910/T9839_03.hs b/tests/examples/pre-ghc910/T9839_03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9839_03.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/pre-ghc910/T9839_04.hs b/tests/examples/pre-ghc910/T9839_04.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9839_04.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/pre-ghc910/T9839_05.hs b/tests/examples/pre-ghc910/T9839_05.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9839_05.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/pre-ghc910/T9839_06.hs b/tests/examples/pre-ghc910/T9839_06.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9839_06.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () diff --git a/tests/examples/pre-ghc910/T9840.hs b/tests/examples/pre-ghc910/T9840.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9840a.hs b/tests/examples/pre-ghc910/T9840a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9858a.hs b/tests/examples/pre-ghc910/T9858a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9858b.hs b/tests/examples/pre-ghc910/T9858b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9858c.hs b/tests/examples/pre-ghc910/T9858c.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9858d.hs b/tests/examples/pre-ghc910/T9858d.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9858e.hs b/tests/examples/pre-ghc910/T9858e.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9867.hs b/tests/examples/pre-ghc910/T9867.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9867.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-} + +module T9867 where + +pattern Nil = [] :: [a] diff --git a/tests/examples/pre-ghc910/T9878b.hs b/tests/examples/pre-ghc910/T9878b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9878b.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE StaticPointers #-} +module T9878b where + +import GHC.StaticPtr + +f = deRefStaticPtr (static True) diff --git a/tests/examples/pre-ghc910/T9938.hs b/tests/examples/pre-ghc910/T9938.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9938B.hs b/tests/examples/pre-ghc910/T9938B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9939.hs b/tests/examples/pre-ghc910/T9939.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9951.hs b/tests/examples/pre-ghc910/T9951.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9951.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T9951 where + +f :: [a] -> () +f x = case x of + [] -> () + (_:_) -> () + diff --git a/tests/examples/pre-ghc910/T9951b.hs b/tests/examples/pre-ghc910/T9951b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9951b.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T9951b where + +f :: String -> Bool +f "ab" = True diff --git a/tests/examples/pre-ghc910/T9964.hs b/tests/examples/pre-ghc910/T9964.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9968.hs b/tests/examples/pre-ghc910/T9968.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9968.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-} + +module T9968 where + +class C a b +data X = X deriving (C Int) + diff --git a/tests/examples/pre-ghc910/T9968a.hs b/tests/examples/pre-ghc910/T9968a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/T9968a.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module T9968 where + +import Data.Bifunctor + +data Blah a b = A a | B b + deriving (Bifunctor) diff --git a/tests/examples/pre-ghc910/T9973.hs b/tests/examples/pre-ghc910/T9973.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9975a.hs b/tests/examples/pre-ghc910/T9975a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/T9975b.hs b/tests/examples/pre-ghc910/T9975b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TDDataConstructor.hs b/tests/examples/pre-ghc910/TDDataConstructor.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TDDataConstructor.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeData #-} +module TDDataConstructor where + +type data P = MkP +data Prom = P + diff --git a/tests/examples/pre-ghc910/TDExistential.hs b/tests/examples/pre-ghc910/TDExistential.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TDExistential.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeData #-} +{-# LANGUAGE TypeFamilies #-} +module TDExistential where + +import Data.Kind (Type) + +-- example from GHC User's Guide 6.4.10.6 + +type data Ex :: Type where + MkEx :: forall a. a -> Ex + +type family UnEx (ex :: Ex) :: k +type instance UnEx (MkEx x) = x + diff --git a/tests/examples/pre-ghc910/TDGADT.hs b/tests/examples/pre-ghc910/TDGADT.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TDGADT.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeData #-} +module TDGADT where + +import Data.Kind (Type) + +type data Nat = Zero | Succ Nat + +-- type level GADT +type data Vec :: Nat -> Type -> Type where + VNil :: Vec Zero a + VCons :: a -> Vec n a -> Vec (Succ n) a + +type X = VCons Bool (VCons Int VNil) + diff --git a/tests/examples/pre-ghc910/TDGoodConsConstraints.hs b/tests/examples/pre-ghc910/TDGoodConsConstraints.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TDGoodConsConstraints.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeData #-} +{-# LANGUAGE GADTs #-} +module TDGoodConsConstraints where + +import Data.Kind (Type) +import Data.Type.Equality + +type data Foo :: Type -> Type where + MkFoo1 :: a ~ Int => Foo a + MkFoo2 :: a ~~ Int => Foo a + diff --git a/tests/examples/pre-ghc910/TDVector.hs b/tests/examples/pre-ghc910/TDVector.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TDVector.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeData #-} +{-# LANGUAGE MonoLocalBinds #-} +module TDVector where + +import Data.Kind (Type) + +type data Nat = Zero | Succ Nat + +type data List a = Nil | Cons a (List a) + +type data Pair a b = MkPair a b + +type data Sum a b = L a | R b + +data Vec :: Nat -> Type -> Type where + VNil :: Vec Zero a + VCons :: a -> Vec n a -> Vec (Succ n) a + +instance Functor (Vec n) where + fmap _ VNil = VNil + fmap f (VCons x xs) = VCons (f x) (fmap f xs) + diff --git a/tests/examples/pre-ghc910/TD_TH_splice.hs b/tests/examples/pre-ghc910/TD_TH_splice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TD_TH_splice.hs @@ -0,0 +1,19 @@ +-- Check that splicing in a quoted declaration has the same effect as +-- giving the declaration directly. +{-# LANGUAGE TemplateHaskell, TypeData, GADTs #-} + +module TD_TH_splice where + +import Data.Kind (Type) + +-- splice should be equivalent to giving the declaration directly +$( [d| type data Nat = Zero | Succ Nat |] ) + +data Vec :: Nat -> Type -> Type where + VNil :: Vec Zero a + VCons :: a -> Vec n a -> Vec (Succ n) a + +instance Functor (Vec n) where + fmap _ VNil = VNil + fmap f (VCons x xs) = VCons (f x) (fmap f xs) + diff --git a/tests/examples/pre-ghc910/TH.1.hs b/tests/examples/pre-ghc910/TH.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH.1.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/pre-ghc910/TH.hs b/tests/examples/pre-ghc910/TH.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH.hs @@ -0,0 +1,279 @@ +{-| +Module : Language.Grammars.AspectAG.TH +Description : Boilerplate generation +Copyright : (c) Juan García Garland +License : GPL +Maintainer : jpgarcia@fing.edu.uy +Stability : experimental +Portability : POSIX +-} + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +module Language.Grammars.AspectAG.TH where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (showName) +import Data.Proxy +import Data.Either +import GHC.TypeLits +import Data.List +import Data.Set (Set) +import qualified Data.Set as S + +import Control.Monad + +import Data.GenRec.Label +import Data.GenRec +import Language.Grammars.AspectAG +import Language.Grammars.AspectAG.RecordInstances +import qualified Data.Kind as DK + + +-- * Attribute labels + +-- | makes a type level lit (Symbol) from a String +str2Sym s = litT$ strTyLit s -- th provides nametoSymbol, btw + + +-- | TH function to define a typed attribute label given a name +-- and a quoted type +attLabel :: String -> Name -> DecsQ +attLabel s t + = [d| $(varP (mkName s)) = Label :: Label ( 'Att $(str2Sym s) + $(conT t)) |] + +-- | for completness, to have a name as the next one +attMono = attLabel + +-- | TH function to define a polymorphic attribute +attPoly :: String -> DecsQ +attPoly s + = [d| $(varP (mkName s)) = Label :: forall a . Label ( 'Att $(str2Sym s) a) |] + +-- | multiple monomorphic attributes at once +attLabels :: [(String,Name)] -> Q [Dec] +attLabels xs = liftM concat . sequence $ [attLabel att ty | (att,ty) <- xs ] + +-- * Non terminals + +-- | add a non terminal symbol +addNont :: String -> Q [Dec] +addNont s + = liftM concat . sequence $ [addNTLabel s, addNTType s] + +addNTLabel :: String -> Q [Dec] +addNTLabel s + = [d| $(varP (mkName ("nt_" ++ s))) = Label :: Label ('NT $(str2Sym s)) |] + +addNTType :: String -> Q [Dec] +addNTType s + = return [TySynD (mkName ("Nt_"++ s)) [] (AppT (PromotedT 'NT) (LitT (StrTyLit s)))] + + +-- * Productions +--data Symbol = N String | Te Name +type family Terminal s :: Either NT T where + Terminal s = 'Right ('T s) + +type family NonTerminal s where + NonTerminal s = 'Left s + + +data SymTH = Ter Name | NonTer Name | Poly + + +addChi :: String -- chi name + -> Name -- prd + -> SymTH -- symbol type + -> Q [Dec] +addChi chi prd (Ter typ) + = [d| $(varP (mkName ("ch_" ++chi))) + = Label :: Label ( 'Chi $(str2Sym chi) + $(conT prd) + (Terminal $(conT typ)))|] +addChi chi prd (NonTer typ) + = [d| $(varP (mkName ("ch_" ++chi))) + = Label :: Label ( 'Chi $(str2Sym chi) + $(conT prd) + (NonTerminal $(conT typ)))|] +addChi chi prd poly + = [d| $(varP (mkName ("ch_" ++chi))) + = Label :: forall a . Label ( 'Chi $(str2Sym chi) + $(conT prd) + ('Right ('T a)))|] + +-- | only prod symbol +addPrd :: String --name + -> Name --nonterm + -> Q [Dec] +addPrd prd nt = liftM concat . sequence + $ [addPrdType prd nt, addPrdLabel prd nt] + +addPrdLabel prd nt + = [d| $(varP (mkName ("p_" ++ prd))) + = Label :: Label ('Prd $(str2Sym prd) $(conT nt))|] + +addPrdType prd nt + = return [TySynD (mkName ("P_"++ prd)) [] + (AppT (AppT (PromotedT 'Prd) (LitT (StrTyLit prd))) (ConT nt))] + + +-- | Productions +addProd :: String -- name + -> Name -- nt + -> [(String, SymTH)] -- chiLst + -> Q [Dec] +addProd prd nt xs + = liftM concat . sequence $ + addPrd prd nt + : addInstance nt prd (map preProc xs) + : [addChi chi (mkName ("P_" ++ prd)) sym | (chi, sym) <- xs] + where preProc (n, Ter a) = (mkName n, a) + preProc (n, NonTer a) = (mkName n, a) + preProc (n, Poly) = (mkName n, mkName "a") + +-- | class +class Prods (lhs :: NT) (name :: Symbol) (rhs :: [(Symbol, Symbol)]) where {} + +-- get a list of instances +getInstances :: Q [InstanceDec] +getInstances = do + ClassI _ instances <- reify ''Prods + return instances + +-- convert the list of instances into an Exp so they can be displayed in GHCi +showInstances :: Q Exp +showInstances = do + ins <- getInstances + return . LitE . stringL $ show $ head ins + +addInstance :: Name -> String -> [(Name, Name)] -> Q [Dec] +addInstance nt name rhs + = [d| instance Prods $(conT nt) $(str2Sym name) $(typeList rhs) where {} |] + +typeList :: [(Name, Name)] -> Q Type +typeList = foldr f promotedNilT + -- where f = \x xs -> appT (appT promotedConsT (nameToSymbolBase x)) xs + where f = \(n,t) xs + -> appT (appT promotedConsT (appT (appT (promotedTupleT 2) + (nameToSymbol n)) + (nameToSymbolBase t))) xs + +nameToSymbol = litT . strTyLit . show +nameToSymbolBase = litT . strTyLit . nameBase + +isNTName :: Name -> Bool +isNTName n + = "Nt_" `isPrefixOf` nameBase n + +closeNT :: Name -> Q [Dec] +closeNT nt + = do decs <- getInstances + let consts = map mkCon $ filter (isInstanceOf nt) decs + return [ DataD [] + (mkName $ drop 3 $ nameBase nt) [] Nothing + consts [DerivClause Nothing [ConT ''Show, ConT ''Eq, ConT ''Read]]] + +isInstanceOf nt (InstanceD _ _ (AppT (AppT (AppT (ConT prods) (ConT nt')) _ ) _) _) + = nameBase nt == nameBase nt' +isInstanceOf _ _ = False + +mkCon :: InstanceDec -> Con +mkCon i + = case i of + InstanceD _ [] (AppT (AppT (AppT (ConT _prods) (ConT nt)) (LitT (StrTyLit prdname))) tlist) _ + -> RecC (mkName prdname) (map mkBangPR $ getTList tlist) + +mkBangP (_, a) = (Bang NoSourceUnpackedness NoSourceStrictness, ConT a) +mkBangPR (n, a) = (n, Bang NoSourceUnpackedness NoSourceStrictness, ConT a) + +getTList :: Type -> [(Name, Name)] +getTList (SigT _ _) = [] +getTList (AppT (AppT (PromotedConsT) + (AppT (AppT (PromotedTupleT 2) + (LitT (StrTyLit n))) + (LitT (StrTyLit pos)))) + ts) + = (mkName n, + if "Nt_" `isPrefixOf` pos then mkName $ drop 3 pos else mkName pos) + : getTList ts +getTList _ = [] + +-- | keeps nt info +getTListNT :: Type -> [(Name, Name)] +getTListNT (SigT _ _) = [] +getTListNT (AppT (AppT (PromotedConsT) + (AppT (AppT (PromotedTupleT 2) + (LitT (StrTyLit n))) + (LitT (StrTyLit pos)))) + ts) + = (mkName n, mkName pos) : getTListNT ts +getTListNT _ = [] + +-- | like |mkCon| in semantic functions, builds a case +mkClause :: InstanceDec -> Clause +mkClause i + = case i of + InstanceD _ [] (AppT (AppT (AppT (ConT _prods) + (ConT nt)) + (LitT (StrTyLit prdname))) + tlist) _ + -> Clause [VarP (mkName "asp"), + ConP (mkName $ prdname) [ VarP a | a <- map fst (getTList tlist)]] + (NormalB ((AppE (AppE (AppE (VarE $ mkName "knitAspect") + (VarE $ mkName $ "p_"++ prdname)) + (VarE $ mkName "asp")) + (toSemRec (getTListNT tlist))))) + [] + +toSemRec :: [(Name, Name)] -> Exp +toSemRec + = foldr mkChSem (VarE (mkName "emptyGenRec")) + where mkChSem (n,pos) xs + | "Nt_" `isPrefixOf` nameBase pos = + (AppE (AppE (VarE $ mkName ".*.") + (AppE (AppE (VarE $ mkName ".=.") + (VarE $ mkName $ "ch_" ++ nameBase n)) + (AppE (AppE (VarE $ mkName $ "sem_" ++ (drop 3 $ nameBase pos)) + (VarE $ mkName "asp")) + (VarE $ n)))) + xs) + | otherwise = + (AppE (AppE (VarE $ mkName ".*.") + (AppE (AppE (VarE $ mkName ".=.") + (VarE $ mkName $ "ch_" ++ nameBase n)) + (AppE (VarE $ mkName "sem_Lit") + (VarE $ n)))) + xs) +closeNTs :: [Name] -> Q [Dec] +closeNTs = liftM concat . sequence . map (closeNT) + +mkSemFunc :: Name -- nonterm + -> Q [Dec] +mkSemFunc nt = + do decs <- getInstances + let clauses = map mkClause $ filter (isInstanceOf nt) decs + return [FunD (mkName $ "sem_" ++ drop 3 (nameBase nt)) clauses ] + +mkSemFuncs :: [Name] -> Q [Dec] +mkSemFuncs + = liftM concat . sequence . map (mkSemFunc) + diff --git a/tests/examples/pre-ghc910/TH1.hs b/tests/examples/pre-ghc910/TH1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH1.hs @@ -0,0 +1,7 @@ +module TH2 where + +typeList = f + -- comment + where f = undefined + +nameToSymbol = undefined diff --git a/tests/examples/pre-ghc910/TH2.hs b/tests/examples/pre-ghc910/TH2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH2.hs @@ -0,0 +1,8 @@ +{- Bloc comment +-} + +{-# LANGUAGE PolyKinds #-} + +module Language.Grammars.AspectAG.TH where + +import Data.GenRec diff --git a/tests/examples/pre-ghc910/THMonadInstance.hs b/tests/examples/pre-ghc910/THMonadInstance.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TH_abstractFamily.1.hs b/tests/examples/pre-ghc910/TH_abstractFamily.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_abstractFamily.1.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module TH_abstractFamily where + +import Language.Haskell.TH + +-- Empty closed type families are okay... +ds1 :: Q [Dec] +ds1 = [d| type family F a where |] + +-- ...but abstract ones should result in a type error +ds2 :: Q [Dec] +ds2 = [d| type family G a where .. |] diff --git a/tests/examples/pre-ghc910/TH_abstractFamily.hs b/tests/examples/pre-ghc910/TH_abstractFamily.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_abstractFamily.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +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/pre-ghc910/TH_bracket1.1.hs b/tests/examples/pre-ghc910/TH_bracket1.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_bracket1.1.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- Check that declarations in a bracket shadow the top-level +-- declarations, rather than clashing with them. + +module TH_bracket1 where + +foo = 1 +bar = [d| foo = 1 |] diff --git a/tests/examples/pre-ghc910/TH_bracket1.hs b/tests/examples/pre-ghc910/TH_bracket1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_bracket1.hs @@ -0,0 +1,9 @@ +-- Check that declarations in a bracket shadow the top-level +{-# LANGUAGE TemplateHaskell #-} +-- declarations, rather than clashing with them. + +module TH_bracket1 where + +foo = 1 +bar = [d| foo = 1 |] + diff --git a/tests/examples/pre-ghc910/TH_bracket2.1.hs b/tests/examples/pre-ghc910/TH_bracket2.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_bracket2.1.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module TH_bracket2 where + +d_show = [d| data A = A + + instance Show A where + show _ = "A" + |] diff --git a/tests/examples/pre-ghc910/TH_bracket2.hs b/tests/examples/pre-ghc910/TH_bracket2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_bracket2.hs @@ -0,0 +1,10 @@ + +{-# LANGUAGE TemplateHaskell #-} +module TH_bracket2 where + +d_show = [d| data A = A + + instance Show A where + show _ = "A" + |] + diff --git a/tests/examples/pre-ghc910/TH_bracket3.1.hs b/tests/examples/pre-ghc910/TH_bracket3.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_bracket3.1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module TH_bracket3 where + +d_class = [d| class Classy a b where + f :: a -> b + + instance Classy Int Bool where + f x = if x == 0 then True else False + |] diff --git a/tests/examples/pre-ghc910/TH_bracket3.hs b/tests/examples/pre-ghc910/TH_bracket3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_bracket3.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +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/pre-ghc910/TH_class1.hs b/tests/examples/pre-ghc910/TH_class1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_class1.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE TemplateHaskell #-} + +module TH_class1 where + +$( [d| class Classy a b c d | a -> b c, c -> d where + f :: a -> b -> c -> d + |] ) + diff --git a/tests/examples/pre-ghc910/TH_dataD1.hs b/tests/examples/pre-ghc910/TH_dataD1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_dataD1.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH_dataD1 where + +import Language.Haskell.TH + +ds :: Q [Dec] +ds = [d| + $(do { d <- dataD (cxt []) (mkName "D") [] Nothing + [normalC (mkName "K") []] [] + ; return [d]}) + |] + diff --git a/tests/examples/pre-ghc910/TH_finalizer.hs b/tests/examples/pre-ghc910/TH_finalizer.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_finalizer.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} + +module ShouldCompile where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +$( do + addModFinalizer (do b <- getQ; reportWarning (show (b::Maybe Bool))) + return [] ) +$( putQ True >> return [] ) diff --git a/tests/examples/pre-ghc910/TH_localname.1.hs b/tests/examples/pre-ghc910/TH_localname.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_localname.1.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module TH_localname where + +x = \y -> [| y |] diff --git a/tests/examples/pre-ghc910/TH_localname.hs b/tests/examples/pre-ghc910/TH_localname.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_localname.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH_localname where + +x = \y -> [| y |] + diff --git a/tests/examples/pre-ghc910/TH_lookupName.hs b/tests/examples/pre-ghc910/TH_lookupName.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_lookupName.hs @@ -0,0 +1,37 @@ +-- test 'lookupTypeName' and 'lookupValueName' +{-# LANGUAGE TemplateHaskell #-} + +import Language.Haskell.TH + +import qualified TH_lookupName_Lib +import qualified TH_lookupName_Lib as TheLib + +f :: String +f = "TH_lookupName.f" + +data D = D + +$(return []) + +main = mapM_ print [ + -- looking up values + $(do { Just n <- lookupValueName "f" ; varE n }), + $(do { Nothing <- lookupTypeName "f"; [| "" |] }), + -- looking up types + $(do { Just n <- lookupTypeName "String"; sigE [| "" |] (conT n) }), + $(do { Nothing <- lookupValueName "String"; [| "" |] }), + -- namespacing + $(do { Just n <- lookupValueName "D"; DataConI{} <- reify n; [| "" |] }), + $(do { Just n <- lookupTypeName "D"; TyConI{} <- reify n; [| "" |] }), + -- qualified lookup + $(do { Just n <- lookupValueName "TH_lookupName_Lib.f"; varE n }), + $(do { Just n <- lookupValueName "TheLib.f"; varE n }), + -- shadowing + $(TheLib.lookup_f), + $( [| let f = "local f" in $(TheLib.lookup_f) |] ), + $( [| let f = "local f" in $(do { Just n <- lookupValueName "f"; varE n }) |] ), + $( [| let f = "local f" in $(varE 'f) |] ), + let f = "local f" in $(TheLib.lookup_f), + let f = "local f" in $(varE 'f) + ] + diff --git a/tests/examples/pre-ghc910/TH_namePackage.hs b/tests/examples/pre-ghc910/TH_namePackage.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TH_nameSpace.hs b/tests/examples/pre-ghc910/TH_nameSpace.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_nameSpace.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Data.Maybe (Maybe(..)) +import Data.Ord (Ord) +import Language.Haskell.TH (mkName, nameSpace) + +main :: IO () +main = mapM_ (print . nameSpace) + [ 'Prelude.id + , mkName "id" + , 'Data.Maybe.Just + , ''Data.Maybe.Maybe + , ''Data.Ord.Ord + ] diff --git a/tests/examples/pre-ghc910/TH_ppr1.1.hs b/tests/examples/pre-ghc910/TH_ppr1.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_ppr1.1.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Main (main) where + +import Language.Haskell.TH + +u1 :: a +u1 = undefined + +u2 :: a +u2 = undefined + +f :: a +f = undefined + +(.+.) :: a +(.+.) = undefined + +main :: IO () +main = do runQ [| f u1 u2 |] >>= p + runQ [| u1 `f` u2 |] >>= p + runQ [| (.+.) u1 u2 |] >>= p + runQ [| u1 .+. u2 |] >>= p + runQ [| (:) u1 u2 |] >>= p + runQ [| u1 : u2 |] >>= p + runQ [| \((:) x xs) -> x |] >>= p + runQ [| \(x : xs) -> x |] >>= p + runQ [d| class Foo a b where + foo :: a -> b |] >>= p + runQ [| \x -> (x, 1 `x` 2) |] >>= p + runQ [| \(+) -> ((+), 1 + 2) |] >>= p + runQ [| (f, 1 `f` 2) |] >>= p + runQ [| ((.+.), 1 .+. 2) |] >>= p + +p :: Ppr a => a -> IO () +p = putStrLn . pprint + diff --git a/tests/examples/pre-ghc910/TH_ppr1.hs b/tests/examples/pre-ghc910/TH_ppr1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_ppr1.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +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/pre-ghc910/TH_raiseErr1.hs b/tests/examples/pre-ghc910/TH_raiseErr1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_raiseErr1.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH_raiseErr1 where +import Language.Haskell.TH + +foo = $(do { report True "Error test succeeded"; fail "" }) + diff --git a/tests/examples/pre-ghc910/TH_recover.hs b/tests/examples/pre-ghc910/TH_recover.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_recover.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +-- The recover successfully find that 'ola' is not in scope +-- and use '1' instead + +y = $(recover (return (LitE (IntegerL 1))) + (reify (mkName ("ola")) >> return (LitE (IntegerL 2)))) + +main = print y + diff --git a/tests/examples/pre-ghc910/TH_recover_warns.hs b/tests/examples/pre-ghc910/TH_recover_warns.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_recover_warns.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall #-} +module Bug where + +import Language.Haskell.TH + +-- Warnings should be preserved through recover +main :: IO () +main = putStrLn $(recover (stringE "splice failed") + [| let x = "a" in let x = "b" in x |]) + diff --git a/tests/examples/pre-ghc910/TH_recursiveDoImport.hs b/tests/examples/pre-ghc910/TH_recursiveDoImport.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_recursiveDoImport.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TemplateHaskell #-} +module TH_recursiveDoImport where +import Data.IORef +import Language.Haskell.TH + +data SelfRef = SelfRef (IORef (IORef SelfRef)) + +recIO :: ExpQ +recIO = [e| + do rec r1 <- newIORef r2 + r2 <- newIORef (SelfRef r1) + readIORef r2 |] + +mdoIO :: ExpQ +mdoIO = [e| + mdo r1 <- return r2 + r2 <- return (const 1 r1) + return r1 |] + +emptyRecIO :: ExpQ +emptyRecIO = [e| + do rec {} + return () |] + diff --git a/tests/examples/pre-ghc910/TH_reifyDecl1.1.hs b/tests/examples/pre-ghc910/TH_reifyDecl1.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_reifyDecl1.1.hs @@ -0,0 +1,88 @@ +-- test reification of data declarations +{-# LANGUAGE TemplateHaskell #-} + +{-# LANGUAGE TypeFamilies #-} +module TH_reifyDecl1 where + +import System.IO +import Language.Haskell.TH +import Text.PrettyPrint.HughesPJ + +infixl 3 `m1` + +-- simple +data T = A | B + +-- parametric +data R a = C a | D + +-- recursive +data List a = Nil | Cons a (List a) + +-- infix operator +data Tree a = Leaf | Tree a :+: Tree a + +-- type declaration +type IntList = [Int] + +-- newtype declaration +newtype Length = Length Int + +-- simple class +class C1 a where + m1 :: a -> Int + +-- class with instances +class C2 a where + m2 :: a -> Int +instance C2 Int where + m2 x = x + +-- associated types +class C3 a where + type AT1 a + data AT2 a + +instance C3 Int where + type AT1 Int = Bool + data AT2 Int = AT2Int + +-- type family +type family TF1 a + +-- type family, with instances +type family TF2 a +type instance TF2 Bool = Bool + +-- data family +data family DF1 a + +-- data family, with instances +data family DF2 a +data instance DF2 Bool = DBool + +$(return []) + +test :: () +test = $(let + display :: Name -> Q () + display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) } + in do { display ''T + ; display ''R + ; display ''List + ; display ''Tree + ; display ''IntList + ; display ''Length + ; display 'Leaf + ; display 'm1 + ; display ''C1 + ; display ''C2 + ; display ''C3 + ; display ''AT1 + ; display ''AT2 + ; display ''TF1 + ; display ''TF2 + ; display ''DF1 + ; display ''DF2 + ; [| () |] }) + diff --git a/tests/examples/pre-ghc910/TH_reifyDecl1.hs b/tests/examples/pre-ghc910/TH_reifyDecl1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_reifyDecl1.hs @@ -0,0 +1,94 @@ +-- test reification of data declarations + +{-# LANGUAGE TypeFamilies, TypeApplications, PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TH_reifyDecl1 where + +import Data.Kind as K +import System.IO +import Language.Haskell.TH +import Text.PrettyPrint.HughesPJ + +infixl 3 `m1` + +-- simple +data T = A | B + +-- parametric +data R a = C a | D + +-- recursive +data List a = Nil | Cons a (List a) + +-- infix operator +data Tree a = Leaf | Tree a :+: Tree a + +-- type declaration +type IntList = [Int] + +-- newtype declaration +newtype Length = Length Int + +-- simple class +class C1 a where + m1 :: a -> Int + +-- class with instances +class C2 a where + m2 :: a -> Int +instance C2 Int where + m2 x = x + +-- associated types +class C3 a where + type AT1 a + data AT2 a + +instance C3 Int where + type AT1 Int = Bool + data AT2 Int = AT2Int + +-- type family +type family TF1 a + +-- type family, with instances +type family TF2 a +type instance TF2 Bool = Bool + +-- data family +data family DF1 a + +-- data family, with instances +data family DF2 a +data instance DF2 Bool = DBool + +data family DF3 (a :: k) +data instance DF3 @K.Type a = DF3Bool +data instance DF3 @(K.Type -> K.Type) b = DF3Char + +$(return []) + +test :: () +test = $(let + display :: Name -> Q () + display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) } + in do { display ''T + ; display ''R + ; display ''List + ; display ''Tree + ; display ''IntList + ; display ''Length + ; display 'Leaf + ; display 'm1 + ; display ''C1 + ; display ''C2 + ; display ''C3 + ; display ''AT1 + ; display ''AT2 + ; display ''TF1 + ; display ''TF2 + ; display ''DF1 + ; display ''DF2 + ; display ''DF3 + ; [| () |] }) + diff --git a/tests/examples/pre-ghc910/TH_reifyDecl1a.hs b/tests/examples/pre-ghc910/TH_reifyDecl1a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_reifyDecl1a.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeFamilies, TypeApplications, PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module TH_reifyDecl1 where + +test :: () +test = $(let + display :: Name -> Q () + display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) } + in do { display ''T + ; display ''DF3 + ; [| () |] }) + diff --git a/tests/examples/pre-ghc910/TH_reifyDecl2.hs b/tests/examples/pre-ghc910/TH_reifyDecl2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_reifyDecl2.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH_reifyDecl2 where + +import Language.Haskell.TH +import System.IO + +$( + do x <- reify ''Maybe + runIO $ hPutStrLn stderr $ pprint x + return [] + ) + diff --git a/tests/examples/pre-ghc910/TH_reifyInstances.hs b/tests/examples/pre-ghc910/TH_reifyInstances.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_reifyInstances.hs @@ -0,0 +1,51 @@ +-- test reifyInstances +{-# LANGUAGE TemplateHaskell #-} + +{-# LANGUAGE TypeFamilies #-} +module TH_reifyInstances where + +import System.IO +import Language.Haskell.TH +import Text.PrettyPrint.HughesPJ + +-- classes +class C1 a where f1 :: a + +class C2 a where f2 :: a +instance C2 Int where f2 = 0 +instance C2 Bool where f2 = True + +-- type families +type family T1 a + +type family T2 a +type instance T2 Int = Char +type instance T2 Bool = Int + +-- data families +data family D1 a + +data family D2 a +data instance D2 Int = DInt | DInt2 +data instance D2 Bool = DBool + +$(return []) + +test :: () +test = $(let + display :: Name -> Q () + display n = do + { intTy <- [t| Int |] + ; is1 <- reifyInstances n [intTy] + ; runIO $ hPutStrLn stderr (nameBase n) + ; runIO $ hPutStrLn stderr (pprint is1) + } + in do { display ''C1 + ; display ''C2 + ; display ''T1 + ; display ''T2 + ; display ''D1 + ; display ''D2 + ; [| () |] + }) + diff --git a/tests/examples/pre-ghc910/TH_reifyLinear.hs b/tests/examples/pre-ghc910/TH_reifyLinear.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_reifyLinear.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE TemplateHaskell #-} +module TH_reifyLinear where + +import Language.Haskell.TH +import System.IO + +type T = Int #-> Int + +$( + do x <- reify ''T + runIO $ hPutStrLn stderr $ pprint x + return [] + ) + diff --git a/tests/examples/pre-ghc910/TH_reifyMkName.hs b/tests/examples/pre-ghc910/TH_reifyMkName.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_reifyMkName.hs @@ -0,0 +1,16 @@ +-- Trac #2339 +{-# LANGUAGE TemplateHaskell #-} + +module Foo where + +import System.IO +import Language.Haskell.TH + +type C = Int + +$(do + a <- reify $ mkName "C" + runIO $ hPutStrLn stderr (show a) + return [] + ) + diff --git a/tests/examples/pre-ghc910/TH_reifyType1.hs b/tests/examples/pre-ghc910/TH_reifyType1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TH_reifyType2.hs b/tests/examples/pre-ghc910/TH_reifyType2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TH_repE1.1.hs b/tests/examples/pre-ghc910/TH_repE1.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repE1.1.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- test the representation of literals and also explicit type annotations + +module TH_repE1 +where + +import Language.Haskell.TH + +integralExpr :: ExpQ +integralExpr = [| 42 |] + +intExpr :: ExpQ +intExpr = [| 42 :: Int |] + +integerExpr :: ExpQ +integerExpr = [| 42 :: Integer |] + +charExpr :: ExpQ +charExpr = [| 'x' |] + +stringExpr :: ExpQ +stringExpr = [| "A String" |] + +fractionalExpr :: ExpQ +fractionalExpr = [| 1.2 |] + +floatExpr :: ExpQ +floatExpr = [| 1.2 :: Float |] + +doubleExpr :: ExpQ +doubleExpr = [| 1.2 :: Double |] diff --git a/tests/examples/pre-ghc910/TH_repE1.hs b/tests/examples/pre-ghc910/TH_repE1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repE1.hs @@ -0,0 +1,32 @@ +-- test the representation of literals and also explicit type annotations +{-# LANGUAGE TemplateHaskell #-} + +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/pre-ghc910/TH_repE2.hs b/tests/examples/pre-ghc910/TH_repE2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repE2.hs @@ -0,0 +1,37 @@ +-- test the representation of literals and also explicit type annotations +{-# LANGUAGE TemplateHaskell #-} + +module Main +where + +import Language.Haskell.TH + +main :: IO () +main = mapM_ putStrLn [show an_integral, show an_int, show an_integer, + show an_char, show an_string, show an_fractional, + show an_float, show an_double] + +an_integral :: Integer +an_integral = $( [| 42 |] ) + +an_int :: Int +an_int = $( [| 42 :: Int |] ) + +an_integer :: Integer +an_integer = $( [| 98765432123456789876 :: Integer |] ) + +an_char :: Char +an_char = $( [| 'x' |] ) + +an_string :: String +an_string = $( [| "A String" |] ) + +an_fractional :: Double +an_fractional = $( [| 1.2 |] ) + +an_float :: Float +an_float = $( [| 1.2 :: Float |] ) + +an_double :: Double +an_double = $( [| 1.2 :: Double |] ) + diff --git a/tests/examples/pre-ghc910/TH_repE3.1.hs b/tests/examples/pre-ghc910/TH_repE3.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repE3.1.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- test the representation of literals and also explicit type annotations + +module TH_repE1 +where + +import Language.Haskell.TH + +emptyListExpr :: ExpQ +emptyListExpr = [| [] |] + +singletonListExpr :: ExpQ +singletonListExpr = [| [4] |] + +listExpr :: ExpQ +listExpr = [| [4,5,6] |] + +consExpr :: ExpQ +consExpr = [| 4:5:6:[] |] + diff --git a/tests/examples/pre-ghc910/TH_repE3.hs b/tests/examples/pre-ghc910/TH_repE3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repE3.hs @@ -0,0 +1,20 @@ +-- test the representation of literals and also explicit type annotations +{-# LANGUAGE TemplateHaskell #-} + +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/pre-ghc910/TH_repGuard.hs b/tests/examples/pre-ghc910/TH_repGuard.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repGuard.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main +where + +import Language.Haskell.TH +import System.IO + +$( + do ds <- [d| + foo :: Int -> Int + foo x + | x == 5 = 6 + foo x = 7 + |] + runIO $ do { putStrLn (pprint ds); hFlush stdout } + return ds + ) + +$( + do ds <- [d| + bar :: Maybe Int -> Int + bar x + | Just y <- x = y + bar _ = 9 + |] + runIO $ do { putStrLn (pprint ds) ; hFlush stdout } + return ds + ) + +main :: IO () +main = do putStrLn $ show $ foo 5 + putStrLn $ show $ foo 8 + putStrLn $ show $ bar (Just 2) + putStrLn $ show $ bar Nothing + diff --git a/tests/examples/pre-ghc910/TH_repGuardOutput.hs b/tests/examples/pre-ghc910/TH_repGuardOutput.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repGuardOutput.hs @@ -0,0 +1,30 @@ +-- test the representation of unboxed literals +{-# LANGUAGE TemplateHaskell #-} + +module Main +where + +$( + [d| + foo :: Int -> Int + foo x + | x == 5 = 6 + foo x = 7 + |] + ) + +$( + [d| + bar :: Maybe Int -> Int + bar x + | Just y <- x = y + bar _ = 9 + |] + ) + +main :: IO () +main = do putStrLn $ show $ foo 5 + putStrLn $ show $ foo 8 + putStrLn $ show $ bar (Just 2) + putStrLn $ show $ bar Nothing + diff --git a/tests/examples/pre-ghc910/TH_repPatSig.hs b/tests/examples/pre-ghc910/TH_repPatSig.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repPatSig.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main +where + +import TH_repPatSig_asserts + +assertFoo [d| foo :: Int -> Int + foo (x :: Int) = x + |] + +assertCon [| \(x :: Either Char Int -> (Char, Int)) -> x |] + +assertVar [| \(x :: Maybe a) -> case x of Just y -> (y :: a) |] + +main :: IO () +main = return () + diff --git a/tests/examples/pre-ghc910/TH_repPatSigTVar.hs b/tests/examples/pre-ghc910/TH_repPatSigTVar.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repPatSigTVar.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main +where + +import Language.Haskell.TH + +$([d| f = \(_ :: Either a b) -> $(sigE (varE 'undefined) (varT ''c)) |]) + +main :: IO () +main = return () + diff --git a/tests/examples/pre-ghc910/TH_repPrim.hs b/tests/examples/pre-ghc910/TH_repPrim.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repPrim.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MagicHash #-} +-- test the representation of unboxed literals + +module Main where + +import GHC.Exts +import GHC.Float +import Language.Haskell.TH +import Text.PrettyPrint +import System.IO + +main :: IO () +main = do putStrLn $ show $ $( do e <- [| I# 20# |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + return e ) + putStrLn $ show $ $( do e <- [| W# 32## |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + return e ) + putStrLn $ show $ $( do e <- [| F# 12.3# |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + return e ) + putStrLn $ show $ $( do e <- [| D# 24.6## |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + return e ) + diff --git a/tests/examples/pre-ghc910/TH_repPrim2.hs b/tests/examples/pre-ghc910/TH_repPrim2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repPrim2.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +{-# LANGUAGE TemplateHaskell #-} +-- test the representation of unboxed literals + +module Main where + +import GHC.Exts +import GHC.Float +import Language.Haskell.TH +import Text.PrettyPrint +import System.IO + +main :: IO () +main = do putStrLn $ show $ $( do e <- [| 20# |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + [| I# $( return e) |] ) + putStrLn $ show $ $( do e <- [| 32## |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + [| W# $(return e) |] ) + putStrLn $ show $ $( do e <- [| 12.3# |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + [| F# $(return e) |] ) + putStrLn $ show $ $( do e <- [| 24.6## |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + [| D# $(return e) |] ) + diff --git a/tests/examples/pre-ghc910/TH_repPrimOutput.hs b/tests/examples/pre-ghc910/TH_repPrimOutput.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repPrimOutput.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +-- test the representation of unboxed literals + +module Main +where + +import GHC.Exts +import GHC.Float +import Language.Haskell.TH +import Text.PrettyPrint +import System.IO + +main :: IO () +main = do putStrLn $ show $ $( do e <- [| I# 20# |] + return e ) + putStrLn $ show $ $( do e <- [| W# 32## |] + return e ) + putStrLn $ show $ $( do e <- [| F# 12.3# |] + return e ) + putStrLn $ show $ $( do e <- [| D# 24.6## |] + return e ) + diff --git a/tests/examples/pre-ghc910/TH_repPrimOutput2.hs b/tests/examples/pre-ghc910/TH_repPrimOutput2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_repPrimOutput2.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +{-# LANGUAGE TemplateHaskell #-} +-- test the representation of unboxed literals + +module Main +where + +import GHC.Exts +import GHC.Float +import Language.Haskell.TH +import Text.PrettyPrint +import System.IO + +main :: IO () +main = do putStrLn $ show $ $( do e <- [| 20# |] + [| I# $(return e) |] ) + putStrLn $ show $ $( do e <- [| 32## |] + [| W# $(return e) |] ) + putStrLn $ show $ $( do e <- [| 12.3# |] + [| F# $(return e) |] ) + putStrLn $ show $ $( do e <- [| 24.6## |] + [| D# $(return e) |] ) + diff --git a/tests/examples/pre-ghc910/TH_scope.1.hs b/tests/examples/pre-ghc910/TH_scope.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_scope.1.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +-- Test for Trac #2188 + +module TH_scope where + +f g = [d| f :: Int + f = g + g :: Int + g = 4 |] diff --git a/tests/examples/pre-ghc910/TH_scope.2.hs b/tests/examples/pre-ghc910/TH_scope.2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_scope.2.hs @@ -0,0 +1,10 @@ +-- Test for #2188 +{-# LANGUAGE TemplateHaskellQuotes #-} + +module TH_scope where + +f g = [d| f :: Int + f = g + g :: Int + g = 4 |] + diff --git a/tests/examples/pre-ghc910/TH_scope.hs b/tests/examples/pre-ghc910/TH_scope.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_scope.hs @@ -0,0 +1,10 @@ +-- Test for Trac #2188 +{-# LANGUAGE TemplateHaskell #-} + +module TH_scope where + +f g = [d| f :: Int + f = g + g :: Int + g = 4 |] + diff --git a/tests/examples/pre-ghc910/TH_sections.hs b/tests/examples/pre-ghc910/TH_sections.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_sections.hs @@ -0,0 +1,11 @@ +-- Test for trac #2956 +{-# LANGUAGE TemplateHaskell #-} + +module TH_sections where + +two :: Int +two = $( [| (1 +) 1 |] ) + +three :: Int +three = $( [| (+ 2) 1 |] ) + diff --git a/tests/examples/pre-ghc910/TH_spliceD2.hs b/tests/examples/pre-ghc910/TH_spliceD2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceD2.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH_spliceD2 where + +import qualified TH_spliceD2_Lib + +$( [d| data T = T TH_spliceD2_Lib.T |] ) + diff --git a/tests/examples/pre-ghc910/TH_spliceDecl1.hs b/tests/examples/pre-ghc910/TH_spliceDecl1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceDecl1.hs @@ -0,0 +1,12 @@ +-- test splicing of a generated data declarations +{-# LANGUAGE TemplateHaskell #-} + +module TH_spliceDecl1 +where + +import Language.Haskell.TH + + +-- splice a simple data declaration +$(return [DataD [] (mkName "T") [] Nothing [NormalC (mkName "C") []] []]) + diff --git a/tests/examples/pre-ghc910/TH_spliceDecl2.hs b/tests/examples/pre-ghc910/TH_spliceDecl2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceDecl2.hs @@ -0,0 +1,13 @@ +-- test splicing of quoted data and newtype declarations +{-# LANGUAGE TemplateHaskell #-} + +module TH_spliceDecl2 +where + +import Language.Haskell.TH + +-- splice a simple quoted declaration (x 2) +$([d| data T1 = C1 |]) + +$([d| newtype T2 = C2 String |]) + diff --git a/tests/examples/pre-ghc910/TH_spliceDecl3.hs b/tests/examples/pre-ghc910/TH_spliceDecl3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceDecl3.hs @@ -0,0 +1,13 @@ +-- test splicing of reified and renamed data declarations +{-# LANGUAGE TemplateHaskell #-} + +module TH_spliceDecl3 +where + +import Language.Haskell.TH +import TH_spliceDecl3_Lib + +data T = C + +$(do { TyConI d <- reify ''T; rename' d}) + diff --git a/tests/examples/pre-ghc910/TH_spliceE1.hs b/tests/examples/pre-ghc910/TH_spliceE1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceE1.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +my_id :: a -> a +my_id x = $( [| x |] ) + +main = print (my_id "hello") + diff --git a/tests/examples/pre-ghc910/TH_spliceE3.hs b/tests/examples/pre-ghc910/TH_spliceE3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceE3.hs @@ -0,0 +1,26 @@ +-- test the representation of literals and also explicit type annotations +{-# LANGUAGE TemplateHaskell #-} + +module TH_repE1 +where + +import Language.Haskell.TH + +$( do let emptyListExpr :: ExpQ + emptyListExpr = [| [] |] + + singletonListExpr :: ExpQ + singletonListExpr = [| [4] |] + + listExpr :: ExpQ + listExpr = [| [4,5,6] |] + + consExpr :: ExpQ + consExpr = [| 4:5:6:[] |] + + [d| foo = ($emptyListExpr, $singletonListExpr, $listExpr, $consExpr) |] + ) + +bar = $( [| case undefined of + [1] -> 1 |] ) + diff --git a/tests/examples/pre-ghc910/TH_spliceE4.hs b/tests/examples/pre-ghc910/TH_spliceE4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceE4.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +$( do let h x = x + foo = [| \x -> $(h [| x |]) |] + + [d| baz = $foo |] + ) + +main = print (baz "Hello") + diff --git a/tests/examples/pre-ghc910/TH_spliceE5_Lib.hs b/tests/examples/pre-ghc910/TH_spliceE5_Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceE5_Lib.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH_spliceE5_Lib where + +import Language.Haskell.TH + +expandVars :: [String] -> Q Exp +expandVars s = [| concat $(return (ListE (map f s))) |] + where + f x = VarE (mkName x) + diff --git a/tests/examples/pre-ghc910/TH_spliceE5_prof_Lib.hs b/tests/examples/pre-ghc910/TH_spliceE5_prof_Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceE5_prof_Lib.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH_spliceE5_prof_Lib where + +import Language.Haskell.TH + +expandVars :: [String] -> Q Exp +expandVars s = [| concat $(return (ListE (map f s))) |] + where + f x = VarE (mkName x) + diff --git a/tests/examples/pre-ghc910/TH_spliceE5_prof_ext.hs b/tests/examples/pre-ghc910/TH_spliceE5_prof_ext.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceE5_prof_ext.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module Main where + +import TH_spliceE5_prof_ext_Lib + +v1 = "foo" + +main = putStrLn $(expandVars ["v1","v2"]) +-- The splice expands to refer to both v1 and v2, +-- and the test checks that we don't dependency-analyse +-- the program so that one or the other isn't in scope +-- to the type checker + + +v2 = "bar" diff --git a/tests/examples/pre-ghc910/TH_spliceE5_prof_ext_Lib.1.hs b/tests/examples/pre-ghc910/TH_spliceE5_prof_ext_Lib.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceE5_prof_ext_Lib.1.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module TH_spliceE5_prof_ext_Lib where + +import Language.Haskell.TH + +expandVars :: [String] -> Q Exp +expandVars s = [| concat $(return (ListE (map f s))) |] + where + f x = VarE (mkName x) diff --git a/tests/examples/pre-ghc910/TH_spliceE5_prof_ext_Lib.hs b/tests/examples/pre-ghc910/TH_spliceE5_prof_ext_Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceE5_prof_ext_Lib.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH_spliceE5_prof_ext_Lib where + +import Language.Haskell.TH + +expandVars :: [String] -> Q Exp +expandVars s = [| concat $(return (ListE (map f s))) |] + where + f x = VarE (mkName x) + diff --git a/tests/examples/pre-ghc910/TH_spliceExpr1.hs b/tests/examples/pre-ghc910/TH_spliceExpr1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_spliceExpr1.hs @@ -0,0 +1,11 @@ +-- test representation and splicing of left-parenthesised right infix operators +{-# LANGUAGE TemplateHaskell #-} + +module TH_spliceExpr1 +where + +import Language.Haskell.TH + +foo :: Int +foo = $( [| ((+) $ 2) $ 2 |] ) + diff --git a/tests/examples/pre-ghc910/TH_tf1.hs b/tests/examples/pre-ghc910/TH_tf1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_tf1.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} + +module TH_tf1 where + +$( [d| data family T a |] ) +$( [d| data instance T Int = TInt Bool |] ) + +foo :: Bool -> T Int +foo b = TInt (b && b) + +$( [d| type family S a |] ) +$( [d| type instance S Int = Bool |] ) + +bar :: S Int -> Int +bar c = if c then 1 else 2 + +$( [d| type family R (a :: * -> *) :: * -> * |] ) +$( [d| type instance R Maybe = [] |] ) + +baz :: R Maybe Int -> Int +baz = head + diff --git a/tests/examples/pre-ghc910/TH_tf2.hs b/tests/examples/pre-ghc910/TH_tf2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TH_tf3.hs b/tests/examples/pre-ghc910/TH_tf3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_tf3.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} + +module TH_tf3 where + +type family T a + +$( [d| foo :: T [a] ~ Bool => a -> a + foo x = x |] ) + +$( [d| class C a + instance a ~ Int => C a |] ) diff --git a/tests/examples/pre-ghc910/TH_unresolvedInfix.1.hs b/tests/examples/pre-ghc910/TH_unresolvedInfix.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_unresolvedInfix.1.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import TH_unresolvedInfix_Lib +import Language.Haskell.TH + +-------------------------------------------------------------------------------- +-- Expressions -- +-------------------------------------------------------------------------------- +exprs = [ +-------------- Completely-unresolved bindings + $( n +? (n *? n) ), + $( (n +? n) *? n ), + $( n +? (n +? n) ), + $( (n +? n) +? n ), + -- VarE version + $( uInfixE n plus2 (uInfixE n plus2 n) ), + $( uInfixE (uInfixE n plus2 n) plus2 n ), + $( uInfixE n plus3 (uInfixE n plus3 n) ), + $( uInfixE (uInfixE n plus3 n) plus3 n ), + +--------------- Completely-resolved bindings + $( n +! (n *! n) ), + $( (n +! n) *! n ), + $( n +! (n +! n) ), + $( (n +! n) +! n ), + +-------------- Mixed resolved/unresolved + $( (n +! n) *? (n +? n) ), + $( (n +? n) *? (n +! n) ), + $( (n +? n) *! (n +! n) ), + $( (n +? n) *! (n +? n) ), + +-------------- Parens + $( ((parensE ((n +? n) *? n)) +? n) *? n ), + $( (parensE (n +? n)) *? (parensE (n +? n)) ), + $( parensE ((n +? n) *? (n +? n)) ), + +-------------- Sections + $( infixE (Just $ n +? n) plus Nothing ) N, + -- see B.hs for the (non-compiling) other version of the above + $( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N + ] + +-------------------------------------------------------------------------------- +-- Patterns -- +-------------------------------------------------------------------------------- +patterns = [ +-------------- Completely-unresolved patterns + case N :+ (N :* N) of + [p1|unused|] -> True, + case N :+ (N :* N) of + [p2|unused|] -> True, + case (N :+ N) :+ N of + [p3|unused|] -> True, + case (N :+ N) :+ N of + [p4|unused|] -> True, +-------------- Completely-resolved patterns + case N :+ (N :* N) of + [p5|unused|] -> True, + case (N :+ N) :* N of + [p6|unused|] -> True, + case N :+ (N :+ N) of + [p7|unused|] -> True, + case (N :+ N) :+ N of + [p8|unused|] -> True, +-------------- Mixed resolved/unresolved + case ((N :+ N) :* N) :+ N of + [p9|unused|] -> True, + case N :+ (N :* (N :+ N)) of + [p10|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p11|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p12|unused|] -> True, +-------------- Parens + case (N :+ (N :* N)) :+ (N :* N) of + [p13|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p14|unused|] -> True, + case (N :+ (N :* N)) :+ N of + [p15|unused|] -> True + ] + +-------------------------------------------------------------------------------- +-- Types -- +-------------------------------------------------------------------------------- + +-------------- Completely-unresolved types +_t1 = 1 `Plus` (1 `Times` 1) :: $( int $+? (int $*? int) ) +_t2 = 1 `Plus` (1 `Times` 1) :: $( (int $+? int) $*? int ) +_t3 = (1 `Plus` 1) `Plus` 1 :: $( int $+? (int $+? int) ) +_t4 = (1 `Plus` 1) `Plus` 1 :: $( (int $+? int) $+? int ) +-------------- Completely-resolved types +_t5 = 1 `Plus` (1 `Times` 1) :: $( int $+! (int $*! int) ) +_t6 = (1 `Plus` 1) `Times` 1 :: $( (int $+! int) $*! int ) +_t7 = 1 `Plus` (1 `Plus` 1) :: $( int $+! (int $+! int) ) +_t8 = (1 `Plus` 1) `Plus` 1 :: $( (int $+! int) $+! int ) +-------------- Mixed resolved/unresolved +_t9 = ((1 `Plus` 1) `Times` 1) `Plus` 1 :: $( (int $+! int) $*? (int $+? int) ) +_t10 = 1 `Plus` (1 `Times` (1 `Plus` 1)) :: $( (int $+? int) $*? (int $+! int) ) +_t11 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+! int) ) +_t12 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+? int) ) +-------------- Parens +_t13 = (1 `Plus` (1 `Times` 1)) `Plus` (1 `Times` 1) :: $( ((parensT ((int $+? int) $*? int)) $+? int) $*? int ) +_t14 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (parensT (int $+? int)) $*? (parensT (int $+? int)) ) +_t15 = (1 `Plus` (1 `Times` 1)) `Plus` 1 :: $( parensT ((int $+? int) $*? (int $+? int)) ) + +main = do + mapM_ print exprs + mapM_ print patterns + -- check that there are no Parens or UInfixes in the output + runQ [|N :* N :+ N|] >>= print + runQ [|(N :* N) :+ N|] >>= print + runQ [p|N :* N :+ N|] >>= print + runQ [p|(N :* N) :+ N|] >>= print + runQ [t|Int * Int + Int|] >>= print + runQ [t|(Int * Int) + Int|] >>= print + + -- pretty-printing of unresolved infix expressions + let ne = ConE $ mkName "N" + np = ConP (mkName "N") [] + nt = ConT (mkName "Int") + plusE = ConE (mkName ":+") + plusP = (mkName ":+") + plusT = (mkName "+") + putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UInfixE ne plusE (UInfixE ne plusE ne))) + putStrLn $ pprint (ParensE ne) + putStrLn $ pprint (InfixP np plusP (UInfixP np plusP (UInfixP np plusP np))) + putStrLn $ pprint (ParensP np) + putStrLn $ pprint (InfixT nt plusT (UInfixT nt plusT (UInfixT nt plusT nt))) + putStrLn $ pprint (ParensT nt) + diff --git a/tests/examples/pre-ghc910/TH_unresolvedInfix.hs b/tests/examples/pre-ghc910/TH_unresolvedInfix.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_unresolvedInfix.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import TH_unresolvedInfix_Lib +import Language.Haskell.TH + +-------------------------------------------------------------------------------- +-- Expressions -- +-------------------------------------------------------------------------------- +exprs = [ +-------------- Completely-unresolved bindings + $( n +? (n *? n) ), + $( (n +? n) *? n ), + $( n +? (n +? n) ), + $( (n +? n) +? n ), + -- VarE version + $( uInfixE n plus2 (uInfixE n plus2 n) ), + $( uInfixE (uInfixE n plus2 n) plus2 n ), + $( uInfixE n plus3 (uInfixE n plus3 n) ), + $( uInfixE (uInfixE n plus3 n) plus3 n ), + +--------------- Completely-resolved bindings + $( n +! (n *! n) ), + $( (n +! n) *! n ), + $( n +! (n +! n) ), + $( (n +! n) +! n ), + +-------------- Mixed resolved/unresolved + $( (n +! n) *? (n +? n) ), + $( (n +? n) *? (n +! n) ), + $( (n +? n) *! (n +! n) ), + $( (n +? n) *! (n +? n) ), + +-------------- Parens + $( ((parensE ((n +? n) *? n)) +? n) *? n ), + $( (parensE (n +? n)) *? (parensE (n +? n)) ), + $( parensE ((n +? n) *? (n +? n)) ), + +-------------- Sections + $( infixE (Just $ n +? n) plus Nothing ) N, + -- see B.hs for the (non-compiling) other version of the above + $( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N, + +-------------- Dropping constructors + $( n *? tupE [n +? n] ) + ] + +-------------------------------------------------------------------------------- +-- Patterns -- +-------------------------------------------------------------------------------- +patterns = [ +-------------- Completely-unresolved patterns + case N :+ (N :* N) of + [p1|unused|] -> True, + case N :+ (N :* N) of + [p2|unused|] -> True, + case (N :+ N) :+ N of + [p3|unused|] -> True, + case (N :+ N) :+ N of + [p4|unused|] -> True, +-------------- Completely-resolved patterns + case N :+ (N :* N) of + [p5|unused|] -> True, + case (N :+ N) :* N of + [p6|unused|] -> True, + case N :+ (N :+ N) of + [p7|unused|] -> True, + case (N :+ N) :+ N of + [p8|unused|] -> True, +-------------- Mixed resolved/unresolved + case ((N :+ N) :* N) :+ N of + [p9|unused|] -> True, + case N :+ (N :* (N :+ N)) of + [p10|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p11|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p12|unused|] -> True, +-------------- Parens + case (N :+ (N :* N)) :+ (N :* N) of + [p13|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p14|unused|] -> True, + case (N :+ (N :* N)) :+ N of + [p15|unused|] -> True, +-------------- Dropping constructors + case (N :* (N :+ N)) of + [p16|unused|] -> True + ] + +-------------------------------------------------------------------------------- +-- Types -- +-------------------------------------------------------------------------------- + +-------------- Completely-unresolved types +_t1 = 1 `Plus` (1 `Times` 1) :: $( int $+? (int $*? int) ) +_t2 = 1 `Plus` (1 `Times` 1) :: $( (int $+? int) $*? int ) +_t3 = (1 `Plus` 1) `Plus` 1 :: $( int $+? (int $+? int) ) +_t4 = (1 `Plus` 1) `Plus` 1 :: $( (int $+? int) $+? int ) +-------------- Completely-resolved types +_t5 = 1 `Plus` (1 `Times` 1) :: $( int $+! (int $*! int) ) +_t6 = (1 `Plus` 1) `Times` 1 :: $( (int $+! int) $*! int ) +_t7 = 1 `Plus` (1 `Plus` 1) :: $( int $+! (int $+! int) ) +_t8 = (1 `Plus` 1) `Plus` 1 :: $( (int $+! int) $+! int ) +-------------- Mixed resolved/unresolved +_t9 = ((1 `Plus` 1) `Times` 1) `Plus` 1 :: $( (int $+! int) $*? (int $+? int) ) +_t10 = 1 `Plus` (1 `Times` (1 `Plus` 1)) :: $( (int $+? int) $*? (int $+! int) ) +_t11 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+! int) ) +_t12 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+? int) ) +-------------- Parens +_t13 = (1 `Plus` (1 `Times` 1)) `Plus` (1 `Times` 1) :: $( ((parensT ((int $+? int) $*? int)) $+? int) $*? int ) +_t14 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (parensT (int $+? int)) $*? (parensT (int $+? int)) ) +_t15 = (1 `Plus` (1 `Times` 1)) `Plus` 1 :: $( parensT ((int $+? int) $*? (int $+? int)) ) + +main = do + mapM_ print exprs + mapM_ print patterns + -- check that there are no Parens or UInfixes in the output + runQ [|N :* N :+ N|] >>= print + runQ [|(N :* N) :+ N|] >>= print + runQ [p|N :* N :+ N|] >>= print + runQ [p|(N :* N) :+ N|] >>= print + runQ [t|Int * Int + Int|] >>= print + runQ [t|(Int * Int) + Int|] >>= print + + -- pretty-printing of unresolved infix expressions + let ne = ConE $ mkName "N" + np = ConP (mkName "N") [] + nt = ConT (mkName "Int") + plusE = ConE (mkName ":+") + plusP = (mkName ":+") + plusT = (mkName "+") + putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UInfixE ne plusE (UInfixE ne plusE ne))) + putStrLn $ pprint (ParensE ne) + putStrLn $ pprint (InfixP np plusP (UInfixP np plusP (UInfixP np plusP np))) + putStrLn $ pprint (ParensP np) + putStrLn $ pprint (InfixT nt plusT (UInfixT nt plusT (UInfixT nt plusT nt))) + putStrLn $ pprint (ParensT nt) + diff --git a/tests/examples/pre-ghc910/TH_unresolvedInfix2.hs b/tests/examples/pre-ghc910/TH_unresolvedInfix2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_unresolvedInfix2.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH_unresolvedInfix2 where + +import Language.Haskell.TH + +infixl 6 :+ + +data Tree = N + | Tree :+ Tree + | Tree :* Tree + +$(return []) + +-- Should fail +expr = $( let plus = conE '(:+) + n = conE 'N + in infixE Nothing plus (Just $ uInfixE n plus n) ) + diff --git a/tests/examples/pre-ghc910/TH_unresolvedInfix_Lib.hs b/tests/examples/pre-ghc910/TH_unresolvedInfix_Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TH_unresolvedInfix_Lib.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoStarIsType #-} + +module TH_unresolvedInfix_Lib where + +import Language.Haskell.TH +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Quote + +infixl 6 :+ +infixl 7 :* + +data Tree = N + | Tree :+ Tree + | Tree :* Tree + +-- custom instance, including redundant parentheses +instance Show Tree where + show N = "N" + show (a :+ b) = "(" ++ show a ++ " :+ " ++ show b ++ ")" + show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")" + +-- VarE versions +infixl 6 +: +infixl 7 *: +(+:) = (:+) +(*:) = (:*) + +n = conE (mkName "N") +plus = conE (mkName ":+") +times = conE (mkName ":*") + +a +? b = uInfixE a plus b +a *? b = uInfixE a times b +a +! b = infixApp a plus b +a *! b = infixApp a times b + +plus2 = varE (mkName "+:") +times2 = varE (mkName "*:") +plus3 = conE ('(:+)) + + +-------------------------------------------------------------------------------- +-- Patterns -- +-------------------------------------------------------------------------------- +-- The only way to test pattern splices is using QuasiQuotation +mkQQ pat = QuasiQuoter undefined (const pat) undefined undefined +p = conP (mkName "N") [] +plus' = mkName ":+" +times' = mkName ":*" + +a ^+? b = uInfixP a plus' b +a ^*? b = uInfixP a times' b +a ^+! b = infixP a plus' b +a ^*! b = infixP a times' b + +-------------- Completely-unresolved patterns +p1 = mkQQ ( p ^+? (p ^*? p) ) +p2 = mkQQ ( (p ^+? p) ^*? p ) +p3 = mkQQ ( p ^+? (p ^+? p) ) +p4 = mkQQ ( (p ^+? p) ^+? p ) +-------------- Completely-resolved patterns +p5 = mkQQ ( p ^+! (p ^*! p) ) +p6 = mkQQ ( (p ^+! p) ^*! p ) +p7 = mkQQ ( p ^+! (p ^+! p) ) +p8 = mkQQ ( (p ^+! p) ^+! p ) +-------------- Mixed resolved/unresolved +p9 = mkQQ ( (p ^+! p) ^*? (p ^+? p) ) +p10 = mkQQ ( (p ^+? p) ^*? (p ^+! p) ) +p11 = mkQQ ( (p ^+? p) ^*! (p ^+! p) ) +p12 = mkQQ ( (p ^+? p) ^*! (p ^+? p) ) +-------------- Parens +p13 = mkQQ ( ((parensP ((p ^+? p) ^*? p)) ^+? p) ^*? p ) +p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) ) +p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) ) + +-------------------------------------------------------------------------------- +-- Types -- +-------------------------------------------------------------------------------- + +infixl 6 + +infixl 7 * +data (+) a b = Plus a b +data (*) a b = Times a b + +int = conT (mkName "Int") +tyPlus = mkName "+" +tyTimes = mkName "*" + +a $+? b = uInfixT a tyPlus b +a $*? b = uInfixT a tyTimes b +a $+! b = infixT a tyPlus b +a $*! b = infixT a tyTimes b + diff --git a/tests/examples/pre-ghc910/TcCustomSolverSuper.hs b/tests/examples/pre-ghc910/TcCustomSolverSuper.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TemplateHaskell.hs b/tests/examples/pre-ghc910/TemplateHaskell.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Templates.hs b/tests/examples/pre-ghc910/Templates.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Templates.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeFamilies, FlexibleInstances, OverlappingInstances, TypeOperators, PatternGuards #-} +module Object.Templates( + makeName, + makeObject, + makeObjectFlexible + ) where + +import Object.Letters +import Object.Types + +import Prelude hiding ((.)) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Data.Char +import Data.Maybe + +-- | +-- implements 'makeObject' or 'makeObjectFlexible' depending on the first argument +makeObject' :: Bool -> Name -> Q [Dec] +makeObject' flexible name = go name where + go :: Name -> Q [Dec] + go obj = do + (name, vars, fields) <- reify name >>= getInfo + let objType = foldl AppT (ConT name) (VarT<*vars) + outputDecls <- if flexible + then return [] + else [d| + type instance Output $(return objType) (Method m) = + MethodOutput $(return objType) (Method m) + type instance Output $(return objType) (Method m := input) = + MethodOutput $(return objType) (Method m := input) + |] + fieldDecls <- (sequence $ makeField name vars <* fields) *> concat + return $ outputDecls ++ fieldDecls +-- "(Object.Example.Foo,[x_1627454179],[(Object.Example._bar,NotStrict,ConT GHC.Types.Int),(Object.Example._baz,NotStrict,ConT GHC.Types.Char),(Object.Example._blub,NotStrict,VarT x_1627454179)])" + makeField :: Name -> [Name] -> VarStrictType -> Q [Dec] + makeField _ _ (name,_,_) | '_' /= head (nameBase name) = fail $ show name ++ " did not start with underscore" + makeField name vars (fName, _, fType) = do + (decs1,(typeName,dataName)) <- makeName' (tail $ nameBase fName) + methodOutput <- lookupTypeName "Object.Types.MethodOutput" *> fromMaybe (error "no MethodOutput in scope") + let objType = foldl AppT (ConT name) (VarT<*vars) + + let methodOutInst = TySynInstD methodOutput $ TySynEqn [objType, ConT typeName] fType + actionInst <- [d| + instance Action $(return objType) $(return $ ConT typeName) where + object . _ = $(return $ VarE fName) object + |] + + matchType <- [t| $(return $ ConT typeName) := $(return $ VarT $ mkName "value") |] + let methodSetOutInst = TySynInstD methodOutput $ TySynEqn [objType, matchType] objType + actionSetInst <- [d| + instance (value ~ $(return fType)) => Action $(return objType) $(return matchType) where + object . ( _ := v) = $(recUpdE [e|object|] [return (fName, VarE $ mkName "v")]) + |] + + return $ [methodOutInst,methodSetOutInst] ++ actionInst ++ actionSetInst ++ decs1 + diff --git a/tests/examples/pre-ghc910/TensorTests.hs b/tests/examples/pre-ghc910/TensorTests.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TensorTests.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, + RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +module TensorTests (tensorTests) where + +import Apply.Cyc +import Tests +import Utils + +import TestTypes + +import Crypto.Lol +import Crypto.Lol.CRTrans +import Crypto.Lol.Cyclotomic.Tensor +import Crypto.Lol.Types + +import Control.Applicative + +import Data.Maybe + +import Data.Singletons +import Data.Promotion.Prelude.Eq +import Data.Singletons.TypeRepStar () + +import qualified Test.Framework as TF + +type TMRParams = ( '(,) <$> Tensors) <*> MRCombos +tmrParams :: Proxy TMRParams +tmrParams = Proxy + +--type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos +type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos +tremParams :: Proxy TrEmParams +tremParams = Proxy + +type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos) + +data Liftable :: TyFun (Factored, Type) Bool -> Type +type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) + diff --git a/tests/examples/pre-ghc910/Test.1.hs b/tests/examples/pre-ghc910/Test.1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Test.1.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/pre-ghc910/Test.2.hs b/tests/examples/pre-ghc910/Test.2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Test.2.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE RankNTypes #-} +module Test.Test2 where +import Data.Typeable + +data Show1 = S1 Char Char Char + deriving Typeable + +data Strict = S2 Char !Char + +data Opaque = forall a. O a +data List1 a = Nil | a :^ (List1 a) + deriving Show + +newtype MyInt = My Int + deriving (Eq,Show,Num, Enum) + +newtype MkT a = MkT a + deriving (Show) + +newtype MkT2 a = MkT2 (MkT a) + deriving Show + +data Param2 s r = P2 (FakeSTRef r (s(Param2 s r))) + | P2Nil +data FakeSTRef r s = Ref s + +testParam2 = O (P2 (Ref P2Nil)) + +infixr 5 :^ +--test T{t=t1} = undefined + +instance Show Show1 where + show (S1 a b c) = show (a) + +type Just1 = Maybe + + +data Unary = Unary deriving Show + +poly :: a -> () +poly x = seq x () + diff --git a/tests/examples/pre-ghc910/Test.hs b/tests/examples/pre-ghc910/Test.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Test.hs @@ -0,0 +1,410 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- | +-- Module : Test +-- Copyright : (c) Simon Marlow 2002 +-- License : BSD-style +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- This module illustrates & tests most of the features of Haddock. +-- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'. +-- +----------------------------------------------------------------------------- + +-- This is plain comment, ignored by Haddock. + +module Test ( + + -- Section headings are introduced with '-- *': + -- * Type declarations + + -- Subsection headings are introduced with '-- **' and so on. + -- ** Data types + T(..), T2, T3(..), T4(..), T5(..), T6(..), + N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..), + + -- ** Records + R(..), R1(..), + + -- | test that we can export record selectors on their own: + p, q, u, + + -- * Class declarations + C(a,b), D(..), E, F(..), + + -- | Test that we can export a class method on its own: + a, + + -- * Function types + f, g, + + -- * Auxiliary stuff + + -- $aux1 + + -- $aux2 + + -- $aux3 + + -- $aux4 + + -- $aux5 + + -- $aux6 + + -- $aux7 + + -- $aux8 + + -- $aux9 + + -- $aux10 + + -- $aux11 + + -- $aux12 + + -- | This is some inline documentation in the export list + -- + -- > a code block using bird-tracks + -- > each line must begin with > (which isn't significant unless it + -- > is at the beginning of the line). + + -- * A hidden module + module Hidden, + + -- * A visible module + module Visible, + + {-| nested-style doc comments -} + + -- * Existential \/ Universal types + Ex(..), + + -- * Type signatures with argument docs + k, l, m, o, + + -- * A section + -- and without an intervening comma: + -- ** A subsection + +{-| + > a literal line + + $ a non /literal/ line $ +-} + + f', + ) where + +import Hidden +import Visible + +-- | This comment applies to the /following/ declaration +-- and it continues until the next non-comment line +data T a b + = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor + | -- | This comment describes the 'B' constructor + B (T a b, T Int Float) -- ^ + +-- | An abstract data declaration +data T2 a b = T2 a b + +-- | A data declaration with no documentation annotations on the constructors +data T3 a b = A1 a | B1 b + +-- A data declaration with no documentation annotations at all +data T4 a b = A2 a | B2 b + +-- A data declaration documentation on the constructors only +data T5 a b + = A3 a -- ^ documents 'A3' + | B3 b -- ^ documents 'B3' + +-- | Testing alternative comment styles +data T6 + -- | This is the doc for 'A4' + = A4 + | B4 + | -- ^ This is the doc for 'B4' + + -- | This is the doc for 'C4' + C4 + +-- | A newtype +newtype N1 a = N1 a + +-- | A newtype with a fieldname +newtype N2 a b = N2 {n :: a b} + +-- | A newtype with a fieldname, documentation on the field +newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field + } + +-- | An abstract newtype - we show this one as data rather than newtype because +-- the difference isn\'t visible to the programmer for an abstract type. +newtype N4 a b = N4 a + +newtype N5 a b = N5 {n5 :: a b -- ^ no docs on the datatype or the constructor + } + +newtype N6 a b = N6 {n6 :: a b + } + -- ^ docs on the constructor only + +-- | docs on the newtype and the constructor +newtype N7 a b = N7 {n7 :: a b + } + -- ^ The 'N7' constructor + + +class (D a) => C a where + -- |this is a description of the 'a' method + a :: IO a + b :: [a] + -- ^ this is a description of the 'b' method + c :: a -- c is hidden in the export list + +-- ^ This comment applies to the /previous/ declaration (the 'C' class) + +class D a where + d :: T a b + e :: (a,a) +-- ^ This is a class declaration with no separate docs for the methods + +instance D Int where + d = undefined + e = undefined + +-- instance with a qualified class name +instance Test.D Float where + d = undefined + e = undefined + +class E a where + ee :: a +-- ^ This is a class declaration with no methods (or no methods exported) + +-- This is a class declaration with no documentation at all +class F a where + ff :: a + +-- | This is the documentation for the 'R' record, which has four fields, +-- 'p', 'q', 'r', and 's'. +data R = + -- | This is the 'C1' record constructor, with the following fields: + C1 { p :: Int -- ^ This comment applies to the 'p' field + , q :: forall a . a->a -- ^ This comment applies to the 'q' field + , -- | This comment applies to both 'r' and 's' + r,s :: Int + } + | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (), + u,v :: Int + } + -- ^ This is the 'C2' record constructor, also with some fields: + +-- | Testing different record commenting styles +data R1 + -- | This is the 'C3' record constructor + = C3 { + -- | The 's1' record selector + s1 :: Int + -- | The 's2' record selector + , s2 :: Int + , s3 :: Int -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here. + -- Since GHC doesn't allow that, I have removed it in this file. + -- ^ The 's3' record selector + } + +-- These section headers are only used when there is no export list to +-- give the structure of the documentation: + +-- * This is a section header (level 1) +-- ** This is a section header (level 2) +-- *** This is a section header (level 3) + +{-| +In a comment string we can refer to identifiers in scope with +single quotes like this: 'T', and we can refer to modules by +using double quotes: "Foo". We can add emphasis /like this/. + + * This is a bulleted list + + - This is the next item (different kind of bullet) + + (1) This is an ordered list + + 2. This is the next item (different kind of bullet) + +@ + This is a block of code, which can include other markup: 'R' + formatting + is + significant +@ + +> this is another block of code + +We can also include URLs in documentation: . +-} + +f :: C a => a -> Int + +-- | we can export foreign declarations too +foreign import ccall "header.h" g :: Int -> IO CInt + +-- | this doc string has a parse error in it: \' +h :: Int +h = 42 + + +-- $aux1 This is some documentation that is attached to a name ($aux1) +-- rather than a source declaration. The documentation may be +-- referred to in the export list using its name. +-- +-- @ code block in named doc @ + +-- $aux2 This is some documentation that is attached to a name ($aux2) + +-- $aux3 +-- @ code block on its own in named doc @ + +-- $aux4 +-- +-- @ code block on its own in named doc (after newline) @ + +{- $aux5 a nested, named doc comment + + with a paragraph, + + @ and a code block @ +-} + +-- some tests for various arrangements of code blocks: + +{- $aux6 +>test +>test1 + +@ test2 + test3 +@ +-} + +{- $aux7 +@ +test1 +test2 +@ +-} + +{- $aux8 +>test3 +>test4 +-} + +{- $aux9 +@ +test1 +test2 +@ + +>test3 +>test4 +-} + +{- $aux10 +>test3 +>test4 + +@ +test1 +test2 +@ +-} + +-- This one is currently wrong (Haddock 0.4). The @...@ part is +-- interpreted as part of the bird-tracked code block. +{- $aux11 +aux11: + +>test3 +>test4 + +@ +test1 +test2 +@ +-} + +-- $aux12 +-- > foo +-- +-- > bar +-- + +-- | A data-type using existential\/universal types +data Ex a + = forall b . C b => Ex1 b + | forall b . Ex2 b + | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file + | Ex4 (forall a . a -> a) + +-- | This is a function with documentation for each argument +k :: T () () -- ^ This argument has type 'T' + -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int' + -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@ + -> T5 () () -- ^ This argument has a very long description that should + -- hopefully cause some wrapping to happen when it is finally + -- rendered by Haddock in the generated HTML page. + -> IO () -- ^ This is the result type + +-- This function has arg docs but no docs for the function itself +l :: (Int, Int, Float) -- ^ takes a triple + -> Int -- ^ returns an 'Int' + +-- | This function has some arg docs +m :: R + -> N1 () -- ^ one of the arguments + -> IO Int -- ^ and the return value + +-- | This function has some arg docs but not a return value doc + +-- can't use the original name ('n') with GHC +newn :: R -- ^ one of the arguments, an 'R' + -> N1 () -- ^ one of the arguments + -> IO Int +newn = undefined + + +-- | A foreign import with argument docs +foreign import ccall unsafe "header.h" + o :: Float -- ^ The input float + -> IO Float -- ^ The output float + +-- | We should be able to escape this: \#\#\# + +-- p :: Int +-- can't use the above original definition with GHC +newp :: Int +newp = undefined + +-- | a function with a prime can be referred to as 'f'' +-- but f' doesn't get link'd 'f\'' +f' :: Int + + +-- Add some definitions here so that this file can be compiled with GHC + +data T1 +f = undefined +f' = undefined +type CInt = Int +k = undefined +l = undefined +m = undefined + diff --git a/tests/examples/pre-ghc910/Test10255.hs b/tests/examples/pre-ghc910/Test10255.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Test10268.hs b/tests/examples/pre-ghc910/Test10268.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Test10269.hs b/tests/examples/pre-ghc910/Test10269.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Test10269.hs @@ -0,0 +1,4 @@ +module Test10269 where + + +(f =*= g) sa i = undefined diff --git a/tests/examples/pre-ghc910/Test10276.hs b/tests/examples/pre-ghc910/Test10276.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Test10276.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test10276 where + +f1 = [| bar |] +f2 = [e| bar |] + +class QQExp a b where + qqExp x = [||fst $ runState $$(qqExpM x) + ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] + +class QQExp2 a b where + qqExp x = [e||fst $ runState $$(qqExpM x) + ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] diff --git a/tests/examples/pre-ghc910/Test10278.hs b/tests/examples/pre-ghc910/Test10278.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Test10280.hs b/tests/examples/pre-ghc910/Test10280.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Test10280.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TupleSections #-} +module Test10280 where + +foo2 = atomicModifyIORef ciTokens ((,()) . f) diff --git a/tests/examples/pre-ghc910/Test10307.hs b/tests/examples/pre-ghc910/Test10307.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Test10309.hs b/tests/examples/pre-ghc910/Test10309.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Test10312.hs b/tests/examples/pre-ghc910/Test10312.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Test10313.hs b/tests/examples/pre-ghc910/Test10313.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Test10354.hs b/tests/examples/pre-ghc910/Test10354.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Test10357.hs b/tests/examples/pre-ghc910/Test10357.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Test10358.hs b/tests/examples/pre-ghc910/Test10358.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Test10396.hs b/tests/examples/pre-ghc910/Test10396.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Test11018.hs b/tests/examples/pre-ghc910/Test11018.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Test11018.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Test11018 where + +nonUnicode :: forall a . a -> IO Int +nonUnicode _ = do + x <- readChar + return 4 + +-- ^ An opaque ESD handle for recording data from the soundcard via ESD. +data Recorder fr ch (r ∷ * -> *) + = Recorder { + reCloseH :: !(FinalizerHandle r) + } + +f :: Arrow a => a (Int,Int,Int) Int +f = proc (x,y,z) -> returnA -< x+y + +f2 :: Arrow a => a (Int,Int,Int) Int +f2 = proc (x,y,z) -> returnA >- x+y + +g :: ArrowApply a => Int -> a (a Int Int,Int) Int +g y = proc (x,z) -> x -<< 2+y + +g2 :: ArrowApply a => Int -> a (a Int Int,Int) Int +g2 y = proc (x,z) -> x >>- 2+y + +-- ------------------------------------- + +unicode ∷ ∀ a . a → IO Int +unicode _ = do + x ← readChar + return 4 + +-- ^ An opaque ESD handle for recording data from the soundcard via ESD. +data RecorderU fr ch (r ∷ ★ → ★) + = RecorderU { + reCloseHU ∷ !(FinalizerHandle r) + } + +fU :: Arrow a ⇒ a (Int,Int,Int) Int +fU = proc (x,y,z) -> returnA ⤙ x+y + +f2U :: Arrow a ⇒ a (Int,Int,Int) Int +f2U = proc (x,y,z) -> returnA ⤚ x+y + +gU :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int +gU y = proc (x,z) -> x ⤛ 2+y + +g2U :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int +g2U y = proc (x,z) -> x ⤜ 2+y diff --git a/tests/examples/pre-ghc910/Test12417.hs b/tests/examples/pre-ghc910/Test12417.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Test12417.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE UnboxedSums, MagicHash #-} + +module Test12417 where + +import GHC.Prim +import GHC.Types + +import System.Mem (performMajorGC) + +type Either1 a b = (# a | b #) + +showEither1 :: (Show a, Show b) => Either1 a b -> String +showEither1 (# left | #) = "Left " ++ show left +showEither1 (# | right #) = "Right " ++ show right + +type T = (# Int | Bool | String | Char | Either Int Bool | Int# | Float# #) + +showEither4 :: T -> String +showEither4 (# | b | | | | | #) = "Alt1: " ++ show b + diff --git a/tests/examples/pre-ghc910/TestBoolFormula.hs b/tests/examples/pre-ghc910/TestBoolFormula.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TestUtils.hs b/tests/examples/pre-ghc910/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TestUtils.hs @@ -0,0 +1,5 @@ + +module Math.NumberTheory.TestUtils where + +class (f `Compose` g) x + diff --git a/tests/examples/pre-ghc910/Token.hs b/tests/examples/pre-ghc910/Token.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Token.hs @@ -0,0 +1,261 @@ +{-# language BangPatterns #-} +{-# language BinaryLiterals #-} +{-# language DerivingStrategies #-} +{-# language DuplicateRecordFields #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} +{-# language UnboxedTuples #-} + +module Json.Token + ( Token(..) + , TokenException(..) + , decode + ) where + +import Control.Monad.ST (ST,runST) +import Data.Bits ((.&.),(.|.),unsafeShiftR) +import Data.Builder.ST (Builder) +import Data.Bytes.Parser (Parser) +import Data.Bytes.Types (Bytes(..)) +import Data.Char (ord) +import Data.Primitive (MutableByteArray,ByteArray) +import Data.Primitive (SmallArray) +import Data.Text.Short (ShortText) +import Data.Word (Word8,Word16) +import GHC.Exts (Int(I#),Char(C#)) +import GHC.Exts (word2Int#,chr#,gtWord#,ltWord#) +import GHC.Word (Word16(W16#),Word8(W8#)) +import Data.Number.Scientific (Scientific) + +import qualified Data.ByteString.Short.Internal as BSS +import qualified Data.Bytes.Parser as P +import qualified Data.Bytes.Parser.Utf8 as Utf8 +import qualified Data.Bytes.Parser.Latin as Latin +import qualified Data.Bytes.Parser.Unsafe as Unsafe +import qualified Data.Builder.ST as B +import qualified Data.Chunks as C +import qualified Data.Primitive as PM +import qualified Data.Text.Short.Unsafe as TS +import qualified Data.Number.Scientific as SCI + +-- | A token in a JSON document. +data Token + = LeftBrace + | RightBrace + | LeftBracket + | RightBracket + | Comma + | Colon + | BooleanTrue + | BooleanFalse + | Null + | String {-# UNPACK #-} !ShortText + | Number {-# UNPACK #-} !Scientific + deriving stock (Eq,Show) + +-- | An exception encountered while tokenizing a JSON document. +data TokenException + = InvalidNumber + | InvalidLeader + | ExpectedTrue + | ExpectedFalse + | ExpectedNull + | LeadingZero + | InvalidEscapeSequence + | IncompleteString + | IncompleteEscapeSequence + deriving stock (Eq,Show) + +isSpace :: Word8 -> Bool +isSpace w = + w == c2w ' ' + || w == c2w '\t' + || w == c2w '\r' + || w == c2w '\n' + +-- | Decode a sequence as JSON tokens. This allows token +-- sequences that would be rejected by the ABNF given in +-- : +-- +-- >>> decode (Bytes.fromAsciiString "[ , true }") +-- Right [ LeftBracket, Comma, BooleanTrue, RightBrace ] +-- +-- It is up to the user to reject such malformed JSON when +-- they parse the token sequence. More surprisingly, this +-- tokenizer accepts some unnatural juxtapositions of token +-- sequences without whitespace. For example: +-- +-- >>> decode (Bytes.fromAsciiString "55truefalse") +-- Right [ Number 55, BooleanTrue, BooleanFalse ] +-- >>> decode (Bytes.fromAsciiString "null\"hello\"") +-- Right [ Null, String "hello" ] +-- +-- Acceptance of such samples simplifies the implementation +-- of this tokenizer. These unnatural juxtapositions always +-- result in token sequences that should be rejected anyway in +-- the subsequent parsing done by the user. Consequently, their +-- acceptance is not considered harmful. +decode :: Bytes -> Either TokenException (SmallArray Token) +decode !bs = runST $ do + !b <- B.new + P.parseBytesEffectfully (P.skipWhile isSpace *> manyTokens b) bs >>= \case + P.Failure err -> pure (Left err) + -- Since manyTokens only completes once the end of the input + -- has been reached, we do not need to check the length here. + P.Success (P.Slice _ _ cs) -> pure (Right cs) + +manyTokens :: + Builder s Token + -> Parser TokenException s (SmallArray Token) +manyTokens !b0 = do + t <- oneToken + !b1 <- P.effect (B.push t b0) + P.skipWhile isSpace + done <- P.isEndOfInput + if done + then P.effect $ do + cs <- B.freeze b1 + pure $! C.concat cs + else manyTokens b1 + +-- TODO: oneToken is only called in contexts where the initial +-- call to Latin.any cannot fail. Consider refactoring to make +-- this more explicit. +oneToken :: Parser TokenException s Token +oneToken = Latin.any InvalidLeader >>= \case + '{' -> pure LeftBrace + '}' -> pure RightBrace + '[' -> pure LeftBracket + ']' -> pure RightBracket + ',' -> pure Comma + ':' -> pure Colon + 't' -> do + Latin.char3 ExpectedTrue 'r' 'u' 'e' + pure BooleanTrue + 'f' -> do + Latin.char4 ExpectedFalse 'a' 'l' 's' 'e' + pure BooleanFalse + 'n' -> do + Latin.char3 ExpectedNull 'u' 'l' 'l' + pure Null + '"' -> do + start <- Unsafe.cursor + string start + '-' -> fmap Number (SCI.parserNegatedUtf8Bytes InvalidNumber) + '0' -> Latin.trySatisfy (\c -> c >= '0' && c <= '9') >>= \case + True -> P.fail LeadingZero + False -> fmap Number (SCI.parserTrailingUtf8Bytes InvalidNumber 0) + c | c >= '1' && c <= '9' -> + fmap Number (SCI.parserTrailingUtf8Bytes InvalidNumber (ord c - 48)) + _ -> P.fail InvalidLeader + +copyAndEscape :: Int -> Parser TokenException s Token +copyAndEscape !maxLen = do + !dst <- P.effect (PM.newByteArray maxLen) + let go !ix = Utf8.any# IncompleteString `P.bindFromCharToLifted` \c -> case c of + '\\'# -> Latin.any IncompleteEscapeSequence >>= \case + '"' -> do + P.effect (PM.writeByteArray dst ix (c2w '"')) + go (ix + 1) + '\\' -> do + P.effect (PM.writeByteArray dst ix (c2w '\\')) + go (ix + 1) + 't' -> do + P.effect (PM.writeByteArray dst ix (c2w '\t')) + go (ix + 1) + 'n' -> do + P.effect (PM.writeByteArray dst ix (c2w '\n')) + go (ix + 1) + 'r' -> do + P.effect (PM.writeByteArray dst ix (c2w '\r')) + go (ix + 1) + '/' -> do + P.effect (PM.writeByteArray dst ix (c2w '/')) + go (ix + 1) + 'b' -> do + P.effect (PM.writeByteArray dst ix (c2w '\b')) + go (ix + 1) + 'f' -> do + P.effect (PM.writeByteArray dst ix (c2w '\f')) + go (ix + 1) + 'u' -> do + w <- Latin.hexFixedWord16 InvalidEscapeSequence + if w >= 0xD800 && w < 0xDFFF + then go =<< P.effect (encodeUtf8Char dst ix '\xFFFD') + else go =<< P.effect (encodeUtf8Char dst ix (w16ToChar w)) + _ -> P.fail InvalidEscapeSequence + '"'# -> do + str <- P.effect + (PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray dst ix) + pure (String (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str))) + _ -> go =<< P.effect (encodeUtf8Char dst ix (C# c)) + go 0 + +encodeUtf8Char :: MutableByteArray s -> Int -> Char -> ST s Int +encodeUtf8Char !marr !ix !c + | c < '\128' = do + PM.writeByteArray marr ix (c2w c) + pure (ix + 1) + | c < '\x0800' = do + PM.writeByteArray marr ix + (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6 .|. 0b11000000)) + PM.writeByteArray marr (ix + 1) + (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c)))) + pure (ix + 2) + | c <= '\xffff' = do + PM.writeByteArray marr ix + (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 12 .|. 0b11100000)) + PM.writeByteArray marr (ix + 1) + (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6)))) + PM.writeByteArray marr (ix + 2) + (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c)))) + pure (ix + 3) + | otherwise = error "encodeUtf8Char: write this" + + +-- Compute the maximum number of bytes that could possibly +-- be required to house the UTF-8-encoded string once any +-- JSON escape sequences have been resolved. +-- The correctness of this hinges on the assumption that +-- the UTF-8 encoding of a character never takes up more +-- bytes than its escape sequence. +-- TODO: Something fishy is going on with escape sequences +-- in this function. Look over this again. +string :: Int -> Parser TokenException s Token +string !start = go 1 where + go !canMemcpy = do + P.any IncompleteString >>= \case + 92 -> P.any InvalidEscapeSequence *> go 0 -- backslash + 34 -> do -- double quote + !pos <- Unsafe.cursor + case canMemcpy of + 1 -> do + src <- Unsafe.expose + str <- P.effect $ do + let end = pos - 1 + let len = end - start + dst <- PM.newByteArray len + PM.copyByteArray dst 0 src start len + PM.unsafeFreezeByteArray dst + pure (String (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str))) + _ -> do + Unsafe.unconsume (pos - start) + let end = pos - 1 + let maxLen = end - start + copyAndEscape maxLen + W8# w -> go (canMemcpy .&. I# (ltWord# w 128##) .&. I# (gtWord# w 31##)) + +byteArrayToShortByteString :: ByteArray -> BSS.ShortByteString +byteArrayToShortByteString (PM.ByteArray x) = BSS.SBS x + +c2w :: Char -> Word8 +c2w = fromIntegral . ord + +-- Precondition: Not in the range [U+D800 .. U+DFFF] +w16ToChar :: Word16 -> Char +w16ToChar (W16# w) = C# (chr# (word2Int# w)) + diff --git a/tests/examples/pre-ghc910/TopLevelSemis.hs b/tests/examples/pre-ghc910/TopLevelSemis.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TopLevelSemis.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +module Network.MoHWS.HTTP.Header where + +x = 1 + +-- Comment +; + +data Foo = Foo + +-- After TyClD +; + +instance Monoid CIRB where + mempty = CIRB mempty mempty mempty mempty + +-- After InstD +; + +deriving instance Eq (GenTickish 'TickishPassCore) + +-- After DerivD +; + +transferCodingStr DeflateTransferCoding = "deflate" + +-- After ValD +; + +getContentType :: Int + +-- After SigD +; + +type MyMaybe :: Type -> Type + +-- After KindSigD +; + +default (Integer) + +-- After DefD +; + +foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int + +-- After ForD +; + +{-# DEPRECATED foo2 [] #-} + +-- After WarningD +; + +{-# ANN module FromA #-} + +-- After AnnD +; + +{-# RULES "myrule2" id f = f #-} + +-- After RuleD +; + +$foo + +-- After SpliceD +; + +type role Representational representational + +-- After RoleAnnotD +; + +getContentType = 1 + +-- Note: skipping DocD, only generated in haddock mode + diff --git a/tests/examples/pre-ghc910/TopLevelSemis1.hs b/tests/examples/pre-ghc910/TopLevelSemis1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TopLevelSemis1.hs @@ -0,0 +1,14 @@ +module TopLevelSemis1 where + +x = 1 + +-- C1 +-- C2 +; +-- C3 +; +-- C4 + +data Foo = Foo + +-- After TyClD diff --git a/tests/examples/pre-ghc910/TopLevelSemis2.hs b/tests/examples/pre-ghc910/TopLevelSemis2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TopLevelSemis2.hs @@ -0,0 +1,25 @@ +module TopLevelSemis2 where + +x = 1 +; + +-- foo: two matches, with params +foo [] = [] +-- After foo1 +; + +foo x = x +-- After foo2 +; + +-- bar: one match, with params +bar a = a +-- after bar +; + +-- baz: one match, no params +baz = 2 +-- after baz +; + +y = 3 diff --git a/tests/examples/pre-ghc910/TopLevelSemis3.hs b/tests/examples/pre-ghc910/TopLevelSemis3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TopLevelSemis3.hs @@ -0,0 +1,7 @@ +module TopLevelSemis3 where + { + x = 1; + -- Comment + class Foo a where { + }; +} diff --git a/tests/examples/pre-ghc910/TopLevelSemis4.hs b/tests/examples/pre-ghc910/TopLevelSemis4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TopLevelSemis4.hs @@ -0,0 +1,12 @@ +module TopLevelSemis4 where + +data Foo = Foo + +-- After Foo +; +-- After Foo semi + +data Bar = Bar + +-- After Bar +; diff --git a/tests/examples/pre-ghc910/Trac10045.hs b/tests/examples/pre-ghc910/Trac10045.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TransAssociated.hs b/tests/examples/pre-ghc910/TransAssociated.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TransBundle.hs b/tests/examples/pre-ghc910/TransBundle.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TransBundle.hs @@ -0,0 +1,9 @@ +module TransAssociated(A(..)) where + +import Bundle (A(..)) + +foo = MkA 5 +baz = NoA + +qux (MkA x) = x +qux NoA = 0 diff --git a/tests/examples/pre-ghc910/TransformListComp.hs b/tests/examples/pre-ghc910/TransformListComp.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TransformListComp.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TransformListComp #-} + +oldest :: [Int] -> [String] +oldest tbl = [ "str" + | n <- tbl + , then id + ] diff --git a/tests/examples/pre-ghc910/Trit.hs b/tests/examples/pre-ghc910/Trit.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TupSection.hs b/tests/examples/pre-ghc910/TupSection.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TupSection.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE TupleSections #-} +module TupSection where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint +-} + +myAp :: (a -> b) -> a -> b +myAp f x = f x + +foo = myAp (,()) () + +qux = ("go2",) $ () diff --git a/tests/examples/pre-ghc910/Tuple.hs b/tests/examples/pre-ghc910/Tuple.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Tuple.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TupleSections #-} + +baz = (1, "hello", 6.5,,) 'a' (Just ()) + diff --git a/tests/examples/pre-ghc910/TupleN.hs b/tests/examples/pre-ghc910/TupleN.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TupleN.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module TupleN where +import Language.Haskell.TH + +tuple :: Int -> ExpQ +tuple n = [|\list -> $(tupE (exprs [|list|])) |] + where + exprs list = id [infixE (Just (list)) + (varE '(!!)) + (Just (litE $ integerL (toInteger num))) + | num <- [0..(n - 1)]] diff --git a/tests/examples/pre-ghc910/TupleSections.hs b/tests/examples/pre-ghc910/TupleSections.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TypeBrackets.hs b/tests/examples/pre-ghc910/TypeBrackets.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TypeBrackets2.hs b/tests/examples/pre-ghc910/TypeBrackets2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TypeBrackets4.hs b/tests/examples/pre-ghc910/TypeBrackets4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TypeFamilies.hs b/tests/examples/pre-ghc910/TypeFamilies.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TypeFamilies.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds, UndecidableInstances #-} + +module TypeFamilies where + +type family F a b = r | r -> a b where + F a IO = IO a -- (1) + F Char b = b Int -- (2) diff --git a/tests/examples/pre-ghc910/TypeFamilies2.hs b/tests/examples/pre-ghc910/TypeFamilies2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TypeFamilyInstanceLHS.hs b/tests/examples/pre-ghc910/TypeFamilyInstanceLHS.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TypeInstance.hs b/tests/examples/pre-ghc910/TypeInstance.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TypeLevelVec.hs b/tests/examples/pre-ghc910/TypeLevelVec.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TypeLevelVec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeInType, UnicodeSyntax, GADTs, NoImplicitPrelude, + TypeOperators, TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + +module TypeLevelVec where + +import Data.Kind + +data ℕ ∷ Type where + O ∷ ℕ + S ∷ ℕ → ℕ + +type family x + y where + O + n = n + S m + n = S (m + n) +infixl 5 + + +data Vec ∷ ℕ → Type → Type where + Nil ∷ Vec O a + (:>) ∷ a → Vec n a → Vec (S n) a +infixr 8 :> + +type family (x ∷ Vec n a) ++ (y ∷ Vec m a) ∷ Vec (n + m) a where + Nil ++ y = y + (x :> xs) ++ y = x :> (xs ++ y) +infixl 5 ++ diff --git a/tests/examples/pre-ghc910/TypeOperators.hs b/tests/examples/pre-ghc910/TypeOperators.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TypeSignature.hs b/tests/examples/pre-ghc910/TypeSignature.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TypeSignatureParens.hs b/tests/examples/pre-ghc910/TypeSignatureParens.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TypeSkolEscape.hs b/tests/examples/pre-ghc910/TypeSkolEscape.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TypeSkolEscape.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes, PolyKinds, TypeInType #-} + +module TypeSkolEscape where + +import GHC.Types +import GHC.Exts + +type Bad = forall (v :: Levity) (a :: TYPE v). a diff --git a/tests/examples/pre-ghc910/TypeSynOperator.hs b/tests/examples/pre-ghc910/TypeSynOperator.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/TypeSynOperator.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TypeOperators #-} + +type a :-> t = a diff --git a/tests/examples/pre-ghc910/TypeSynParens.hs b/tests/examples/pre-ghc910/TypeSynParens.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/TypedSplice.hs b/tests/examples/pre-ghc910/TypedSplice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Types.hs b/tests/examples/pre-ghc910/Types.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Types.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-duplicate-exports #-} + +module Graphics.UI.Threepenny.Editors.Types + ( + -- * GenericWidgets + GenericWidget(..) + , edited + , contents + , widgetControl + , widgetTidings + -- * Editors + , Editor(.., Horizontally, horizontally, Vertically, vertically) + , liftElement + , dimapE + , applyE + -- ** Editor composition + , (|*|), (|*), (*|) + , (-*-), (-*), (*-) + , field + , fieldLayout + -- ** Editor constructors + , editorUnit + , editorIdentity + , editorString + , editorText + , editorCheckBox + , editorReadShow + , editorEnumBounded + , editorSelection + , editorSum + , editorJust + , EditorCollection(..) + , editorCollection + , editorList + , EditorCollectionConfig(..) + , defaultEditorCollectionConfig + -- ** Representation of empty values + , HasEmpty(..) + ) where + +import Control.Monad +import Data.Biapplicative +import Data.Maybe +import Data.HasEmpty +import qualified Data.Foldable as F +import Data.Functor.Compose +import Data.Functor.Identity +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Profunctor +import Data.Text (Text) +import qualified Data.Text as Text +import Graphics.UI.Threepenny.Attributes +import Graphics.UI.Threepenny.Core as UI hiding (empty) +import Graphics.UI.Threepenny.Editors.Layout +import Graphics.UI.Threepenny.Editors.Utils +import Graphics.UI.Threepenny.Elements +import Graphics.UI.Threepenny.Events +import Graphics.UI.Threepenny.Widgets +import Text.Read + +data GenericWidget control a = GenericWidget + { widgetTidings :: Tidings a -- ^ The dynamic contents of the widget. + , widgetControl :: control -- ^ The actual widget. + } + deriving Functor + +instance Bifunctor GenericWidget where + bimap f g (GenericWidget t e) = GenericWidget (g <$> t) (f e) + +traverseControl :: Applicative f => (control -> f control') -> GenericWidget control a -> f (GenericWidget control' a) +traverseControl f (GenericWidget t e) = GenericWidget t <$> f e + +edited :: GenericWidget el a -> Event a +edited = rumors . widgetTidings + +contents :: GenericWidget el a -> Behavior a +contents = facts . widgetTidings + +instance Widget el => Widget (GenericWidget el a) where + getElement = getElement . widgetControl + +instance Renderable el => Renderable (GenericWidget el a) where + render = render . widgetControl + +renderEditor :: Renderable w => GenericWidget w a -> UI (GenericWidget Element a) +renderEditor = traverseControl render + +-- | An editor for values of type @inner@ inside a datatype @outer@ realized by a @widget@. +-- +-- All the three type arguments are functorial, but @outer@ is contravariant, so @Editor@ is a 'Biapplicative' functor and a 'Profunctor' (via 'dimapE'). +-- +-- 'Biapplicative' allows to compose editors on both their @widget@ and @inner@ structure. When @widget@ is monoidal, widget composition is implicit and 'Applicative' suffices. +-- +-- 'Profunctor' allows to apply an @inner@ editor to an @outer@ datatype. +-- +-- Once 'create'd, an 'Editor' yields a tuple of an @widget@ and a @Tidings inner@ which can be integrated in a threepenny app. +-- + +newtype Editor outer widget inner = Editor { + create :: Behavior outer -> UI (GenericWidget widget inner) + } + +-- | Lift an HTML element into a vacuous editor. +liftElement :: UI el -> Editor a el () +liftElement el = Editor $ \_ -> GenericWidget (pure ()) <$> el + +bimapEditor :: (el -> el') -> (b -> b') -> Editor a el b -> Editor a el' b' +bimapEditor g h = Editor . fmap (fmap (bimap g h)) . create + +dimapE :: (a' -> a) -> (b -> b') -> Editor a el b -> Editor a' el b' +dimapE g h = unCoer . dimap (fmap g) h . coer + where + coer = Star . (Compose .) . create + unCoer = Editor . fmap getCompose . runStar + +applyE :: (el1 -> el2 -> el) -> Editor in_ el1 (a -> b) -> Editor in_ el2 a -> Editor in_ el b +applyE combineElements a b = Editor $ \s -> do + a <- create a s + b <- create b s + return $ GenericWidget (widgetTidings a <*> widgetTidings b) (widgetControl a `combineElements` widgetControl b) + +instance Functor (Editor a el) where + fmap = dimapE id + +instance Bifunctor (Editor a) where + bimap = bimapEditor + +instance Biapplicative (Editor a) where + bipure w o = Editor $ \_ -> return $ GenericWidget (pure o) w + (<<*>>) = applyE ($) + +instance Monoid el => Applicative (Editor a el) where + pure = bipure mempty + (<*>) = applyE mappend + +-- | Applicative modifier for vertical composition of editor factories. +-- This can be used in conjunction with ApplicativeDo as: +-- +-- > editorPerson = vertically $ do +-- > firstName <- Vertically $ field "First:" firstName editor +-- > lastName <- Vertically $ field "Last:" lastName editor +-- > age <- Vertically $ field "Age:" age editor +-- > return Person{..} +-- +-- DEPRECATED: Use the 'Vertical' layout builder instead +pattern Vertically :: Editor a Layout b -> Editor a Vertical b +pattern Vertically {vertically} <- (withLayout getVertical -> vertically) where Vertically a = withLayout Vertical a + +-- | Applicative modifier for horizontal composition of editor factories. +-- This can be used in conjunction with ApplicativeDo as: +-- +-- > editorPerson = horizontally $ do +-- > firstName <- Horizontally $ field "First:" firstName editor +-- > lastName <- Horizontally $ field "Last:" lastName editor +-- > age <- Horizontally $ field "Age:" age editor +-- > return Person{..} +-- +-- DEPRECATED: Use the 'Horizontal' layout builder instead +pattern Horizontally :: Editor a Layout b -> Editor a Horizontal b +pattern Horizontally {horizontally} <- (withLayout getHorizontal -> horizontally) where Horizontally a = withLayout Horizontal a + +infixl 4 |*|, -*- +infixl 5 |*, *|, -*, *- + +-- | Apply a layout builder. +withLayout :: (layout -> layout') -> Editor a layout b -> Editor a layout' b +withLayout f = bimap f id + +-- | Left-right editor composition +(|*|) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a +a |*| b = withLayout getHorizontal $ withLayout Horizontal a <*> withLayout Horizontal b + +-- | Left-right composition of an element with a editor +(*|) :: UI Element -> Editor s Layout a -> Editor s Layout a +e *| a = withLayout getHorizontal $ liftElement(return $ horizontal e) *> withLayout Horizontal a + +-- | Left-right composition of an element with a editor +(|*) :: Editor s Layout a -> UI Element -> Editor s Layout a +a |* e = withLayout getHorizontal $ withLayout Horizontal a <* liftElement(return $ horizontal e) + +-- | Left-right editor composition +(-*-) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a +a -*- b = withLayout getVertical $ withLayout Vertical a <*> withLayout Vertical b + +-- | Left-right composition of an element with a editor +(*-) :: UI Element -> Editor s Layout a -> Editor s Layout a +e *- a = withLayout getVertical $ liftElement(return $ vertical e) *> withLayout Vertical a + +-- | Left-right composition of an element with a editor +(-*) :: Editor s Layout a -> UI Element -> Editor s Layout a +a -* e = withLayout getVertical $ withLayout Vertical a <* liftElement(return $ vertical e) + +-- | A helper that arranges a label and an editor horizontally, +-- wrapped in the given monoidal layout builder. +fieldLayout :: (Renderable m, Renderable m') => (Layout -> m') -> String -> (out -> inn) -> Editor inn m a -> Editor out m' a +fieldLayout l name f e = withLayout l (string name *| first getLayout (dimapE f id e)) + +-- | A helper that arranges a label +-- and an editor horizontally. +field :: Renderable m => String -> (out -> inn) -> Editor inn m a -> Editor out Layout a +field name f e = string name *| first getLayout (dimapE f id e) + +editorUnit :: Editor b Element b +editorUnit = Editor $ \b -> do + t <- new + return $ GenericWidget (tidings b never) t + +editorCheckBox :: Editor Bool Element Bool +editorCheckBox = Editor $ \b -> do + t <- sink checked b $ input # set type_ "checkbox" + return $ GenericWidget (tidings b $ checkedChange t) t + +editorString :: Editor String TextEntry String +editorString = Editor $ \b -> do + w <- askWindow + t <- entry b + liftIOLater $ do + initialValue <- currentValue b + _ <- runUI w $ set value initialValue (element t) + return () + return $ GenericWidget (userText t) t + +editorText :: Editor Text TextEntry Text +editorText = dimapE Text.unpack Text.pack editorString + +editorReadShow :: (Read a, Show a) => Editor (Maybe a) TextEntry (Maybe a) +editorReadShow = Editor $ \b -> do + e <- create editorString (maybe "" show <$> b) + let readIt "" = Nothing + readIt x = readMaybe x + let t = tidings b (readIt <$> edited e) + return $ GenericWidget t (widgetControl e) + +-- An editor that presents a choice of values. +editorEnumBounded + :: (Bounded a, Enum a, Ord a, Show a) + => Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a) +editorEnumBounded = editorSelection (pure $ enumFrom minBound) + +-- | An editor that presents a dynamic choice of values. +editorSelection + :: Ord a + => Behavior [a] -> Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a) +editorSelection options display = Editor $ \b -> do + l <- listBox options b display + return $ GenericWidget (tidings b (rumors $ userSelection l)) l + +-- | Ignores 'Nothing' values and only updates for 'Just' values +editorJust :: Editor (Maybe b) el (Maybe b) -> Editor b el b +editorJust (Editor editor) = Editor $ \b -> do + e <- editor (Just <$> b) + let ev = filterJust (edited e) + return $ GenericWidget (tidings b ev) (widgetControl e) + +-- | An editor for union types, built from editors for its constructors. +editorSum + :: (Ord tag, Show tag, Renderable el) + => (Layout -> Layout -> Layout) -> [(tag, Editor a el a)] -> (a -> tag) -> Editor a Layout a +editorSum combineLayout options selector = Editor $ \ba -> do + options <- mapM (\(tag, Editor mk) -> (tag,) <$> (mk ba >>= renderEditor)) options + let tag = selector <$> ba + tag' <- calmB tag + let build a = lookup a options + -- build a tag selector following the current tag + l <- listBox (pure $ fmap fst options) (Just <$> tag) (pure (string . show)) + -- a placeholder for the constructor editor + nestedEditor <- + new # sink children ((\x -> [maybe (error "editorSum") widgetControl (build x)]) <$> tag') + -- + let composed = combineLayout (Single (return $ getElement l)) (Single $ return nestedEditor) + -- the result event fires when any of the nested editors or the tag selector fire. + let editedEvents = fmap (edited . snd) options + eTag = filterJust $ rumors (userSelection l) + taggedOptions = sequenceA [(tag, ) <$> contents e | (tag, e) <- options] + editedTag = filterJust $ flip lookup <$> taggedOptions <@> eTag + editedE = head <$> unions (editedTag : editedEvents) + return $ GenericWidget (tidings ba editedE) composed + +editorIdentity :: Editor a el a -> Editor (Identity a) el (Identity a) +editorIdentity = dimapE runIdentity Identity + +-------------------------- +-- EditorCollection + +data EditorCollection k w = EditorCollection + { selector :: ListBox k + , add, remove :: Element + , selected :: w + } + +instance Renderable w => Renderable (EditorCollection k w) where + render EditorCollection{..} = + column + [row [ element selector, element add, element remove] + ,render selected] + +data EditorCollectionConfig k v = EditorCollectionConfig + { eccNewKey :: Behavior k -- ^ Current value to use for creating a new key + , eccAfterDelKey :: Behavior (Maybe k) -- ^ Current value to use if the selected key is deleted + , eccTemplate :: v -- ^ Value to use for creating new items + , eccOptions :: Behavior (Set k) -- ^ Currently user select able keys + , eccDisplay :: Behavior (k -> UI Element) -- ^ How to render a key + } + +defaultEditorCollectionConfig + :: (Enum k, Ord k, Show k, HasEmpty v) + => Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v +defaultEditorCollectionConfig db = EditorCollectionConfig + { eccTemplate = emptyValue + , eccOptions = options + , eccDisplay = pure (UI.string . show) + , eccNewKey = maybe (toEnum 0) succ . Set.lookupMax <$> options + , eccAfterDelKey = deletedKey <$> (fst <$> db) <*> options + } + where + options = Map.keysSet . snd <$> db + + deletedKey Nothing _ = Nothing + deletedKey (Just k) kk = Set.lookupLT k kk `mplus` Set.lookupGT k kk + +-- | A barebones editor for collections of editable items. +-- Displays an index selector, add and delete buttons, and an editor for the selected item. +-- Limitations: +-- - Won't work with recursive data structures, due to the lack of FRP switch. +editorCollection + :: forall k v w. + (Ord k, Renderable w) + => (Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v) + -> Editor v w v + -> Editor (Maybe k, Map k v) (EditorCollection k w) (Maybe k, Map k v) +editorCollection mkConfig editorOne = Editor $ \(ba :: Behavior (Maybe k, Map k v)) -> mdo + let EditorCollectionConfig{..} = mkConfig ba + (selectedKey, db) = (fst <$> ba, snd <$> ba) + sel <- create (editorSelection (Set.toList <$> eccOptions) eccDisplay) (fst <$> ba) + one <- create editorOne $ (\(k, db) -> fromMaybe eccTemplate (k >>= (`Map.lookup` db))) <$> ba + addB <- button #+ [string "+"] + remB <- button #+ [string "-"] + let insert i = Map.insert i eccTemplate + editsDb = head <$> unions + [ replace <$> ba <@> edited one + , insert <$> eccNewKey <*> db <@ click addB + , delete <$> ba <@ click remB + ] + editsKey = head <$> unions + [ edited sel + , Just <$> eccNewKey <@ click addB + , eccAfterDelKey <@ click remB + ] + tids = (,) <$> tidings selectedKey editsKey <*> tidings db editsDb + return $ GenericWidget tids (EditorCollection (widgetControl sel) addB remB (widgetControl one)) + where + replace (Just i,xx) x = Map.alter (const $ Just x) i xx + replace (Nothing,x) _ = x + delete (Just i,xx) = Map.delete i xx + delete (_,xx) = xx + +-- | A barebones editor for collections of editable items. +-- Displays an index selector, add and delete buttons, and an editor for the selected item. +-- Limitations: +-- - Won't work with recursive data structures, due to the lack of FRP switch. +editorList + :: (HasEmpty a, Renderable w) + => Editor a w a -> Editor (Maybe Int, [a]) (EditorCollection Int w) (Maybe Int, [a]) +editorList e = + dimapE (second (Map.fromAscList . zip [0 ..])) (second F.toList) $ + editorCollection config e + where + (<&>) = flip (<$>) + infixl 1 <&> + config ba = + (defaultEditorCollectionConfig ba) + { eccAfterDelKey = + ba <&> (\(i,m) -> + i >>= (\i -> + if Map.member (i + 1) m + then return i + else let i' = max 0 (i - 1) + in guard(i'>=0) >> return i')) + } + diff --git a/tests/examples/pre-ghc910/Unboxed.hs b/tests/examples/pre-ghc910/Unboxed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Undefined10.hs b/tests/examples/pre-ghc910/Undefined10.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Undefined10a.hs b/tests/examples/pre-ghc910/Undefined10a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Undefined10a.hs @@ -0,0 +1,7 @@ +module Data.Monoid.Factorial where + +class FactorialMonoid m where + -- comment A + factors :: m + -- comment B + primePrefix :: m diff --git a/tests/examples/pre-ghc910/Undefined11.hs b/tests/examples/pre-ghc910/Undefined11.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Undefined13.hs b/tests/examples/pre-ghc910/Undefined13.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Undefined2.hs b/tests/examples/pre-ghc910/Undefined2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Undefined3.hs b/tests/examples/pre-ghc910/Undefined3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Undefined4.hs b/tests/examples/pre-ghc910/Undefined4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Undefined5.hs b/tests/examples/pre-ghc910/Undefined5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Undefined6.hs b/tests/examples/pre-ghc910/Undefined6.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Undefined7.hs b/tests/examples/pre-ghc910/Undefined7.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Undefined8.hs b/tests/examples/pre-ghc910/Undefined8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Undefined9.hs b/tests/examples/pre-ghc910/Undefined9.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Unicode.hs b/tests/examples/pre-ghc910/Unicode.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/UnicodeRules.hs b/tests/examples/pre-ghc910/UnicodeRules.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/UnicodeSyntax.hs b/tests/examples/pre-ghc910/UnicodeSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/UnicodeSyntax.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE Arrows #-} + +module Tutorial where + +-- import Abt.Class +-- import Abt.Types +-- import Abt.Concrete.LocallyNameless + +import Control.Applicative +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Except +-- import Data.Vinyl +import Prelude hiding (pi) + +-- | We'll start off with a monad in which to manipulate ABTs; we'll need some +-- state for fresh variable generation. +-- +newtype M α + = M + { _M ∷ State Int α + } deriving (Functor, Applicative, Monad) + +-- | We'll run an ABT computation by starting the variable counter at @0@. +-- +runM ∷ M α → α +runM (M m) = evalState m 0 + +-- | Check out the source to see fresh variable generation. +-- +instance MonadVar Var M where + fresh = M $ do + n ← get + let n' = n + 1 + put n' + return $ Var Nothing n' + + named a = do + v ← fresh + return $ v { _varName = Just a } + +-- | Next, we'll define the operators for a tiny lambda calculus as a datatype +-- indexed by arities. +-- +data Lang ns where + LAM ∷ Lang '[S Z] + APP ∷ Lang '[Z, Z] + PI ∷ Lang '[Z, S Z] + UNIT ∷ Lang '[] + AX ∷ Lang '[] + +instance Show1 Lang where + show1 = \case + LAM → "lam" + APP → "ap" + PI → "pi" + UNIT → "unit" + AX → "<>" + +instance HEq1 Lang where + heq1 LAM LAM = Just Refl + heq1 APP APP = Just Refl + heq1 PI PI = Just Refl + heq1 UNIT UNIT = Just Refl + heq1 AX AX = Just Refl + heq1 _ _ = Nothing + +lam ∷ Tm Lang (S Z) → Tm0 Lang +lam e = LAM $$ e :& RNil + +app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang +app m n = APP $$ m :& n :& RNil + +ax ∷ Tm0 Lang +ax = AX $$ RNil + +unit ∷ Tm0 Lang +unit = UNIT $$ RNil + +pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang +pi α xβ = PI $$ α :& xβ :& RNil + +-- | A monad transformer for small step operational semantics. +-- +newtype StepT m α + = StepT + { runStepT ∷ MaybeT m α + } deriving (Monad, Functor, Applicative, Alternative) + +-- | To indicate that a term is in normal form. +-- +stepsExhausted + ∷ Applicative m + ⇒ StepT m α +stepsExhausted = StepT . MaybeT $ pure Nothing + +instance MonadVar Var m ⇒ MonadVar Var (StepT m) where + fresh = StepT . MaybeT $ Just <$> fresh + named str = StepT . MaybeT $ Just <$> named str + +-- | A single evaluation step. +-- +step + ∷ Tm0 Lang + → StepT M (Tm0 Lang) +step tm = + out tm >>= \case + APP :$ m :& n :& RNil → + out m >>= \case + LAM :$ xe :& RNil → xe // n + _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n + PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ + _ → stepsExhausted + +-- | The reflexive-transitive closure of a small-step operational semantics. +-- +star + ∷ Monad m + ⇒ (α → StepT m α) + → (α → m α) +star f a = + runMaybeT (runStepT $ f a) >>= + return a `maybe` star f + +-- | Evaluate a term to normal form +-- +eval ∷ Tm0 Lang → Tm0 Lang +eval = runM . star step + +newtype JudgeT m α + = JudgeT + { runJudgeT ∷ ExceptT String m α + } deriving (Monad, Functor, Applicative, Alternative) + +instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where + fresh = JudgeT . ExceptT $ Right <$> fresh + named str = JudgeT . ExceptT $ Right <$> named str + +type Ctx = [(Var, Tm0 Lang)] + +raise ∷ Monad m ⇒ String → JudgeT m α +raise = JudgeT . ExceptT . return . Left + +checkTy + ∷ Ctx + → Tm0 Lang + → Tm0 Lang + → JudgeT M () +checkTy g tm ty = do + let ntm = eval tm + nty = eval ty + (,) <$> out ntm <*> out nty >>= \case + (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do + z ← fresh + ez ← xe // var z + βz ← yβ // var z + checkTy ((z,α):g) ez βz + (AX :$ RNil, UNIT :$ RNil) → return () + _ → do + ty' ← inferTy g tm + if ty' === nty + then return () + else raise "Type error" + +inferTy + ∷ Ctx + → Tm0 Lang + → JudgeT M (Tm0 Lang) +inferTy g tm = do + out (eval tm) >>= \case + V v | Just (eval → ty) ← lookup v g → return ty + | otherwise → raise "Ill-scoped variable" + APP :$ m :& n :& RNil → do + inferTy g m >>= out >>= \case + PI :$ α :& xβ :& RNil → do + checkTy g n α + eval <$> xβ // n + _ → raise "Expected pi type for lambda abstraction" + _ → raise "Only infer neutral terms" + +-- | @λx.x@ +-- +identityTm ∷ M (Tm0 Lang) +identityTm = do + x ← fresh + return $ lam (x \\ var x) + +-- | @(λx.x)(λx.x)@ +-- +appTm ∷ M (Tm0 Lang) +appTm = do + tm ← identityTm + return $ app tm tm + +-- | A demonstration of evaluating (and pretty-printing). Output: +-- +-- @ +-- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4] +-- @ +-- +main ∷ IO () +main = do + -- Try out the type checker + either fail print . runM . runExceptT . runJudgeT $ do + x ← fresh + checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit)) + + print . runM $ do + mm ← appTm + mmStr ← toString mm + mmStr' ← toString $ eval mm + return $ mmStr ++ " ~>* " ++ mmStr' + +doMap ∷ FilePath → IOSArrow XmlTree TiledMap +doMap mapPath = proc m → do + mapWidth ← getAttrR "width" ⤙ m + returnA -< baz + +-- ^ An opaque ESD handle for recording data from the soundcard via ESD. +data Recorder fr ch (r ∷ ★ → ★) + = Recorder { + reRate ∷ !Int + , reHandle ∷ !Handle + , reCloseH ∷ !(FinalizerHandle r) + } + +-- from ghc-prim + +-- | A backward-compatible (pre-GHC 8.0) synonym for 'Type' +-- type * = TYPE 'PtrRepLifted + +-- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type' +-- type ★ = TYPE 'PtrRepLifted diff --git a/tests/examples/pre-ghc910/Utilities.hs b/tests/examples/pre-ghc910/Utilities.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Utils.hs b/tests/examples/pre-ghc910/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Utils.hs @@ -0,0 +1,1056 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Utils +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- has low level functions for running programs, a bunch of wrappers for +-- various directory and file functions that do extra logging. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Utils ( + -- * logging and errors + die, + dieWithLocation, + topHandler, + warn, notice, info, debug, + debugNoWrap, chattyTry, + + -- * running programs + rawSystemExit, + rawSystemExitCode, + rawSystemExitWithEnv, + rawSystemStdout, + rawSystemStdInOut, + rawSystemIOWithEnv, + maybeExit, + xargs, + findProgramLocation, + + -- * copying files + createDirectoryIfMissingVerbose, + copyFileVerbose, + copyDirectoryRecursiveVerbose, + copyFiles, + + -- * installing files + installOrdinaryFile, + installExecutableFile, + installOrdinaryFiles, + installDirectoryContents, + + -- * File permissions + setFileOrdinary, + setFileExecutable, + + -- * file names + currentDir, + + -- * finding files + findFile, + findFirstFile, + findFileWithExtension, + findFileWithExtension', + + -- * environment variables + isInSearchPath, + + -- * simple file globbing + matchFileGlob, + matchDirFileGlob, + parseFileGlob, + FileGlob(..), + + -- * temp files and dirs + withTempFile, + withTempDirectory, + + -- * .cabal and .buildinfo files + defaultPackageDesc, + findPackageDesc, + defaultHookedPackageDesc, + findHookedPackageDesc, + + -- * reading and writing files safely + withFileContents, + writeFileAtomic, + rewriteFile, + + -- * Unicode + fromUTF8, + toUTF8, + readUTF8File, + withUTF8FileContents, + writeUTF8File, + normaliseLineEndings, + + -- * generic utils + equating, + comparing, + isInfixOf, + intercalate, + lowercase, + wrapText, + wrapLine, + ) where + +import Control.Monad + ( when, unless, filterM ) +import Control.Concurrent.MVar + ( newEmptyMVar, putMVar, takeMVar ) +import Data.List + ( nub, unfoldr, isPrefixOf, tails, intercalate ) +import Data.Char as Char + ( toLower, chr, ord ) +import Data.Bits + ( Bits((.|.), (.&.), shiftL, shiftR) ) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 + +import System.Directory + ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile + , findExecutable ) +import System.Environment + ( getProgName ) +import System.Cmd + ( rawSystem ) +import System.Exit + ( exitWith, ExitCode(..) ) +import System.FilePath + ( normalise, (), (<.>) + , getSearchPath, takeDirectory, splitFileName + , splitExtension, splitExtensions, splitDirectories ) +import System.Directory + ( createDirectory, renameFile, removeDirectoryRecursive ) +import System.IO + ( Handle, openFile, openBinaryFile, openBinaryTempFile + , IOMode(ReadMode), hSetBinaryMode + , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) +import System.IO.Error as IO.Error + ( isDoesNotExistError, isAlreadyExistsError + , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) +import System.IO.Error + ( ioeSetLocation, ioeGetLocation ) +import System.IO.Unsafe + ( unsafeInterleaveIO ) +import qualified Control.Exception as Exception + +import Distribution.Text + ( display ) + +import Control.Exception (evaluate) +import System.Process (runProcess) + +import Control.Concurrent (forkIO) +import System.Process (runInteractiveProcess, waitForProcess) +#if __GLASGOW_HASKELL__ >= 702 +import System.Process (showCommandForUser) +#endif + +import Distribution.Compat.CopyFile + ( copyFile, copyOrdinaryFile, copyExecutableFile + , setFileOrdinary, setFileExecutable, setDirOrdinary ) +import Distribution.Compat.TempFile + ( openTempFile, createTempDirectory ) +import Distribution.Compat.Exception + ( IOException, throwIOIO, tryIO, catchIO, catchExit ) +import Distribution.Verbosity + +-- ---------------------------------------------------------------------------- +-- Exception and logging utils + +dieWithLocation :: FilePath -> Maybe Int -> String -> IO a +dieWithLocation filename lineno msg = + ioError . setLocation lineno + . flip ioeSetFileName (normalise filename) + $ userError msg + where + setLocation Nothing err = err + setLocation (Just n) err = ioeSetLocation err (show n) + +die :: String -> IO a +die msg = ioError (userError msg) + +topHandler :: IO a -> IO a +topHandler prog = catchIO prog handle + where + handle ioe = do + hFlush stdout + pname <- getProgName + hPutStr stderr (mesage pname) + exitWith (ExitFailure 1) + where + mesage pname = wrapText (pname ++ ": " ++ file ++ detail) + file = case ioeGetFileName ioe of + Nothing -> "" + Just path -> path ++ location ++ ": " + location = case ioeGetLocation ioe of + l@(n:_) | n >= '0' && n <= '9' -> ':' : l + _ -> "" + detail = ioeGetErrorString ioe + +-- | Non fatal conditions that may be indicative of an error or problem. +-- +-- We display these at the 'normal' verbosity level. +-- +warn :: Verbosity -> String -> IO () +warn verbosity msg = + when (verbosity >= normal) $ do + hFlush stdout + hPutStr stderr (wrapText ("Warning: " ++ msg)) + +-- | Useful status messages. +-- +-- We display these at the 'normal' verbosity level. +-- +-- This is for the ordinary helpful status messages that users see. Just +-- enough information to know that things are working but not floods of detail. +-- +notice :: Verbosity -> String -> IO () +notice verbosity msg = + when (verbosity >= normal) $ + putStr (wrapText msg) + +-- | More detail on the operation of some action. +-- +-- We display these messages when the verbosity level is 'verbose' +-- +info :: Verbosity -> String -> IO () +info verbosity msg = + when (verbosity >= verbose) $ + putStr (wrapText msg) + +-- | Detailed internal debugging information +-- +-- We display these messages when the verbosity level is 'deafening' +-- +debug :: Verbosity -> String -> IO () +debug verbosity msg = + when (verbosity >= deafening) $ do + putStr (wrapText msg) + hFlush stdout + +-- | A variant of 'debug' that doesn't perform the automatic line +-- wrapping. Produces better output in some cases. +debugNoWrap :: Verbosity -> String -> IO () +debugNoWrap verbosity msg = + when (verbosity >= deafening) $ do + putStrLn msg + hFlush stdout + +-- | Perform an IO action, catching any IO exceptions and printing an error +-- if one occurs. +chattyTry :: String -- ^ a description of the action we were attempting + -> IO () -- ^ the action itself + -> IO () +chattyTry desc action = + catchIO action $ \exception -> + putStrLn $ "Error while " ++ desc ++ ": " ++ show exception + +-- ----------------------------------------------------------------------------- +-- Helper functions + +-- | Wraps text to the default line width. Existing newlines are preserved. +wrapText :: String -> String +wrapText = unlines + . map (intercalate "\n" + . map unwords + . wrapLine 79 + . words) + . lines + +-- | Wraps a list of words to a list of lines of words of a particular width. +wrapLine :: Int -> [String] -> [[String]] +wrapLine width = wrap 0 [] + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +-- ----------------------------------------------------------------------------- +-- rawSystem variants +maybeExit :: IO ExitCode -> IO () +maybeExit cmd = do + res <- cmd + unless (res == ExitSuccess) $ exitWith res + +printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () +printRawCommandAndArgs verbosity path args + | verbosity >= deafening = print (path, args) + | verbosity >= verbose = +#if __GLASGOW_HASKELL__ >= 702 + putStrLn $ showCommandForUser path args +#else + putStrLn $ unwords (path : args) +#endif + | otherwise = return () + +printRawCommandAndArgsAndEnv :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +printRawCommandAndArgsAndEnv verbosity path args env + | verbosity >= deafening = do putStrLn ("Environment: " ++ show env) + print (path, args) + | verbosity >= verbose = putStrLn $ unwords (path : args) + | otherwise = return () + +-- Exit with the same exitcode if the subcommand fails +rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () +rawSystemExit verbosity path args = do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode +rawSystemExitCode verbosity path args = do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + return exitcode + +rawSystemExitWithEnv :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnv verbosity path args env = do + printRawCommandAndArgsAndEnv verbosity path args env + hFlush stdout + ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing + exitcode <- waitForProcess ph + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +-- Closes the passed in handles before returning. +rawSystemIOWithEnv :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> Maybe Handle -- ^ stdin + -> Maybe Handle -- ^ stdout + -> Maybe Handle -- ^ stderr + -> IO ExitCode +rawSystemIOWithEnv verbosity path args env inp out err = do + printRawCommandAndArgsAndEnv verbosity path args env + hFlush stdout + ph <- runProcess path args Nothing (Just env) inp out err + exitcode <- waitForProcess ph + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + return exitcode + +-- | Run a command and return its output. +-- +-- The output is assumed to be text in the locale encoding. +-- +rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String +rawSystemStdout verbosity path args = do + (output, errors, exitCode) <- rawSystemStdInOut verbosity path args + Nothing False + when (exitCode /= ExitSuccess) $ + die errors + return output + +-- | Run a command and return its output, errors and exit status. Optionally +-- also supply some input. Also provides control over whether the binary/text +-- mode of the input and output. +-- +rawSystemStdInOut :: Verbosity + -> FilePath -> [String] + -> Maybe (String, Bool) -- ^ input text and binary mode + -> Bool -- ^ output in binary mode + -> IO (String, String, ExitCode) -- ^ output, errors, exit +rawSystemStdInOut verbosity path args input outputBinary = do + printRawCommandAndArgs verbosity path args + + Exception.bracket + (runInteractiveProcess path args Nothing Nothing) + (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) + $ \(inh,outh,errh,pid) -> do + + -- output mode depends on what the caller wants + hSetBinaryMode outh outputBinary + -- but the errors are always assumed to be text (in the current locale) + hSetBinaryMode errh False + + -- fork off a couple threads to pull on the stderr and stdout + -- so if the process writes to stderr we do not block. + + err <- hGetContents errh + out <- hGetContents outh + + mv <- newEmptyMVar + let force str = (evaluate (length str) >> return ()) + `Exception.finally` putMVar mv () + --TODO: handle exceptions like text decoding. + _ <- forkIO $ force out + _ <- forkIO $ force err + + -- push all the input, if any + case input of + Nothing -> return () + Just (inputStr, inputBinary) -> do + -- input mode depends on what the caller wants + hSetBinaryMode inh inputBinary + hPutStr inh inputStr + hClose inh + --TODO: this probably fails if the process refuses to consume + -- or if it closes stdin (eg if it exits) + + -- wait for both to finish, in either order + takeMVar mv + takeMVar mv + + -- wait for the program to terminate + exitcode <- waitForProcess pid + unless (exitcode == ExitSuccess) $ + debug verbosity $ path ++ " returned " ++ show exitcode + ++ if null err then "" else + " with error message:\n" ++ err + ++ case input of + Nothing -> "" + Just ("", _) -> "" + Just (inp, _) -> "\nstdin input:\n" ++ inp + + return (out, err, exitcode) + + +-- | Look for a program on the path. +findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) +findProgramLocation verbosity prog = do + debug verbosity $ "searching for " ++ prog ++ " in path." + res <- findExecutable prog + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) + return res + + +-- | Like the unix xargs program. Useful for when we've got very long command +-- lines that might overflow an OS limit on command line length and so you +-- need to invoke a command multiple times to get all the args in. +-- +-- Use it with either of the rawSystem variants above. For example: +-- +-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs +-- +xargs :: Int -> ([String] -> IO ()) + -> [String] -> [String] -> IO () +xargs maxSize rawSystemFun fixedArgs bigArgs = + let fixedArgSize = sum (map length fixedArgs) + length fixedArgs + chunkSize = maxSize - fixedArgSize + in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) + + where chunks len = unfoldr $ \s -> + if null s then Nothing + else Just (chunk [] len s) + + chunk acc _ [] = (reverse acc,[]) + chunk acc len (s:ss) + | len' < len = chunk (s:acc) (len-len'-1) ss + | otherwise = (reverse acc, s:ss) + where len' = length s + +-- ------------------------------------------------------------ +-- * File Utilities +-- ------------------------------------------------------------ + +---------------- +-- Finding files + +-- | Find a file by looking in a search path. The file path must match exactly. +-- +findFile :: [FilePath] -- ^search locations + -> FilePath -- ^File Name + -> IO FilePath +findFile searchPath fileName = + findFirstFile id + [ path fileName + | path <- nub searchPath] + >>= maybe (die $ fileName ++ " doesn't exist") return + +-- | Find a file by looking in a search path with one of a list of possible +-- file extensions. The file base name should be given and it will be tried +-- with each of the extensions in each element of the search path. +-- +findFileWithExtension :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe FilePath) +findFileWithExtension extensions searchPath baseName = + findFirstFile id + [ path baseName <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +-- | Like 'findFileWithExtension' but returns which element of the search path +-- the file was found in, and the file path relative to that base directory. +-- +findFileWithExtension' :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe (FilePath, FilePath)) +findFileWithExtension' extensions searchPath baseName = + findFirstFile (uncurry ()) + [ (path, baseName <.> ext) + | path <- nub searchPath + , ext <- nub extensions ] + +findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) +findFirstFile file = findFirst + where findFirst [] = return Nothing + findFirst (x:xs) = do exists <- doesFileExist (file x) + if exists + then return (Just x) + else findFirst xs + + +-- | List all the files in a directory and all subdirectories. +-- +-- The order places files in sub-directories after all the files in their +-- parent directories. The list is generated lazily so is not well defined if +-- the source directory structure changes before the list is used. +-- +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + + where + collect files dirs' [] = return (reverse files, reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist (topdir dirEntry) + if isDirectory + then collect files (dirEntry:dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +------------------------ +-- Environment variables + +-- | Is this directory in the system search path? +isInSearchPath :: FilePath -> IO Bool +isInSearchPath path = fmap (elem path) getSearchPath + +---------------- +-- File globbing + +data FileGlob + -- | No glob at all, just an ordinary file + = NoGlob FilePath + + -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to + -- @FileGlob \"foo\/bar\" \".baz\"@ + | FileGlob FilePath String + +parseFileGlob :: FilePath -> Maybe FileGlob +parseFileGlob filepath = case splitExtensions filepath of + (filepath', ext) -> case splitFileName filepath' of + (dir, "*") | '*' `elem` dir + || '*' `elem` ext + || null ext -> Nothing + | null dir -> Just (FileGlob "." ext) + | otherwise -> Just (FileGlob dir ext) + _ | '*' `elem` filepath -> Nothing + | otherwise -> Just (NoGlob filepath) + +matchFileGlob :: FilePath -> IO [FilePath] +matchFileGlob = matchDirFileGlob "." + +matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath] +matchDirFileGlob dir filepath = case parseFileGlob filepath of + Nothing -> die $ "invalid file glob '" ++ filepath + ++ "'. Wildcards '*' are only allowed in place of the file" + ++ " name, not in the directory name or file extension." + ++ " If a wildcard is used it must be with an file extension." + Just (NoGlob filepath') -> return [filepath'] + Just (FileGlob dir' ext) -> do + files <- getDirectoryContents (dir dir') + case [ dir' file + | file <- files + , let (name, ext') = splitExtensions file + , not (null name) && ext' == ext ] of + [] -> die $ "filepath wildcard '" ++ filepath + ++ "' does not match any files." + matches -> return matches + +---------------------------------------- +-- Copying and installing files and dirs + +-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. +-- +createDirectoryIfMissingVerbose :: Verbosity + -> Bool -- ^ Create its parents too? + -> FilePath + -> IO () +createDirectoryIfMissingVerbose verbosity create_parents path0 + | create_parents = createDirs (parents path0) + | otherwise = createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir:[]) = createDir dir throwIOIO + createDirs (dir:dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throwIOIO + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- tryIO $ createDirectoryVerbose verbosity dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exeption in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> (do + isDir <- doesDirectoryExist dir + if isDir then return () + else throwIOIO e + ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throwIOIO e + +createDirectoryVerbose :: Verbosity -> FilePath -> IO () +createDirectoryVerbose verbosity dir = do + info verbosity $ "creating " ++ dir + createDirectory dir + setDirOrdinary dir + +-- | Copies a file without copying file permissions. The target file is created +-- with default permissions. Any existing target file is replaced. +-- +-- At higher verbosity levels it logs an info message. +-- +copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyFileVerbose verbosity src dest = do + info verbosity ("copy " ++ src ++ " to " ++ dest) + copyFile src dest + +-- | Install an ordinary file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" +-- while on Windows it uses the default permissions for the target directory. +-- +installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () +installOrdinaryFile verbosity src dest = do + info verbosity ("Installing " ++ src ++ " to " ++ dest) + copyOrdinaryFile src dest + +-- | Install an executable file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" +-- while on Windows it uses the default permissions for the target directory. +-- +installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installExecutableFile verbosity src dest = do + info verbosity ("Installing executable " ++ src ++ " to " ++ dest) + copyExecutableFile src dest + +-- | Copies a bunch of files to a target directory, preserving the directory +-- structure in the target location. The target directories are created if they +-- do not exist. +-- +-- The files are identified by a pair of base directory and a path relative to +-- that base. It is only the relative part that is preserved in the +-- destination. +-- +-- For example: +-- +-- > copyFiles normal "dist/src" +-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] +-- +-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and +-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". +-- +-- This operation is not atomic. Any IO failure during the copy (including any +-- missing source files) leaves the target in an unknown state so it is best to +-- use it with a freshly created directory so that it can be simply deleted if +-- anything goes wrong. +-- +copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFiles verbosity targetDir srcFiles = do + + -- Create parent directories for everything + let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ [ let src = srcBase srcFile + dest = targetDir srcFile + in copyFileVerbose verbosity src dest + | (srcBase, srcFile) <- srcFiles ] + +-- | This is like 'copyFiles' but uses 'installOrdinaryFile'. +-- +installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +installOrdinaryFiles verbosity targetDir srcFiles = do + + -- Create parent directories for everything + let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ [ let src = srcBase srcFile + dest = targetDir srcFile + in installOrdinaryFile verbosity src dest + | (srcBase, srcFile) <- srcFiles ] + +-- | This installs all the files in a directory to a target location, +-- preserving the directory layout. All the files are assumed to be ordinary +-- rather than executable files. +-- +installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () +installDirectoryContents verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +--------------------------------- +-- Deprecated file copy functions + +{-# DEPRECATED copyDirectoryRecursiveVerbose + "You probably want installDirectoryContents instead" #-} +copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyDirectoryRecursiveVerbose verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +--------------------------- +-- Temporary files and dirs + +-- | Use a temporary filename that doesn't already exist. +-- +withTempFile :: Bool -- ^ Keep temporary files? + -> FilePath -- ^ Temp dir to create the file in + -> String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) -> IO a +withTempFile keepTempFiles tmpDir template action = + Exception.bracket + (openTempFile tmpDir template) + (\(name, handle) -> do hClose handle + unless keepTempFiles $ removeFile name) + (uncurry action) + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +-- +withTempDirectory :: Verbosity + -> Bool -- ^ Keep temporary files? + -> FilePath -> String -> (FilePath -> IO a) -> IO a +withTempDirectory _verbosity keepTempFiles targetDir template = + Exception.bracket + (createTempDirectory targetDir template) + (unless keepTempFiles . removeDirectoryRecursive) + +----------------------------------- +-- Safely reading and writing files + +-- | Gets the contents of a file, but guarantee that it gets closed. +-- +-- The file is read lazily but if it is not fully consumed by the action then +-- the remaining input is truncated and the file is closed. +-- +withFileContents :: FilePath -> (String -> IO a) -> IO a +withFileContents name action = + Exception.bracket (openFile name ReadMode) hClose + (\hnd -> hGetContents hnd >>= action) + +-- | Writes a file atomically. +-- +-- The file is either written sucessfully or an IO exception is raised and +-- the original file is left unchanged. +-- +-- On windows it is not possible to delete a file that is open by a process. +-- This case will give an IO exception but the atomic property is not affected. +-- +writeFileAtomic :: FilePath -> BS.ByteString -> IO () +writeFileAtomic targetPath content = do + let (targetDir, targetFile) = splitFileName targetPath + Exception.bracketOnError + (openBinaryTempFile targetDir $ targetFile <.> "tmp") + (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) + (\(tmpPath, handle) -> do + BS.hPut handle content + hClose handle + renameFile tmpPath targetPath) + +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +rewriteFile :: FilePath -> String -> IO () +rewriteFile path newContent = + flip catchIO mightNotExist $ do + existingContent <- readFile path + _ <- evaluate (length existingContent) + unless (existingContent == newContent) $ + writeFileAtomic path (BS.Char8.pack newContent) + where + mightNotExist e | isDoesNotExistError e = writeFileAtomic path + (BS.Char8.pack newContent) + | otherwise = ioError e + +-- | The path name that represents the current directory. +-- In Unix, it's @\".\"@, but this is system-specific. +-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) +currentDir :: FilePath +currentDir = "." + +-- ------------------------------------------------------------ +-- * Finding the description file +-- ------------------------------------------------------------ + +-- |Package description file (/pkgname/@.cabal@) +defaultPackageDesc :: Verbosity -> IO FilePath +defaultPackageDesc _verbosity = findPackageDesc currentDir + +-- |Find a package description file in the given directory. Looks for +-- @.cabal@ files. +findPackageDesc :: FilePath -- ^Where to look + -> IO FilePath -- ^.cabal +findPackageDesc dir + = do files <- getDirectoryContents dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal + -- file we filter to exclude dirs and null base file names: + cabalFiles <- filterM doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" ] + case cabalFiles of + [] -> noDesc + [cabalFile] -> return cabalFile + multiple -> multiDesc multiple + + where + noDesc :: IO a + noDesc = die $ "No cabal file found.\n" + ++ "Please create a package description file .cabal" + + multiDesc :: [String] -> IO a + multiDesc l = die $ "Multiple cabal files found.\n" + ++ "Please use only one of: " + ++ intercalate ", " l + +-- |Optional auxiliary package information file (/pkgname/@.buildinfo@) +defaultHookedPackageDesc :: IO (Maybe FilePath) +defaultHookedPackageDesc = findHookedPackageDesc currentDir + +-- |Find auxiliary package information in the given directory. +-- Looks for @.buildinfo@ files. +findHookedPackageDesc + :: FilePath -- ^Directory to search + -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present +findHookedPackageDesc dir = do + files <- getDirectoryContents dir + buildInfoFiles <- filterM doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == buildInfoExt ] + case buildInfoFiles of + [] -> return Nothing + [f] -> return (Just f) + _ -> die ("Multiple files with extension " ++ buildInfoExt) + +buildInfoExt :: String +buildInfoExt = ".buildinfo" + +-- ------------------------------------------------------------ +-- * Unicode stuff +-- ------------------------------------------------------------ + +-- This is a modification of the UTF8 code from gtk2hs and the +-- utf8-string package. + +fromUTF8 :: String -> String +fromUTF8 [] = [] +fromUTF8 (c:cs) + | c <= '\x7F' = c : fromUTF8 cs + | c <= '\xBF' = replacementChar : fromUTF8 cs + | c <= '\xDF' = twoBytes c cs + | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) + | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) + | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) + | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) + | otherwise = replacementChar : fromUTF8 cs + where + twoBytes c0 (c1:cs') + | ord c1 .&. 0xC0 == 0x80 + = let d = ((ord c0 .&. 0x1F) `shiftL` 6) + .|. (ord c1 .&. 0x3F) + in if d >= 0x80 + then chr d : fromUTF8 cs' + else replacementChar : fromUTF8 cs' + twoBytes _ cs' = replacementChar : fromUTF8 cs' + + moreBytes :: Int -> Int -> [Char] -> Int -> [Char] + moreBytes 1 overlong cs' acc + | overlong <= acc && acc <= 0x10FFFF + && (acc < 0xD800 || 0xDFFF < acc) + && (acc < 0xFFFE || 0xFFFF < acc) + = chr acc : fromUTF8 cs' + + | otherwise + = replacementChar : fromUTF8 cs' + + moreBytes byteCount overlong (cn:cs') acc + | ord cn .&. 0xC0 == 0x80 + = moreBytes (byteCount-1) overlong cs' + ((acc `shiftL` 6) .|. ord cn .&. 0x3F) + + moreBytes _ _ cs' _ + = replacementChar : fromUTF8 cs' + + replacementChar = '\xfffd' + +toUTF8 :: String -> String +toUTF8 [] = [] +toUTF8 (c:cs) + | c <= '\x07F' = c + : toUTF8 cs + | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) + : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + | otherwise = chr (0xf0 .|. (w `shiftR` 18)) + : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) + : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + where w = ord c + +-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input +-- +ignoreBOM :: String -> String +ignoreBOM ('\xFEFF':string) = string +ignoreBOM string = string + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Reads lazily using ordinary 'readFile'. +-- +readUTF8File :: FilePath -> IO String +readUTF8File f = fmap (ignoreBOM . fromUTF8) + . hGetContents =<< openBinaryFile f ReadMode + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Same behaviour as 'withFileContents'. +-- +withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a +withUTF8FileContents name action = + Exception.bracket + (openBinaryFile name ReadMode) + hClose + (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8) + +-- | Writes a Unicode String as a UTF8 encoded text file. +-- +-- Uses 'writeFileAtomic', so provides the same guarantees. +-- +writeUTF8File :: FilePath -> String -> IO () +writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8 + +-- | Fix different systems silly line ending conventions +normaliseLineEndings :: String -> String +normaliseLineEndings [] = [] +normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows +normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx +normaliseLineEndings ( c :s) = c : normaliseLineEndings s + +-- ------------------------------------------------------------ +-- * Common utils +-- ------------------------------------------------------------ + +equating :: Eq a => (b -> a) -> b -> b -> Bool +equating p x y = p x == p y + +comparing :: Ord a => (b -> a) -> b -> b -> Ordering +comparing p x y = p x `compare` p y + +isInfixOf :: String -> String -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) + +lowercase :: String -> String +lowercase = map Char.toLower + diff --git a/tests/examples/pre-ghc910/Utils2.hs b/tests/examples/pre-ghc910/Utils2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ViewPatterns.hs b/tests/examples/pre-ghc910/ViewPatterns.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Vta1.hs b/tests/examples/pre-ghc910/Vta1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Vta1.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE TypeApplications, ScopedTypeVariables, PolyKinds, + TypeFamilies, RankNTypes, + FlexibleContexts #-} +-- tests about visible type application + +module Vta1 where + +quad :: a -> b -> c -> d -> (a, b, c, d) +quad = (,,,) + +silly = quad @_ @Bool @Char @_ 5 True 'a' "Hello" + +pairup_nosig x y = (x, y) + +pairup_sig :: a -> b -> (a,b) +pairup_sig u w = (u, w) + +answer_sig = pairup_sig @Bool @Int False 7 -- +-- (False, 7) :: (Bool, Int) + +answer_read = show (read @Int "3") -- "3" :: String +answer_show = show @Integer (read "5") -- "5" :: String +answer_showread = show @Int (read @Int "7") -- "7" :: String + +intcons a = (:) @Int a + +intpair x y = pairup_sig @Int x y + +answer_pairup = pairup_sig @Int 5 True -- (5, True) :: (Int, Bool) +answer_intpair = intpair 1 "hello" -- (1, "hello") :: (Int, String) +answer_intcons = intcons 7 [] -- [7] :: [Int] + +type family F a +type instance F Char = Bool + +g :: F a -> a +g _ = undefined + +f :: Char +f = g True + +answer = g @Char False + +mapSame :: forall b. (forall a. a -> a) -> [b] -> [b] +mapSame _ [] = [] +mapSame fun (x:xs) = fun @b x : (mapSame @b fun xs) + +pair :: forall a. a-> (forall b. b -> (a, b)) +pair x y = (x, y) + +b = pair @Int 3 @Bool True +c = mapSame id [1,2,3] +d = pair 3 @Bool True + +pairnum :: forall a. Num a => forall b. b -> (a, b) +pairnum = pair 3 + +e = (pair 3 :: forall a. Num a => forall b. b -> (a, b)) @Int @Bool True +h = pairnum @Int @Bool True + +data First (a :: * -> *) = F +data Proxy (a :: k) = P -- This expands to P (kind variable) (type variable) +data Three (a :: * -> k -> *) = T + +foo :: Proxy a -> Int +foo _ = 0 + +first :: First a -> Int +first _ = 0 + +fTest = first F +fMaybe = first @Maybe F + +test = foo P +bar = foo @Bool P -- should work + +too :: Three a -> Int +too _ = 3 + +threeBase = too T +threeOk = too @Either T + +blah = Nothing @Int + +newtype N = MkN { unMkN :: forall a. Show a => a -> String } + +n = MkN show + +boo = unMkN n @Bool + +boo2 :: forall (a :: * -> *) . Proxy a -> Bool +boo2 _ = False + +base = boo2 P +bar'= boo2 @Maybe P -- should work diff --git a/tests/examples/pre-ghc910/Vta2.hs b/tests/examples/pre-ghc910/Vta2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Vta2.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE RankNTypes, TypeApplications #-} + + +module Vta2 where + +checkIf :: Bool -> (forall a. a -> a) -> (Bool, Int) +checkIf _ = if True + then \f -> (f True, f 5) + else \f -> (f False, f @Int 3) + +checkCase :: Bool -> (forall a. a -> a) -> (Bool, Int) +checkCase _ = case True of + True -> \f -> (f True, f 5) + False -> \f -> (f False, f @Int 3) diff --git a/tests/examples/pre-ghc910/WCompatWarningsNotOn.hs b/tests/examples/pre-ghc910/WCompatWarningsNotOn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/WCompatWarningsNotOn.hs @@ -0,0 +1,26 @@ +-- Test purpose: +-- Ensure that not using -Wcompat does not enable its warnings + +-- {-# OPTIONS_GHC -Wcompat #-} +-- {-# OPTIONS_GHC -Wno-compat #-} + +module WCompatWarningsNotOn where + +import qualified Data.Semigroup as Semi + +monadFail :: Monad m => m a +monadFail = do + Just _ <- undefined + undefined + +(<>) = undefined -- Semigroup warnings + +-- -fwarn-noncanonical-monoid-instances +newtype S = S Int + +instance Semi.Semigroup S where + (<>) = mappend + +instance Semi.Monoid S where + S a `mappend` S b = S (a+b) + mempty = S 0 diff --git a/tests/examples/pre-ghc910/WCompatWarningsOff.hs b/tests/examples/pre-ghc910/WCompatWarningsOff.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/WCompatWarningsOff.hs @@ -0,0 +1,26 @@ +-- Test purpose: +-- Ensure that using -Wno-compat does not switch on warnings + +-- {-# OPTIONS_GHC -Wcompat #-} +{-# OPTIONS_GHC -Wno-compat #-} + +module WCompatWarningsOff where + +import qualified Data.Semigroup as Semi + +monadFail :: Monad m => m a +monadFail = do + Just _ <- undefined + undefined + +(<>) = undefined -- Semigroup warnings + +-- -fwarn-noncanonical-monoid-instances +newtype S = S Int + +instance Semi.Semigroup S where + (<>) = mappend + +instance Semi.Monoid S where + S a `mappend` S b = S (a+b) + mempty = S 0 diff --git a/tests/examples/pre-ghc910/WCompatWarningsOn.hs b/tests/examples/pre-ghc910/WCompatWarningsOn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/WCompatWarningsOn.hs @@ -0,0 +1,26 @@ +-- Test purpose: +-- Ensure that -Wcompat switches on the right warnings + +{-# OPTIONS_GHC -Wcompat #-} +-- {-# OPTIONS_GHC -Wno-compat #-} + +module WCompatWarningsOn where + +import qualified Data.Semigroup as Semi + +monadFail :: Monad m => m a +monadFail = do + Just _ <- undefined + undefined + +(<>) = undefined -- Semigroup warnings + +-- -fwarn-noncanonical-monoid-instances +newtype S = S Int + +instance Semi.Semigroup S where + (<>) = mappend + +instance Semi.Monoid S where + S a `mappend` S b = S (a+b) + mempty = S 0 diff --git a/tests/examples/pre-ghc910/WCompatWarningsOnOff.hs b/tests/examples/pre-ghc910/WCompatWarningsOnOff.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/WCompatWarningsOnOff.hs @@ -0,0 +1,26 @@ +-- Test purpose: +-- Ensure that -Wno-compat disables a previously set -Wcompat + +{-# OPTIONS_GHC -Wcompat #-} +{-# OPTIONS_GHC -Wno-compat #-} + +module WCompatWarningsOnOff where + +import qualified Data.Semigroup as Semi + +monadFail :: Monad m => m a +monadFail = do + Just _ <- undefined + undefined + +(<>) = undefined -- Semigroup warnings + +-- -fwarn-noncanonical-monoid-instances +newtype S = S Int + +instance Semi.Semigroup S where + (<>) = mappend + +instance Semi.Monoid S where + S a `mappend` S b = S (a+b) + mempty = S 0 diff --git a/tests/examples/pre-ghc910/Warning.hs b/tests/examples/pre-ghc910/Warning.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Webhook.hs b/tests/examples/pre-ghc910/Webhook.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Webhook.hs @@ -0,0 +1,176 @@ +{-| +Module : Servant.GitHub.Webhook +Description : Easily write safe GitHub webhook handlers with Servant +Copyright : (c) Jacob Thomas Errington, 2016 +License : MIT +Maintainer : servant-github-webhook@mail.jerrington.me +Stability : experimental + +The GitHub webhook machinery will attach three headers to the HTTP requests +that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@. +The former two headers correspond with the 'GitHubEvent' and +'GitHubSignedReqBody''' routing combinators. This library ignores the +@X-Github-Delivery@ header; if you would like to access its value, then use the +builtin 'Header' combinator from Servant. + +Usage of the library is straightforward: protect routes with the 'GitHubEvent' +combinator to ensure that the route is only reached for specific +'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write +under that route with 'GitHubSignedReqBody'. It is advised to always include a +'GitHubSignedReqBody''', as this is the only way you can be sure that it is +GitHub who is sending the request, and not a malicious user. If you don't care +about the request body, then simply use Aeson\'s 'Object' type as the +deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and +ignore the @Object@ in the handler. + +The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in +order to extract the signing key. This is the same key that must be entered in +the configuration of the webhook on GitHub. See 'GitHubKey'' for more details. + +In order to support multiple keys on a per-route basis, the basic combinator +@GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this, +create a datatype, e.g. @KeyIndex@ whose constructors identify the different +keys you will be using. Generally, this means one constructor per repository. +Use the @DataKinds@ extension to promote this datatype to a kind, and write an +instance of 'Reflect' for each promoted constructor of your datatype. Finally, +create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is +the datatype you've built up. Thus, your function can determine which key to +retrieve. +-} + +{-# LANGUAGE CPP #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- GHC 8 seems to have improved its decidability check for type family +-- instances and class instances. In particular, without UndecidableInstances +-- enabled, the Demote' instance for lists, which we need, will not compile. +-- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol, +-- won't compile on GHC < 8 because the instance head is no smaller than the +-- instance head. +#if __GLASGOW_HASKELL__ < 800 +{-# LANGUAGE UndecidableInstances #-} +#endif + +module Servant.GitHub.Webhook +( -- * Servant combinators + GitHubSignedReqBody'' +, GitHubSignedReqBody' +, GitHubSignedReqBody +, GitHubEvent + + -- ** Security +, GitHubKey'(..) +, GitHubKey +, gitHubKey + + -- * Reexports + -- + -- | We reexport a few datatypes that are typically needed to use the + -- library. +, RepoWebhookEvent(..) +, KProxy(..) + + -- * Implementation details + + -- ** Type-level programming machinery +, Demote +, Demote' +, Reflect(..) + + -- ** Stringy stuff +, parseHeaderMaybe +, matchEvent + + -- * Examples + -- + -- $example1 + -- + -- $example2 +) where + +import Control.Monad.IO.Class ( liftIO ) +import Data.Aeson ( decode', encode ) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy ( fromStrict, toStrict ) +import qualified Data.ByteString.Base16 as B16 +import Data.HMAC ( hmac_sha1 ) +import Data.List ( intercalate ) +import Data.Maybe ( catMaybes, fromMaybe ) +import Data.Monoid ( (<>) ) +import Data.Proxy +import Data.String.Conversions ( cs ) +import qualified Data.Text.Encoding as E +import GHC.TypeLits +import GitHub.Data.Webhooks +import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Wai ( requestHeaders, strictRequestBody ) +import Servant +import Servant.API.ContentTypes ( AllCTUnrender(..) ) +import Servant.Server.Internal + + +-- | A clone of Servant's 'ReqBody' combinator, except that it will also +-- verify the signature provided by GitHub in the @X-Hub-Signature@ header by +-- computing the SHA1 HMAC of the request body and comparing. +-- +-- The use of this combinator will require that the router context contain an +-- appropriate 'GitHubKey'' entry. Specifically, the type parameter of +-- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the +-- index @key@ used here. Consequently, it will be necessary to use +-- 'serveWithContext' instead of 'serve'. +-- +-- Other routes are not tried upon the failure of this combinator, and a 401 +-- response is generated. +-- +-- Use of this datatype directly is discouraged, since the choice of the index +-- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use +-- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just +-- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for +-- the implementation of the 'HasServer' instance for the datatype. +data GitHubSignedReqBody'' + (proxy :: KProxy k) + (key :: k) + (list :: [Type]) + (result :: Type) where + +-- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first +-- type argument given just the second one. +-- +-- Use this type synonym if you are creating a webhook server to handle +-- webhooks from multiple repositories, with different secret keys. +type GitHubSignedReqBody' (key :: k) + = GitHubSignedReqBody'' ('KProxy :: KProxy k) key + +-- | A convenient alias for a trivial key index. +-- +-- USe this type synonym if you are creating a webhook server to handle only +-- webhooks from a single repository, or for mutliple repositories using the +-- same secret key. +type GitHubSignedReqBody = GitHubSignedReqBody' '() + +-- | A routing combinator that succeeds only for a webhook request that matches +-- one of the given 'RepoWebhookEvent' given in the type-level list @events@. +-- +-- If the list contains 'WebhookWildcardEvent', then all events will be +-- matched. +-- +-- The combinator will require that its associated handler take a +-- 'RepoWebhookEvent' parameter, and the matched event will be passed to the +-- handler. This allows the handler to determine which event triggered it from +-- the list. +-- +-- Other routes are tried if there is a mismatch. +data GitHubEvent (events :: [RepoWebhookEvent]) where + diff --git a/tests/examples/pre-ghc910/Zipper.hs b/tests/examples/pre-ghc910/Zipper.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/Zwaluw.hs b/tests/examples/pre-ghc910/Zwaluw.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/Zwaluw.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +module Web.Zwaluw ( + -- * Types + Router, (:-)(..), (<>), + + -- * Running routers + parse, unparse, + parse1, unparse1, + + -- * Constructing routers + -- | The @constrN@ functions are helper functions to lift constructors of + -- datatypes to routers. Their first argument is the constructor; their + -- second argument is a (partial) destructor. + constr0, constr1, constr2, + int, slash, lit + ) where + +import Prelude hiding ((.), id) +import Control.Monad +import Control.Category +import Control.Arrow (first) +import Data.Monoid + +infixr 8 <> +infixr 8 :- + +-- | Infix operator for 'mappend'. +(<>) :: Monoid m => m -> m -> m +(<>) = mappend + +data Router a b = Router + { ser :: b -> [(a, String)] + , prs :: String -> [(a -> b, String)] } + +data a :- b = a :- b deriving (Eq, Show) + +xmap :: (b -> a) -> (a -> b) -> Router r a -> Router r b +xmap f g (Router s p) = Router (s . f) ((fmap . liftM . first . fmap) g p) + +instance Category (Router) where + id = lit "" + Router sf pf . Router sg pg = Router + (\a -> do + (b, s) <- sf a + (c, s') <- sg b + return (c, s ++ s')) + (\s -> do + (f, s') <- pf s + (g, s'') <- pg s' + return (f . g, s'')) + +instance Monoid (Router a b) where + mempty = Router (const mzero) (const mzero) + Router sf pf `mappend` Router sg pg = Router + (\s -> sf s `mplus` sg s) + (\s -> pf s `mplus` pg s) + +parse :: Router () a -> String -> [a] +parse p = concatMap (\(a, s) -> if (s == "") then [a ()] else []) . prs p + +parse1 :: Router () (a :- ()) -> String -> [a] +parse1 p s = map (\(r :- ()) -> r) (parse p s) + +unparse :: Router () a -> a -> [String] +unparse p = map snd . ser p + +unparse1 :: Router () (a :- ()) -> a -> [String] +unparse1 p x = unparse p (x :- ()) + +maph :: (b -> a) -> (a -> b) -> Router i (a :- o) -> Router i (b :- o) +maph f g = xmap (\(h :- t) -> f h :- t) (\(h :- t) -> g h :- t) + +opt :: Eq a => a -> Router r (a :- r) -> Router r (a :- r) +opt a p = p <> push a + +nil :: Router r ([a] :- r) +nil = constr0 [] $ \x -> do [] <- x; Just () + +cons :: Router (a :- [a] :- r) ([a] :- r) +cons = constr2 (:) $ \x -> do a:as <- x; return (a, as) + +-- many :: Eq a => (forall r. Router r (a :- r)) -> Router r ([a] :- r) +-- many p = nil <> many1 p + +-- many1 :: Eq a => (forall r. Router r (a :- r)) -> Router r ([a] :- r) +-- many1 p = cons . p . many p + +satisfy :: (Char -> Bool) -> Router r (Char :- r) +satisfy p = Router + (\(c :- a) -> if (p c) then return (a, [c]) else mzero) + (\s -> case s of + [] -> mzero + (c:cs) -> if (p c) then return ((c :-), cs) else mzero) + +char :: Router r (Char :- r) +char = satisfy (const True) + +digitChar :: Router r (Char :- r) +digitChar = satisfy (\c -> c >= '0' && c <= '9') + +digit :: Router r (Int :- r) +digit = maph (head . show) (read . (:[])) digitChar + + +-- | Routes a constant string. +lit :: String -> Router r r +lit l = Router + (\b -> return (b, l)) + (\s -> let (s1, s2) = splitAt (length l) s in if s1 == l then return (id, s2) else mzero) + +-- | Routes a slash. +slash :: Router r r +slash = lit "/" + +-- | Routes any integer. +int :: Router r (Int :- r) +-- int = maph show read $ many1 digitChar +int = Router + (\(i :- a) -> return (a, show i)) + (\s -> let l = reads s in map (first (:-)) l) + + + +push :: Eq h => h -> Router r (h :- r) +push h = Router + (\(h' :- t) -> do guard (h == h'); return (t, "")) + (\s -> return ((h :-), s)) + +left :: Router (a :- r) (Either a b :- r) +left = constr1 Left $ \x -> do Left a <- x; return a + +right :: Router (b :- r) (Either a b :- r) +right = constr1 Right $ \x -> do Right b <- x; return b + +eitherP :: Router r (a :- r) -> Router r (b :- r) -> Router r (Either a b :- r) +eitherP l r = left . l <> right . r + +-- | For example: +-- +-- > nil :: Router r ([a] :- r) +-- > nil = constr0 [] $ \x -> do [] <- x; Just () +constr0 :: o -> (Maybe o -> Maybe ()) -> Router r (o :- r) +constr0 c d = Router + (\(a :- t) -> maybe mzero (\_ -> return (t, "")) (d (return a))) + (\s -> return ((c :-), s)) + +-- | For example: +-- +-- > left :: Router (a :- r) (Either a b :- r) +-- > left = constr1 Left $ \x -> do Left a <- x; return a +constr1 :: (a -> o) -> (Maybe o -> Maybe a) -> Router (a :- r) (o :- r) +constr1 c d = Router + (\(a :- t) -> maybe mzero (\a -> return (a :- t, "")) (d (return a))) + (\s -> return (\(a :- t) -> c a :- t, s)) + +-- | For example: +-- +-- > cons :: Router (a :- [a] :- r) ([a] :- r) +-- > cons = constr2 (:) $ \x -> do a:as <- x; return (a, as) +constr2 :: (a -> b -> o) -> (Maybe o -> Maybe (a, b)) -> + Router (a :- b :- r) (o :- r) +constr2 c d = Router + (\(a :- t) -> + maybe mzero (\(a, b) -> return (a :- b :- t, "")) (d (return a))) + (\s -> return (\(a :- b :- t) -> c a b :- t, s)) + diff --git a/tests/examples/pre-ghc910/ado001.hs b/tests/examples/pre-ghc910/ado001.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ado002.hs b/tests/examples/pre-ghc910/ado002.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ado003.hs b/tests/examples/pre-ghc910/ado003.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ado004.hs b/tests/examples/pre-ghc910/ado004.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ado005.hs b/tests/examples/pre-ghc910/ado005.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ado006.hs b/tests/examples/pre-ghc910/ado006.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/ado007.hs b/tests/examples/pre-ghc910/ado007.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/anf.hs b/tests/examples/pre-ghc910/anf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/anf.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE LinearTypes #-} +-- !! Data constructors with strict fields +-- This test should use -funbox-strict-fields + +module Main ( main ) where + +main = print (g (f t)) + +t = MkT 1 2 (3,4) (MkS 5 6) + +g (MkT x _ _ _) = x + +data T = MkT Int !Int !(Int,Int) !(S Int) + +data S a = MkS a a + + +{-# NOINLINE f #-} +f :: T -> T -- Takes apart the thing and puts it + -- back together differently +f (MkT x y (a,b) (MkS p q)) = MkT a b (p,q) (MkS x y) diff --git a/tests/examples/pre-ghc910/boolFormula.hs b/tests/examples/pre-ghc910/boolFormula.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/brackets.hs b/tests/examples/pre-ghc910/brackets.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/brackets.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UnicodeSyntax #-} + +-- See Trac #10162 and #11743 for details + +module ShouldCompile where + +import Control.Arrow +import Language.Haskell.TH + +handle :: ArrowPlus a => a (b,s) c -> a (b,(String,s)) c -> a (b,s) c +handle f h = proc (b,s) -> (f -< (b,s)) <+> (h -< (b,("FAIL",s))) + +f :: ArrowPlus a => a (Int,Int) String +f = proc (x,y) -> + ⦇handle + (returnA -< show y) + (\s -> returnA -< s ++ show x) + ⦈ + +g :: ArrowPlus a => a (Int,Int) String +g = proc (x,y) -> + ⦇handle + (\msg -> returnA -< msg ++ show y) + (\s msg -> returnA -< s ++ show x) + ⦈ ("hello " ++ show x) + +h :: ArrowPlus a => a (Int,Int) Int +h = proc (x,y) -> + ( + (\z -> returnA -< x + z) + <+> + (\z -> returnA -< y + z) + ) (x*y) + + +matches :: PatQ -> ExpQ +matches pat = ⟦\x -> + case x of + $pat -> True + _ -> False + ⟧ + diff --git a/tests/examples/pre-ghc910/completesig01.hs b/tests/examples/pre-ghc910/completesig01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/completesig01.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} +module Simple where + +pattern Foo :: () +pattern Foo = () + +a :: () -> () +a Foo = () + +data A = B | C | D + +{-# COMPLETE Foo #-} +{-# COMPLETE B,C #-} +{-# COMPLETE B #-} + +b :: A -> A +b B = B +b C = C + diff --git a/tests/examples/pre-ghc910/deriving-via-compile.hs b/tests/examples/pre-ghc910/deriving-via-compile.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/deriving-via-compile.hs @@ -0,0 +1,460 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module DerivingViaCompile where + +import Data.Void +import Data.Complex +import Data.Functor.Const +import Data.Functor.Identity +import Data.Ratio +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Control.Applicative hiding (WrappedMonad(..)) + +import Data.Bifunctor +import Data.Monoid +import Data.Kind + +type f ~> g = forall xx. f xx -> g xx + +----- +-- Simple example +----- + +data Foo a = MkFoo a a + deriving Show + via (Identity (Foo a)) + +----- +-- Eta reduction at work +----- + +newtype Flip p a b = Flip { runFlip :: p b a } + +instance Bifunctor p => Bifunctor (Flip p) where + bimap f g = Flip . bimap g f . runFlip + +instance Bifunctor p => Functor (Flip p a) where + fmap f = Flip . first f . runFlip + +newtype Bar a = MkBar (Either a Int) + deriving Functor + via (Flip Either Int) + +----- +-- Monad transformers +----- + +type MTrans = (Type -> Type) -> (Type -> Type) + +-- From `constraints' +data Dict c where + Dict :: c => Dict c + +newtype a :- b = Sub (a => Dict b) + +infixl 1 \\ +(\\) :: a => (b => r) -> (a :- b) -> r +r \\ Sub Dict = r + +-- With `-XQuantifiedConstraints' this just becomes +-- +-- type Lifting cls trans = forall mm. cls mm => cls (trans mm) +-- +-- type LiftingMonad trans = Lifting Monad trans +-- +class LiftingMonad (trans :: MTrans) where + proof :: Monad m :- Monad (trans m) + +instance LiftingMonad (StateT s :: MTrans) where + proof :: Monad m :- Monad (StateT s m) + proof = Sub Dict + +instance Monoid w => LiftingMonad (WriterT w :: MTrans) where + proof :: Monad m :- Monad (WriterT w m) + proof = Sub Dict + +instance (LiftingMonad trans, LiftingMonad trans') => LiftingMonad (ComposeT trans trans' :: MTrans) where + proof :: forall m. Monad m :- Monad (ComposeT trans trans' m) + proof = Sub (Dict \\ proof @trans @(trans' m) \\ proof @trans' @m) + +newtype Stack :: MTrans where + Stack :: ReaderT Int (StateT Bool (WriterT String m)) a -> Stack m a + deriving newtype + ( Functor + , Applicative + , Monad + , MonadReader Int + , MonadState Bool + , MonadWriter String + ) + deriving (MonadTrans, MFunctor) + via (ReaderT Int `ComposeT` StateT Bool `ComposeT` WriterT String) + +class MFunctor (trans :: MTrans) where + hoist :: Monad m => (m ~> m') -> (trans m ~> trans m') + +instance MFunctor (ReaderT r :: MTrans) where + hoist :: Monad m => (m ~> m') -> (ReaderT r m ~> ReaderT r m') + hoist nat = ReaderT . fmap nat . runReaderT + +instance MFunctor (StateT s :: MTrans) where + hoist :: Monad m => (m ~> m') -> (StateT s m ~> StateT s m') + hoist nat = StateT . fmap nat . runStateT + +instance MFunctor (WriterT w :: MTrans) where + hoist :: Monad m => (m ~> m') -> (WriterT w m ~> WriterT w m') + hoist nat = WriterT . nat . runWriterT + +infixr 9 `ComposeT` +newtype ComposeT :: MTrans -> MTrans -> MTrans where + ComposeT :: { getComposeT :: f (g m) a } -> ComposeT f g m a + deriving newtype (Functor, Applicative, Monad) + +instance (MonadTrans f, MonadTrans g, LiftingMonad g) => MonadTrans (ComposeT f g) where + lift :: forall m. Monad m => m ~> ComposeT f g m + lift = ComposeT . lift . lift + \\ proof @g @m + +instance (MFunctor f, MFunctor g, LiftingMonad g) => MFunctor (ComposeT f g) where + hoist :: forall m m'. Monad m => (m ~> m') -> (ComposeT f g m ~> ComposeT f g m') + hoist f = ComposeT . hoist (hoist f) . getComposeT + \\ proof @g @m + +----- +-- Using tuples in a `via` type +----- + +newtype X a = X (a, a) + deriving (Semigroup, Monoid) + via (Product a, Sum a) + + deriving (Show, Eq) + via (a, a) + +----- +-- Abstract data types +----- + +class C f where + c :: f a -> Int + +newtype X2 f a = X2 (f a) + +instance C (X2 f) where + c = const 0 + +deriving via (X2 IO) instance C IO + +---- +-- Testing parser +---- + +newtype P0 a = P0 a deriving Show via a +newtype P1 a = P1 [a] deriving Show via [a] +newtype P2 a = P2 (a, a) deriving Show via (a, a) +newtype P3 a = P3 (Maybe a) deriving Show via (First a) +newtype P4 a = P4 (Maybe a) deriving Show via (First $ a) +newtype P5 a = P5 a deriving Show via (Identity $ a) +newtype P6 a = P6 [a] deriving Show via ([] $ a) +newtype P7 a = P7 (a, a) deriving Show via (Identity $ (a, a)) +newtype P8 a = P8 (Either () a) deriving Functor via (($) (Either ())) + +newtype f $ a = APP (f a) deriving newtype Show deriving newtype Functor + +---- +-- From Baldur's notes +---- + +---- +-- 1 +---- +newtype WrapApplicative f a = WrappedApplicative (f a) + deriving (Functor, Applicative) + +instance (Applicative f, Num a) => Num (WrapApplicative f a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + fromInteger = pure . fromInteger + abs = fmap abs + signum = fmap signum + +instance (Applicative f, Fractional a) => Fractional (WrapApplicative f a) where + recip = fmap recip + fromRational = pure . fromRational + +instance (Applicative f, Floating a) => Floating (WrapApplicative f a) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh + +instance (Applicative f, Semigroup s) => Semigroup (WrapApplicative f s) where + (<>) = liftA2 (<>) + +instance (Applicative f, Monoid m) => Monoid (WrapApplicative f m) where + mempty = pure mempty + +---- +-- 2 +---- +class Pointed p where + pointed :: a -> p a + +newtype WrapMonad f a = WrappedMonad (f a) + deriving newtype (Pointed, Monad) + +instance (Monad m, Pointed m) => Functor (WrapMonad m) where + fmap = liftM + +instance (Monad m, Pointed m) => Applicative (WrapMonad m) where + pure = pointed + (<*>) = ap + +-- data +data Sorted a = Sorted a a a + deriving (Functor, Applicative) + via (WrapMonad Sorted) + deriving (Num, Fractional, Floating, Semigroup, Monoid) + via (WrapApplicative Sorted a) + + +instance Monad Sorted where + (>>=) :: Sorted a -> (a -> Sorted b) -> Sorted b + Sorted a b c >>= f = Sorted a' b' c' where + Sorted a' _ _ = f a + Sorted _ b' _ = f b + Sorted _ _ c' = f c + +instance Pointed Sorted where + pointed :: a -> Sorted a + pointed a = Sorted a a a + +---- +-- 3 +---- +class IsZero a where + isZero :: a -> Bool + +newtype WrappedNumEq a = WrappedNumEq a +newtype WrappedShow a = WrappedShow a +newtype WrappedNumEq2 a = WrappedNumEq2 a + +instance (Num a, Eq a) => IsZero (WrappedNumEq a) where + isZero :: WrappedNumEq a -> Bool + isZero (WrappedNumEq a) = 0 == a + +instance Show a => IsZero (WrappedShow a) where + isZero :: WrappedShow a -> Bool + isZero (WrappedShow a) = "0" == show a + +instance (Num a, Eq a) => IsZero (WrappedNumEq2 a) where + isZero :: WrappedNumEq2 a -> Bool + isZero (WrappedNumEq2 a) = a + a == a + +newtype INT = INT Int + deriving newtype Show + deriving IsZero via (WrappedNumEq Int) + +newtype VOID = VOID Void deriving IsZero via (WrappedShow Void) + +---- +-- 4 +---- +class Bifunctor p => Biapplicative p where + bipure :: a -> b -> p a b + + biliftA2 + :: (a -> b -> c) + -> (a' -> b' -> c') + -> p a a' + -> p b b' + -> p c c' + +instance Biapplicative (,) where + bipure = (,) + + biliftA2 f f' (a, a') (b, b') = + (f a b, f' a' b') + +newtype WrapBiapp p a b = WrapBiap (p a b) + deriving newtype (Bifunctor, Biapplicative, Eq) + +instance (Biapplicative p, Num a, Num b) => Num (WrapBiapp p a b) where + (+) = biliftA2 (+) (+) + (-) = biliftA2 (*) (*) + (*) = biliftA2 (*) (*) + negate = bimap negate negate + abs = bimap abs abs + signum = bimap signum signum + fromInteger n = fromInteger n `bipure` fromInteger n + +newtype INT2 = INT2 (Int, Int) + deriving IsZero via (WrappedNumEq2 (WrapBiapp (,) Int Int)) + +---- +-- 5 +---- +class Monoid a => MonoidNull a where + null :: a -> Bool + +newtype WrpMonNull a = WRM a deriving (Eq, Semigroup, Monoid) + +instance (Eq a, Monoid a) => MonoidNull (WrpMonNull a) where + null :: WrpMonNull a -> Bool + null = (== mempty) + +deriving via (WrpMonNull Any) instance MonoidNull Any +deriving via () instance MonoidNull () +deriving via Ordering instance MonoidNull Ordering + +---- +-- 6 +---- +-- https://github.com/mikeizbicki/subhask/blob/f53fd8f465747681c88276c7dabe3646fbdf7d50/src/SubHask/Algebra.hs#L635 + +class Lattice a where + sup :: a -> a -> a + (.>=) :: a -> a -> Bool + (.>) :: a -> a -> Bool + +newtype WrapOrd a = WrappedOrd a + deriving newtype (Eq, Ord) + +instance Ord a => Lattice (WrapOrd a) where + sup = max + (.>=) = (>=) + (.>) = (>) + +deriving via [a] instance Ord a => Lattice [a] +deriving via (a, b) instance (Ord a, Ord b) => Lattice (a, b) +--mkLattice_(Bool) +deriving via Bool instance Lattice Bool +--mkLattice_(Char) +deriving via Char instance Lattice Char +--mkLattice_(Int) +deriving via Int instance Lattice Int +--mkLattice_(Integer) +deriving via Integer instance Lattice Integer +--mkLattice_(Float) +deriving via Float instance Lattice Float +--mkLattice_(Double) +deriving via Double instance Lattice Double +--mkLattice_(Rational) +deriving via Rational instance Lattice Rational + +---- +-- 7 +---- +-- https://hackage.haskell.org/package/linear-1.20.7/docs/src/Linear-Affine.html + +class Functor f => Additive f where + zero :: Num a => f a + (^+^) :: Num a => f a -> f a -> f a + (^+^) = liftU2 (+) + (^-^) :: Num a => f a -> f a -> f a + x ^-^ y = x ^+^ fmap negate y + liftU2 :: (a -> a -> a) -> f a -> f a -> f a + +instance Additive [] where + zero = [] + liftU2 f = go where + go (x:xs) (y:ys) = f x y : go xs ys + go [] ys = ys + go xs [] = xs + +instance Additive Maybe where + zero = Nothing + liftU2 f (Just a) (Just b) = Just (f a b) + liftU2 _ Nothing ys = ys + liftU2 _ xs Nothing = xs + +instance Applicative f => Additive (WrapApplicative f) where + zero = pure 0 + liftU2 = liftA2 + +deriving via (WrapApplicative ((->) a)) instance Additive ((->) a) +deriving via (WrapApplicative Complex) instance Additive Complex +deriving via (WrapApplicative Identity) instance Additive Identity + +instance Additive ZipList where + zero = ZipList [] + liftU2 f (ZipList xs) (ZipList ys) = ZipList (liftU2 f xs ys) + +class Additive (Diff p) => Affine p where + type Diff p :: Type -> Type + + (.-.) :: Num a => p a -> p a -> Diff p a + (.+^) :: Num a => p a -> Diff p a -> p a + (.-^) :: Num a => p a -> Diff p a -> p a + p .-^ v = p .+^ fmap negate v + +-- #define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \ +-- (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \ +-- (.-^) = (^-^) ; {-# INLINE (.-^) #-} +-- #define ADDITIVE(T) ADDITIVEC((), T) +newtype WrapAdditive f a = WrappedAdditive (f a) + +instance Additive f => Affine (WrapAdditive f) where + type Diff (WrapAdditive f) = f + + WrappedAdditive a .-. WrappedAdditive b = a ^-^ b + WrappedAdditive a .+^ b = WrappedAdditive (a ^+^ b) + WrappedAdditive a .-^ b = WrappedAdditive (a ^-^ b) + +-- ADDITIVE(((->) a)) +deriving via (WrapAdditive ((->) a)) instance Affine ((->) a) +-- ADDITIVE([]) +deriving via (WrapAdditive []) instance Affine [] +-- ADDITIVE(Complex) +deriving via (WrapAdditive Complex) instance Affine Complex +-- ADDITIVE(Maybe) +deriving via (WrapAdditive Maybe) instance Affine Maybe +-- ADDITIVE(ZipList) +deriving via (WrapAdditive ZipList) instance Affine ZipList +-- ADDITIVE(Identity) +deriving via (WrapAdditive Identity) instance Affine Identity + +---- +-- 8 +---- + +class C2 a b c where + c2 :: a -> b -> c + +instance C2 a b (Const a b) where + c2 x _ = Const x + +newtype Fweemp a = Fweemp a + deriving (C2 a b) + via (Const a (b :: Type)) + diff --git a/tests/examples/pre-ghc910/determ004.hs b/tests/examples/pre-ghc910/determ004.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/determ004.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE TypeOperators + , DataKinds + , PolyKinds + , TypeFamilies + , GADTs + , UndecidableInstances + , RankNTypes + , ScopedTypeVariables + #-} + +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Werror #-} +{-# OPTIONS_GHC -O1 -fspec-constr #-} + +{- + +With reversed order of allocated uniques the type variables would be in +wrong order: + +*** Core Lint errors : in result of SpecConstr *** +determ004.hs:88:12: warning: + [in body of lambda with binder m_azbFg :: a_afdP_azbON] + @ (a_afdP_azbON :: BOX) is out of scope +*** Offending Program *** + +... + +Rec { +$s$wsFoldr1_szbtK + :: forall (m_azbFg :: a_afdP_azbON) + (x_azbOM :: TyFun + a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> Type) + -> Type) + (a_afdP_azbON :: BOX) + (ipv_szbwN :: a_afdP_azbON) + (ipv_szbwO :: [a_afdP_azbON]). + R:Sing[]z (ipv_szbwN : ipv_szbwO) + ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO) + -> Sing ipv_szbwO + -> Sing ipv_szbwN + -> (forall (t_azbNM :: a_afdP_azbON). + Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) + -> Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) +[LclId, + Arity=4, + Str=DmdType ] +$s$wsFoldr1_szbtK = + \ (@ (m_azbFg :: a_afdP_azbON)) + (@ (x_azbOM :: TyFun + a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> Type) + -> Type)) + (@ (a_afdP_azbON :: BOX)) + (@ (ipv_szbwN :: a_afdP_azbON)) + (@ (ipv_szbwO :: [a_afdP_azbON])) + (sg_szbtL + :: R:Sing[]z (ipv_szbwN : ipv_szbwO) + ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO)) + (sc_szbtM :: Sing ipv_szbwO) + (sc_szbtN :: Sing ipv_szbwN) + (sc_szbtP + :: forall (t_azbNM :: a_afdP_azbON). + Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) -> + case (SCons + @ a_afdP_azbON + @ (ipv_szbwN : ipv_szbwO) + @ ipv_szbwO + @ ipv_szbwN + @~ (_N + :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO)) + sc_szbtN + sc_szbtM) + `cast` (sg_szbtL + ; TFCo:R:Sing[]z[0] _N _N + :: R:Sing[]z (ipv_szbwN : ipv_szbwO) + ~R# R:Sing[]z + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) + of wild_XD { + SNil dt_dzbxX -> + (lvl_szbwi @ a_afdP_azbON) + `cast` ((Sing + (Sym (TFCo:R:Foldr1[2] _N _N) + ; Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N <'[]>_N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) + (Sym dt_dzbxX))_N))_R + :: Sing (Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list") + ~R# Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); + SCons @ n_azbFh @ m_XzbGe dt_dzbxK _sX_azbOH + ds_dzbyu [Dmd=] -> + case ds_dzbyu + `cast` (TFCo:R:Sing[]z[0] _N _N + :: Sing n_azbFh ~R# R:Sing[]z n_azbFh) + of wild_Xo { + SNil dt_dzbxk -> + (lvl_szbw1 @ a_afdP_azbON @ m_XzbGe) + `cast` ((Sing + (Sym (TFCo:R:Foldr1[0] _N _N _N) + ; Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N <'[m_XzbGe]>_N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) + ((_N ': Sym dt_dzbxk)_N ; Sym dt_dzbxK))_N))_R + :: Sing m_XzbGe + ~R# Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); + SCons @ ipv_XzbxR @ ipv_XzbyV ipv_szbwM ipv_szbwL ipv_szbwK -> + case (sc_szbtP @ m_XzbGe _sX_azbOH) + `cast` (TFCo:R:Sing(->)f[0] + _N _N _N + :: Sing (Apply x_azbOM m_XzbGe) + ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe)) + of wild_X3X { SLambda ds_XzbBr [Dmd=] -> + (ds_XzbBr + @ (Foldr1 x_azbOM (ipv_XzbyV : ipv_XzbxR)) + (($wsFoldr1_szbuc + @ a_afdP_azbON + @ x_azbOM + @ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR) + sc_szbtP + ((SCons + @ a_afdP_azbON + @ (ipv_XzbyV : ipv_XzbxR) + @ ipv_XzbxR + @ ipv_XzbyV + @~ (_N + :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR)) + ipv_szbwL + ipv_szbwK) + `cast` (Sym (TFCo:R:Sing[]z[0] _N) (Sym + (TFCo:R:Apply[][]:$$i[0] + _N + _N + _N) + ; (Apply + (Sym + (TFCo:R:Applyk(->):$l[0] + _N + _N)) + _N)_N) + :: R:Sing[]z (ipv_XzbyV : ipv_XzbxR) + ~R# Sing (Apply (Apply (:$) ipv_XzbyV) ipv_XzbxR)))) + `cast` ((Sing + ((Apply + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N) + _N)_N + ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N + ((Apply + (TFCo:R:Applyk(->):$l[0] _N _N) + _N)_N + ; TFCo:R:Apply[][]:$$i[0] + _N _N _N) + _N))_R + :: Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR)) + ~R# Sing (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))))) + `cast` ((Sing + ((Apply + _N + (Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N _N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] + _N _N)) + (Sym + (TFCo:R:Apply[][]:$$i[0] + _N _N _N) + ; (Apply + (Sym + (TFCo:R:Applyk(->):$l[0] _N _N)) + _N)_N))_N))_N + ; Sym + (TFCo:R:Foldr1[1] + _N + _N + _N + _N + _N) + ; Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N _N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) + ((_N ': Sym ipv_szbwM)_N ; Sym dt_dzbxK))_N))_R + :: Sing + (Apply + (Apply x_azbOM m_XzbGe) + (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))) + ~R# Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))) + } + } + } +... +-} + +module List (sFoldr1) where + +data Proxy t + +data family Sing (a :: k) + +data TyFun (a :: Type) (b :: Type) + +type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2 + +data instance Sing (f :: TyFun k1 k2 -> Type) = + 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)) +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 -> Type) + -> Type) + (t_afdZ :: [a_afdP]) = + Foldr1 t_afdY t_afdZ +data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) + -> Type) + (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 + -> Type) + -> Type) (TyFun [a_afdP] a_afdP -> Type)) +type instance Apply Foldr1Sym0 l = Foldr1Sym1 l + +type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP + -> Type) + -> Type) + (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 -> Type) -> Type) + (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/pre-ghc910/determinism001.hs b/tests/examples/pre-ghc910/determinism001.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/determinism001.hs @@ -0,0 +1,23 @@ +module Main where + +import Digraph + +main = mapM_ print + [ test001 + , test002 + , test003 + , test004 + ] + +-- These check that the result of SCCs doesn't depend on the order of the key +-- type (Int here). + +test001 = testSCC [("a", 1, []), ("b", 2, []), ("c", 3, [])] + +test002 = testSCC [("a", 2, []), ("b", 3, []), ("c", 1, [])] + +test003 = testSCC [("b", 1, []), ("c", 2, []), ("a", 3, [])] + +test004 = testSCC [("b", 2, []), ("c", 3, []), ("a", 1, [])] + +testSCC = flattenSCCs . stronglyConnCompFromEdgedVertices diff --git a/tests/examples/pre-ghc910/dynamic-paper.hs b/tests/examples/pre-ghc910/dynamic-paper.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/dynamic-paper.hs @@ -0,0 +1,341 @@ +{- This is the code extracted from "A reflection on types", by Simon PJ, +Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -} + +{-# LANGUAGE RankNTypes, PolyKinds, TypeOperators, + ScopedTypeVariables, GADTs, FlexibleInstances, + UndecidableInstances, RebindableSyntax, + DataKinds, MagicHash, AutoDeriveTypeable, TypeInType #-} +{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-redundant-constraints #-} + +module Dynamic where + +import Data.Map ( Map ) +import qualified Data.Map as Map +import Unsafe.Coerce ( unsafeCoerce ) +import Control.Monad ( (<=<) ) +import Prelude hiding ( lookup, fromInteger, replicate ) +import qualified Prelude +import qualified Data.Typeable +import qualified Data.Data +import Data.Kind + +lookupMap = Map.lookup +insertMap = Map.insert + +-- let's ignore overloaded numbers +fromInteger :: Integer -> Int +fromInteger = Prelude.fromInteger + +insertStore = undefined +schema = undefined +withTypeable = undefined +throw# = undefined + +toDynamicST = undefined +fromDynamicST = undefined + +extendStore :: Typeable a => STRef s a -> a -> Store -> Store +lookupStore :: Typeable a => STRef s a -> Store -> Maybe a + +type Key = Int +data STRef s a = STR Key +type Store = Map Key Dynamic + +extendStore (STR k) v s = insertMap k (toDynamicST v) s +lookupStore (STR k) s = case lookupMap k s of + Just d -> fromDynamicST d + Nothing -> Nothing + +toDynamicST :: Typeable a => a -> Dynamic +fromDynamicST :: Typeable a => Dynamic -> Maybe a + +eval = undefined +data Term + +data DynamicSilly = DIntSilly Int + | DBoolSilly Bool + | DCharSilly Char + | DPairSilly DynamicSilly DynamicSilly + + +toDynInt :: Int -> DynamicSilly +toDynInt = DIntSilly + +fromDynInt :: DynamicSilly -> Maybe Int +fromDynInt (DIntSilly n) = Just n +fromDynInt _ = Nothing + +toDynPair :: DynamicSilly -> DynamicSilly -> DynamicSilly +toDynPair = DPairSilly + +dynFstSilly :: DynamicSilly -> Maybe DynamicSilly +dynFstSilly (DPairSilly x1 x2) = Just x1 +dynFstSilly _ = Nothing + +eval :: Term -> DynamicSilly + +eqT = undefined + +instance Typeable (->) +instance Typeable Maybe +instance Typeable Bool +instance Typeable Int +instance (Typeable a, Typeable b) => Typeable (a b) +instance Typeable (,) + +instance Eq TypeRepX + +data Dynamic where + Dyn :: TypeRep a -> a -> Dynamic + +toDynamic :: Typeable a => a -> Dynamic +toDynamic x = Dyn typeRep x + +eqTNoKind = undefined + +eqTNoKind :: TypeRep a -> TypeRep b -> Maybe (a :***: b) + -- Primitive; implemented by compiler + +data a :***: b where + ReflNoKind :: a :***: a + +fromDynamic :: forall d. Typeable d => Dynamic -> Maybe d +fromDynamic (Dyn (ra :: TypeRep a) (x :: a)) + = case eqT ra (typeRep :: TypeRep d) of + Nothing -> Nothing + Just Refl -> Just x + +fromDynamicMonad :: forall d. Typeable d => Dynamic -> Maybe d + +fromDynamicMonad (Dyn ra x) + = do Refl <- eqT ra (typeRep :: TypeRep d) + return x + +cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b +cast x = do Refl <- eqT (typeRep :: TypeRep a) + (typeRep :: TypeRep b) + return x + +gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b) +gcast x = do Refl <- eqT (typeRep :: TypeRep a) + (typeRep :: TypeRep b) + return x + +data SameKind :: k -> k -> Type +type CheckAppResult = SameKind AppResult AppResultNoKind + -- not the most thorough check +foo :: AppResult x -> AppResultNoKind x +foo (App y z) = AppNoKind y z + +splitApp :: TypeRep a -> Maybe (AppResult a) +splitApp = undefined +splitAppNoKind = undefined +splitAppNoKind :: TypeRep a -> Maybe (AppResultNoKind a) + -- Primitive; implemented by compiler + +data AppResultNoKind t where + AppNoKind :: TypeRep a -> TypeRep b -> AppResultNoKind (a b) + +dynFstNoKind :: Dynamic -> Maybe Dynamic +dynFstNoKind (Dyn rpab x) + = do AppNoKind rpa rb <- splitAppNoKind rpab + AppNoKind rp ra <- splitAppNoKind rpa + Refl <- eqT rp (typeRep :: TypeRep (,)) + return (Dyn ra (fst x)) + +dynApply :: Dynamic -> Dynamic -> Maybe Dynamic +dynApply (Dyn rf f) (Dyn rx x) = do + App ra rt2 <- splitApp rf + App rtc rt1 <- splitApp ra + Refl <- eqT rtc (typeRep :: TypeRep (->)) + Refl <- eqT rt1 rx + return (Dyn rt2 (f x)) + +data TypeRepAbstract (a :: k) -- primitive, indexed by type and kind + +class Typeable (a :: k) where + typeRep :: TypeRep a + +data AppResult (t :: k) where + App :: forall k1 k (a :: k1 -> k) (b :: k1). + TypeRep a -> TypeRep b -> AppResult (a b) + +dynFst :: Dynamic -> Maybe Dynamic +dynFst (Dyn (rpab :: TypeRep pab) (x :: pab)) + + = do App (rpa :: TypeRep pa ) (rb :: TypeRep b) <- splitApp rpab + -- introduces kind |k2|, and types |pa :: k2 -> *|, |b :: k2| + + App (rp :: TypeRep p ) (ra :: TypeRep a) <- splitApp rpa + -- introduces kind |k1|, and types |p :: k1 -> k2 -> *|, |a :: k1| + + Refl <- eqT rp (typeRep :: TypeRep (,)) + -- introduces |p ~ (,)| and |(k1 -> k2 -> Type) ~ (Type -> Type -> Type)| + + return (Dyn ra (fst x)) + +eqT :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~: b) + +data (a :: k1) :~: (b :: k2) where + Refl :: forall k (a :: k). a :~: a + +castDance :: (Typeable a, Typeable b) => a -> Maybe b +castDance = castR typeRep typeRep + +withTypeable :: TypeRep a -> (Typeable a => r) -> r + +castR :: TypeRep a -> TypeRep b -> a -> Maybe b +castR ta tb = withTypeable ta (withTypeable tb castDance) + +cmpT = undefined +compareTypeRep = undefined + +data TypeRepX where + TypeRepX :: TypeRep a -> TypeRepX + +type TyMapLessTyped = Map TypeRepX Dynamic + +insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped +insertLessTyped x = Map.insert (TypeRepX (typeRep :: TypeRep a)) (toDynamic x) + +lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a +lookupLessTyped = fromDynamic <=< Map.lookup (TypeRepX (typeRep :: TypeRep a)) + +instance Ord TypeRepX where + compare (TypeRepX tr1) (TypeRepX tr2) = compareTypeRep tr1 tr2 + +compareTypeRep :: TypeRep a -> TypeRep b -> Ordering -- primitive + +data TyMap = Empty | Node Dynamic TyMap TyMap + +lookup :: TypeRep a -> TyMap -> Maybe a +lookup tr1 (Node (Dyn tr2 v) left right) = + case compareTypeRep tr1 tr2 of + LT -> lookup tr1 left + EQ -> castR tr2 tr1 v -- know this cast will succeed + GT -> lookup tr1 right +lookup tr1 Empty = Nothing + +cmpT :: TypeRep a -> TypeRep b -> OrderingT a b + -- definition is primitive + +data OrderingT a b where + LTT :: OrderingT a b + EQT :: OrderingT t t + GTT :: OrderingT a b + +data TypeRep (a :: k) where + TrApp :: TypeRep a -> TypeRep b -> TypeRep (a b) + TrTyCon :: TyCon -> TypeRep k -> TypeRep (a :: k) + +data TyCon = TyCon { tc_module :: Module, tc_name :: String } +data Module = Module { mod_pkg :: String, mod_name :: String } + +tcMaybe :: TyCon +tcMaybe = TyCon { tc_module = Module { mod_pkg = "base" + , mod_name = "Data.Maybe" } + , tc_name = "Maybe" } + +rt = undefined + +delta1 :: Dynamic -> Dynamic +delta1 dn = case fromDynamic dn of + Just f -> f dn + Nothing -> dn +loop1 = delta1 (toDynamic delta1) + +data Rid = MkT (forall a. TypeRep a -> a -> a) +rt :: TypeRep Rid +delta :: forall a. TypeRep a -> a -> a +delta ra x = case (eqT ra rt) of + Just Refl -> case x of MkT y -> y rt x + Nothing -> x +loop = delta rt (MkT delta) + +throw# :: SomeException -> a + +data SomeException where + SomeException :: Exception e => e -> SomeException + +class (Typeable e, Show e) => Exception e where { } + +data Company +data Salary +incS :: Float -> Salary -> Salary +incS = undefined + +-- some impedance matching with SYB +instance Data.Data.Data Company +instance {-# INCOHERENT #-} Data.Typeable.Typeable a => Typeable a + +mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a +mkT f x = case (cast f) of + Just g -> g x + Nothing -> x + +data Expr a +frontEnd = undefined + +data DynExp where + DE :: TypeRep a -> Expr a -> DynExp + +frontEnd :: String -> DynExp + +data TyConOld + +typeOf = undefined +eqTOld = undefined +funTcOld = undefined :: TyConOld +splitTyConApp = undefined +mkTyCon3 = undefined +boolTcOld = undefined +tupleTc = undefined +mkTyConApp = undefined +instance Eq TypeRepOld +instance Eq TyConOld + +data TypeRepOld -- Abstract + +class TypeableOld a where + typeRepOld :: proxy a -> TypeRepOld + +data DynamicOld where + DynOld :: TypeRepOld -> a -> DynamicOld + +data Proxy a = Proxy + +fromDynamicOld :: forall d. TypeableOld d => DynamicOld -> Maybe d +fromDynamicOld (DynOld trx x) + | typeRepOld (Proxy :: Proxy d) == trx = Just (unsafeCoerce x) + | otherwise = Nothing + +dynApplyOld :: DynamicOld -> DynamicOld -> Maybe DynamicOld +dynApplyOld (DynOld trf f) (DynOld trx x) = + case splitTyConApp trf of + (tc, [t1,t2]) | tc == funTcOld && t1 == trx -> + Just (DynOld t2 ((unsafeCoerce f) x)) + _ -> Nothing + +data DynamicClosed where + DynClosed :: TypeRepClosed a -> a -> DynamicClosed + +data TypeRepClosed (a :: Type) where + TBool :: TypeRepClosed Bool + TFun :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a -> b) + TProd :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a, b) + + +lookupPil = undefined + +lookupPil :: Typeable a => [Dynamic] -> Maybe a + +data Dyn1 = Dyn1 Int + | DynFun (Dyn1 -> Dyn1) + | DynPair (Dyn1, Dyn1) + +data TypeEnum = IntType | FloatType | BoolType | DateType | StringType +data Schema = Object [Schema] | + Field TypeEnum | + Array Schema + +schema :: Typeable a => a -> Schema diff --git a/tests/examples/pre-ghc910/dynbrk005.hs b/tests/examples/pre-ghc910/dynbrk005.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/dynbrk005.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +import TupleN + +tuple3 x = $(tuple 3) x + +normal_fn x = tuple3 x diff --git a/tests/examples/pre-ghc910/empty-foralls.hs b/tests/examples/pre-ghc910/empty-foralls.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/empty-foralls.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +-- Empty foralls are handled correctly in different situations. + +data D = forall. D Int + +data G where + G :: forall. Int -> G diff --git a/tests/examples/pre-ghc910/empty-foralls2.hs b/tests/examples/pre-ghc910/empty-foralls2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/empty-foralls2.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +-- Empty foralls are handled correctly in different situations. + +data D = forall. D Int + +data G where + G :: forall. Int -> G + +f :: forall. a -> a +f x = x + +type family T x where + forall. T x = x + +{-# RULES + "r" + forall. r a = () +#-} diff --git a/tests/examples/pre-ghc910/export-class.hs b/tests/examples/pre-ghc910/export-class.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/export-ps-rec-sel.hs b/tests/examples/pre-ghc910/export-ps-rec-sel.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/export-ps-rec-sel.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} +module Foo( R(P,x)) where + +data Q = Q Int + +data R = R + +pattern P{x} = Q x diff --git a/tests/examples/pre-ghc910/export-record-selector.hs b/tests/examples/pre-ghc910/export-record-selector.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/export-record-selector.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Foo ( A(foo) ) where + +data A a = A a + +pattern P :: Int -> A Int +pattern P{foo} = A foo diff --git a/tests/examples/pre-ghc910/export-super-class-fail.hs b/tests/examples/pre-ghc910/export-super-class-fail.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/export-super-class.hs b/tests/examples/pre-ghc910/export-super-class.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/export-syntax.hs b/tests/examples/pre-ghc910/export-syntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/export-syntax.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} +module Foo(A(.., B)) where + +data A = A | B diff --git a/tests/examples/pre-ghc910/export-type-synonym.hs b/tests/examples/pre-ghc910/export-type-synonym.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/export-type-synonym.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Foo ( A(P) ) where + +data A = A +data B = B + +type C = B + +pattern P :: C +pattern P = B diff --git a/tests/examples/pre-ghc910/export-type.hs b/tests/examples/pre-ghc910/export-type.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/export-type.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Export (A(..,MyB), B(MyA), C(MyC)) where + +data A = A + +data B = B + +pattern MyB = B + +pattern MyA = A + +data C a = C + +pattern MyC = B diff --git a/tests/examples/pre-ghc910/ffi1.hs b/tests/examples/pre-ghc910/ffi1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ffi1.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-} + +module Lib where + +import GHC.Prim + +-- Can't unboxed tuples and sums to FFI, we should fail appropriately. + +foreign import ccall "f1" f1 :: (# Int | Int #) -> IO Int +foreign import ccall "f2" f2 :: (# (# Int, Int #) | (# Float#, Float# #) #) -> IO Int +foreign import ccall "f3" f3 :: (# (# #) | Void# | (# Int# | String #) #) -> IO Int + diff --git a/tests/examples/pre-ghc910/frontend01.hs b/tests/examples/pre-ghc910/frontend01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/frontend01.hs @@ -0,0 +1,1 @@ +main = putStrLn "hello world" diff --git a/tests/examples/pre-ghc910/ghci006.hs b/tests/examples/pre-ghc910/ghci006.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/ghci006.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE RankNTypes #-} +module Ghci006 where + +data Q = forall x . Show x => Q x +showQ (Q x) = show x + +-- associated bug is that at the interpreter command line, +-- showQ (Q "foo") crashed the interpreter. + diff --git a/tests/examples/pre-ghc910/haddockA026.hs b/tests/examples/pre-ghc910/haddockA026.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/haddockA026.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE RankNTypes #-} + +module ShouldCompile where + +test :: (Eq a) => [a] -- ^ doc1 + -> forall b . [b] {-^ doc2 -} + -> [a] -- ^ doc3 +test xs ys = xs + diff --git a/tests/examples/pre-ghc910/haddockA027.hs b/tests/examples/pre-ghc910/haddockA027.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/haddockA027.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE RankNTypes #-} + +module ShouldCompile where + +test :: [a] -- ^ doc1 + -> forall b. (Ord b) => [b] {-^ doc2 -} + -> forall c. (Num c) => [c] -- ^ doc3 + -> [a] +test xs ys zs = xs + diff --git a/tests/examples/pre-ghc910/haddockA031.hs b/tests/examples/pre-ghc910/haddockA031.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/haddockA031.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes #-} +module ShouldCompile where + +data A + = A + | {-| comment for B -} forall a. B a a + | forall a. Num a => C a {-^ comment for C -} + diff --git a/tests/examples/pre-ghc910/haddockA034.hs b/tests/examples/pre-ghc910/haddockA034.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/haddockC026.hs b/tests/examples/pre-ghc910/haddockC026.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/haddockC026.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE RankNTypes #-} + +module ShouldCompile where + +test :: (Eq a) => [a] -- ^ doc1 + -> forall b . [b] {-^ doc2 -} + -> [a] -- ^ doc3 +test xs ys = xs + diff --git a/tests/examples/pre-ghc910/haddockC027.hs b/tests/examples/pre-ghc910/haddockC027.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/haddockC027.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE RankNTypes #-} + +module ShouldCompile where + +-- I bet this test is a mistake! From the layout it +-- looks as if 'test' takes three args, the latter two +-- of higher rank. But the parens around these args are +-- missing, so it parses as +-- test :: [a] +-- -> forall a. Ord a +-- => [b] +-- -> forall c. Num c +-- => [c] +-- -> [a] +-- +-- But maybe that what was intended; I'm not sure +-- Anyway it should typecheck! + +test :: [a] -- ^ doc1 + -> forall b. (Ord b) => [b] {-^ doc2 -} + -> forall c. (Num c) => [c] -- ^ doc3 + -> [a] +test xs ys zs = xs + diff --git a/tests/examples/pre-ghc910/haddockC031.hs b/tests/examples/pre-ghc910/haddockC031.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/haddockC031.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes #-} +module ShouldCompile where + +data A + = A + | {-| comment for B -} forall a. B a a + | forall a. Num a => C a {-^ comment for C -} + diff --git a/tests/examples/pre-ghc910/hie010.hs b/tests/examples/pre-ghc910/hie010.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/hie010.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +module MoreExplicitForalls where + +import Data.Proxy + +data family F1 a +data instance forall (x :: Bool). F1 (Proxy x) = MkF + +class C a where + type F2 a b + +instance forall a. C [a] where + type forall b. F2 [a] b = Int + + +type family G a b where + forall x y. G [x] (Proxy y) = Double + forall z. G z z = Bool + diff --git a/tests/examples/pre-ghc910/listcomps.hs b/tests/examples/pre-ghc910/listcomps.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/mdo.hs b/tests/examples/pre-ghc910/mdo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/mdo.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RecursiveDo #-} +import Control.Monad.Fix +import Data.IORef +import Prelude hiding (traverse) + +data N a = N (IORef Bool, N a, a, N a) + +newNode :: N a -> a -> N a -> IO (N a) +newNode b c f = do v <- newIORef False + return (N (v, b, c, f)) + +ll = mdo n0 <- newNode n3 0 n1 + n1 <- newNode n0 1 n2 + n2 <- newNode n1 2 n3 + n3 <- newNode n2 3 n0 + return n0 + +data Dir = F | B deriving Eq + +traverse :: Dir -> N a -> IO [a] +traverse d (N (v, b, i, f)) = + do visited <- readIORef v + if visited + then return [] + else do writeIORef v True + let next = if d == F then f else b + is <- traverse d next + return (i:is) + +l2dll :: [a] -> IO (N a) +l2dll (x:xs) = mdo c <- newNode l x f + (f, l) <- l2dll' c xs + return c + +l2dll' :: N a -> [a] -> IO (N a, N a) +l2dll' p [] = return (p, p) +l2dll' p (x:xs) = mdo c <- newNode p x f + (f, l) <- l2dll' c xs + return (c, l) + diff --git a/tests/examples/pre-ghc910/mixed-pat-syn-record-sels.hs b/tests/examples/pre-ghc910/mixed-pat-syn-record-sels.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/mixed-pat-syn-record-sels.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +module Foo where + + +pattern A { a } = Just a +pattern B { b } = Just b + +foo :: Maybe a -> Maybe Bool +foo x = x { a = True, b = False } diff --git a/tests/examples/pre-ghc910/mkGADTVars.hs b/tests/examples/pre-ghc910/mkGADTVars.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/mkGADTVars.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs, TypeInType #-} + +module GADTVars where + +import Data.Kind +import Data.Proxy + +data T (k1 :: Type) (k2 :: Type) (a :: k2) (b :: k2) where + MkT :: T x1 * (Proxy (y :: x1), z) z diff --git a/tests/examples/pre-ghc910/mod181.hs b/tests/examples/pre-ghc910/mod181.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/mod181.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-- If 'ImportQualifiedPost' is enabled 'qualified' can appear in +-- postpositive position. + +import Prelude qualified + +main = Prelude.undefined + diff --git a/tests/examples/pre-ghc910/multi-export.hs b/tests/examples/pre-ghc910/multi-export.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/n-plus-k-patterns.hs b/tests/examples/pre-ghc910/n-plus-k-patterns.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/n-plus-k-patterns.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE NPlusKPatterns #-} +singleline :: Int +singleline (n + 1) = n + +multiline :: Int +multiline(n + + 1) = n + +n :: Int +(n + 1) = 3 + diff --git a/tests/examples/pre-ghc910/overloadedlabelsfail01.hs b/tests/examples/pre-ghc910/overloadedlabelsfail01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedlabelsfail01.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedLabels, DataKinds, FlexibleContexts #-} + +import GHC.OverloadedLabels + +-- No instance for (OverloadedLabel "x" t0) +a = #x + +-- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0) +b = #x #y + +-- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t) +c :: IsLabel "x" t => t +c = #y + +main = return () diff --git a/tests/examples/pre-ghc910/overloadedlabelsrun01.hs b/tests/examples/pre-ghc910/overloadedlabelsrun01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedlabelsrun01.hs @@ -0,0 +1,29 @@ +-- Basic tests of overloaded labels + +{-# LANGUAGE OverloadedLabels + , DataKinds + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , NoMonomorphismRestriction + #-} + +import GHC.OverloadedLabels + +instance IsLabel "true" Bool where + fromLabel _ = True + +instance IsLabel "false" Bool where + fromLabel _ = False + +a :: IsLabel "true" t => t +a = #true + +b = #false + +c :: Bool +c = #true + +main = do print (a :: Bool) + print (b :: Bool) + print c diff --git a/tests/examples/pre-ghc910/overloadedlabelsrun02.hs b/tests/examples/pre-ghc910/overloadedlabelsrun02.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedlabelsrun02.hs @@ -0,0 +1,61 @@ +-- Using overloaded labels to provide nice syntactic sugar for a +-- term representation using de Bruijn indices + +{-# LANGUAGE OverloadedLabels + , DataKinds + , FlexibleContexts + , FlexibleInstances + , GADTs + , KindSignatures + , MultiParamTypeClasses + , NoMonomorphismRestriction + , OverlappingInstances + , ScopedTypeVariables + , StandaloneDeriving + , TypeOperators + #-} + +import GHC.OverloadedLabels +import Data.Proxy ( Proxy(..) ) +import GHC.TypeLits ( Symbol ) + +instance x ~ y => IsLabel x (Proxy y) where + fromLabel _ = Proxy + +data Elem (x :: Symbol) g where + Top :: Elem x (x ': g) + Pop :: Elem x g -> Elem x (y ': g) +deriving instance Show (Elem x g) + + +class IsElem x g where + which :: Elem x g + +instance IsElem x (x ': g) where + which = Top + +instance IsElem x g => IsElem x (y ': g) where + which = Pop which + + +data Tm g where + Var :: Elem x g -> Tm g + App :: Tm g -> Tm g -> Tm g + Lam :: Tm (x ': g) -> Tm g +deriving instance Show (Tm g) + +instance IsElem x g => IsLabel x (Tm g) where + fromLabel _ = Var (which :: Elem x g) + +lam :: Proxy x -> Tm (x ': g) -> Tm g +lam _ = Lam + +s = lam #x #x +t = lam #x (lam #y (#x `App` #y)) + +u :: IsElem "z" g => Tm g +u = #z `App` #z + +main = do print s + print t + print (u :: Tm '["z"]) diff --git a/tests/examples/pre-ghc910/overloadedlabelsrun03.hs b/tests/examples/pre-ghc910/overloadedlabelsrun03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedlabelsrun03.hs @@ -0,0 +1,21 @@ +-- Using overloaded labels as strings, slightly pointlessly + +{-# LANGUAGE OverloadedLabels + , DataKinds + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , ScopedTypeVariables + , TypeFamilies + , TypeSynonymInstances + #-} + +import GHC.OverloadedLabels +import Data.Proxy ( Proxy(..) ) +import GHC.TypeLits ( KnownSymbol, symbolVal ) + +instance (KnownSymbol x, c ~ Char) => IsLabel x [c] where + fromLabel _ = symbolVal (Proxy :: Proxy x) + +main = do putStrLn #x + print $ #x ++ #y diff --git a/tests/examples/pre-ghc910/overloadedrecflds_generics.hs b/tests/examples/pre-ghc910/overloadedrecflds_generics.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecflds_generics.hs @@ -0,0 +1,50 @@ +-- Test that DuplicateRecordFields doesn't affect the metadata +-- generated by GHC.Generics or Data.Data + +-- Based on a Stack Overflow post by bennofs +-- (http://stackoverflow.com/questions/24474581) +-- licensed under cc by-sa 3.0 + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +import GHC.Generics +import Data.Data +import Data.Proxy + +type family FirstSelector (f :: Type -> Type) :: Meta +type instance FirstSelector (M1 D x f) = FirstSelector f +type instance FirstSelector (M1 C x f) = FirstSelector f +type instance FirstSelector (a :*: b) = FirstSelector a +type instance FirstSelector (M1 S s f) = s + +data SelectorProxy (s :: Meta) (f :: Type -> Type) a = SelectorProxy +type SelectorProxy' (s :: Meta) = SelectorProxy s Proxy () + +-- Extract the first selector name using GHC.Generics +firstSelectorName :: forall a. Selector (FirstSelector (Rep a)) + => Proxy a -> String +firstSelectorName _ = + selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a))) + +-- Extract the list of selector names for a constructor using Data.Data +selectorNames :: Data a => a -> [String] +selectorNames = constrFields . toConstr + +data T = MkT { foo :: Int } deriving (Data, Generic) +data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic) + +main = do -- This should yield "foo", not "$sel:foo:MkT" + print (firstSelectorName (Proxy :: Proxy T)) + -- Similarly this should yield "foo" + print (firstSelectorName (Proxy :: Proxy U)) + -- This should yield ["foo"] + print (selectorNames (MkT 3)) + -- And this should yield ["foo","bar"] + print (selectorNames (MkU 3 True)) diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail01.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail01.hs @@ -0,0 +1,19 @@ +-- Test ambiguous updates are rejected with appropriate error messages + +{-# LANGUAGE DuplicateRecordFields #-} + +data R = MkR { w :: Bool, x :: Int, y :: Bool } +data S = MkS { w :: Bool, x :: Int, y :: Bool } +data T = MkT { x :: Int, z :: Bool } +data U = MkU { y :: Bool } + +-- Straightforward ambiguous update +upd1 r = r { x = 3 } + +-- No type has all these fields +upd2 r = r { x = 3, y = True, z = False } + +-- User-specified type does not have these fields +upd3 r = r { w = True, x = 3, y = True } :: U + +main = return () diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail02.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail02.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail02.hs @@ -0,0 +1,9 @@ +-- Test selectors cannot be used ambiguously + +{-# LANGUAGE DuplicateRecordFields #-} + +data R = MkR { x :: Int, y :: Bool } +data S = MkS { x :: Int } + +main = do print (x (MkS 42)) + print (y (MkR 42 42)) diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail03.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail03.hs @@ -0,0 +1,10 @@ +-- Test that a top-level definition with the same name as a record +-- field is rejected + +{-# LANGUAGE DuplicateRecordFields #-} + +foo = True + +data T = MkT { foo :: Int } + +main = print foo diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail04.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail04.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail04.hs @@ -0,0 +1,14 @@ +-- Test that importing an overloaded field and using it as a selector +-- leads to a suitable error + +{-# LANGUAGE DuplicateRecordFields #-} + +import OverloadedRecFldsFail04_A as I + +-- Qualified overloaded fields are not allowed here +x' = I.x + +-- But this is okay +f e = e { I.x = True, I.y = False } + +main = return () diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail05.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail05.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail05.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -fwarn-unused-binds -Werror #-} + +module Main (main, T(MkT)) where + +data S = MkS { foo :: Int } +data T = MkT { foo :: Int } + +-- This should count as a use of S(foo) but not T(foo) +main = print ((\ MkS{foo=foo} -> foo) (MkS 3)) diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail06.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail06.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail06.hs @@ -0,0 +1,18 @@ +-- Check that unused imports are reported correctly in the presence of +-- DuplicateRecordFields + +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -Werror -fwarn-unused-imports #-} + +import OverloadedRecFldsFail06_A (U(x, y), V(MkV, MkV2, x, y), Unused(unused), u, getY) +import qualified OverloadedRecFldsFail06_A as M (U(x)) +import qualified OverloadedRecFldsFail06_A as N (V(x, y)) +import qualified OverloadedRecFldsFail06_A as P (U(x), V(x)) + +v = MkV2 True + +-- Check that this counts a use of U(x) and V(y) but not U(y) or V(x)... +main = do print (u { x = True } :: U) + print ((\ MkV2{y=y} -> y) v) + print (N.x v) + print (getY (v { P.x = 3 })) diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail07.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail07.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail07.hs @@ -0,0 +1,9 @@ +-- Test type errors contain field names, not selector names + +{-# LANGUAGE DuplicateRecordFields #-} + +data T = MkT { x :: Int } + +y = x x + +main = return () diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail08.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail08.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail08.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} + +data family F a +data instance F Int = MkFInt { x :: Int } +data instance F Bool = MkFBool { y :: Bool } + +-- No data type has both these fields, but they belong to the same +-- lexical parent (F). This used to confuse DuplicateRecordFields. +foo e = e { x = 3, y = True } + +main = return () diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail09.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail09.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail09.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} + +data S = MkS { x :: Int } +data T = MkT { x :: Int } + +-- This tests what happens when an ambiguous record update is used in +-- a splice: since it can't be represented in TH, it should error +-- cleanly, rather than panicking or silently using one field. +foo = [e| (MkS 3) { x = 3 } |] + +main = return () diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail10.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail10.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail10.hs @@ -0,0 +1,11 @@ +-- Modules A and B both declare F(foo) +-- Module C declares F($sel:foo:MkFChar) but exports A.F(foo) as well +-- Thus we can't export F(..) even with DuplicateRecordFields enabled + +{-# LANGUAGE DuplicateRecordFields #-} +module Main (main, F(..)) where + +import OverloadedRecFldsFail10_B +import OverloadedRecFldsFail10_C + +main = return () diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail11.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail11.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail11.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -Werror #-} +import OverloadedRecFldsFail11_A + +main = print (foo (MkS True :: S)) diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail12.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail12.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail12.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# OPTIONS_GHC -Werror #-} + +import OverloadedRecFldsFail12_A + +data S = MkS { foo :: Bool } + +-- Use of foo and bar should give deprecation warnings +f :: T -> T +f e = e { foo = 3, bar = 3 } + +s :: T -> Int +s = foo + +main = return () diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail13.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail13.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail13.hs @@ -0,0 +1,20 @@ +-- Test that giving a stupid type annotation to an ambiguous field +-- yields a sensible error message + +{-# LANGUAGE DuplicateRecordFields #-} + +data S = MkS { x :: Int } +data T = MkT { x :: Bool } +data U = MkU + +a = x (MkU :: U) + +b = x (MkU :: a) + +c :: U -> Int +c = x + +d :: a -> Int +d = x + +main = return () diff --git a/tests/examples/pre-ghc910/overloadedrecfldsfail14.hs b/tests/examples/pre-ghc910/overloadedrecfldsfail14.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsfail14.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +-- Test that we deal gracefully with non-fields in updates + +data S = MkS { x :: Int } +data T = MkT { x :: Int } + +y :: Bool +y = True + +-- y isn't a field +f r = r { x = 3, y = False } + +main = return () diff --git a/tests/examples/pre-ghc910/overloadedrecfldsrun01.hs b/tests/examples/pre-ghc910/overloadedrecfldsrun01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsrun01.hs @@ -0,0 +1,28 @@ +-- Test that unambiguous constructions remain valid when +-- DuplicateRecordFields is enabled + +{-# LANGUAGE DuplicateRecordFields #-} + +data S = MkS { x :: Int } + deriving Show + +data T = MkT { x :: Bool, y :: Bool -> Bool, tField :: Bool } + +data U a = MkU { x :: a, y :: a } + +-- Construction is unambiguous +s = MkS { x = 42 } +t = MkT { x = True, y = id, tField = False } + +-- Pattern matching is unambiguous +get_x MkS{x=x} = x + +-- Resolving ambiguous monomorphic updates +a = t { x = False, y = not, tField = True } -- only T has all these fields +b = s { x = 3 } :: S -- type being pushed in +c = (t :: T) { x = False } -- type signature on record expression + +-- Unambiguous selectors are in scope normally +z = tField t + +main = print (get_x b) diff --git a/tests/examples/pre-ghc910/overloadedrecfldsrun02.hs b/tests/examples/pre-ghc910/overloadedrecfldsrun02.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsrun02.hs @@ -0,0 +1,6 @@ +-- This module does not enable -XDuplicateRecordFields, but it should +-- still be able to refer to non-overloaded fields like `y` + +import OverloadedRecFldsRun02_A + +main = print (y u) diff --git a/tests/examples/pre-ghc910/overloadedrecfldsrun03.hs b/tests/examples/pre-ghc910/overloadedrecfldsrun03.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsrun03.hs @@ -0,0 +1,25 @@ +-- Test that DuplicateRecordFields can be used along with +-- TypeFamilies (with selectors only if unambiguous) + +{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} + +data family F a + +data instance F Int = MkFInt { foo :: Int } +data instance F Bool = MkFBool { bar :: Bool, baz :: Bool } + + +data family G a + +data instance G Int = MkGInt { foo :: Int } +data instance G Bool = MkGBool { bar :: Bool } + +x = MkFBool { bar = False, baz = True } + +y :: F Bool +y = x { bar = True } + +get_bar MkFBool{bar=bar} = bar + +main = do print (baz y) + print (get_bar y) diff --git a/tests/examples/pre-ghc910/overloadedrecfldsrun04.hs b/tests/examples/pre-ghc910/overloadedrecfldsrun04.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsrun04.hs @@ -0,0 +1,30 @@ +-- Test that DuplicateRecordFields works with TemplateHaskell + +{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +-- Splice in a datatype with field... +$(return [DataD [] (mkName "R") [] [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []]) + +-- New TH story means reify only sees R if we do this: +$(return []) + +-- ... and check that we can inspect it +main = do putStrLn $(do { info <- reify ''R + ; case info of + TyConI (DataD _ _ _ [RecC _ [(n, _, _)]] _) -> + do { info' <- reify n + ; lift (pprint info ++ "\n" ++ pprint info') + } + _ -> error "unexpected result of reify" + }) + putStrLn $(do { info <- reify 'foo + ; case info of + VarI n _ _ -> + do { info' <- reify n + ; lift (pprint info ++ "\n" ++ pprint info') + } + }) + print (foo (MkR { foo = 42 })) diff --git a/tests/examples/pre-ghc910/overloadedrecfldsrun05.hs b/tests/examples/pre-ghc910/overloadedrecfldsrun05.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsrun05.hs @@ -0,0 +1,27 @@ +-- Test that DuplicateRecordFields works with NamedFieldPuns and +-- RecordWildCards + +{-# LANGUAGE DuplicateRecordFields, NamedFieldPuns, RecordWildCards #-} + +data S = MkS { foo :: Int } + deriving Show +data T = MkT { foo :: Int } + deriving Show + +f MkS{foo} = MkT{foo} + +g MkT{..} = MkS{..} + +h e = let foo = 6 in e { foo } :: S + +main = do print a + print b + print c + print d + where + foo = 42 + + a = MkS{foo} + b = f a + c = g b + d = h c diff --git a/tests/examples/pre-ghc910/overloadedrecfldsrun06.hs b/tests/examples/pre-ghc910/overloadedrecfldsrun06.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/overloadedrecfldsrun06.hs @@ -0,0 +1,21 @@ +-- Test that ambiguous selectors can be disambiguated by providing +-- type signatures in various places + +{-# LANGUAGE DuplicateRecordFields #-} + +data S = MkS { x :: Int } +data T = MkT { x :: Bool } +data U a = MkU { x :: a } + +x_for_s :: S -> Int +x_for_s = x + +x_for_t = x :: T -> Bool + +x_for_u u = x (u :: U Int) + +k :: (T -> Bool) -> Bool +k f = f (MkT True) + +main = do print (x_for_s (MkS 42)) + print (k x) diff --git a/tests/examples/pre-ghc910/performGC.hs b/tests/examples/pre-ghc910/performGC.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/plugins07.hs b/tests/examples/pre-ghc910/plugins07.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/plugins07.hs @@ -0,0 +1,6 @@ +module Main where + +{-# NOINLINE x #-} +x = "foo" + +main = putStrLn (show x) diff --git a/tests/examples/pre-ghc910/pmc001.hs b/tests/examples/pre-ghc910/pmc001.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/pmc001.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeFamilies, GADTs #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module PMC001 where + +data family T a + +data instance T [a] where + MkT1 :: T [Int] + MkT2 :: Char -> T [Char] + MkT3 :: T [a] + +f :: T [a] -> T [a] -> Bool +f MkT1 MkT1 = True +f (MkT2 _) (MkT2 _) = True +f MkT3 MkT3 = True + +g :: T [a] -> T [a] -> Bool +g x y + | MkT1 <- x, MkT1 <- y = True + | (MkT2 _) <- x, (MkT2 _) <- y = True + | MkT3 <- x, MkT3 <- y = True diff --git a/tests/examples/pre-ghc910/pmc002.hs b/tests/examples/pre-ghc910/pmc002.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/pmc002.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module PMC002 where + +f :: [a] -> Bool +f [] = True +f x | (_:_) <- x = False -- exhaustive diff --git a/tests/examples/pre-ghc910/pmc003.hs b/tests/examples/pre-ghc910/pmc003.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/pmc003.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module PMC003 where + +f :: Bool -> Bool -> () +f _ False = () +f True False = () +f _ _ = () + diff --git a/tests/examples/pre-ghc910/pmc004.hs b/tests/examples/pre-ghc910/pmc004.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/pmc004.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} +{-# LANGUAGE GADTs #-} + +module PMC004 where + +data F a where + F1 :: F Int + F2 :: F Bool + +data G a where + G1 :: G Int + G2 :: G Char + +h :: F a -> G a -> () +h F1 G1 = () +h _ G1 = () diff --git a/tests/examples/pre-ghc910/pmc005.hs b/tests/examples/pre-ghc910/pmc005.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/pmc005.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} +{-# LANGUAGE GADTs #-} + +module PMC005 where + +data T a where + TList :: T [a] + TBool :: T Bool + +foo :: T c -> T c -> () +foo TList _ = () +foo _ TList = () diff --git a/tests/examples/pre-ghc910/pmc006.hs b/tests/examples/pre-ghc910/pmc006.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/pmc006.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module PMC006 where + +len :: [a] -> Int +len xs = case xs of + [] -> 0 + (_:ys) -> case () of + () | (_:_) <- xs -> 1 + len ys + +-- -- we would like these to work too but they don't yet +-- +-- len :: [a] -> Int +-- len [] = 0 +-- len xs = case xs of +-- (_:ys) -> 1 + len ys +-- +-- len :: [a] -> Int +-- len xs = case xs of +-- [] -> 0 +-- ys -> case ys of +-- (_:zs) -> 1 + len zs diff --git a/tests/examples/pre-ghc910/pmc007.hs b/tests/examples/pre-ghc910/pmc007.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/pmc007.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module PMC007 where + +-- overloaded +f "ab" = () +f "ac" = () + +-- non-overloaded +g :: String -> () +g "ab" = () +g "ac" = () + +-- non-overloaded due to type inference +h :: String -> () +h s = let s' = s + in case s' of + "ab" -> () + "ac" -> () diff --git a/tests/examples/pre-ghc910/poly-export-fail2.hs b/tests/examples/pre-ghc910/poly-export-fail2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/poly-export.hs b/tests/examples/pre-ghc910/poly-export.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/poly-export.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +module Foo (Foo(P)) where + +data Foo a = Foo a + +instance C Foo where + build a = Foo a + destruct (Foo a) = a + +class C f where + build :: a -> f a + destruct :: f a -> a + +pattern P :: C f => a -> f a +pattern P x <- (destruct -> x) + where + P x = build x diff --git a/tests/examples/pre-ghc910/poly-export2.hs b/tests/examples/pre-ghc910/poly-export2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/poly-export3.hs b/tests/examples/pre-ghc910/poly-export3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/proc-do-complex-four-out.hs b/tests/examples/pre-ghc910/proc-do-complex-four-out.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/proc-do-complex-four-out.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE Arrows #-} + +foo + f + g + h + ma = + proc + ( (a, b) + , (c, d) + , (e, f) + ) + -> do + -- Begin do + (x, y) <- -- GHC parser fails if layed out over multiple lines + f -- Call into f + ( a + , c -- Tuple together arguments + ) + ( b + , d + ) + -< + ( b + 1 -- Funnel into arrow + , d * b + ) + if x `mod` y == 0 -- Basic condition + then case e of -- Only left case is relevant + Left + ( z + , w + ) -> \u -> -- Procs can have lambdas + let v = + u -- Actually never used + ^ 2 + in ( returnA + -< + -- Just do the calculation + (x + y * z) + ) + else do + let u = x -- Let bindings bind expressions, not commands + -- Could pattern match directly on x + i <- case u of + 0 -> (g . h -< u) + n -> + ( ( h . g + -< + y -- First actual use of y + ) + ) + returnA -< () + -- Sometimes execute effects + if i > 0 + then ma -< () + else returnA -< () + returnA + -< + ( i + + x + * y -- Just do the calculation + ) + diff --git a/tests/examples/pre-ghc910/proc-do-complex-out.hs b/tests/examples/pre-ghc910/proc-do-complex-out.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/proc-do-complex-out.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE Arrows #-} + +foo + f + g + h + ma = + proc + ( (a, b), + (c, d), + (e, f) + ) + -> do + -- Begin do + (x, y) <- -- GHC parser fails if layed out over multiple lines + f -- Call into f + ( a, + c -- Tuple together arguments + ) + ( b, + d + ) + -< + ( b + 1, -- Funnel into arrow + d * b + ) + if x `mod` y == 0 -- Basic condition + then case e of -- Only left case is relevant + Left + ( z, + w + ) -> \u -> -- Procs can have lambdas + let v = + u -- Actually never used + ^ 2 + in ( returnA + -< + -- Just do the calculation + (x + y * z) + ) + else do + let u = x -- Let bindings bind expressions, not commands + -- Could pattern match directly on x + i <- case u of + 0 -> (g . h -< u) + n -> + ( ( h . g + -< + y -- First actual use of y + ) + ) + returnA -< () + -- Sometimes execute effects + if i > 0 + then ma -< () + else returnA -< () + returnA + -< + ( i + + x + * y -- Just do the calculation + ) + diff --git a/tests/examples/pre-ghc910/proc-do-complex.hs b/tests/examples/pre-ghc910/proc-do-complex.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/proc-do-complex.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE Arrows #-} +foo + f + g + h + ma = proc ( + (a, b), + (c, d), + (e, f) + ) -> + do -- Begin do + (x,y) -- GHC parser fails if layed out over multiple lines + <- f -- Call into f + (a, + c) -- Tuple together arguments + (b, + d) + -< (b + 1, -- Funnel into arrow + d * b) + if + x `mod` y == 0 -- Basic condition + then case e -- Only left case is relevant + of Left (z, + w) -> \u -> -- Procs can have lambdas + let + v + = u -- Actually never used + ^ 2 + in + (returnA + -< -- Just do the calculation + (x + y * z)) + else do + let u = x -- Let bindings bind expressions, not commands + -- Could pattern match directly on x + i <- case u of + 0 -> (g . h -< u) + n -> ( + (h . g + -< y) -- First actual use of y + ) + returnA -< () + -- Sometimes execute effects + if i > 0 + then ma -< () + else returnA -< () + returnA -< (i + + x * + y) -- Just do the calculation + diff --git a/tests/examples/pre-ghc910/proc-lets-out.hs b/tests/examples/pre-ghc910/proc-lets-out.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/proc-lets-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Arrows #-} + +foo f = proc a -> let b = a in f -< b + +bar f g = proc a -> + let h = + f + . g a + j = + g + . h + in id -< (h, j) + diff --git a/tests/examples/pre-ghc910/proc-lets.hs b/tests/examples/pre-ghc910/proc-lets.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/proc-lets.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Arrows #-} + +foo f = proc a -> let b = a in f -< b + +bar f g = proc a -> + let + h + = f + . g a + j = g + . + h + in + id -< (h, j) + diff --git a/tests/examples/pre-ghc910/qdocompile001.hs b/tests/examples/pre-ghc910/qdocompile001.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/qdocompile001.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE QualifiedDo #-} + +import Prelude as P + +-- Test that the context of the do shows well in the renamer +-- output. +-- +-- The nested do in the renamer output must be qualified the +-- same as the outer P.do written in the source program. +-- +-- > ==================== Renamer ==================== +-- > Main.main +-- > = print +-- > $ P.do (x <- [1, 2] | +-- > y <- P.do y@1 <- [1, 2] -- qualified! +-- > [1, 2] +-- > y) +-- > return y +-- +main = + print $ P.do + x <- [1, 2] + y@1 <- [1, 2] + [1, 2] + P.return y + diff --git a/tests/examples/pre-ghc910/qdocompile002.hs b/tests/examples/pre-ghc910/qdocompile002.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/qdocompile002.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE QualifiedDo #-} + +import Prelude as P hiding (fail) + + +-- Tests that fail is not required with irrefutable patterns +main = + print $ P.do + x <- [1, 2] + (_, y) <- [(1, "a"), (2, "b")] + P.return (x, y) + diff --git a/tests/examples/pre-ghc910/qdorun001.hs b/tests/examples/pre-ghc910/qdorun001.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/qdorun001.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE QualifiedDo #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + putStrLn "The unqualified do still works." + print $ toList $ Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + Graded.return (x, y) + -- test Graded.fail + print $ toList $ Graded.do + 1 <- VCons 1 VNil + Graded.return 1 + diff --git a/tests/examples/pre-ghc910/qdorun002.hs b/tests/examples/pre-ghc910/qdorun002.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/qdorun002.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RecursiveDo #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + print $ take 6 $ concat $ toList $ Graded.do + rec + VCons (take 6 y) VNil + y <- VCons (1 : zipWith (+) y (0 : y)) VNil + Graded.return y + diff --git a/tests/examples/pre-ghc910/qdorun003.hs b/tests/examples/pre-ghc910/qdorun003.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/qdorun003.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE QualifiedDo #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + print $ toList $ Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + Graded.return (x, y) + -- Test Graded.join + print $ toList $ Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + VCons (y, x) VNil + diff --git a/tests/examples/pre-ghc910/qdorun004.hs b/tests/examples/pre-ghc910/qdorun004.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/qdorun004.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RecursiveDo #-} +import qualified Control.Monad.Fix as P +import Prelude (print, ($)) +import qualified Prelude as P + +return :: a -> [a] +return x = [x, x] + +-- Tests that QualifiedDo doesn't affect return +main = do + print $ P.do + x <- [1, 2] + return x + print $ P.mdo + x <- [1, 2] + return x + diff --git a/tests/examples/pre-ghc910/qdorun005.hs b/tests/examples/pre-ghc910/qdorun005.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/qdorun005.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RebindableSyntax #-} +import qualified Monad.Graded as Graded +import Vector +import Prelude (print, ($)) +import qualified Prelude as P + +xs >>= f = 'c' : P.concatMap f xs +(>>) = (P.>>) + +main = do + print $ toList $ Graded.do + x <- VCons 'a' (VCons 'b' VNil) + Graded.return x + print $ do + a <- ['a', 'b'] + P.return a + diff --git a/tests/examples/pre-ghc910/qdorun006.hs b/tests/examples/pre-ghc910/qdorun006.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/qdorun006.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TemplateHaskell #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + print $ toList $([| Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + Graded.return (x, y) |]) + print $ toList $([| Graded.mdo + z <- VCons (take 8 y) VNil + y <- VCons (1 : zipWith (+) y (0 : y)) VNil + Graded.return z |]) + diff --git a/tests/examples/pre-ghc910/qdorun007.hs b/tests/examples/pre-ghc910/qdorun007.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/qdorun007.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE QualifiedDo #-} +-- Tests that QualfiedDo works for a linear monad. + +import Monad.Linear as Linear + + +main = do + let r = runTM (Linear.do + t0 <- newT + t1 <- increaseT t0 + (t2, ur) <- extractT t1 + deleteT t2 + Linear.return ur) + print r + print r + diff --git a/tests/examples/pre-ghc910/read018.hs b/tests/examples/pre-ghc910/read018.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/read018.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DatatypeContexts #-} +-- !!! Checking that empty contexts are permitted. +module ShouldCompile where + +data () => Foo a = Foo a + +newtype () => Bar = Bar Int + +f :: () => Int -> Int +f = (+1) + + +class () => Fob a where + +instance () => Fob Int where +instance () => Fob Float + diff --git a/tests/examples/pre-ghc910/record-dot-four-out.hs b/tests/examples/pre-ghc910/record-dot-four-out.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/record-dot-four-out.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedRecordUpdate #-} +{-# LANGUAGE RebindableSyntax #-} + +data Foo = Foo {bar :: Foo} + +mfoo = fmap (.bar) $ Nothing + +baz = (Foo 1).bar + +fooplus f n = f{foo = f.bar + n} + +nestedFoo f = f.bar.bar.bar.bar.bar + +nestedFooUpdate f = f{bar.bar = f.bar} <> f{bar.bar.bar.bar} diff --git a/tests/examples/pre-ghc910/records-check-sels.hs b/tests/examples/pre-ghc910/records-check-sels.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-check-sels.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms #-} +module Qux where + +-- Make sure selectors aren't generated for normal synonyms + +pattern Uni a = Just a + +pattern a :+: b = (a, b) + +qux = a (Just True) diff --git a/tests/examples/pre-ghc910/records-compile.hs b/tests/examples/pre-ghc910/records-compile.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-compile.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} +module ShouldCompile where + +pattern Single{x} = [x] + +-- Selector +selector :: Int +selector = x [5] + +update :: [String] +update = ["String"] { x = "updated" } diff --git a/tests/examples/pre-ghc910/records-exquant.hs b/tests/examples/pre-ghc910/records-exquant.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-exquant.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms, ExistentialQuantification #-} +module ExQuant where + +data Showable = forall a . Show a => Showable a + +pattern Nasty{a} = Showable a + +qux = a (Showable True) + +foo = (Showable ()) { a = True } diff --git a/tests/examples/pre-ghc910/records-mixing-fields.hs b/tests/examples/pre-ghc910/records-mixing-fields.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-mixing-fields.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PatternSynonyms #-} + +data MyRec = MyRec { foo :: Int, qux :: String } + +pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} + +updater,updater1, updater2 :: MyRec -> MyRec +updater a = a {f1 = 1 } + +updater1 a = a {f1 = 1, qux = "two" } + +updater2 a = a {f1 = 1, foo = 2 } diff --git a/tests/examples/pre-ghc910/records-no-uni-update.hs b/tests/examples/pre-ghc910/records-no-uni-update.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-no-uni-update.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module RecordPats where + +-- No updates +pattern Uni{a,b} <- (a, b) + +foo = ("a","b") { a = "b" } diff --git a/tests/examples/pre-ghc910/records-no-uni-update2.hs b/tests/examples/pre-ghc910/records-no-uni-update2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-no-uni-update2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} +module RecordPats where + +-- No updates +pattern Uni{a} <- Just a + +qux = a (Just True) + +qux2 (Uni b) = b + +foo = Uni { a = "b" } diff --git a/tests/examples/pre-ghc910/records-poly-update.hs b/tests/examples/pre-ghc910/records-poly-update.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-poly-update.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE PatternSynonyms #-} +module Main where + +pattern ReqNoProv :: Show a => a -> Maybe a +pattern ReqNoProv{j} = Just j + +data A = A deriving Show + +p1 = Just True + +p6 = p1 {j = A} + +main = print p6 diff --git a/tests/examples/pre-ghc910/records-poly.hs b/tests/examples/pre-ghc910/records-poly.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-poly.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms #-} +module PolyPat where + +-- Testing whether type changing updates work correctly. + +pattern MyTuple :: a -> b -> (a, b) +pattern MyTuple{mfst, msnd} = (mfst, msnd) + + +expr1 :: (Int, String) -> (Int, Int) +expr1 a = a { msnd = 2} + +expr3 a = a { msnd = 2} + +expr2 :: (a, b) -> a +expr2 a = mfst a diff --git a/tests/examples/pre-ghc910/records-prov-req.hs b/tests/examples/pre-ghc910/records-prov-req.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-prov-req.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns, GADTs, RankNTypes, + StandaloneDeriving, FlexibleInstances #-} +module ShouldCompile where + +-- Testing that selectors work properly with prov and req thetas + +data T a b where + MkT :: (Show b) => a -> b -> T a b + +deriving instance Show (T Int A) + +data G a b = MkG { care :: a, y :: (Show b => b) } + +pattern ExNumPat :: (Eq b) => (Show b) => b -> T Int b +pattern ExNumPat{x} = MkT 42 x + +data A = A | B deriving (Show, Eq) + +f3 :: T Int A +f3 = (MkT 42 A) { x = B } + +f5 :: T Int A +f5 = (ExNumPat A) { x = B } + + +f4 = (MkG 42 True) { y = False } diff --git a/tests/examples/pre-ghc910/records-req-only.hs b/tests/examples/pre-ghc910/records-req-only.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-req-only.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Main where + +import Prelude (Maybe(..), Show(..), String, Bool(..), print) + +pattern ReqNoProv :: Show a => a -> Maybe a +pattern ReqNoProv{j} = Just j + +p1 = ReqNoProv True + +p7 (ReqNoProv _) = ReqNoProv False + +p6 = p1 {j = False} + +main = print p6 diff --git a/tests/examples/pre-ghc910/records-req.hs b/tests/examples/pre-ghc910/records-req.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-req.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-} + +-- Pattern synonyms + +module ShouldCompile where + +data T a where + MkT :: (Eq b) => a -> b -> T a + +f :: (Show a) => a -> Bool +f = undefined + +pattern P{x} <- MkT (f -> True) x diff --git a/tests/examples/pre-ghc910/records-run.hs b/tests/examples/pre-ghc910/records-run.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/records-run.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Main where + +pattern Bi{a, b} = (a, b) + +foo = ("a","b") + +main = do + print foo + print (a foo) + print (b foo) + print (foo {a = "c"}) + print (foo {a = "fst", b = "snd"}) diff --git a/tests/examples/pre-ghc910/saks029.hs b/tests/examples/pre-ghc910/saks029.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/saks029.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE PolyKinds, DataKinds, RankNTypes, TypeFamilies #-} + +module SAKS_029 where + +import Data.Kind +import Data.Proxy +import Data.Type.Bool + +type IfK :: forall j m n. forall (e :: Proxy (j :: Bool)) -> m -> n -> If j m n +type family IfK e f g where + IfK (_ :: Proxy True) f _ = f + IfK (_ :: Proxy False) _ g = g + diff --git a/tests/examples/pre-ghc910/saks032.hs b/tests/examples/pre-ghc910/saks032.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/saks032.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, RankNTypes #-} + +module SAKS_032 where + +import Data.Kind +import Data.Proxy + +type Const :: Type -> forall k. k -> Type +data Const a b = Const a + +type F :: Type -> Type -> forall k. k -> Type +type family F a b :: forall k. k -> Type where + F () () = Proxy + F a b = Const (a,b) + +type F1 :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type +type family F1 a b + +type F2 :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type +type family F2 a b :: forall r2. (r1, r2) -> Type + diff --git a/tests/examples/pre-ghc910/spec-inline-determ.hs b/tests/examples/pre-ghc910/spec-inline-determ.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/spec-inline-determ.hs @@ -0,0 +1,40 @@ +module Roman where + +-- This is a simplified version of simplCore/should_compile/spec-inline.hs +-- +-- It reproduces a problem where workers get specialized in different ways +-- depending on the values of uniques. +-- +-- Compare: +-- +-- $s$wgo_s1CN :: Int# -> Int -> Int# +-- [LclId, Arity=2, Str=DmdType ] +-- $s$wgo_s1CN = +-- \ (sc_s1CI :: Int#) (sc_s1CJ :: Int) -> +-- case tagToEnum# @ Bool (<=# sc_s1CI 0#) of _ [Occ=Dead] { +-- False -> +-- $wgo_s1BU (Just @ Int (I# (-# sc_s1CI 1#))) (Just @ Int sc_s1CJ); +-- True -> 0# +-- } +-- +-- vs +-- +-- $s$wgo_s18mTj :: Int -> Int# -> Int# +-- [LclId, Arity=2, Str=DmdType ] +-- $s$wgo_s18mTj = +-- \ (sc_s18mTn :: Int) (sc_s18mTo :: Int#) -> +-- case tagToEnum# @ Bool (<=# sc_s18mTo 0#) of _ [Occ=Dead] { +-- False -> +-- $wgo_s18mUc +-- (Just @ Int (I# (-# sc_s18mTo 1#))) (Just @ Int sc_s18mTn); +-- True -> 0# +-- } + +foo :: Int -> Int +foo n = + go (Just n) (Just (6::Int)) + where + go Nothing (Just x) = go (Just 10) (Just x) + go (Just n) (Just x) + | n <= 0 = 0 + | otherwise = go (Just (n-1)) (Just x) diff --git a/tests/examples/pre-ghc910/stringSource.hs b/tests/examples/pre-ghc910/stringSource.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10255.hs b/tests/examples/pre-ghc910/t10255.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10268.hs b/tests/examples/pre-ghc910/t10268.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10269.hs b/tests/examples/pre-ghc910/t10269.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10278.hs b/tests/examples/pre-ghc910/t10278.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10280.hs b/tests/examples/pre-ghc910/t10280.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10307.hs b/tests/examples/pre-ghc910/t10307.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10309.hs b/tests/examples/pre-ghc910/t10309.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10312.hs b/tests/examples/pre-ghc910/t10312.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10354.hs b/tests/examples/pre-ghc910/t10354.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10357.hs b/tests/examples/pre-ghc910/t10357.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10358.hs b/tests/examples/pre-ghc910/t10358.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10396.hs b/tests/examples/pre-ghc910/t10396.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/t10399.hs b/tests/examples/pre-ghc910/t10399.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/tc265.hs b/tests/examples/pre-ghc910/tc265.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/tcfail223.hs b/tests/examples/pre-ghc910/tcfail223.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/pre-ghc910/update-existential.hs b/tests/examples/pre-ghc910/update-existential.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc910/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/AddArgFromWhereComments.hs b/tests/examples/transform/AddArgFromWhereComments.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddArgFromWhereComments.hs @@ -0,0 +1,6 @@ +foo -- c1 + -- | c2 + {- c3 -} True -- c4 + = new_def + +foo False = False diff --git a/tests/examples/transform/AddArgFromWhereComments.hs.expected b/tests/examples/transform/AddArgFromWhereComments.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddArgFromWhereComments.hs.expected @@ -0,0 +1,6 @@ +foo -- c1 + -- | c2 + {- c3 -} True -- c4 + = new_def + +foo False = False diff --git a/tests/examples/transform/AddDecl.hs b/tests/examples/transform/AddDecl.hs --- a/tests/examples/transform/AddDecl.hs +++ b/tests/examples/transform/AddDecl.hs @@ -6,4 +6,6 @@ foo a b = a + b -- | Do bar -bar x y = foo (x+y) x +bar x y = {- baz -} foo (x+y) x + +-- end of file diff --git a/tests/examples/transform/AddDecl.hs.expected b/tests/examples/transform/AddDecl.hs.expected --- a/tests/examples/transform/AddDecl.hs.expected +++ b/tests/examples/transform/AddDecl.hs.expected @@ -1,11 +1,13 @@ module AddDecl where -nn = n2 - -- Adding a declaration to an existing file +nn = n2 + -- | Do foo foo a b = a + b -- | Do bar -bar x y = foo (x+y) x +bar x y = {- baz -} foo (x+y) x + +-- end of file diff --git a/tests/examples/transform/AddLocalDecl1.hs b/tests/examples/transform/AddLocalDecl1.hs --- a/tests/examples/transform/AddLocalDecl1.hs +++ b/tests/examples/transform/AddLocalDecl1.hs @@ -11,3 +11,5 @@ -- trailing 2 y = 3 + +-- eof diff --git a/tests/examples/transform/AddLocalDecl1.hs.expected b/tests/examples/transform/AddLocalDecl1.hs.expected --- a/tests/examples/transform/AddLocalDecl1.hs.expected +++ b/tests/examples/transform/AddLocalDecl1.hs.expected @@ -13,3 +13,5 @@ -- trailing 2 y = 3 + +-- eof diff --git a/tests/examples/transform/WhereIn3b.hs b/tests/examples/transform/WhereIn3b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/WhereIn3b.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/WhereIn3b.hs.expected b/tests/examples/transform/WhereIn3b.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/WhereIn3b.hs.expected @@ -0,0 +1,26 @@ +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. + +-- 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 + +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/vect/DiophantineVect.hs b/tests/examples/vect/DiophantineVect.hs deleted file mode 100644 --- a/tests/examples/vect/DiophantineVect.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE ParallelArrays #-} -{-# OPTIONS -fvectorise -XParallelListComp #-} -module DiophantineVect (solution3) where - -import Data.Array.Parallel -import Data.Array.Parallel.Prelude.Int as I - -import qualified Prelude as P - -solution3' - = let - pow x i = productP (replicateP i x) - primes = [: 2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73 :] - a `cutTo` b = sliceP 0 (lengthP b) a - sumpri xx = productP [: pow p x | p <- primes `cutTo` xx | x <- xx :] - distinct xx = productP [: x I.+ 1 | x <- xx :] - - series :: [:Int:] -> Int -> [:[:Int:]:] - series xs n - | n == 1 = [: [: 0 :] :] - | otherwise = [: [: x :] +:+ ps - | x <- xs - , ps <- series (I.enumFromToP 0 x) (n I.- 1) :] - - prob x y - = let xx = [: (sumpri m ,m) - | m <- series (I.enumFromToP 1 3) x - , distinct [: x I.* 2 | x <- m :] > y :] - i = minIndexP [: a | (a, b) <- xx :] - in xx !: i - in - prob 5 200 - -solution3 :: (Int, PArray Int) -{-# NOINLINE solution3 #-} -solution3 - = let (i, is) = solution3' - in - (i, toPArrayP is) -