diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +2018-07-11 v0.5.7.0 + * Include support for GHC 8.6.1 alpha 1 2018-03-11 v0.5.6.1 * Relax base constraints so tests can configure with GHC 8.4.1 2018-01-27 v0.5.6.0 diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,5 +1,5 @@ name: ghc-exactprint -version: 0.5.6.1 +version: 0.5.7.0 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 7.10.2, this library provides a means to round trip any code that can @@ -29,7 +29,7 @@ maintainer: alan.zimm@gmail.com category: Development build-type: Simple -tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.2 +tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.2, GHC == 8.4.3 extra-source-files: ChangeLog src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs tests/examples/failing/*.hs @@ -38,6 +38,9 @@ tests/examples/ghc80/*.hs tests/examples/ghc82/*.hs tests/examples/ghc84/*.hs + tests/examples/ghc86/*.hs + tests/examples/pre-ghc86/*.hs + tests/examples/vect/*.hs tests/examples/transform/*.hs tests/examples/failing/*.hs.bad tests/examples/transform/*.hs.expected @@ -80,7 +83,7 @@ -- other-modules: -- other-extensions: GHC-Options: -Wall - build-depends: base >=4.7 && <4.12 + build-depends: base >=4.7 && <4.13 , bytestring >= 0.10.6 , containers >= 0.5 , directory >= 1.2 @@ -94,16 +97,19 @@ build-depends: ghc-boot hs-source-dirs: src - if impl (ghc > 8.2.2) - hs-source-dirs: src-ghc84 + if impl (ghc > 8.4.3) + hs-source-dirs: src-ghc86 else - if impl (ghc > 8.0.3) - hs-source-dirs: src-ghc82 + if impl (ghc > 8.2.2) + hs-source-dirs: src-ghc84 else - if impl (ghc > 7.10.3) - hs-source-dirs: src-ghc80 + if impl (ghc > 8.0.3) + hs-source-dirs: src-ghc82 else - hs-source-dirs: src-ghc710 + if impl (ghc > 7.10.3) + hs-source-dirs: src-ghc80 + else + hs-source-dirs: src-ghc710 default-language: Haskell2010 if impl (ghc < 7.10.2) @@ -117,16 +123,19 @@ else hs-source-dirs: tests - if impl (ghc > 8.2.2) - hs-source-dirs: src-ghc84 + if impl (ghc > 8.4.3) + hs-source-dirs: src-ghc86 else - if impl (ghc > 8.0.3) - hs-source-dirs: src-ghc82 + if impl (ghc > 8.2.2) + hs-source-dirs: src-ghc84 else - if impl (ghc > 7.10.3) - hs-source-dirs: src-ghc80 + if impl (ghc > 8.0.3) + hs-source-dirs: src-ghc82 else - hs-source-dirs: src-ghc710 + if impl (ghc > 7.10.3) + hs-source-dirs: src-ghc80 + else + hs-source-dirs: src-ghc710 main-is: Test.hs other-modules: Test.Common @@ -138,7 +147,7 @@ if impl (ghc < 7.10.2) buildable: False Build-depends: HUnit >= 1.2 - , base < 4.12 + , base < 4.13 , bytestring , containers >= 0.5 , Diff @@ -154,7 +163,7 @@ if flag (dev) build-depends: free else - build-depends: ghc-exactprint >= 0.5.4 + build-depends: ghc-exactprint if impl (ghc >= 7.11) build-depends: ghc-boot diff --git a/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs --- a/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ b/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs @@ -2503,6 +2503,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (ResTyGADTHook name) where markAST _ (ResTyGADTHook bndrs) = do + markManyOptional GHC.AnnOpenP unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs diff --git a/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs new file mode 100644 --- /dev/null +++ b/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs @@ -0,0 +1,2800 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | 'annotate' is a function which given a GHC AST fragment, constructs +-- a syntax tree which indicates which annotations belong to each specific +-- part of the fragment. +-- +-- "Delta" and "Print" provide two interpreters for this structure. You +-- should probably use those unless you know what you're doing! +-- +-- The functor 'AnnotationF' has a number of constructors which correspond +-- to different sitations which annotations can arise. It is hoped that in +-- future versions of GHC these can be simplified by making suitable +-- modifications to the AST. + +module Language.Haskell.GHC.ExactPrint.Annotater + ( + annotate + , AnnotationF(..) + , Annotated + , Annotate(..) + , withSortKeyContextsHelper + ) where + + +import Language.Haskell.GHC.ExactPrint.AnnotateTypes +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils + +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 FastString as GHC +import qualified ForeignCall as GHC +import qualified GHC as GHC +-- import qualified HsDoc as GHC +import qualified Name as GHC +import qualified RdrName as GHC +import qualified Outputable as GHC + +import Control.Monad.Identity +import Data.Data +import Data.Maybe + +import qualified Data.Set as Set + +import Debug.Trace + + +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} +-- --------------------------------------------------------------------- + +class Data ast => Annotate ast where + markAST :: GHC.SrcSpan -> ast -> Annotated () + +-- --------------------------------------------------------------------- + +-- | Construct a syntax tree which represent which KeywordIds must appear +-- where. +annotate :: (Annotate ast) => GHC.Located ast -> Annotated () +annotate = markLocated + +-- --------------------------------------------------------------------- + +-- | Constructs a syntax tree which contains information about which +-- annotations are required by each element. +markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () +markLocated ast = + case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of + Just d -> markLHsDecl d + Nothing -> withLocated ast markAST + +-- --------------------------------------------------------------------- + +-- |When adding missing annotations, do not put a preceding space in front of a list +markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () +markListNoPrecedingSpace intercal ls = + case ls of + [] -> return () + (l:ls') -> do + if intercal + then do + if null ls' + then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l + else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l + markListIntercalate ls' + else do + setContext (Set.singleton NoPrecedingSpace) $ markLocated l + mapM_ markLocated ls' + +-- --------------------------------------------------------------------- + + +-- |Mark a list, with the given keyword as a list item separator +markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () +markListIntercalate ls = markListIntercalateWithFun markLocated ls + +-- --------------------------------------------------------------------- + +markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () +markListWithContexts ctxInitial ctxRest ls = + case ls of + [] -> return () + [x] -> setContextLevel ctxInitial 2 $ markLocated x + (x:xs) -> do + setContextLevel ctxInitial 2 $ markLocated x + setContextLevel ctxRest 2 $ mapM_ markLocated xs + +-- --------------------------------------------------------------------- + +-- Context for only if just one, else first item, middle ones, and last one +markListWithContexts' :: Annotate ast + => ListContexts + -> [GHC.Located ast] -> Annotated () +markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = + case ls of + [] -> return () + [x] -> setContextLevel ctxOnly level $ markLocated x + (x:xs) -> do + setContextLevel ctxInitial level $ markLocated x + go xs + where + level = 2 + go [] = return () + go [x] = setContextLevel ctxLast level $ markLocated x + go (x:xs) = do + setContextLevel ctxMiddle level $ markLocated x + go xs + + +-- --------------------------------------------------------------------- + +markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () +markListWithLayout ls = + setLayoutFlag $ markList ls + +-- --------------------------------------------------------------------- + +markList :: Annotate ast => [GHC.Located ast] -> Annotated () +markList ls = + setContext (Set.singleton NoPrecedingSpace) + $ markListWithContexts' listContexts' ls + +markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () +markLocalBindsWithLayout binds = markHsLocalBinds binds + +-- --------------------------------------------------------------------- + +-- |This function is used to get around shortcomings in the GHC AST for 7.10.1 +markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () +markLocatedFromKw kw (GHC.L l a) = do + -- Note: l is needed so that the pretty printer can make something up + ss <- getSrcSpanForKw l kw + AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) + markLocated (GHC.L ss' a) + +-- --------------------------------------------------------------------- + +markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () +markMaybe Nothing = return () +markMaybe (Just ast) = markLocated ast + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + +prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] +prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsModule GHC.GhcPs) where + markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do + + case mmn of + Nothing -> return () + Just (GHC.L ln mn) -> do + mark GHC.AnnModule + markExternal ln GHC.AnnVal (GHC.moduleNameString mn) + + forM_ mdepr markLocated + forM_ mexp markLocated + + mark GHC.AnnWhere + + markOptional GHC.AnnOpenC -- Possible '{' + markManyOptional GHC.AnnSemi -- possible leading semis + setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps + + setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs + + markOptional GHC.AnnCloseC -- Possible '}' + + markEOF + +-- --------------------------------------------------------------------- + +instance Annotate GHC.WarningTxt where + markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do + markAnnOpen txt "{-# WARNING" + mark GHC.AnnOpenS + markListIntercalate lss + mark GHC.AnnCloseS + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do + markAnnOpen txt "{-# DEPRECATED" + mark GHC.AnnOpenS + markListIntercalate lss + mark GHC.AnnCloseS + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance Annotate GHC.StringLiteral where + markAST l (GHC.StringLiteral src fs) = do + markExternalSourceText l src (show (GHC.unpackFS fs)) + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.SourceText,GHC.FastString) where + markAST l (src,fs) = do + markExternalSourceText l src (show (GHC.unpackFS fs)) + +-- --------------------------------------------------------------------- + +instance Annotate [GHC.LIE GHC.GhcPs] where + markAST _ ls = do + inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl + mark GHC.AnnOpenP -- '(' + -- Can't use markListIntercalate, there can be trailing commas, but only in imports. + markListIntercalateWithFunLevel markLocated 2 ls + + mark GHC.AnnCloseP -- ')' + +instance Annotate (GHC.IE GHC.GhcPs) where + markAST _ ie = do + + case ie of + GHC.IEVar _ ln -> markLocated ln + + GHC.IEThingAbs _ ln -> do + setContext (Set.singleton PrefixOp) $ markLocated ln + + GHC.IEThingWith _ ln wc ns _lfs -> do + setContext (Set.singleton PrefixOp) $ markLocated ln + mark GHC.AnnOpenP + case wc of + GHC.NoIEWildcard -> + unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) + $ markListIntercalate ns + GHC.IEWildcard n -> do + setContext (Set.fromList [PrefixOp,Intercalate]) + $ mapM_ markLocated (take n ns) + mark GHC.AnnDotdot + case drop n ns of + [] -> return () + ns' -> do + mark GHC.AnnComma + unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) + $ markListIntercalate ns' + mark GHC.AnnCloseP + + (GHC.IEThingAll _ ln) -> do + setContext (Set.fromList [PrefixOp]) $ markLocated ln + mark GHC.AnnOpenP + mark GHC.AnnDotdot + mark GHC.AnnCloseP + + (GHC.IEModuleContents _ (GHC.L lm mn)) -> do + mark GHC.AnnModule + markExternal lm GHC.AnnVal (GHC.moduleNameString mn) + + -- Only used in Haddock mode so we can ignore them. + (GHC.IEGroup {}) -> return () + + (GHC.IEDoc {}) -> return () + + (GHC.IEDocNamed {}) -> return () + GHC.XIE x -> error $ "got XIE for :" ++ showGhc x + ifInContext (Set.fromList [Intercalate]) + (mark GHC.AnnComma) + (markOptional GHC.AnnComma) + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.IEWrappedName GHC.RdrName) where + markAST _ (GHC.IEName ln) = do + unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) + $ markLocated ln + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + markAST _ (GHC.IEPattern ln) = do + mark GHC.AnnPattern + setContext (Set.singleton PrefixOp) $ markLocated ln + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + markAST _ (GHC.IEType ln) = do + mark GHC.AnnType + setContext (Set.singleton PrefixOp) $ markLocated ln + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +isSymRdr :: GHC.RdrName -> Bool +isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." + +instance Annotate GHC.RdrName where + markAST l n = do + let + str = rdrName2String n + isSym = isSymRdr n + canParen = isSym + doNormalRdrName = do + let str' = case str of + -- TODO: unicode support? + "forall" -> if spanLength l == 1 then "∀" else str + _ -> str + + let + markParen :: GHC.AnnKeywordId -> Annotated () + markParen pa = do + if canParen + then ifInContext (Set.singleton PrefixOp) + (mark pa) -- '(' + (markOptional pa) + else if isSym + then ifInContext (Set.singleton PrefixOpDollar) + (mark pa) + (markOptional pa) + else markOptional pa + + markOptional GHC.AnnSimpleQuote + markParen GHC.AnnOpenP + unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 + cnt <- countAnns GHC.AnnVal + case cnt of + 0 -> markExternal l GHC.AnnVal str' + 1 -> markWithString GHC.AnnVal str' + _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) + unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 + markParen GHC.AnnCloseP + + case n of + GHC.Unqual _ -> doNormalRdrName + GHC.Qual _ _ -> doNormalRdrName + GHC.Orig _ _ -> if str == "~" + then doNormalRdrName + -- then error $ "GHC.orig:(isSym,canParen)=" ++ show (isSym,canParen) + else markExternal l GHC.AnnVal str + -- GHC.Orig _ _ -> markExternal l GHC.AnnVal str + -- GHC.Orig _ _ -> error $ "GHC.orig:str=[" ++ str ++ "]" + GHC.Exact n' -> do + case str of + -- Special handling for Exact RdrNames, which are built-in Names + "[]" -> do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnCloseS -- ']' + "()" -> do + mark GHC.AnnOpenP -- '(' + mark GHC.AnnCloseP -- ')' + ('(':'#':_) -> do + markWithString GHC.AnnOpen "(#" -- '(#' + let cnt = length $ filter (==',') str + replicateM_ cnt (mark GHC.AnnCommaTuple) + markWithString GHC.AnnClose "#)"-- '#)' + "[::]" -> do + markWithString GHC.AnnOpen "[:" -- '[:' + markWithString GHC.AnnClose ":]" -- ':]' + "->" -> do + mark GHC.AnnOpenP -- '(' + mark GHC.AnnRarrow + mark GHC.AnnCloseP -- ')' + -- "~#" -> do + -- mark GHC.AnnOpenP -- '(' + -- mark GHC.AnnTildehsh + -- mark GHC.AnnCloseP + "*" -> do + markExternal l GHC.AnnVal str + "★" -> do -- Note: unicode star + markExternal l GHC.AnnVal str + ":" -> do + -- Note: The OccName for ":" has the following attributes (via occAttributes) + -- (d, Data DataSym Sym Val ) + -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon + doNormalRdrName + -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName + ('(':',':_) -> do + mark GHC.AnnOpenP + let cnt = length $ filter (==',') str + replicateM_ cnt (mark GHC.AnnCommaTuple) + mark GHC.AnnCloseP -- ')' + _ -> do + let isSym' = isSymRdr (GHC.nameRdrName n') + when isSym' $ mark GHC.AnnOpenP -- '(' + markWithString GHC.AnnVal str + when isSym $ mark GHC.AnnCloseP -- ')' + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.ImportDecl GHC.GhcPs) where + markAST _ imp@(GHC.ImportDecl _ msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do + + -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec + mark GHC.AnnImport + + -- "{-# SOURCE" and "#-}" + case msrc of + GHC.SourceText _txt -> do + markAnnOpen msrc "{-# SOURCE" + markWithString GHC.AnnClose "#-}" + GHC.NoSourceText -> return () + when safeflag (mark GHC.AnnSafe) + when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) + case mpkg of + Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> + markWithString GHC.AnnPackageName srcPkg + _ -> return () + + markLocated modname + + case GHC.ideclAs imp of + Nothing -> return () + Just mn -> do + mark GHC.AnnAs + markLocated mn + + case hiding of + Nothing -> return () + Just (isHiding,lie) -> do + if isHiding + then setContext (Set.singleton HasHiding) $ + markLocated lie + else markLocated lie + markTrailingSemi + + markAST _ (GHC.XImportDecl x) = error $ "got XImportDecl for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate GHC.ModuleName where + markAST l mname = + markExternal l GHC.AnnVal (GHC.moduleNameString mname) + +-- --------------------------------------------------------------------- + +markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated () +markLHsDecl (GHC.L l decl) = + case decl of + GHC.TyClD _ d -> markLocated (GHC.L l d) + GHC.InstD _ d -> markLocated (GHC.L l d) + GHC.DerivD _ d -> markLocated (GHC.L l d) + GHC.ValD _ d -> markLocated (GHC.L l d) + GHC.SigD _ d -> markLocated (GHC.L l d) + GHC.DefD _ d -> markLocated (GHC.L l d) + GHC.ForD _ d -> markLocated (GHC.L l d) + GHC.WarningD _ d -> markLocated (GHC.L l d) + GHC.AnnD _ d -> markLocated (GHC.L l d) + GHC.RuleD _ d -> markLocated (GHC.L l d) + GHC.SpliceD _ d -> markLocated (GHC.L l d) + GHC.DocD _ d -> markLocated (GHC.L l d) + GHC.RoleAnnotD _ d -> markLocated (GHC.L l d) + GHC.XHsDecl x -> error $ "got XHsDecl for:" ++ showGhc x + +instance Annotate (GHC.HsDecl GHC.GhcPs) where + markAST l d = markLHsDecl (GHC.L l d) + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where + markAST _ (GHC.RoleAnnotDecl _ ln mr) = do + mark GHC.AnnType + mark GHC.AnnRole + markLocated ln + mapM_ markLocated mr + markAST _ (GHC.XRoleAnnotDecl x) = error $ "got XRoleAnnotDecl for:" ++ showGhc x + +instance Annotate (Maybe GHC.Role) where + markAST l Nothing = markExternal l GHC.AnnVal "_" + markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.SpliceDecl GHC.GhcPs) where + markAST _ (GHC.SpliceDecl _ e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do + markLocated e + markTrailingSemi + markAST _ (GHC.SpliceDecl _ e _flag) = do + markLocated e + markTrailingSemi + + markAST _ (GHC.XSpliceDecl x) = error $ "got XSpliceDecl for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.RuleDecls GHC.GhcPs) where + markAST _ (GHC.HsRules _ src rules) = do + markAnnOpen src "{-# RULES" + setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules + markWithString GHC.AnnClose "#-}" + markTrailingSemi + markAST _ (GHC.XRuleDecls x) = error $ "got XRuleDecls for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.RuleDecl GHC.GhcPs) where + markAST l (GHC.HsRule _ ln act bndrs lhs rhs) = do + markLocated ln + setContext (Set.singleton ExplicitNeverActive) $ markActivation l act + + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + markLocated lhs + mark GHC.AnnEqual + markLocated rhs + inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi + markTrailingSemi + + markAST _ (GHC.XRuleDecl x) = error $ "got XRuleDecl for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated () +markActivation _ act = do + case act of + GHC.ActiveBefore src phase -> do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + markSourceText src (show phase) + mark GHC.AnnCloseS -- ']' + GHC.ActiveAfter src phase -> do + mark GHC.AnnOpenS -- '[' + markSourceText src (show phase) + mark GHC.AnnCloseS -- ']' + GHC.NeverActive -> do + inContext (Set.singleton ExplicitNeverActive) $ do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + mark GHC.AnnCloseS -- ']' + _ -> return () + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.RuleBndr GHC.GhcPs) where + markAST _ (GHC.RuleBndr _ ln) = markLocated ln + markAST _ (GHC.RuleBndrSig _ ln st) = do + mark GHC.AnnOpenP -- "(" + markLocated ln + mark GHC.AnnDcolon + markLHsSigWcType st + mark GHC.AnnCloseP -- ")" + markAST _ (GHC.XRuleBndr x) = error $ "got XRuleBndr for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated () +markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty)) = do + markLocated ty +markLHsSigWcType (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) = error "markLHsSigWcType extension hit" +markLHsSigWcType (GHC.XHsWildCardBndrs _) = error "markLHsSigWcType extension hit" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.AnnDecl GHC.GhcPs) where + markAST _ (GHC.HsAnnotation _ src prov e) = do + markAnnOpen src "{-# ANN" + case prov of + (GHC.ValueAnnProvenance n) -> markLocated n + (GHC.TypeAnnProvenance n) -> do + mark GHC.AnnType + markLocated n + GHC.ModuleAnnProvenance -> mark GHC.AnnModule + + markLocated e + markWithString GHC.AnnClose "#-}" + markTrailingSemi + + markAST _ (GHC.XAnnDecl x) = error $ "got XAnnDecl for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.WarnDecls GHC.GhcPs) where + markAST _ (GHC.Warnings _ src warns) = do + markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED + mapM_ markLocated warns + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.XWarnDecls x) = error $ "got XWarnDecls for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.WarnDecl GHC.GhcPs) where + markAST _ (GHC.Warning _ lns txt) = do + markListIntercalate lns + mark GHC.AnnOpenS -- "[" + case txt of + GHC.WarningTxt _src ls -> markListIntercalate ls + GHC.DeprecatedTxt _src ls -> markListIntercalate ls + mark GHC.AnnCloseS -- "]" + + markAST _ (GHC.XWarnDecl x) = error $ "got XWarnDecl for:" ++ showGhc x + +instance Annotate GHC.FastString where + -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. + markAST l fs = do + markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.ForeignDecl GHC.GhcPs) where + markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ) + (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do + mark GHC.AnnForeign + mark GHC.AnnImport + markLocated cconv + unless (ll == GHC.noSrcSpan) $ markLocated safety + markExternalSourceText ls src "" + markLocated ln + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + + markAST _l (GHC.ForeignExport _ ln (GHC.HsIB _ typ) (GHC.CExport spec (GHC.L ls src))) = do + mark GHC.AnnForeign + mark GHC.AnnExport + markLocated spec + markExternal ls GHC.AnnVal (sourceTextToString src "") + setContext (Set.singleton PrefixOp) $ markLocated ln + mark GHC.AnnDcolon + markLocated typ + + + markAST _ (GHC.ForeignImport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" + markAST _ (GHC.ForeignExport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" + markAST _ (GHC.XForeignDecl _) = error "markAST ForeignDecl hit extenstion" + +-- --------------------------------------------------------------------- + +instance (Annotate GHC.CExportSpec) where + markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv + +-- --------------------------------------------------------------------- + +instance (Annotate GHC.CCallConv) where + markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" + markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" + markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" + markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" + markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" + +-- --------------------------------------------------------------------- + +instance (Annotate GHC.Safety) where + markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" + markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" + markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.DerivDecl GHC.GhcPs) where + + markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do + mark GHC.AnnDeriving + markMaybe ms + mark GHC.AnnInstance + markMaybe mov + markLocated typ + markTrailingSemi + +{- +data DerivDecl pass = DerivDecl + { deriv_ext :: XCDerivDecl pass + , deriv_type :: LHsSigWcType pass + -- ^ The instance type to derive. + -- + -- It uses an 'LHsSigWcType' because the context is allowed to be a + -- single wildcard: + -- + -- > deriving instance _ => Eq (Foo a) + -- + -- Which signifies that the context should be inferred. + + -- See Note [Inferring the instance context] in TcDerivInfer. + + , deriv_strategy :: Maybe (LDerivStrategy pass) + , deriv_overlap_mode :: Maybe (Located OverlapMode) + +type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both + +data HsWildCardBndrs pass thing + -- See Note [HsType binders] + -- See Note [The wildcard story for types] + = HsWC { hswc_ext :: XHsWC pass thing + -- after the renamer + -- Wild cards, both named and anonymous + + , hswc_body :: thing + -- Main payload (type or list of types) + -- If there is an extra-constraints wildcard, + -- it's still there in the hsc_body. + } + + +-} + + + markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) _ _) = error "markAST DerivDecl hit extension" + markAST _ (GHC.DerivDecl _ (GHC.XHsWildCardBndrs _) _ _) = error "markAST DerivDecl hit extension" + markAST _ (GHC.XDerivDecl _) = error "markAST DerivDecl hit extension" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.DerivStrategy GHC.GhcPs) where + + markAST _ GHC.StockStrategy = mark GHC.AnnStock + markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass + markAST _ GHC.NewtypeStrategy = mark GHC.AnnNewtype + markAST _ (GHC.ViaStrategy (GHC.HsIB _ ty)) = do + mark GHC.AnnVia + markLocated ty + markAST _ (GHC.ViaStrategy (GHC.XHsImplicitBndrs _)) + = error $ "got XHsImplicitBndrs in AnnDerivStrategy" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.DefaultDecl GHC.GhcPs) where + + markAST _ (GHC.DefaultDecl _ typs) = do + mark GHC.AnnDefault + mark GHC.AnnOpenP -- '(' + markListIntercalate typs + mark GHC.AnnCloseP -- ')' + markTrailingSemi + + markAST _ (GHC.XDefaultDecl x) = error $ "got XDefaultDecl for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.InstDecl GHC.GhcPs) where + + markAST l (GHC.ClsInstD _ cid) = markAST l cid + markAST l (GHC.DataFamInstD _ dfid) = markAST l dfid + markAST l (GHC.TyFamInstD _ tfid) = markAST l tfid + markAST _ (GHC.XInstDecl x) = error $ "got XInstDecl for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate GHC.OverlapMode where + + -- NOTE: NoOverlap is only used in the typechecker + markAST _ (GHC.NoOverlap src) = do + markAnnOpen src "{-# NO_OVERLAP" + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlappable src) = do + markAnnOpen src "{-# OVERLAPPABLE" + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlapping src) = do + markAnnOpen src "{-# OVERLAPPING" + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlaps src) = do + markAnnOpen src "{-# OVERLAPS" + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Incoherent src) = do + markAnnOpen src "{-# INCOHERENT" + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where + + markAST _ (GHC.ClsInstDecl _ (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do + mark GHC.AnnInstance + markMaybe mov + markLocated poly + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + + applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) + ++ prepareListAnnotation sigs + ++ prepareListAnnotation tyfams + ++ prepareListAnnotation datafams + ) + + markOptional GHC.AnnCloseC -- '}' + markTrailingSemi + + markAST _ (GHC.ClsInstDecl _ (GHC.XHsImplicitBndrs _) _ _ _ _ _) = error "extension hit for ClsInstDecl" + markAST _ (GHC.XClsInstDecl _) = error "extension hit for ClsInstDecl" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where + + markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn)) = do + mark GHC.AnnType + mark GHC.AnnInstance -- Note: this keyword is optional + markFamEqn eqn + markTrailingSemi + + markAST _ (GHC.TyFamInstDecl (GHC.XHsImplicitBndrs _)) = error "extension hit for TyFamInstDecl" + +-- --------------------------------------------------------------------- + +markFamEqn :: (GHC.HasOccName (GHC.IdP pass), + Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2) + => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2) + -> Annotated () +markFamEqn (GHC.FamEqn _ ln pats fixity rhs) = do + markTyClass fixity ln pats + mark GHC.AnnEqual + markLocated rhs +markFamEqn (GHC.XFamEqn _) = error "got XFamEqn" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where + + markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln pats fixity + defn@(GHC.HsDataDefn _ nd ctx typ _mk cons mderivs) ))) = do + case GHC.dd_ND defn of + GHC.NewType -> mark GHC.AnnNewtype + GHC.DataType -> mark GHC.AnnData + mark GHC.AnnInstance + + markLocated ctx + + markTyClass fixity ln pats + + case (GHC.dd_kindSig defn) of + Just s -> do + mark GHC.AnnDcolon + markLocated s + Nothing -> return () + if isGadt $ GHC.dd_cons defn + then mark GHC.AnnWhere + else mark GHC.AnnEqual + markDataDefn l (GHC.HsDataDefn GHC.noExt nd (GHC.noLoc []) typ _mk cons mderivs) + markTrailingSemi + +{- +newtype DataFamInstDecl pass + = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) } + +type FamInstEqn pass rhs + = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) + +data FamEqn pass pats rhs + = FamEqn + { feqn_ext :: XCFamEqn pass pats rhs + , feqn_tycon :: Located (IdP pass) + , feqn_pats :: pats + , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration + , feqn_rhs :: rhs + } +-} + + markAST _ + (GHC.DataFamInstDecl + (GHC.HsIB _ (GHC.FamEqn _ _ _ _ (GHC.XHsDataDefn _)))) + = error "extension hit for DataFamInstDecl" + markAST _ (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.XFamEqn _))) + = error "extension hit for DataFamInstDecl" + markAST _ (GHC.DataFamInstDecl (GHC.XHsImplicitBndrs _)) + = error "extension hit for DataFamInstDecl" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsBind GHC.GhcPs) where + markAST _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _) = do + -- Note: from a layout perspective a FunBind should not exist, so the + -- current context is passed through unchanged to the matches. + -- TODO: perhaps bring the edp from the first match up to the annotation for + -- the FunBind. + let + tlFun = + ifInContext (Set.fromList [CtxOnly,CtxFirst]) + (markListWithContexts' listContexts matches) + (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) + ifInContext (Set.singleton TopLevel) + (setContextLevel (Set.singleton TopLevel) 2 tlFun) + tlFun + + -- ----------------------------------- + + markAST _ (GHC.PatBind _ lhs (GHC.GRHSs _ grhs (GHC.L _ lb)) _ticks) = do + markLocated lhs + case grhs of + (GHC.L _ (GHC.GRHS _ [] _):_) -> mark GHC.AnnEqual -- empty guards + _ -> return () + markListIntercalateWithFunLevel markLocated 2 grhs + + -- TODO: extract this common code + case lb of + GHC.EmptyLocalBinds{} -> return () + _ -> do + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + markLocalBindsWithLayout lb + markOptional GHC.AnnCloseC -- '}' + markTrailingSemi + + -- ----------------------------------- + + markAST _ (GHC.VarBind _ _n rhse _) = + -- Note: this bind is introduced by the typechecker + markLocated rhse + + -- ----------------------------------- + + -- Introduced after renaming. + markAST _ (GHC.AbsBinds {}) = + traceM "warning: AbsBinds introduced after renaming" + + -- ----------------------------------- + + markAST l (GHC.PatSynBind _ (GHC.PSB _ ln args def dir)) = do + mark GHC.AnnPattern + case args of + GHC.InfixCon la lb -> do + markLocated la + setContext (Set.singleton InfixOp) $ markLocated ln + markLocated lb + GHC.PrefixCon ns -> do + markLocated ln + mapM_ markLocated ns + GHC.RecCon fs -> do + markLocated ln + mark GHC.AnnOpenC -- '{' + markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs + mark GHC.AnnCloseC -- '}' + case dir of + GHC.ImplicitBidirectional -> mark GHC.AnnEqual + _ -> mark GHC.AnnLarrow + + markLocated def + case dir of + GHC.Unidirectional -> return () + GHC.ImplicitBidirectional -> return () + GHC.ExplicitBidirectional mg -> do + mark GHC.AnnWhere + mark GHC.AnnOpenC -- '{' + markMatchGroup l mg + mark GHC.AnnCloseC -- '}' + + markTrailingSemi + + -- ----------------------------------- + + markAST _ (GHC.FunBind _ _ (GHC.XMatchGroup _) _ _) + = error "extension hit for HsBind" + markAST _ (GHC.PatBind _ _ (GHC.XGRHSs _) _) + = error "extension hit for HsBind" + markAST _ (GHC.PatSynBind _ (GHC.XPatSynBind _)) + = error "extension hit for HsBind" + markAST _ (GHC.XHsBindsLR _) + = error "extension hit for HsBind" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.IPBind GHC.GhcPs) where + markAST _ (GHC.IPBind _ en e) = do + case en of + Left n -> markLocated n + Right _i -> return () + mark GHC.AnnEqual + markLocated e + markTrailingSemi + + -- markAST _ (GHC.XCIPBind x) = error $ "got XIPBind for:" ++ showGhc x + markAST _ (GHC.XIPBind x) = error $ "got XIPBind for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsIPName where + markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) + +-- --------------------------------------------------------------------- + +instance (Annotate body) + => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where + + markAST _ (GHC.Match _ mln pats (GHC.GRHSs _ grhs (GHC.L _ lb))) = do + let + get_infix (GHC.FunRhs _ f _) = f + get_infix _ = GHC.Prefix + + isFunBind GHC.FunRhs{} = True + isFunBind _ = False + case (get_infix mln,pats) of + (GHC.Infix, a:b:xs) -> do + if null xs + then markOptional GHC.AnnOpenP + else mark GHC.AnnOpenP + markLocated a + case mln of + GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n + _ -> return () + markLocated b + if null xs + then markOptional GHC.AnnCloseP + else mark GHC.AnnCloseP + mapM_ markLocated xs + _ -> do + annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] + inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam + case mln of + GHC.FunRhs n _ s -> do + setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do + when (s == GHC.SrcStrict) $ mark GHC.AnnBang + markLocated n + mapM_ markLocated pats + _ -> markListNoPrecedingSpace False pats + + -- TODO: The AnnEqual annotation actually belongs in the first GRHS value + case grhs of + (GHC.L _ (GHC.GRHS _ [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards + _ -> return () + inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam + mapM_ markLocated grhs + + case lb of + GHC.EmptyLocalBinds{} -> return () + _ -> do + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + markLocalBindsWithLayout lb + markOptional GHC.AnnCloseC -- '}' + markTrailingSemi + + -- ----------------------------------- + + markAST _ (GHC.Match _ _ _ (GHC.XGRHSs _)) + = error "hit extension for Match" + markAST _ (GHC.XMatch _) + = error "hit extension for Match" + +-- --------------------------------------------------------------------- + +instance (Annotate body) + => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where + markAST _ (GHC.GRHS _ guards expr) = do + case guards of + [] -> return () + (_:_) -> do + mark GHC.AnnVbar + unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) + $ markListIntercalate guards + ifInContext (Set.fromList [CaseAlt]) + (return ()) + (mark GHC.AnnEqual) + + markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test + + inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam + setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr + + markAST _ (GHC.XGRHS x) = error $ "got XGRHS for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.Sig GHC.GhcPs) where + + markAST _ (GHC.TypeSig _ lns st) = do + setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns + mark GHC.AnnDcolon + markLHsSigWcType st + markTrailingSemi + tellContext (Set.singleton FollowingLine) + + markAST _ (GHC.PatSynSig _ lns (GHC.HsIB _ typ)) = do + mark GHC.AnnPattern + markListIntercalate lns + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + + markAST _ (GHC.ClassOpSig _ isDefault ns (GHC.HsIB _ typ)) = do + when isDefault $ mark GHC.AnnDefault + setContext (Set.singleton PrefixOp) $ markListIntercalate ns + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + + markAST _ (GHC.IdSig {}) = + traceM "warning: Introduced after renaming" + + markAST _ (GHC.FixSig _ (GHC.FixitySig _ lns (GHC.Fixity src v fdir))) = do + let fixstr = case fdir of + GHC.InfixL -> "infixl" + GHC.InfixR -> "infixr" + GHC.InfixN -> "infix" + markWithString GHC.AnnInfix fixstr + markSourceText src (show v) + setContext (Set.singleton InfixOp) $ markListIntercalate lns + markTrailingSemi + + markAST l (GHC.InlineSig _ ln inl) = do + markAnnOpen (GHC.inl_src inl) "{-# INLINE" + markActivation l (GHC.inl_act inl) + setContext (Set.singleton PrefixOp) $ markLocated ln + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + markAST l (GHC.SpecSig _ ln typs inl) = do + markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE + markActivation l (GHC.inl_act inl) + markLocated ln + mark GHC.AnnDcolon -- '::' + markListIntercalateWithFunLevel markLHsSigType 2 typs + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + + markAST _ (GHC.SpecInstSig _ src typ) = do + markAnnOpen src "{-# SPECIALISE" + mark GHC.AnnInstance + markLHsSigType typ + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + + markAST _ (GHC.MinimalSig _ src formula) = do + markAnnOpen src "{-# MINIMAL" + markLocated formula + markWithString GHC.AnnClose "#-}" + markTrailingSemi + + markAST _ (GHC.SCCFunSig _ src ln ml) = do + markAnnOpen src "{-# SCC" + markLocated ln + markMaybe ml + markWithString GHC.AnnClose "#-}" + markTrailingSemi + + markAST _ (GHC.CompleteMatchSig _ src (GHC.L _ ns) mlns) = do + markAnnOpen src "{-# COMPLETE" + markListIntercalate ns + case mlns of + Nothing -> return () + Just _ -> do + mark GHC.AnnDcolon + markMaybe mlns + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + -- ----------------------------------- + markAST _ (GHC.PatSynSig _ _ (GHC.XHsImplicitBndrs _)) + = error "hit extension for Sig" + markAST _ (GHC.ClassOpSig _ _ _ (GHC.XHsImplicitBndrs _)) + = error "hit extension for Sig" + markAST _ (GHC.FixSig _ (GHC.XFixitySig _)) + = error "hit extension for Sig" + markAST _ (GHC.XSig _) + = error "hit extension for Sig" + +-- -------------------------------------------------------------------- + +markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated () +markLHsSigType (GHC.HsIB _ typ) = markLocated typ +markLHsSigType (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x + +instance Annotate [GHC.LHsSigType GHC.GhcPs] where + markAST _ ls = do + -- mark GHC.AnnDeriving + -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it + -- is a HsTyVar. So for round trip pretty printing we need to take this into + -- account. + let marker = case ls of + [] -> markManyOptional + [GHC.HsIB _ t] -> if GHC.hsTypeNeedsParens GHC.appPrec (GHC.unLoc t) + then markMany + else markManyOptional + _ -> markMany -- Need parens if more than one entry + marker GHC.AnnOpenP + markListIntercalateWithFun markLHsSigType ls + marker GHC.AnnCloseP + +-- -------------------------------------------------------------------- + +instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where + markAST _ (GHC.Var x) = do + setContext (Set.singleton PrefixOp) $ markLocated x + inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls + markAST _ (GHC.And ls) = do + markListIntercalateWithFunLevel markLocated 2 ls + inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + markAST _ (GHC.Parens x) = do + mark GHC.AnnOpenP -- '(' + markLocated x + mark GHC.AnnCloseP -- ')' + inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsTyVarBndr GHC.GhcPs) where + markAST _l (GHC.UserTyVar _ n) = do + markLocated n + + markAST _ (GHC.KindedTyVar _ n ty) = do + mark GHC.AnnOpenP -- '(' + markLocated n + mark GHC.AnnDcolon -- '::' + markLocated ty + mark GHC.AnnCloseP -- '(' + + markAST _l (GHC.XTyVarBndr x) = error $ "got XTyVarBndr for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsType GHC.GhcPs) where + markAST loc ty = do + markType loc ty + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) + where + + -- markType :: GHC.SrcSpan -> ast -> Annotated () + markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated () + markType _ (GHC.HsForAllTy _ tvs typ) = do + mark GHC.AnnForall + mapM_ markLocated tvs + mark GHC.AnnDot + markLocated typ + + markType _ (GHC.HsQualTy _ cxt typ) = do + markLocated cxt + markLocated typ + + markType _ (GHC.HsTyVar _ promoted name) = do + when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote + unsetContext InfixOp $ setContext (Set.singleton PrefixOp) $ markLocated name + + markType _ (GHC.HsAppTy _ t1 t2) = do + setContext (Set.singleton PrefixOp) $ markLocated t1 + markLocated t2 + + markType _ (GHC.HsFunTy _ t1 t2) = do + markLocated t1 + mark GHC.AnnRarrow + markLocated t2 + -- markManyOptional GHC.AnnCloseP -- For trailing parens after res_ty in ConDeclGADT + + markType _ (GHC.HsListTy _ t) = do + mark GHC.AnnOpenS -- '[' + markLocated t + mark GHC.AnnCloseS -- ']' + + markType _ (GHC.HsTupleTy _ tt ts) = do + case tt of + GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' + _ -> markWithString GHC.AnnOpen "(#" -- '(#' + markListIntercalateWithFunLevel markLocated 2 ts + case tt of + GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' + _ -> markWithString GHC.AnnClose "#)" -- '#)' + + markType _ (GHC.HsSumTy _ tys) = do + markWithString GHC.AnnOpen "(#" + markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys + markWithString GHC.AnnClose "#)" + + markType _ (GHC.HsOpTy _ t1 lo t2) = do + markLocated t1 + if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) + then do + markOptional GHC.AnnSimpleQuote + else do + mark GHC.AnnSimpleQuote + unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo + markLocated t2 + + markType _ (GHC.HsParTy _ t) = do + mark GHC.AnnOpenP -- '(' + markLocated t + mark GHC.AnnCloseP -- ')' + + markType _ (GHC.HsIParamTy _ n t) = do + markLocated n + mark GHC.AnnDcolon + markLocated t + + markType l (GHC.HsStarTy _ isUnicode) = do + if isUnicode + then markExternal l GHC.AnnVal "\x2605" -- Unicode star + else markExternal l GHC.AnnVal "*" + + markType _ (GHC.HsKindSig _ t k) = do + mark GHC.AnnOpenP -- '(' + markLocated t + mark GHC.AnnDcolon -- '::' + markLocated k + mark GHC.AnnCloseP -- ')' + + markType l (GHC.HsSpliceTy _ s) = do + markAST l s + + markType _ (GHC.HsDocTy _ t ds) = do + markLocated t + markLocated ds + + markType _ (GHC.HsBangTy _ (GHC.HsSrcBang mt _up str) t) = do + case mt of + GHC.NoSourceText -> return () + GHC.SourceText src -> do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + case str of + GHC.SrcLazy -> mark GHC.AnnTilde + GHC.SrcStrict -> mark GHC.AnnBang + GHC.NoSrcStrict -> return () + + markLocated t + + markType _ (GHC.HsRecTy _ cons) = do + mark GHC.AnnOpenC -- '{' + markListIntercalate cons + mark GHC.AnnCloseC -- '}' + + markType _ (GHC.HsExplicitListTy _ promoted ts) = do + when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote + mark GHC.AnnOpenS -- "[" + markListIntercalate ts + mark GHC.AnnCloseS -- ']' + + markType _ (GHC.HsExplicitTupleTy _ ts) = do + mark GHC.AnnSimpleQuote + mark GHC.AnnOpenP + markListIntercalate ts + mark GHC.AnnCloseP + + markType l (GHC.HsTyLit _ lit) = do + case lit of + (GHC.HsNumTy s v) -> + markExternalSourceText l s (show v) + (GHC.HsStrTy s v) -> + markExternalSourceText l s (show v) + + markType l (GHC.HsWildCardTy _) = do + markExternal l GHC.AnnVal "_" + + markType _ (GHC.XHsType x) = error $ "got XHsType for:" ++ showGhc x + + +-- --------------------------------------------------------------------- + +-- instance Annotate (GHC.HsAppType GHC.GhcPs) where +-- markAST _ (GHC.HsAppInfix _ n) = do +-- when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote +-- setContext (Set.singleton InfixOp) $ markLocated n +-- markAST _ (GHC.HsAppPrefix _ t) = do +-- markOptional GHC.AnnTilde +-- setContext (Set.singleton PrefixOp) $ markLocated t + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsSplice GHC.GhcPs) where + markAST l c = + case c of + GHC.HsQuasiQuote _ _ n _pos fs -> do + markExternal l GHC.AnnVal + -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 + ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") + + GHC.HsTypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do + when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE + if (hasParens == GHC.HasDollar) + then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) + else markLocated b + when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP + + GHC.HsTypedSplice _ hasParens _n b -> do + when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE + markLocated b + when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP + + -- ------------------------------- + + GHC.HsUntypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do + when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPE + if (hasParens == GHC.HasDollar) + then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) + else markLocated b + when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP + + GHC.HsUntypedSplice _ hasParens _n b -> do + case hasParens of + GHC.HasParens -> mark GHC.AnnOpenPE + GHC.HasDollar -> mark GHC.AnnThIdSplice + GHC.NoParens -> return () + markLocated b + when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP + + GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" + + -- ------------------------------- + + (GHC.XSplice x) -> error $ "got XSplice for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.ConDeclField GHC.GhcPs) where + markAST _ (GHC.ConDeclField _ ns ty mdoc) = do + unsetContext Intercalate $ do + markListIntercalate ns + mark GHC.AnnDcolon + markLocated ty + markMaybe mdoc + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + + markAST _ (GHC.XConDeclField x) = error $ "got XConDeclField for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.FieldOcc GHC.GhcPs) where + markAST _ (GHC.FieldOcc _ rn) = do + markLocated rn + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + + markAST _ (GHC.XFieldOcc x) = error $ "got XFieldOcc for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsDocString where + markAST l s = do + markExternal l GHC.AnnVal (GHC.unpackHDS s) + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.Pat GHC.GhcPs) where + markAST loc typ = do + markPat loc typ + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") + where + markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" + markPat l (GHC.VarPat _ n) = do + -- The parser inserts a placeholder value for a record pun rhs. This must be + -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is + -- resolved, particularly for pretty printing where annotations are added. + let pun_RDR = "pun-right-hand-side" + when (showGhc n /= pun_RDR) $ + unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) + markPat _ (GHC.LazyPat _ p) = do + mark GHC.AnnTilde + markLocated p + + markPat _ (GHC.AsPat _ ln p) = do + markLocated ln + mark GHC.AnnAt + markLocated p + + markPat _ (GHC.ParPat _ p) = do + mark GHC.AnnOpenP + markLocated p + mark GHC.AnnCloseP + + markPat _ (GHC.BangPat _ p) = do + mark GHC.AnnBang + markLocated p + + markPat _ (GHC.ListPat _ ps) = do + mark GHC.AnnOpenS + markListIntercalateWithFunLevel markLocated 2 ps + mark GHC.AnnCloseS + + markPat _ (GHC.TuplePat _ pats b) = do + if b == GHC.Boxed then mark GHC.AnnOpenP + else markWithString GHC.AnnOpen "(#" + markListIntercalateWithFunLevel markLocated 2 pats + if b == GHC.Boxed then mark GHC.AnnCloseP + else markWithString GHC.AnnClose "#)" + + markPat _ (GHC.SumPat _ pat alt arity) = do + markWithString GHC.AnnOpen "(#" + replicateM_ (alt - 1) $ mark GHC.AnnVbar + markLocated pat + replicateM_ (arity - alt) $ mark GHC.AnnVbar + markWithString GHC.AnnClose "#)" + + markPat _ (GHC.ConPatIn n dets) = do + markHsConPatDetails n dets + + markPat _ GHC.ConPatOut {} = + traceM "warning: ConPatOut Introduced after renaming" + + markPat _ (GHC.ViewPat _ e pat) = do + markLocated e + mark GHC.AnnRarrow + markLocated pat + + markPat l (GHC.SplicePat _ s) = do + markAST l s + + markPat l (GHC.LitPat _ lp) = markAST l lp + + markPat _ (GHC.NPat _ ol mn _) = do + when (isJust mn) $ mark GHC.AnnMinus + markLocated ol + + markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do + markLocated ln + markWithString GHC.AnnVal "+" -- "+" + markLocated ol + + + markPat _ (GHC.SigPat ty pat) = do + markLocated pat + mark GHC.AnnDcolon + markLHsSigWcType ty + + markPat _ GHC.CoPat {} = + traceM "warning: CoPat introduced after renaming" + + markPat _ (GHC.XPat x) = error $ "got XPat for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +hsLit2String :: GHC.HsLit GHC.GhcPs -> String +hsLit2String lit = + case lit of + GHC.HsChar src v -> toSourceTextWithSuffix src v "" + -- It should be included here + -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 + GHC.HsCharPrim src p -> toSourceTextWithSuffix src p "#" + GHC.HsString src v -> toSourceTextWithSuffix src v "" + GHC.HsStringPrim src v -> toSourceTextWithSuffix src v "" + GHC.HsInt _ (GHC.IL src _ v) -> toSourceTextWithSuffix src v "" + GHC.HsIntPrim src v -> toSourceTextWithSuffix src v "" + GHC.HsWordPrim src v -> toSourceTextWithSuffix src v "" + GHC.HsInt64Prim src v -> toSourceTextWithSuffix src v "" + GHC.HsWord64Prim src v -> toSourceTextWithSuffix src v "" + GHC.HsInteger src v _ -> toSourceTextWithSuffix src v "" + GHC.HsRat _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v "" + GHC.HsFloatPrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "#" + GHC.HsDoublePrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "##" + (GHC.XLit x) -> error $ "got XLit for:" ++ showGhc x + +toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String +toSourceTextWithSuffix (GHC.NoSourceText) alt suffix = show alt ++ suffix +toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix + +-- -------------------------------------------------------------------- + +markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated () +markHsConPatDetails ln dets = do + case dets of + GHC.PrefixCon args -> do + setContext (Set.singleton PrefixOp) $ markLocated ln + mapM_ markLocated args + GHC.RecCon (GHC.HsRecFields fs dd) -> do + markLocated ln + mark GHC.AnnOpenC -- '{' + case dd of + Nothing -> markListIntercalateWithFunLevel markLocated 2 fs + Just _ -> do + setContext (Set.singleton Intercalate) $ mapM_ markLocated fs + mark GHC.AnnDotdot + mark GHC.AnnCloseC -- '}' + GHC.InfixCon a1 a2 -> do + markLocated a1 + unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln + markLocated a2 + +markHsConDeclDetails :: + Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated () + +markHsConDeclDetails isDeprecated inGadt lns dets = do + case dets of + GHC.PrefixCon args -> + setContext (Set.singleton PrefixOp) $ mapM_ markLocated args + -- GHC.RecCon fs -> markLocated fs + GHC.RecCon fs -> do + mark GHC.AnnOpenC + if inGadt + then do + if isDeprecated + then setContext (Set.fromList [InGadt]) $ markLocated fs + else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs + else do + if isDeprecated + then markLocated fs + else setContext (Set.fromList [InRecCon]) $ markLocated fs + GHC.InfixCon a1 a2 -> do + markLocated a1 + setContext (Set.singleton InfixOp) $ mapM_ markLocated lns + markLocated a2 + +-- --------------------------------------------------------------------- + +instance Annotate [GHC.LConDeclField GHC.GhcPs] where + markAST _ fs = do + markOptional GHC.AnnOpenC -- '{' + markListIntercalate fs + markOptional GHC.AnnDotdot + inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' + inContext (Set.singleton InGadt) $ do + mark GHC.AnnRarrow + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsOverLit GHC.GhcPs) where + markAST l ol = + let str = case GHC.ol_val ol of + GHC.HsIntegral (GHC.IL src _ _) -> src + GHC.HsFractional (GHC.FL src _ _) -> src + GHC.HsIsString src _ -> src + in + markExternalSourceText l str "" + +-- --------------------------------------------------------------------- + +instance (Annotate arg) + => Annotate (GHC.HsImplicitBndrs GHC.GhcPs (GHC.Located arg)) where + markAST _ (GHC.HsIB _ thing) = do + markLocated thing + markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance (Annotate body) => Annotate (GHC.Stmt GHC.GhcPs (GHC.Located body)) where + + markAST _ (GHC.LastStmt _ body _ _) + = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body + + markAST _ (GHC.BindStmt _ pat body _ _) = do + unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat + mark GHC.AnnLarrow + unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body + + ifInContext (Set.singleton Intercalate) + (mark GHC.AnnComma) + (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) + markTrailingSemi + + markAST _ GHC.ApplicativeStmt{} + = error "ApplicativeStmt should not appear in ParsedSource" + + markAST _ (GHC.BodyStmt _ body _ _) = do + unsetContext Intercalate $ markLocated body + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + + markAST _ (GHC.LetStmt _ (GHC.L _ lb)) = do + mark GHC.AnnLet + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + markLocalBindsWithLayout lb + markOptional GHC.AnnCloseC -- '}' + ifInContext (Set.singleton Intercalate) + (mark GHC.AnnComma) + (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) + markTrailingSemi + + markAST l (GHC.ParStmt _ pbs _ _) = do + -- Within a given parallel list comprehension,one of the sections to be done + -- in parallel. It is a normal list comprehension, so has a list of + -- ParStmtBlock, one for each part of the sub- list comprehension + + + ifInContext (Set.singleton Intercalate) + ( + + unsetContext Intercalate $ + markListWithContextsFunction + (LC (Set.singleton Intercalate) -- only + Set.empty -- first + Set.empty -- middle + (Set.singleton Intercalate) -- last + ) (markAST l) pbs + ) + ( + unsetContext Intercalate $ + markListWithContextsFunction + (LC Set.empty -- only + (Set.fromList [AddVbar]) -- first + (Set.fromList [AddVbar]) -- middle + Set.empty -- last + ) (markAST l) pbs + ) + markTrailingSemi + + markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do + setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts + case form of + GHC.ThenForm -> do + mark GHC.AnnThen + unsetContext Intercalate $ markLocated using + case by of + Just b -> do + mark GHC.AnnBy + unsetContext Intercalate $ markLocated b + Nothing -> return () + GHC.GroupForm -> do + mark GHC.AnnThen + mark GHC.AnnGroup + case by of + Just b -> mark GHC.AnnBy >> markLocated b + Nothing -> return () + mark GHC.AnnUsing + markLocated using + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + + markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do + mark GHC.AnnRec + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + mapM_ markLocated stmts + markOptional GHC.AnnCloseC + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + + markAST _ (GHC.XStmtLR x) = error $ "got XStmtLR for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +-- Note: We never have a located ParStmtBlock, so have nothing to hang the +-- annotation on. This means there is no pushing of context from the parent ParStmt. +instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where + markAST _ (GHC.ParStmtBlock _ stmts _ns _) = do + markListIntercalate stmts + markAST _ (GHC.XParStmtBlock x) = error $ "got XParStmtBlock for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where + markAST _ lb = markHsLocalBinds lb + +-- --------------------------------------------------------------------- + +markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () +markHsLocalBinds (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)) = + applyListAnnotationsLayout + (prepareListAnnotation (GHC.bagToList binds) + ++ prepareListAnnotation sigs + ) +markHsLocalBinds (GHC.HsIPBinds _ (GHC.IPBinds _ binds)) = markListWithLayout binds +markHsLocalBinds GHC.EmptyLocalBinds{} = return () + +markHsLocalBinds (GHC.HsValBinds _ (GHC.XValBindsLR _)) = error "markHsLocalBinds:got extension" +markHsLocalBinds (GHC.HsIPBinds _ (GHC.XHsIPBinds _)) = error "markHsLocalBinds:got extension" +markHsLocalBinds (GHC.XHsLocalBindsLR _) = error "markHsLocalBinds:got extension" + +-- --------------------------------------------------------------------- + +markMatchGroup :: (Annotate body) + => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body) + -> Annotated () +markMatchGroup _ (GHC.MG _ (GHC.L _ matches) _) + = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches +markMatchGroup _ (GHC.XMatchGroup x) = error $ "got XMatchGroup for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance (Annotate body) + => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsExpr GHC.GhcPs) where + markAST loc expr = do + markExpr loc expr + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + -- TODO: If the AnnComma is not needed, revert to markAST + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + where + markExpr _ (GHC.HsVar _ n) = unsetContext Intercalate $ do + ifInContext (Set.singleton PrefixOp) + (setContext (Set.singleton PrefixOp) $ markLocated n) + (ifInContext (Set.singleton InfixOp) + (setContext (Set.singleton InfixOp) $ markLocated n) + (markLocated n) + ) + + markExpr l (GHC.HsRecFld _ f) = markAST l f + + markExpr l (GHC.HsOverLabel _ _ fs) + = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) + + + markExpr l (GHC.HsIPVar _ n@(GHC.HsIPName _v)) = + markAST l n + markExpr l (GHC.HsOverLit _ ov) = markAST l ov + markExpr l (GHC.HsLit _ lit) = markAST l lit + + markExpr _ (GHC.HsLam _ (GHC.MG _ (GHC.L _ [match]) _)) = do + setContext (Set.singleton LambdaExpr) $ do + -- TODO: Change this, HsLam binds do not need obey layout rules. + -- And will only ever have a single match + markLocated match + markExpr _ (GHC.HsLam _ _) = error $ "HsLam with other than one match" + + markExpr l (GHC.HsLamCase _ match) = do + mark GHC.AnnLam + mark GHC.AnnCase + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + markMatchGroup l match + markOptional GHC.AnnCloseC + + markExpr _ (GHC.HsApp _ e1 e2) = do + setContext (Set.singleton PrefixOp) $ markLocated e1 + setContext (Set.singleton PrefixOp) $ markLocated e2 + + markExpr _ (GHC.OpApp _ e1 e2 e3) = do + let + isInfix = case e2 of + -- TODO: generalise this. Is it a fixity thing? + GHC.L _ (GHC.HsVar{}) -> True + _ -> False + + normal = + -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context + ifInContext (Set.singleton LeftMost) + (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) + (markLocated e1) + + if isInfix + then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 + else normal + + unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 + + if isInfix + then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 + else markLocated e3 + + markExpr _ (GHC.NegApp _ e _) = do + mark GHC.AnnMinus + markLocated e + + markExpr _ (GHC.HsPar _ e) = do + mark GHC.AnnOpenP -- '(' + markLocated e + mark GHC.AnnCloseP -- ')' + + markExpr _ (GHC.SectionL _ e1 e2) = do + markLocated e1 + setContext (Set.singleton InfixOp) $ markLocated e2 + + markExpr _ (GHC.SectionR _ e1 e2) = do + setContext (Set.singleton InfixOp) $ markLocated e1 + markLocated e2 + + markExpr _ (GHC.ExplicitTuple _ args b) = do + if b == GHC.Boxed then mark GHC.AnnOpenP + else markWithString GHC.AnnOpen "(#" + + setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args + + if b == GHC.Boxed then mark GHC.AnnCloseP + else markWithString GHC.AnnClose "#)" + + markExpr _ (GHC.ExplicitSum _ alt arity e) = do + markWithString GHC.AnnOpen "(#" + replicateM_ (alt - 1) $ mark GHC.AnnVbar + markLocated e + replicateM_ (arity - alt) $ mark GHC.AnnVbar + markWithString GHC.AnnClose "#)" + + markExpr l (GHC.HsCase _ e1 matches) = setRigidFlag $ do + mark GHC.AnnCase + setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 + mark GHC.AnnOf + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + setContext (Set.singleton CaseAlt) $ markMatchGroup l matches + markOptional GHC.AnnCloseC + + -- We set the layout for HsIf even though it need not obey layout rules as + -- when moving these expressions it's useful that they maintain "internal + -- integrity", that is to say the subparts remain indented relative to each + -- other. + markExpr _ (GHC.HsIf _ _ e1 e2 e3) = setLayoutFlag $ do + -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do + mark GHC.AnnIf + markLocated e1 + markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen + mark GHC.AnnThen + setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 + markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse + mark GHC.AnnElse + setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 + + markExpr _ (GHC.HsMultiIf _ rhs) = do + mark GHC.AnnIf + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + -- mapM_ markLocated rhs + markListWithLayout rhs + markOptional GHC.AnnCloseC + + markExpr _ (GHC.HsLet _ (GHC.L _ binds) e) = do + setLayoutFlag (do -- Make sure the 'in' gets indented too + mark GHC.AnnLet + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + markLocalBindsWithLayout binds + markOptional GHC.AnnCloseC + mark GHC.AnnIn + markLocated e) + + -- ------------------------------- + + markExpr _ (GHC.HsDo _ cts (GHC.L _ es)) = do + case cts of + GHC.DoExpr -> mark GHC.AnnDo + GHC.MDoExpr -> mark GHC.AnnMdo + _ -> return () + let (ostr,cstr) = + if isListComp cts + then ("[", "]") + else ("{", "}") + + when (isListComp cts) $ markWithString GHC.AnnOpen ostr + markOptional GHC.AnnOpenS + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + if isListComp cts + then do + markLocated (last es) + mark GHC.AnnVbar + setLayoutFlag (markListIntercalate (init es)) + else do + markListWithLayout es + markOptional GHC.AnnCloseS + markOptional GHC.AnnCloseC + when (isListComp cts) $ markWithString GHC.AnnClose cstr + + -- ------------------------------- + + markExpr _ (GHC.ExplicitList _ _ es) = do + mark GHC.AnnOpenS + setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es + mark GHC.AnnCloseS + + markExpr _ (GHC.RecordCon _ n (GHC.HsRecFields fs dd)) = do + markLocated n + mark GHC.AnnOpenC + case dd of + Nothing -> markListIntercalate fs + Just _ -> do + setContext (Set.singleton Intercalate) $ mapM_ markLocated fs + mark GHC.AnnDotdot + mark GHC.AnnCloseC + + markExpr _ (GHC.RecordUpd _ e fs) = do + markLocated e + mark GHC.AnnOpenC + markListIntercalate fs + mark GHC.AnnCloseC + + markExpr _ (GHC.ExprWithTySig typ e) = do + setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e + mark GHC.AnnDcolon + markLHsSigWcType typ + + markExpr _ (GHC.ArithSeq _ _ seqInfo) = do + mark GHC.AnnOpenS -- '[' + case seqInfo of + GHC.From e -> do + markLocated e + mark GHC.AnnDotdot + GHC.FromTo e1 e2 -> do + markLocated e1 + mark GHC.AnnDotdot + markLocated e2 + GHC.FromThen e1 e2 -> do + markLocated e1 + mark GHC.AnnComma + markLocated e2 + mark GHC.AnnDotdot + GHC.FromThenTo e1 e2 e3 -> do + markLocated e1 + mark GHC.AnnComma + markLocated e2 + mark GHC.AnnDotdot + markLocated e3 + mark GHC.AnnCloseS -- ']' + + markExpr _ (GHC.HsSCC _ src csFStr e) = do + markAnnOpen src "{-# SCC" + let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) + markWithStringOptional GHC.AnnVal txt + markWithString GHC.AnnValStr txt + markWithString GHC.AnnClose "#-}" + markLocated e + + markExpr _ (GHC.HsCoreAnn _ src csFStr e) = do + -- markWithString GHC.AnnOpen src -- "{-# CORE" + markAnnOpen src "{-# CORE" + -- markWithString GHC.AnnVal (GHC.sl_st csFStr) + markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) + markWithString GHC.AnnClose "#-}" + markLocated e + -- TODO: make monomorphic + markExpr l (GHC.HsBracket _ (GHC.VarBr _ True v)) = do + mark GHC.AnnSimpleQuote + setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) + markExpr l (GHC.HsBracket _ (GHC.VarBr _ False v)) = do + mark GHC.AnnThTyQuote + markLocatedFromKw GHC.AnnName (GHC.L l v) + markExpr _ (GHC.HsBracket _ (GHC.DecBrL _ ds)) = do + markWithString GHC.AnnOpen "[d|" + markOptional GHC.AnnOpenC + setContext (Set.singleton NoAdvanceLine) + $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds + markOptional GHC.AnnCloseC + mark GHC.AnnCloseQ -- "|]" + -- Introduced after the renamer + markExpr _ (GHC.HsBracket _ (GHC.DecBrG _ _)) = + traceM "warning: DecBrG introduced after renamer" + markExpr _l (GHC.HsBracket _ (GHC.ExpBr _ e)) = do + mark GHC.AnnOpenEQ -- "[|" + markOptional GHC.AnnOpenE -- "[e|" + markLocated e + mark GHC.AnnCloseQ -- "|]" + markExpr _l (GHC.HsBracket _ (GHC.TExpBr _ e)) = do + markWithString GHC.AnnOpen "[||" + markWithStringOptional GHC.AnnOpenE "[e||" + markLocated e + markWithString GHC.AnnClose "||]" + markExpr _ (GHC.HsBracket _ (GHC.TypBr _ e)) = do + markWithString GHC.AnnOpen "[t|" + markLocated e + mark GHC.AnnCloseQ -- "|]" + markExpr _ (GHC.HsBracket _ (GHC.PatBr _ e)) = do + markWithString GHC.AnnOpen "[p|" + markLocated e + mark GHC.AnnCloseQ -- "|]" + + markExpr _ (GHC.HsRnBracketOut {}) = + traceM "warning: HsRnBracketOut introduced after renamer" + markExpr _ (GHC.HsTcBracketOut {}) = + traceM "warning: HsTcBracketOut introduced after renamer" + + markExpr l (GHC.HsSpliceE _ e) = markAST l e + + markExpr _ (GHC.HsProc _ p c) = do + mark GHC.AnnProc + markLocated p + mark GHC.AnnRarrow + markLocated c + + markExpr _ (GHC.HsStatic _ e) = do + mark GHC.AnnStatic + markLocated e + + markExpr _ (GHC.HsArrApp _ e1 e2 o isRightToLeft) = do + -- isRightToLeft True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + if isRightToLeft + then do + markLocated e1 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail + else do + markLocated e2 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail + + if isRightToLeft + then markLocated e2 + else markLocated e1 + + markExpr _ (GHC.HsArrForm _ e _ cs) = do + markWithString GHC.AnnOpenB "(|" + markLocated e + mapM_ markLocated cs + markWithString GHC.AnnCloseB "|)" + + markExpr _ (GHC.HsTick {}) = return () + markExpr _ (GHC.HsBinTick {}) = return () + + markExpr _ (GHC.HsTickPragma _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do + -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' + markAnnOpen src "{-# GENERATED" + markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING + + let + markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) + markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s + + markOne 1 v1 s1 -- INTEGER + markOffset GHC.AnnColon 0 -- ':' + markOne 2 v2 s2 -- INTEGER + mark GHC.AnnMinus -- '-' + markOne 3 v3 s3 -- INTEGER + markOffset GHC.AnnColon 1 -- ':' + markOne 4 v4 s4 -- INTEGER + markWithString GHC.AnnClose "#-}" + markLocated e + + markExpr l (GHC.EWildPat _) = do + ifInContext (Set.fromList [InfixOp]) + (do mark GHC.AnnBackquote + markWithString GHC.AnnVal "_" + mark GHC.AnnBackquote) + (markExternal l GHC.AnnVal "_") + + markExpr _ (GHC.EAsPat _ ln e) = do + markLocated ln + mark GHC.AnnAt + markLocated e + + markExpr _ (GHC.EViewPat _ e1 e2) = do + markLocated e1 + mark GHC.AnnRarrow + markLocated e2 + + markExpr _ (GHC.ELazyPat _ e) = do + mark GHC.AnnTilde + markLocated e + + markExpr _ (GHC.HsAppType ty e) = do + markLocated e + markInstead GHC.AnnAt AnnTypeApp + markLHsWcType ty + + markExpr _ (GHC.HsWrap {}) = + traceM "warning: HsWrap introduced after renaming" + markExpr _ (GHC.HsUnboundVar {}) = + traceM "warning: HsUnboundVar introduced after renaming" + + markExpr _ (GHC.HsConLikeOut{}) = + traceM "warning: HsConLikeOut introduced after type checking" + + markExpr _ (GHC.HsBracket _ (GHC.XBracket _)) = error "markExpr got extension" + markExpr _ (GHC.XExpr _) = error "markExpr got extension" + +-- --------------------------------------------------------------------- + +markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated () +markLHsWcType (GHC.HsWC _ ty) = do + markLocated ty +markLHsWcType (GHC.XHsWildCardBndrs x) = error $ "markLHsWcType got :" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsLit GHC.GhcPs) where + markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where + markAST _ (GHC.HsRecField lbl expr punFlag) = do + unsetContext Intercalate $ markLocated lbl + when (punFlag == False) $ do + mark GHC.AnnEqual + unsetContext Intercalate $ markLocated expr + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +instance Annotate (GHC.AmbiguousFieldOcc GHC.GhcPs) where + markAST _ (GHC.Unambiguous _ n) = markLocated n + markAST _ (GHC.Ambiguous _ n) = markLocated n + markAST _ (GHC.XAmbiguousFieldOcc x) = error $ "got XAmbiguousFieldOcc for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +-- |Used for declarations that need to be aligned together, e.g. in a +-- do or let .. in statement/expr +instance Annotate [GHC.ExprLStmt GHC.GhcPs] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsTupArg GHC.GhcPs) where + markAST _ (GHC.Present _ (GHC.L l e)) = do + markLocated (GHC.L l e) + inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) + + markAST _ (GHC.Missing _) = do + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + + markAST _ (GHC.XTupArg x) = error $ "got XTupArg got:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsCmdTop GHC.GhcPs) where + markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd + markAST _ (GHC.XCmdTop x) = error $ "got XCmdTop for:" ++ showGhc x + +instance Annotate (GHC.HsCmd GHC.GhcPs) where + markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do + -- isRightToLeft True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + if isRightToLeft + then do + markLocated e1 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail + else do + markLocated e2 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail + + if isRightToLeft + then markLocated e2 + else markLocated e1 + + markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do + -- The AnnOpen should be marked for a prefix usage, not for a postfix one, + -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm + + let isPrefixOp = case fixity of + GHC.Infix -> False + GHC.Prefix -> True + when isPrefixOp $ mark GHC.AnnOpenB -- "(|" + + -- This may be an infix operation + applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) + (Set.singleton InfixOp) (Set.singleton InfixOp)) + (prepareListAnnotation [e] + ++ prepareListAnnotation cs) + when isPrefixOp $ mark GHC.AnnCloseB -- "|)" + + markAST _ (GHC.HsCmdApp _ e1 e2) = do + markLocated e1 + markLocated e2 + + markAST l (GHC.HsCmdLam _ match) = do + setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match + + markAST _ (GHC.HsCmdPar _ e) = do + mark GHC.AnnOpenP + markLocated e + mark GHC.AnnCloseP -- ')' + + markAST l (GHC.HsCmdCase _ e1 matches) = do + mark GHC.AnnCase + markLocated e1 + mark GHC.AnnOf + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + markMatchGroup l matches + markOptional GHC.AnnCloseC + + markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do + mark GHC.AnnIf + markLocated e1 + markOffset GHC.AnnSemi 0 + mark GHC.AnnThen + markLocated e2 + markOffset GHC.AnnSemi 1 + mark GHC.AnnElse + markLocated e3 + + markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do + mark GHC.AnnLet + markOptional GHC.AnnOpenC + markLocalBindsWithLayout binds + markOptional GHC.AnnCloseC + mark GHC.AnnIn + markLocated e + + markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do + mark GHC.AnnDo + markOptional GHC.AnnOpenC + markListWithLayout es + markOptional GHC.AnnCloseC + + markAST _ (GHC.HsCmdWrap {}) = + traceM "warning: HsCmdWrap introduced after renaming" + + markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.TyClDecl GHC.GhcPs) where + + markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi + + markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity typ) = 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 + -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] + mark GHC.AnnType + + markTyClass fixity ln tyvars + mark GHC.AnnEqual + markLocated typ + markTrailingSemi + + markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity + (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do + if nd == GHC.DataType + then mark GHC.AnnData + else mark GHC.AnnNewtype + markMaybe mctyp + markLocated ctx + markTyClass fixity ln tyVars + case mk of + Nothing -> return () + Just k -> do + mark GHC.AnnDcolon + markLocated k + if isGadt cons + then mark GHC.AnnWhere + else unless (null cons) $ mark GHC.AnnEqual + markOptional GHC.AnnWhere + markOptional GHC.AnnOpenC + setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) + $ markListWithContexts' listContexts cons + markOptional GHC.AnnCloseC + setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs + markTrailingSemi + + -- ----------------------------------- + + markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds + sigs meths ats atdefs docs) = do + mark GHC.AnnClass + markLocated ctx + + markTyClass fixity ln tyVars + + unless (null fds) $ do + mark GHC.AnnVbar + markListIntercalateWithFunLevel markLocated 2 fds + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + -- AZ:TODO: we end up with both the tyVars and the following body of the + -- class defn in annSortKey for the class. This could cause problems when + -- changing things. + setContext (Set.singleton InClassDecl) $ + applyListAnnotationsLayout + (prepareListAnnotation sigs + ++ prepareListAnnotation (GHC.bagToList meths) + ++ prepareListAnnotation ats + ++ prepareListAnnotation atdefs + ++ prepareListAnnotation docs + ) + markOptional GHC.AnnCloseC -- '}' + markTrailingSemi +{- + | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs + tcdCtxt :: LHsContext pass, -- ^ Context... + tcdLName :: Located (IdP pass), -- ^ Name of the class + tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables + tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration + tcdFDs :: [Located (FunDep (Located (IdP pass)))], + -- ^ Functional deps + tcdSigs :: [LSig pass], -- ^ Methods' signatures + tcdMeths :: LHsBinds pass, -- ^ Default methods + tcdATs :: [LFamilyDecl pass], -- ^ Associated types; + tcdATDefs :: [LTyFamDefltEqn pass], + -- ^ Associated type defaults + tcdDocs :: [LDocDecl] -- ^ Haddock docs + } + +-} + + markAST _ (GHC.SynDecl _ _ (GHC.XLHsQTyVars _) _ _) + = error "extension hit for TyClDecl" + markAST _ (GHC.DataDecl _ _ (GHC.HsQTvs _ _) _ (GHC.XHsDataDefn _)) + = error "extension hit for TyClDecl" + markAST _ (GHC.DataDecl _ _ (GHC.XLHsQTyVars _) _ _) + = error "extension hit for TyClDecl" + markAST _ (GHC.ClassDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _ _ _ _ _) + = error "extension hit for TyClDecl" + markAST _ (GHC.XTyClDecl _) + = error "extension hit for TyClDecl" + +-- --------------------------------------------------------------------- + +markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) + => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated () +markTyClass fixity ln tyVars = do + -- There may be arbitrary parens around parts of the constructor + -- Turn these into comments so that they feed into the right place automatically + annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] + let markParens = if fixity == GHC.Infix && length tyVars > 2 + then markMany + else markManyOptional + if fixity == GHC.Prefix + then do + markManyOptional GHC.AnnOpenP + setContext (Set.singleton PrefixOp) $ markLocated ln + -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars + setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ take 2 tyVars + when (length tyVars >= 2) $ do + markParens GHC.AnnCloseP + setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ drop 2 tyVars + markManyOptional GHC.AnnCloseP + else do + case tyVars of + (x:y:xs) -> do + markParens GHC.AnnOpenP + markLocated x + setContext (Set.singleton InfixOp) $ markLocated ln + markLocated y + markParens GHC.AnnCloseP + mapM_ markLocated xs + markManyOptional GHC.AnnCloseP + _ -> error $ "markTyClass: Infix op without operands" + +-- --------------------------------------------------------------------- + +instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where + markAST _ ds = mapM_ markLocated ds + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where + markAST _ (GHC.HsDerivingClause _ mstrategy typs) = do + mark GHC.AnnDeriving + case mstrategy of + Nothing -> return () + Just (GHC.L _ (GHC.ViaStrategy{})) -> return () + Just s -> markLocated s + markLocated typs + case mstrategy of + Just s@(GHC.L _ (GHC.ViaStrategy{})) -> markLocated s + _ -> return () + + markAST _ (GHC.XHsDerivingClause x) = error $ "got XHsDerivingClause for:" ++ showGhc x + +{- + = HsDerivingClause + { deriv_clause_ext :: XCHsDerivingClause pass + , deriv_clause_strategy :: Maybe (LDerivStrategy pass) + -- ^ The user-specified strategy (if any) to use when deriving + -- 'deriv_clause_tys'. + , deriv_clause_tys :: Located [LHsSigType pass] + -- ^ The types to derive. + -- + -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, + -- we can mention type variables that aren't bound by the datatype, e.g. + -- + -- > data T b = ... deriving (C [a]) + -- + -- should produce a derived instance for @C [a] (T b)@. + } + +-} + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.FamilyDecl GHC.GhcPs) where + markAST _ (GHC.FamilyDecl _ info ln (GHC.HsQTvs _ tyvars) fixity rsig minj) = do + case info of + GHC.DataFamily -> mark GHC.AnnData + _ -> mark GHC.AnnType + + mark GHC.AnnFamily + + markTyClass fixity ln tyvars + case GHC.unLoc rsig of + GHC.NoSig _ -> return () + GHC.KindSig _ _ -> do + mark GHC.AnnDcolon + markLocated rsig + GHC.TyVarSig _ _ -> do + mark GHC.AnnEqual + markLocated rsig + (GHC.XFamilyResultSig x) -> error $ "FamilyDecl:got XFamilyResultSig for:" ++ showGhc x + case minj of + Nothing -> return () + Just inj -> do + mark GHC.AnnVbar + markLocated inj + case info of + GHC.ClosedTypeFamily (Just eqns) -> do + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- { + markListWithLayout eqns + markOptional GHC.AnnCloseC -- } + GHC.ClosedTypeFamily Nothing -> do + mark GHC.AnnWhere + mark GHC.AnnOpenC -- { + mark GHC.AnnDotdot + mark GHC.AnnCloseC -- } + _ -> return () + markTrailingSemi + + markAST _ (GHC.FamilyDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _) + = error "got extension for FamilyDecl" + markAST _ (GHC.XFamilyDecl _) + = error "got extension for FamilyDecl" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where + markAST _ (GHC.NoSig _) = return () + markAST _ (GHC.KindSig _ k) = markLocated k + markAST _ (GHC.TyVarSig _ ltv) = markLocated ltv + markAST _ (GHC.XFamilyResultSig x) = error $ "got XFamilyResultSig for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where + markAST _ (GHC.InjectivityAnn ln lns) = do + markLocated ln + mark GHC.AnnRarrow + mapM_ markLocated lns + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where + + markAST _ (GHC.HsIB _ eqn) = do + markFamEqn eqn + markTrailingSemi + markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where + + markAST _ (GHC.FamEqn _ ln (GHC.HsQTvs _ bndrs) fixity typ) = do + mark GHC.AnnType + mark GHC.AnnInstance + markTyClass fixity ln bndrs + mark GHC.AnnEqual + markLocated typ + + markAST _ (GHC.FamEqn _ _ (GHC.XLHsQTyVars _) _ _) + = error "TyFamDefltEqn hit extension point" + markAST _ (GHC.XFamEqn _) + = error "TyFamDefltEqn hit extension point" + +-- --------------------------------------------------------------------- + +-- TODO: modify lexer etc, in the meantime to not set haddock flag +instance Annotate GHC.DocDecl where + markAST l v = + let str = + case v of + (GHC.DocCommentNext ds) -> GHC.unpackHDS ds + (GHC.DocCommentPrev ds) -> GHC.unpackHDS ds + (GHC.DocCommentNamed _s ds) -> GHC.unpackHDS ds + (GHC.DocGroup _i ds) -> GHC.unpackHDS ds + in + markExternal l GHC.AnnVal str >> markTrailingSemi +{- +data DocDecl + = DocCommentNext HsDocString + | DocCommentPrev HsDocString + | DocCommentNamed String HsDocString + | DocGroup Int HsDocString + +-} + +-- --------------------------------------------------------------------- + +markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.GhcPs -> Annotated () +markDataDefn _ (GHC.HsDataDefn _ _ ctx typ _mk cons derivs) = do + markLocated ctx + markMaybe typ + if isGadt cons + then markListWithLayout cons + else markListIntercalateWithFunLevel markLocated 2 cons + setContext (Set.singleton Deriving) $ markLocated derivs +markDataDefn _ (GHC.XHsDataDefn x) = error $ "got XHsDataDefn for:" ++ showGhc x + +-- --------------------------------------------------------------------- + +-- Note: GHC.HsContext name aliases to here too +instance Annotate [GHC.LHsType GHC.GhcPs] where + markAST l ts = do + -- Note: A single item in parens in a standalone deriving clause + -- is parsed as a HsSigType, which is always a HsForAllTy or + -- HsQualTy. Without parens it is always a HsVar. So for round + -- trip pretty printing we need to take this into account. + let + parenIfNeeded' pa = + case ts of + [] -> if l == GHC.noSrcSpan + then markManyOptional pa + else markMany pa + [GHC.L _ GHC.HsForAllTy{}] -> markMany pa + [GHC.L _ GHC.HsQualTy{}] -> markMany pa + [_] -> markManyOptional pa + _ -> markMany pa + + parenIfNeeded'' pa = + ifInContext (Set.singleton Parens) -- AZ:TODO: this is never set? + (markMany pa) + (parenIfNeeded' pa) + + parenIfNeeded pa = + case ts of + [GHC.L _ GHC.HsParTy{}] -> markOptional pa + _ -> parenIfNeeded'' pa + + -- ------------- + + parenIfNeeded GHC.AnnOpenP + + unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts + + parenIfNeeded GHC.AnnCloseP + + ifInContext (Set.singleton NoDarrow) + (return ()) + (if null ts && (l == GHC.noSrcSpan) + then markOptional GHC.AnnDarrow + else mark GHC.AnnDarrow) + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.ConDecl GHC.GhcPs) where + markAST _ (GHC.ConDeclH98 _ ln _fa mqtvs mctx + dets _) = do + case mqtvs of + [] -> return () + bndrs -> do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + case mctx of + Just ctx -> do + setContext (Set.fromList [NoDarrow]) $ markLocated ctx + unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow + Nothing -> return () + + case dets of + GHC.InfixCon _ _ -> return () + _ -> setContext (Set.singleton PrefixOp) $ markLocated ln + + markHsConDeclDetails False False [ln] dets + + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar + markTrailingSemi +{- + | ConDeclH98 + { con_ext :: XConDeclH98 pass + , con_name :: Located (IdP pass) + + , con_forall :: Bool -- ^ True <=> explicit user-written forall + -- e.g. data T a = forall b. MkT b (b->a) + -- con_ex_tvs = {b} + -- False => con_ex_tvs is empty + , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon + + , con_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + } + +-} + markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) (GHC.HsQTvs _ qvars) mbCxt args typ _) = do + setContext (Set.singleton PrefixOp) $ markListIntercalate lns + mark GHC.AnnDcolon + annotationsToComments [GHC.AnnOpenP] + markLocated (GHC.L l (ResTyGADTHook forall qvars)) + markMaybe mbCxt + markHsConDeclDetails False True lns args + markLocated typ + markManyOptional GHC.AnnCloseP + markTrailingSemi +{- + = ConDeclGADT + { con_g_ext :: XConDeclGADT pass + , con_names :: [Located (IdP pass)] + + -- The next four fields describe the type after the '::' + -- See Note [GADT abstract syntax] + , con_forall :: Located Bool -- ^ True <=> explicit forall + -- False => hsq_explicit is empty + , con_qvars :: LHsQTyVars pass + -- Whether or not there is an /explicit/ forall, we still + -- need to capture the implicitly-bound type/kind variables + + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon + , con_res_ty :: LHsType pass -- ^ Result type + + , con_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + } + +-} + + markAST _ (GHC.ConDeclGADT _ _ (GHC.L _ _) (GHC.XLHsQTyVars _) _ _ _ _) + = error "hit extension point in ConDecl" + markAST _ (GHC.XConDecl _) + = error "hit extension point in ConDecl" + +-- ResTyGADT has a SrcSpan for the original sigtype, we need to create +-- a type for exactPC and annotatePC +data ResTyGADTHook = ResTyGADTHook Bool [GHC.LHsTyVarBndr GHC.GhcPs] + deriving (Typeable) +deriving instance Data (ResTyGADTHook) + +instance GHC.Outputable ResTyGADTHook where + ppr (ResTyGADTHook b bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr b GHC.<+> GHC.ppr bs + + +-- WildCardAnon exists because the GHC anonymous wildcard type is defined as +-- = AnonWildCard (PostRn name Name) +-- We need to reconstruct this from the typed hole SrcSpan in an HsForAllTy, but +-- the instance doing this is parameterised on name, so we cannot put a value in +-- for the (PostRn name Name) field. This is used instead. +data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable) + +instance Annotate WildCardAnon where + markAST l WildCardAnon = do + markExternal l GHC.AnnVal "_" + +-- --------------------------------------------------------------------- + +instance Annotate ResTyGADTHook where + markAST _ (ResTyGADTHook forall bndrs) = do + unless (null bndrs) $ do + when forall $ mark GHC.AnnForall + mapM_ markLocated bndrs + when forall $ mark GHC.AnnDot + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where + markAST _ (GHC.HsRecField n e punFlag) = do + unsetContext Intercalate $ markLocated n + unless punFlag $ do + mark GHC.AnnEqual + unsetContext Intercalate $ markLocated e + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + + +instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where + markAST _ (GHC.HsRecField n e punFlag) = do + unsetContext Intercalate $ markLocated n + unless punFlag $ do + mark GHC.AnnEqual + unsetContext Intercalate $ markLocated e + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where + + markAST _ (ls,rs) = do + mapM_ markLocated ls + mark GHC.AnnRarrow + mapM_ markLocated rs + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate GHC.CType where + markAST _ (GHC.CType src mh f) = do + -- markWithString GHC.AnnOpen src + markAnnOpen src "" + case mh of + Nothing -> return () + Just (GHC.Header srcH _h) -> + -- markWithString GHC.AnnHeader srcH + markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") + -- markWithString GHC.AnnVal (fst f) + markSourceText (fst f) (GHC.unpackFS $ snd f) + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +stringLiteralToString :: GHC.StringLiteral -> String +stringLiteralToString (GHC.StringLiteral st fs) = + case st of + GHC.NoSourceText -> GHC.unpackFS fs + GHC.SourceText src -> src diff --git a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs --- a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs @@ -122,7 +122,9 @@ (G GHC.AnnStatic ) -> "static" (G GHC.AnnThen ) -> "then" (G GHC.AnnTilde ) -> "~" +#if __GLASGOW_HASKELL__ <= 804 (G GHC.AnnTildehsh ) -> "~#" +#endif (G GHC.AnnType ) -> "type" (G GHC.AnnUnit ) -> "()" (G GHC.AnnUsing ) -> "using" @@ -150,6 +152,9 @@ #endif #if __GLASGOW_HASKELL__ >= 800 AnnTypeApp -> "@" +#endif +#if __GLASGOW_HASKELL__ > 804 + (G GHC.AnnVia) -> "via" #endif #if __GLASGOW_HASKELL__ <= 710 diff --git a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs --- a/src/Language/Haskell/GHC/ExactPrint/Pretty.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Pretty.hs @@ -210,6 +210,9 @@ dp = case ann of (G GHC.AnnAs) -> tellKd (ann,DP (0,1)) (G GHC.AnnAt) -> tellKd (ann,DP (0,0)) +#if __GLASGOW_HASKELL__ >= 806 + (G GHC.AnnAnyclass) -> tellKd (ann,DP (0,1)) +#endif (G GHC.AnnBackquote) -> tellKd (ann,DP (0,1)) (G GHC.AnnBang) -> tellKd (ann,DP (0,1)) (G GHC.AnnBy) -> tellKd (ann,DP (0,1)) @@ -217,6 +220,9 @@ (G GHC.AnnClass) -> tellKd (ann,DP (0,1)) (G GHC.AnnClose) -> tellKd (ann,DP (0,1)) (G GHC.AnnCloseC) -> tellKd (ann,DP (0,0)) +#if __GLASGOW_HASKELL__ >= 802 + (G GHC.AnnCloseQ) -> tellKd (ann,DP (0,1)) +#endif (G GHC.AnnDcolon) -> tellKd (ann,DP (0,1)) (G GHC.AnnDeriving) -> tellKd (ann,DP (0,1)) (G GHC.AnnDo) -> tellKd (ann,DP (0,1)) @@ -234,6 +240,7 @@ (G GHC.AnnLam) -> tellKd (ann,DP (0,1)) (G GHC.AnnMinus) -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator (G GHC.AnnModule) -> tellKd (ann,DP (0,1)) + (G GHC.AnnNewtype) -> tellKd (ann,DP (0,1)) (G GHC.AnnOf) -> tellKd (ann,DP (0,1)) (G GHC.AnnOpenC) -> tellKd (ann,DP (0,0)) (G GHC.AnnOpenPE) -> tellKd (ann,DP (0,1)) @@ -242,6 +249,9 @@ (G GHC.AnnRarrow) -> tellKd (ann,DP (0,1)) (G GHC.AnnRole) -> tellKd (ann,DP (0,1)) (G GHC.AnnSafe) -> tellKd (ann,DP (0,1)) +#if __GLASGOW_HASKELL__ >= 806 + (G GHC.AnnStock) -> tellKd (ann,DP (0,1)) +#endif (G GHC.AnnSimpleQuote) -> tellKd (ann,DP (0,1)) (G GHC.AnnThIdSplice) -> tellKd (ann,DP (0,1)) (G GHC.AnnThIdTySplice) -> tellKd (ann,DP (0,1)) @@ -253,6 +263,9 @@ (G GHC.AnnVal) -> tellKd (ann,DP (0,1)) (G GHC.AnnValStr) -> tellKd (ann,DP (0,1)) (G GHC.AnnVbar) -> tellKd (ann,DP (0,1)) +#if __GLASGOW_HASKELL__ >= 806 + (G GHC.AnnVia) -> tellKd (ann,DP (0,1)) +#endif (G GHC.AnnWhere) -> tellKd (ann,DP (1,2)) #if __GLASGOW_HASKELL__ >= 800 AnnTypeApp -> tellKd (ann,DP (0,1)) 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 @@ -250,27 +250,43 @@ -- nothing to any annotations that may be attached to either of the elements. -- It is used as a utility function in 'replaceDecls' decl2Bind :: GHC.LHsDecl name -> [GHC.LHsBind name] +#if __GLASGOW_HASKELL__ > 804 +decl2Bind (GHC.L l (GHC.ValD _ s)) = [GHC.L l s] +#else decl2Bind (GHC.L l (GHC.ValD s)) = [GHC.L l s] +#endif decl2Bind _ = [] -- |Pure function to convert a 'GHC.LSig' to a 'GHC.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 :: GHC.LHsDecl name -> [GHC.LSig name] +#if __GLASGOW_HASKELL__ > 804 +decl2Sig (GHC.L l (GHC.SigD _ s)) = [GHC.L l s] +#else decl2Sig (GHC.L l (GHC.SigD s)) = [GHC.L l s] +#endif decl2Sig _ = [] -- --------------------------------------------------------------------- -- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl' wrapSig :: GHC.LSig GhcPs -> GHC.LHsDecl GhcPs +#if __GLASGOW_HASKELL__ > 804 +wrapSig (GHC.L l s) = GHC.L l (GHC.SigD GHC.noExt s) +#else wrapSig (GHC.L l s) = GHC.L l (GHC.SigD s) +#endif -- --------------------------------------------------------------------- -- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl' wrapDecl :: GHC.LHsBind GhcPs -> GHC.LHsDecl GhcPs +#if __GLASGOW_HASKELL__ > 804 +wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD GHC.noExt s) +#else wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD s) +#endif -- --------------------------------------------------------------------- @@ -458,7 +474,11 @@ -- logTr $ "balanceComments entered" -- logDataWithAnnsTr "first" first case cast first :: Maybe (GHC.LHsDecl GhcPs) of - Just (GHC.L l (GHC.ValD fb@(GHC.FunBind{}))) -> do +#if __GLASGOW_HASKELL__ > 804 + Just (GHC.L l (GHC.ValD _ fb@(GHC.FunBind{}))) -> do +#else + Just (GHC.L l (GHC.ValD fb@(GHC.FunBind{}))) -> do +#endif balanceCommentsFB (GHC.L l fb) second _ -> case cast first :: Maybe (GHC.LHsBind GhcPs) of Just fb'@(GHC.L _ (GHC.FunBind{})) -> do @@ -493,10 +513,12 @@ -- 'GHC.FunBind', these need to be pushed down from the top level to the last -- 'GHC.Match' if that 'GHC.Match' needs to be manipulated. balanceCommentsFB :: (Data b,Monad m) => GHC.LHsBind GhcPs -> GHC.Located b -> TransformT m () -#if __GLASGOW_HASKELL__ <= 710 -balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do -#else +#if __GLASGOW_HASKELL__ > 804 +balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do +#elif __GLASGOW_HASKELL__ > 710 balanceCommentsFB (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) second = do +#else +balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do #endif -- logTr $ "balanceCommentsFB entered" balanceComments' (last matches) second @@ -646,7 +668,9 @@ -- --------------------------------------------------------------------- instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where -#if __GLASGOW_HASKELL__ >= 804 +#if __GLASGOW_HASKELL__ > 804 + hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _ (GHC.L _ lb)))) = do +#elif __GLASGOW_HASKELL__ >= 804 hsDecls d@(GHC.L _ (GHC.Match _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do #elif __GLASGOW_HASKELL__ >= 800 hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do @@ -657,8 +681,15 @@ #endif decls <- hsDeclsValBinds lb orderedDecls d decls +#if __GLASGOW_HASKELL__ > 804 + hsDecls (GHC.L _ (GHC.Match _ _ _ (GHC.XGRHSs _))) = return [] + hsDecls (GHC.L _ (GHC.XMatch _)) = return [] +#endif -#if __GLASGOW_HASKELL__ >= 804 + +#if __GLASGOW_HASKELL__ > 804 + replaceDecls m@(GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds))) [] +#elif __GLASGOW_HASKELL__ >= 804 replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) [] #else replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) [] @@ -684,13 +715,17 @@ binds'' <- replaceDeclsValbinds (GHC.unLoc binds) [] let binds' = GHC.L (GHC.getLoc binds) binds'' #endif -#if __GLASGOW_HASKELL__ >= 804 +#if __GLASGOW_HASKELL__ > 804 + return (GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds'))) +#elif __GLASGOW_HASKELL__ >= 804 return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds'))) #else return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds'))) #endif -#if __GLASGOW_HASKELL__ >= 804 +#if __GLASGOW_HASKELL__ > 804 + replaceDecls m@(GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds))) newBinds +#elif __GLASGOW_HASKELL__ >= 804 replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) newBinds #else replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds @@ -704,7 +739,11 @@ #else case GHC.unLoc binds of #endif +#if __GLASGOW_HASKELL__ > 804 + GHC.EmptyLocalBinds{} -> do +#else GHC.EmptyLocalBinds -> do +#endif let addWhere mkds = case Map.lookup (mkAnnKey m) mkds of @@ -729,25 +768,37 @@ let binds' = GHC.L (GHC.getLoc binds) binds'' #endif -- logDataWithAnnsTr "Match.replaceDecls:binds'" binds' -#if __GLASGOW_HASKELL__ >= 804 +#if __GLASGOW_HASKELL__ > 804 + return (GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds'))) +#elif __GLASGOW_HASKELL__ >= 804 return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds'))) #else return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds'))) #endif +#if __GLASGOW_HASKELL__ > 804 + replaceDecls (GHC.L _ (GHC.Match _ _ _ (GHC.XGRHSs _))) _ = error "replaceDecls" + replaceDecls (GHC.L _ (GHC.XMatch _)) _ = error "replaceDecls" +#endif -- --------------------------------------------------------------------- instance HasDecls (GHC.LHsExpr GhcPs) where -#if __GLASGOW_HASKELL__ <= 710 - hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do -#else +#if __GLASGOW_HASKELL__ > 804 + hsDecls ls@(GHC.L _ (GHC.HsLet _ (GHC.L _ decls) _ex)) = do +#elif __GLASGOW_HASKELL__ > 710 hsDecls ls@(GHC.L _ (GHC.HsLet (GHC.L _ decls) _ex)) = do +#else + hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do #endif ds <- hsDeclsValBinds decls orderedDecls ls ds hsDecls _ = return [] +#if __GLASGOW_HASKELL__ > 804 + replaceDecls e@(GHC.L l (GHC.HsLet x decls ex)) newDecls +#else replaceDecls e@(GHC.L l (GHC.HsLet decls ex)) newDecls +#endif = do logTr "replaceDecls HsLet" modifyAnnsT (captureOrder e newDecls) @@ -757,12 +808,25 @@ decls'' <- replaceDeclsValbinds (GHC.unLoc decls) newDecls let decls' = GHC.L (GHC.getLoc decls) decls'' #endif +#if __GLASGOW_HASKELL__ > 804 + return (GHC.L l (GHC.HsLet x decls' ex)) +#else return (GHC.L l (GHC.HsLet decls' ex)) +#endif + +#if __GLASGOW_HASKELL__ > 804 + replaceDecls (GHC.L l (GHC.HsPar x e)) newDecls +#else replaceDecls (GHC.L l (GHC.HsPar e)) newDecls +#endif = do logTr "replaceDecls HsPar" e' <- replaceDecls e newDecls +#if __GLASGOW_HASKELL__ > 804 + return (GHC.L l (GHC.HsPar x e')) +#else return (GHC.L l (GHC.HsPar e')) +#endif replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GhcPs) undefined for:" ++ showGhc old -- --------------------------------------------------------------------- @@ -772,7 +836,11 @@ -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is -- idempotent. hsDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> TransformT m [GHC.LHsDecl GhcPs] +#if __GLASGOW_HASKELL__ > 804 +hsDeclsPatBindD (GHC.L l (GHC.ValD _ d)) = hsDeclsPatBind (GHC.L l d) +#else hsDeclsPatBindD (GHC.L l (GHC.ValD d)) = hsDeclsPatBind (GHC.L l d) +#endif hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x -- | Extract the immediate declarations for a 'GHC.PatBind'. This @@ -780,10 +848,12 @@ -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is -- idempotent. hsDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs] -#if __GLASGOW_HASKELL__ <= 710 -hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do -#else +#if __GLASGOW_HASKELL__ > 804 +hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ _ (GHC.GRHSs _ _grhs (GHC.L _ lb)) _)) = do +#elif __GLASGOW_HASKELL__ > 710 hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs (GHC.L _ lb)) _ _ _)) = do +#else +hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do #endif decls <- hsDeclsValBinds lb orderedDecls d decls @@ -797,9 +867,15 @@ -- idempotent. replaceDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> [GHC.LHsDecl GhcPs] -> TransformT m (GHC.LHsDecl GhcPs) +#if __GLASGOW_HASKELL__ > 804 +replaceDeclsPatBindD (GHC.L l (GHC.ValD x d)) newDecls = do + (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls + return (GHC.L l (GHC.ValD x d')) +#else replaceDeclsPatBindD (GHC.L l (GHC.ValD d)) newDecls = do (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls return (GHC.L l (GHC.ValD d')) +#endif replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x -- | Replace the immediate declarations for a 'GHC.PatBind'. This @@ -808,7 +884,11 @@ -- idempotent. replaceDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> [GHC.LHsDecl GhcPs] -> TransformT m (GHC.LHsBind GhcPs) +#if __GLASGOW_HASKELL__ > 804 +replaceDeclsPatBind p@(GHC.L l (GHC.PatBind x a (GHC.GRHSs xr rhss binds) b)) newDecls +#else replaceDeclsPatBind p@(GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds) b c d)) newDecls +#endif = do logTr "replaceDecls PatBind" -- Need to throw in a fresh where clause if the binds were empty, @@ -818,7 +898,11 @@ #else case GHC.unLoc binds of #endif +#if __GLASGOW_HASKELL__ > 804 + GHC.EmptyLocalBinds{} -> do +#else GHC.EmptyLocalBinds -> do +#endif let addWhere mkds = case Map.lookup (mkAnnKey p) mkds of @@ -839,33 +923,55 @@ binds'' <- replaceDeclsValbinds (GHC.unLoc binds) newDecls let binds' = GHC.L (GHC.getLoc binds) binds'' #endif +#if __GLASGOW_HASKELL__ > 804 + return (GHC.L l (GHC.PatBind x a (GHC.GRHSs xr rhss binds') b)) +#else return (GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds') b c d)) +#endif replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x -- --------------------------------------------------------------------- instance HasDecls (GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) where -#if __GLASGOW_HASKELL__ <= 710 - hsDecls ls@(GHC.L _ (GHC.LetStmt lb)) = do -#else +#if __GLASGOW_HASKELL__ > 804 + hsDecls ls@(GHC.L _ (GHC.LetStmt _ (GHC.L _ lb))) = do +#elif __GLASGOW_HASKELL__ > 710 hsDecls ls@(GHC.L _ (GHC.LetStmt (GHC.L _ lb))) = do +#else + hsDecls ls@(GHC.L _ (GHC.LetStmt lb)) = do #endif decls <- hsDeclsValBinds lb orderedDecls ls decls -#if __GLASGOW_HASKELL__ <= 710 - hsDecls (GHC.L _ (GHC.LastStmt e _)) = hsDecls e -#else +#if __GLASGOW_HASKELL__ > 804 + hsDecls (GHC.L _ (GHC.LastStmt _ e _ _)) = hsDecls e +#elif __GLASGOW_HASKELL__ >= 804 hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e -#endif -#if __GLASGOW_HASKELL__ <= 710 - hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _)) = hsDecls e +#elif __GLASGOW_HASKELL__ > 800 + hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e +#elif __GLASGOW_HASKELL__ > 710 + hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e #else + hsDecls (GHC.L _ (GHC.LastStmt e _)) = hsDecls e +#endif +#if __GLASGOW_HASKELL__ > 804 + hsDecls (GHC.L _ (GHC.BindStmt _ _pat e _ _)) = hsDecls e +#elif __GLASGOW_HASKELL__ > 710 hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _ _)) = hsDecls e +#else + hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _)) = hsDecls e #endif +#if __GLASGOW_HASKELL__ > 804 + hsDecls (GHC.L _ (GHC.BodyStmt _ e _ _)) = hsDecls e +#else hsDecls (GHC.L _ (GHC.BodyStmt e _ _ _)) = hsDecls e +#endif hsDecls _ = return [] +#if __GLASGOW_HASKELL__ > 804 + replaceDecls s@(GHC.L l (GHC.LetStmt x lb)) newDecls +#else replaceDecls s@(GHC.L l (GHC.LetStmt lb)) newDecls +#endif = do modifyAnnsT (captureOrder s newDecls) #if __GLASGOW_HASKELL__ <= 710 @@ -874,34 +980,55 @@ lb'' <- replaceDeclsValbinds (GHC.unLoc lb) newDecls let lb' = GHC.L (GHC.getLoc lb) lb'' #endif - return (GHC.L l (GHC.LetStmt lb')) -#if __GLASGOW_HASKELL__ <= 710 - replaceDecls (GHC.L l (GHC.LastStmt e se)) newDecls +#if __GLASGOW_HASKELL__ > 804 + return (GHC.L l (GHC.LetStmt x lb')) +#else + return (GHC.L l (GHC.LetStmt lb')) +#endif +#if __GLASGOW_HASKELL__ > 804 + replaceDecls (GHC.L l (GHC.LastStmt x e d se)) newDecls = do e' <- replaceDecls e newDecls - return (GHC.L l (GHC.LastStmt e' se)) -#else + return (GHC.L l (GHC.LastStmt x e' d se)) +#elif __GLASGOW_HASKELL__ > 710 replaceDecls (GHC.L l (GHC.LastStmt e d se)) newDecls = do e' <- replaceDecls e newDecls return (GHC.L l (GHC.LastStmt e' d se)) +#else + replaceDecls (GHC.L l (GHC.LastStmt e se)) newDecls + = do + e' <- replaceDecls e newDecls + return (GHC.L l (GHC.LastStmt e' se)) #endif -#if __GLASGOW_HASKELL__ <= 710 - replaceDecls (GHC.L l (GHC.BindStmt pat e a b)) newDecls +#if __GLASGOW_HASKELL__ > 804 + replaceDecls (GHC.L l (GHC.BindStmt x pat e a b)) newDecls = do e' <- replaceDecls e newDecls - return (GHC.L l (GHC.BindStmt pat e' a b)) -#else + return (GHC.L l (GHC.BindStmt x pat e' a b)) +#elif __GLASGOW_HASKELL__ > 710 replaceDecls (GHC.L l (GHC.BindStmt pat e a b c)) newDecls = do e' <- replaceDecls e newDecls return (GHC.L l (GHC.BindStmt pat e' a b c)) +#else + replaceDecls (GHC.L l (GHC.BindStmt pat e a b)) newDecls + = do + e' <- replaceDecls e newDecls + return (GHC.L l (GHC.BindStmt pat e' a b)) #endif +#if __GLASGOW_HASKELL__ > 804 + replaceDecls (GHC.L l (GHC.BodyStmt x e a b)) newDecls + = do + e' <- replaceDecls e newDecls + return (GHC.L l (GHC.BodyStmt x e' a b)) +#else replaceDecls (GHC.L l (GHC.BodyStmt e a b c)) newDecls = do e' <- replaceDecls e newDecls return (GHC.L l (GHC.BodyStmt e' a b c)) +#endif replaceDecls x _newDecls = return x -- ===================================================================== @@ -947,9 +1074,15 @@ = workerBind b lhsbind x = return x +#if __GLASGOW_HASKELL__ > 804 + lvald (GHC.L l (GHC.ValD x d)) = do + (GHC.L _ d') <- lhsbind (GHC.L l d) + return (GHC.L l (GHC.ValD x d')) +#else lvald (GHC.L l (GHC.ValD d)) = do (GHC.L _ d') <- lhsbind (GHC.L l d) return (GHC.L l (GHC.ValD d')) +#endif lvald x = return x -- --------------------------------------------------------------------- @@ -982,10 +1115,12 @@ -- --------------------------------- lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs] -#if __GLASGOW_HASKELL__ <= 710 - lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do -#else +#if __GLASGOW_HASKELL__ > 804 + lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do +#elif __GLASGOW_HASKELL__ > 710 lhsbind (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) = do +#else + lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do #endif dss <- mapM hsDecls matches return (concat dss) @@ -995,7 +1130,11 @@ -- --------------------------------- +#if __GLASGOW_HASKELL__ > 804 + lhsbindd (GHC.L l (GHC.ValD _ d)) = lhsbind (GHC.L l d) +#else lhsbindd (GHC.L l (GHC.ValD d)) = lhsbind (GHC.L l d) +#endif lhsbindd _ = return [] -- --------------------------------- @@ -1032,6 +1171,17 @@ -- context in the AST. hsDeclsValBinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs] hsDeclsValBinds lb = case lb of +#if __GLASGOW_HASKELL__ > 804 + GHC.HsValBinds _ (GHC.ValBinds _ bs sigs) -> do + let + bds = map wrapDecl (GHC.bagToList bs) + sds = map wrapSig sigs + return (bds ++ sds) + GHC.HsValBinds _ (GHC.XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid" + GHC.HsIPBinds {} -> return [] + GHC.EmptyLocalBinds {} -> return [] + GHC.XHsLocalBindsLR {} -> return [] +#else GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do let bds = map wrapDecl (GHC.bagToList bs) @@ -1040,6 +1190,7 @@ GHC.HsValBinds (GHC.ValBindsOut _ _) -> error $ "hsDecls.ValbindsOut not valid" GHC.HsIPBinds _ -> return [] GHC.EmptyLocalBinds -> return [] +#endif -- | Utility function for returning decls to 'GHC.HsLocalBinds'. Use with -- care, as this does not manage the declaration order, the @@ -1049,22 +1200,45 @@ => GHC.HsLocalBinds GhcPs -> [GHC.LHsDecl GhcPs] -> TransformT m (GHC.HsLocalBinds GhcPs) replaceDeclsValbinds _ [] = do +#if __GLASGOW_HASKELL__ > 804 + return (GHC.EmptyLocalBinds GHC.noExt) +#else return (GHC.EmptyLocalBinds) +#endif +#if __GLASGOW_HASKELL__ > 804 +replaceDeclsValbinds (GHC.HsValBinds _ _b) new +#else replaceDeclsValbinds (GHC.HsValBinds _b) new +#endif = do logTr "replaceDecls HsLocalBinds" let decs = GHC.listToBag $ concatMap decl2Bind new let sigs = concatMap decl2Sig new +#if __GLASGOW_HASKELL__ > 804 + return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs)) +#else return (GHC.HsValBinds (GHC.ValBindsIn decs sigs)) -replaceDeclsValbinds (GHC.HsIPBinds _b) _new = error "undefined replaceDecls HsIPBinds" +#endif +replaceDeclsValbinds (GHC.HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds" +#if __GLASGOW_HASKELL__ > 804 +replaceDeclsValbinds (GHC.EmptyLocalBinds _) new +#else replaceDeclsValbinds (GHC.EmptyLocalBinds) new +#endif = do logTr "replaceDecls HsLocalBinds" let newBinds = map decl2Bind new newSigs = map decl2Sig new let decs = GHC.listToBag $ concat newBinds let sigs = concat newSigs +#if __GLASGOW_HASKELL__ > 804 + return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs)) +#else return (GHC.HsValBinds (GHC.ValBindsIn decs sigs)) +#endif +#if __GLASGOW_HASKELL__ > 804 +replaceDeclsValbinds (GHC.XHsLocalBindsLR _) _ = error "replaceDeclsValbinds. XHsLocalBindsLR" +#endif -- --------------------------------------------------------------------- @@ -1080,7 +1254,11 @@ -> Decl -> (Match -> [Decl] -> m ([Decl], Maybe t)) -> m (Decl,Maybe t) +#if __GLASGOW_HASKELL__ > 804 +modifyValD p pb@(GHC.L ss (GHC.ValD _ (GHC.PatBind {} ))) f = +#else modifyValD p pb@(GHC.L ss (GHC.ValD (GHC.PatBind {} ))) f = +#endif if ss == p then do ds <- liftT $ hsDeclsPatBindD pb 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 @@ -355,8 +355,27 @@ -- --------------------------------------------------------------------- declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GhcPs -> b + +#if __GLASGOW_HASKELL__ > 804 declFun f (GHC.L l de) = case de of + GHC.TyClD _ d -> f (GHC.L l d) + GHC.InstD _ d -> f (GHC.L l d) + GHC.DerivD _ d -> f (GHC.L l d) + GHC.ValD _ d -> f (GHC.L l d) + GHC.SigD _ d -> f (GHC.L l d) + GHC.DefD _ d -> f (GHC.L l d) + GHC.ForD _ d -> f (GHC.L l d) + GHC.WarningD _ d -> f (GHC.L l d) + GHC.AnnD _ d -> f (GHC.L l d) + GHC.RuleD _ d -> f (GHC.L l d) + GHC.SpliceD _ d -> f (GHC.L l d) + GHC.DocD _ d -> f (GHC.L l d) + GHC.RoleAnnotD _ d -> f (GHC.L l d) + GHC.XHsDecl _ -> error "declFun:XHsDecl" +#else +declFun f (GHC.L l de) = + case de of GHC.TyClD d -> f (GHC.L l d) GHC.InstD d -> f (GHC.L l d) GHC.DerivD d -> f (GHC.L l d) @@ -374,7 +393,7 @@ #if __GLASGOW_HASKELL__ < 711 GHC.QuasiQuoteD d -> f (GHC.L l d) #endif - +#endif -- --------------------------------------------------------------------- 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 @@ -263,7 +263,9 @@ isListComp cts = case cts of GHC.ListComp -> True GHC.MonadComp -> True +#if __GLASGOW_HASKELL__ <= 804 GHC.PArrComp -> True +#endif GHC.DoExpr -> False GHC.MDoExpr -> False diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -28,11 +28,14 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 deriving (Eq, Ord, Show) +data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 + deriving (Eq, Ord, Show) ghcVersion :: GHCVersion ghcVersion = -#if __GLASGOW_HASKELL__ > 802 +#if __GLASGOW_HASKELL__ > 804 + GHC86 +#elif __GLASGOW_HASKELL__ > 802 GHC84 #elif __GLASGOW_HASKELL__ > 800 GHC82 @@ -46,14 +49,16 @@ testDirs :: [FilePath] testDirs = case ghcVersion of - GHC710 -> ["ghc710-only","ghc710"] - GHC80 -> ["ghc710", "ghc80"] - GHC82 -> ["ghc710", "ghc80", "ghc82"] - GHC84 -> ["ghc710", "ghc80", "ghc82", "ghc84" ] - -- GHC84 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc84-copied"] - -- GHC84 -> ["ghc84-copied"] - -- GHC84 -> ["ghc84"] + GHC710 -> ["ghc710-only","ghc710", "vect"] + GHC80 -> [ "ghc710", "ghc80", "vect"] + GHC82 -> ["pre-ghc86", "ghc710", "ghc80", "ghc82", "vect"] + GHC84 -> ["pre-ghc86", "ghc710", "ghc80", "ghc82", "ghc84", "vect" ] + GHC86 -> [ "ghc710", "ghc80", "ghc82", "ghc84", "ghc86" ] + -- GHC86 -> [ "ghc710", "ghc80", "ghc82", "ghc84"] + -- GHC86 -> ["ghc86-copied"] + -- GHC86 -> ["ghc86"] + -- --------------------------------------------------------------------- main :: IO () @@ -192,39 +197,21 @@ tt' :: IO (Counts,Int) tt' = runTestText (putTextToHandle stdout True) $ TestList [ - -- mkPrettyRoundtrip "ghc80" "Zwaluw.hs" - -- mkPrettyRoundtrip "ghc80" "pmc007.hs" - -- mkPrettyRoundtrip "ghc80" "MultiQuote.hs" - -- mkPrettyRoundtrip "ghc80" "T10689a.hs" -- mkPrettyRoundtrip "ghc82" "TensorTests.hs" - -- mkParserTest "ghc84" "Main.hs" - -- mkParserTest "ghc84" "Types.hs" - -- , mkPrettyRoundtrip "ghc80" "BundleExport.hs" - -- , mkPrettyRoundtrip "ghc80" "ExportSyntax.hs" - -- , mkPrettyRoundtrip "ghc80" "export-class.hs" - -- , mkPrettyRoundtrip "ghc80" "export-syntax.hs" - -- , mkPrettyRoundtrip "ghc80" "export-type.hs" - - -- mkPrettyRoundtrip "ghc84" "Main.hs" - -- mkPrettyRoundtrip "ghc84" "Types.hs" - - mkPrettyRoundtrip "ghc80" "Vta1.hs" - , mkPrettyRoundtrip "ghc80" "Vta2.hs" - - -- mkParserTest "ghc80" "BundleExport.hs" + mkParserTest "ghc710" "GADTContext.hs" - -- , mkParserTest "ghc710" "TypeOperators.hs" - -- , mkParserTest "ghc80" "TestUtils.hs" + -- mkParserTest "ghc86" "deriving-via-compile.hs" + -- mkParserTest "pre-ghc86" "TensorTests.hs" + -- , mkParserTest "pre-ghc86" "Webhook.hs" + -- , mkParserTest "ghc710" "RdrNames.hs" - -- mkParserTest "ghc84" "Functors.hs" - -- , mkParserTest "ghc80" "MonadT.hs" + -- mkPrettyRoundtrip "ghc86" "BinDU.hs" + -- , mkPrettyRoundtrip "ghc86" "Dial.hs" - -- mkParserTest "ghc80" "SemicolonIf.hs" - -- mkParserTest "ghc80" "T10689a.hs" - -- mkParserTest "ghc80" "MonadT.hs" - -- mkParserTest "ghc710" "Ann01.hs" + -- mkParserTest "ghc84" "Types.hs" + -- , mkPrettyRoundtrip "ghc80" "export-type.hs" -- Needs GHC changes -- mkParserTest "failing" "CtorOp.hs" diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -95,8 +95,13 @@ -- prior local decl. So it adds a "where" annotation. changeLocalDecls2 :: Changer changeLocalDecls2 ans (GHC.L l p) = do +#if __GLASGOW_HASKELL__ > 804 + Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") + Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") +#else Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") Right (sigAnns, s@(GHC.L ls (GHC.SigD sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") +#endif let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns @@ -110,8 +115,10 @@ replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.EmptyLocalBinds)))) = do #elif __GLASGOW_HASKELL__ <= 802 replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do -#else +#elif __GLASGOW_HASKELL__ <= 804 replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do +#else + replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L _ GHC.EmptyLocalBinds{})))) = do #endif newSpan <- uniqueSrcSpanT let @@ -132,16 +139,24 @@ let decls = [s,d] -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls) modifyAnnsT (captureOrderAnnKey newAnnKey decls) +#if __GLASGOW_HASKELL__ > 804 + let binds = (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt (GHC.listToBag $ [GHC.L ld decl]) + [GHC.L ls sig])) +#else let binds = (GHC.HsValBinds (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl]) [GHC.L ls sig])) +#endif #if __GLASGOW_HASKELL__ <= 710 return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds))) #elif __GLASGOW_HASKELL__ <= 802 bindSpan <- uniqueSrcSpanT return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L bindSpan binds)))) -#else +#elif __GLASGOW_HASKELL__ <= 804 bindSpan <- uniqueSrcSpanT return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L bindSpan binds)))) +#else + bindSpan <- uniqueSrcSpanT + return (GHC.L lm (GHC.Match GHC.noExt mln pats (GHC.GRHSs GHC.noExt rhs (GHC.L bindSpan binds)))) #endif replaceLocalBinds x = return x -- putStrLn $ "log:" ++ intercalate "\n" w @@ -152,8 +167,13 @@ -- | Add a local declaration with signature to LocalDecl changeLocalDecls :: Changer changeLocalDecls ans (GHC.L l p) = do +#if __GLASGOW_HASKELL__ > 804 + Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") + Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") +#else Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") Right (sigAnns, s@(GHC.L ls (GHC.SigD sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") +#endif let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns @@ -167,8 +187,10 @@ replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs))))) = do #elif __GLASGOW_HASKELL__ <= 802 replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do -#else +#elif __GLASGOW_HASKELL__ <= 804 replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do +#else + replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L lb (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)))))) = do #endif a1 <- getAnnsT a' <- case sigs of @@ -181,15 +203,23 @@ let decls = s:d:oldDecls -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls) modifyAnnsT (captureOrder m decls) +#if __GLASGOW_HASKELL__ > 804 + let binds' = (GHC.HsValBinds GHC.noExt + (GHC.ValBinds GHC.noExt (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds) + (GHC.L ls sig:sigs))) +#else let binds' = (GHC.HsValBinds (GHC.ValBindsIn (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds) (GHC.L ls sig:sigs))) +#endif #if __GLASGOW_HASKELL__ <= 710 return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds'))) #elif __GLASGOW_HASKELL__ <= 802 return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb binds')))) -#else +#elif __GLASGOW_HASKELL__ <= 804 return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb binds')))) +#else + return (GHC.L lm (GHC.Match GHC.noExt mln pats (GHC.GRHSs GHC.noExt rhs (GHC.L lb binds')))) #endif replaceLocalBinds x = return x -- putStrLn $ "log:" ++ intercalate "\n" w @@ -289,22 +319,26 @@ replaceRdr x = x replaceHsVar :: GHC.LHsExpr GhcPs -> GHC.LHsExpr GhcPs - replaceHsVar (GHC.L ln (GHC.HsVar _)) + replaceHsVar (GHC.L ln (GHC.HsVar{})) #if __GLASGOW_HASKELL__ <= 710 | cond ln = GHC.L ln (GHC.HsVar newName) -#else +#elif __GLASGOW_HASKELL__ <= 804 | cond ln = GHC.L ln (GHC.HsVar (GHC.L ln newName)) +#else + | cond ln = GHC.L ln (GHC.HsVar GHC.noExt (GHC.L ln newName)) #endif replaceHsVar x = x #if __GLASGOW_HASKELL__ > 802 replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs #endif - replacePat (GHC.L ln (GHC.VarPat _)) + replacePat (GHC.L ln (GHC.VarPat {})) #if __GLASGOW_HASKELL__ <= 710 | cond ln = GHC.L ln (GHC.VarPat newName) -#else +#elif __GLASGOW_HASKELL__ <= 804 | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName)) +#else + | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName)) #endif replacePat x = x @@ -334,16 +368,27 @@ replace :: GHC.HsExpr GhcPs -> GHC.HsExpr GhcPs #if __GLASGOW_HASKELL__ <= 710 replace (GHC.HsLet localDecls expr@(GHC.L _ _)) -#else +#elif __GLASGOW_HASKELL__ <= 804 replace (GHC.HsLet (GHC.L lb localDecls) expr@(GHC.L _ _)) +#else + replace (GHC.HsLet _ (GHC.L lb localDecls) expr@(GHC.L _ _)) #endif = +#if __GLASGOW_HASKELL__ > 804 + let (GHC.HsValBinds x (GHC.ValBinds xv bagDecls sigs)) = localDecls + bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls +#else let (GHC.HsValBinds (GHC.ValBindsIn bagDecls sigs)) = localDecls bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls +#endif #if __GLASGOW_HASKELL__ <= 710 in (GHC.HsLet (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs)) expr) -#else +#elif __GLASGOW_HASKELL__ <= 802 in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr) +#elif __GLASGOW_HASKELL__ <= 804 + in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr) +#else + in (GHC.HsLet GHC.noExt (GHC.L lb (GHC.HsValBinds x (GHC.ValBinds xv bagDecls' sigs))) expr) #endif replace x = x @@ -494,8 +539,10 @@ #if __GLASGOW_HASKELL__ <= 710 let GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1 -#else +#elif __GLASGOW_HASKELL__ <= 804 let GHC.L _ (GHC.ValD (GHC.FunBind _ (GHC.MG (GHC.L _ [m1,m2]) _ _ _) _ _ _)) = d1 +#else + let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1 #endif balanceComments m1 m2 @@ -601,8 +648,10 @@ go :: GHC.HsExpr GhcPs -> Transform (GHC.HsExpr GhcPs) #if __GLASGOW_HASKELL__ <= 710 go (GHC.HsLet lb expr) = do -#else +#elif __GLASGOW_HASKELL__ <= 804 go (GHC.HsLet (GHC.L l lb) expr) = do +#else + go (GHC.HsLet _ (GHC.L l lb) expr) = do #endif decs <- hsDeclsValBinds lb let dec = last decs @@ -610,8 +659,10 @@ lb' <- replaceDeclsValbinds lb [dec] #if __GLASGOW_HASKELL__ <= 710 return (GHC.HsLet lb' expr) -#else +#elif __GLASGOW_HASKELL__ <= 804 return (GHC.HsLet (GHC.L l lb') expr) +#else + return (GHC.HsLet GHC.noExt (GHC.L l lb') expr) #endif go x = return x @@ -671,9 +722,12 @@ #if __GLASGOW_HASKELL__ <= 710 (GHC.L l (GHC.SigD (GHC.TypeSig names typ p))) = s1 s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ p))) -#else +#elif __GLASGOW_HASKELL__ <= 804 (GHC.L l (GHC.SigD (GHC.TypeSig names typ))) = s1 s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ))) +#else + (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 names typ))) = s1 + s1' = (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 (tail names) typ))) #endif replaceDecls lp (s1':d1:d2) @@ -709,7 +763,10 @@ [GHC.L li imp1,imp2] = GHC.hsmodImports p n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1")) n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) -#if __GLASGOW_HASKELL__ > 800 +#if __GLASGOW_HASKELL__ > 804 + v1 = GHC.L l1 (GHC.IEVar GHC.noExt (GHC.L l1 (GHC.IEName n1))) + v2 = GHC.L l2 (GHC.IEVar GHC.noExt (GHC.L l2 (GHC.IEName n2))) +#elif __GLASGOW_HASKELL__ > 800 v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1))) v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2))) #else @@ -740,7 +797,10 @@ Just (_,GHC.L lh ns) = GHC.ideclHiding imp1 n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1")) n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) -#if __GLASGOW_HASKELL__ > 800 +#if __GLASGOW_HASKELL__ > 804 + v1 = GHC.L l1 (GHC.IEVar GHC.noExt (GHC.L l1 (GHC.IEName n1))) + v2 = GHC.L l2 (GHC.IEVar GHC.noExt (GHC.L l2 (GHC.IEName n2))) +#elif __GLASGOW_HASKELL__ > 800 v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1))) v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2))) #else diff --git a/tests/examples/ghc710/DiophantineVect.hs b/tests/examples/ghc710/DiophantineVect.hs deleted file mode 100644 --- a/tests/examples/ghc710/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) - diff --git a/tests/examples/ghc710/GADTContext.hs b/tests/examples/ghc710/GADTContext.hs deleted file mode 100644 --- a/tests/examples/ghc710/GADTContext.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} - -data StackItem a where - Snum :: forall a. Fractional a => a -> StackItem a - Sop :: OpDesc -> StackItem a -deriving instance Show a => Show (StackItem a) - --- AZ added to test Trac #10399 -data MaybeDefault v where - SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v - SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v -> a -> MaybeDefault [a]) diff --git a/tests/examples/ghc710/LiftedConstructors.hs b/tests/examples/ghc710/LiftedConstructors.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/OveridingPrimitives.hs b/tests/examples/ghc710/OveridingPrimitives.hs --- a/tests/examples/ghc710/OveridingPrimitives.hs +++ b/tests/examples/ghc710/OveridingPrimitives.hs @@ -4,3 +4,4 @@ (~#) :: Comonad w => CascadeW w (t ': ts) -> w t -> Last (t ': ts) (~#) = cascadeW infixr 0 ~# + diff --git a/tests/examples/ghc710/SlidingTypeSyn.hs b/tests/examples/ghc710/SlidingTypeSyn.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc710/Vect.hs b/tests/examples/ghc710/Vect.hs deleted file mode 100644 --- a/tests/examples/ghc710/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/ghc80/BadTelescope.hs b/tests/examples/ghc80/BadTelescope.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/BadTelescope2.hs b/tests/examples/ghc80/BadTelescope2.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/BadTelescope3.hs b/tests/examples/ghc80/BadTelescope3.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/BadTelescope4.hs b/tests/examples/ghc80/BadTelescope4.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/Dep3.hs b/tests/examples/ghc80/Dep3.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/GADTContext.hs b/tests/examples/ghc80/GADTContext.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/GADTContext.hs @@ -0,0 +1,37 @@ +{-# 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/ghc80/KindEqualities2.hs b/tests/examples/ghc80/KindEqualities2.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/RAE_T32a.hs b/tests/examples/ghc80/RAE_T32a.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/RAE_T32b.hs b/tests/examples/ghc80/RAE_T32b.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/Rae31.hs b/tests/examples/ghc80/Rae31.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/RaeBlogPost.hs b/tests/examples/ghc80/RaeBlogPost.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/RenamingStar.hs b/tests/examples/ghc80/RenamingStar.hs deleted file mode 100644 --- a/tests/examples/ghc80/RenamingStar.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TypeInType #-} - -module RenamingStar where - -data Foo :: * diff --git a/tests/examples/ghc80/T10134a.hs b/tests/examples/ghc80/T10134a.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/T10321.hs b/tests/examples/ghc80/T10321.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/T10689a.hs b/tests/examples/ghc80/T10689a.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/T10934.hs b/tests/examples/ghc80/T10934.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/T11142.hs b/tests/examples/ghc80/T11142.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/T3927b.hs b/tests/examples/ghc80/T3927b.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/T9632.hs b/tests/examples/ghc80/T9632.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/UnicodeSyntax.hs b/tests/examples/ghc80/UnicodeSyntax.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/Webhook.hs b/tests/examples/ghc80/Webhook.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/determ004.hs b/tests/examples/ghc80/determ004.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/dynamic-paper.hs b/tests/examples/ghc80/dynamic-paper.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/mkGADTVars.hs b/tests/examples/ghc80/mkGADTVars.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc80/overloadedrecflds_generics.hs b/tests/examples/ghc80/overloadedrecflds_generics.hs deleted file mode 100644 --- a/tests/examples/ghc80/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/ghc82/TensorTests.hs b/tests/examples/ghc82/TensorTests.hs deleted file mode 100644 --- a/tests/examples/ghc82/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, *) Bool -> * -type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) - diff --git a/tests/examples/ghc86/Arith.hs b/tests/examples/ghc86/Arith.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/BadTelescope.hs b/tests/examples/ghc86/BadTelescope.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/BadTelescope2.hs b/tests/examples/ghc86/BadTelescope2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/BadTelescope3.hs b/tests/examples/ghc86/BadTelescope3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/BadTelescope4.hs b/tests/examples/ghc86/BadTelescope4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/Boot1.hs b/tests/examples/ghc86/Boot1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/Dep3.hs b/tests/examples/ghc86/Dep3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/GADT.hs b/tests/examples/ghc86/GADT.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/HashTab.hs b/tests/examples/ghc86/HashTab.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/KindEqualities2.hs b/tests/examples/ghc86/KindEqualities2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/LiftedConstructors.hs b/tests/examples/ghc86/LiftedConstructors.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/Parser.hs b/tests/examples/ghc86/Parser.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/RAE_T32a.hs b/tests/examples/ghc86/RAE_T32a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/RAE_T32b.hs b/tests/examples/ghc86/RAE_T32b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/Rae31.hs b/tests/examples/ghc86/Rae31.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/RaeBlogPost.hs b/tests/examples/ghc86/RaeBlogPost.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/RenamingStar.hs b/tests/examples/ghc86/RenamingStar.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/RenamingStar.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeInType #-} + +module RenamingStar where + +data Foo :: Type diff --git a/tests/examples/ghc86/ST.hs b/tests/examples/ghc86/ST.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/SlidingTypeSyn.hs b/tests/examples/ghc86/SlidingTypeSyn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T10134a.hs b/tests/examples/ghc86/T10134a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T10279.hs b/tests/examples/ghc86/T10279.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T10321.hs b/tests/examples/ghc86/T10321.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T10638.hs b/tests/examples/ghc86/T10638.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T10689a.hs b/tests/examples/ghc86/T10689a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T10819.hs b/tests/examples/ghc86/T10819.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T10891.hs b/tests/examples/ghc86/T10891.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T10934.hs b/tests/examples/ghc86/T10934.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T11142.hs b/tests/examples/ghc86/T11142.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T11484.hs b/tests/examples/ghc86/T11484.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T12478_5.hs b/tests/examples/ghc86/T12478_5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T14164.hs b/tests/examples/ghc86/T14164.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T14650.hs b/tests/examples/ghc86/T14650.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T2632.hs b/tests/examples/ghc86/T2632.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T3263-2.hs b/tests/examples/ghc86/T3263-2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T3391.hs b/tests/examples/ghc86/T3391.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T3572.hs b/tests/examples/ghc86/T3572.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T3927b.hs b/tests/examples/ghc86/T3927b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T4056.hs b/tests/examples/ghc86/T4056.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T4169.hs b/tests/examples/ghc86/T4169.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T4170.hs b/tests/examples/ghc86/T4170.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T5217.hs b/tests/examples/ghc86/T5217.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T6018th.hs b/tests/examples/ghc86/T6018th.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T6062.hs b/tests/examples/ghc86/T6062.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/T6062.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} +module T6062 where +x = [| False True |] + diff --git a/tests/examples/ghc86/T8455.hs b/tests/examples/ghc86/T8455.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/T8455.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module T8455 where + +ty = [t| 5 |] + diff --git a/tests/examples/ghc86/T8759a.hs b/tests/examples/ghc86/T8759a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/T8759a.hs @@ -0,0 +1,7 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T9367.hs b/tests/examples/ghc86/T9367.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T9632.hs b/tests/examples/ghc86/T9632.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T9662.hs b/tests/examples/ghc86/T9662.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/T9824.hs b/tests/examples/ghc86/T9824.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_abstractFamily.hs b/tests/examples/ghc86/TH_abstractFamily.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_bracket1.hs b/tests/examples/ghc86/TH_bracket1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_bracket2.hs b/tests/examples/ghc86/TH_bracket2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_bracket3.hs b/tests/examples/ghc86/TH_bracket3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_class1.hs b/tests/examples/ghc86/TH_class1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_dataD1.hs b/tests/examples/ghc86/TH_dataD1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_localname.hs b/tests/examples/ghc86/TH_localname.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/TH_localname.hs @@ -0,0 +1,5 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_ppr1.hs b/tests/examples/ghc86/TH_ppr1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_raiseErr1.hs b/tests/examples/ghc86/TH_raiseErr1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_recover.hs b/tests/examples/ghc86/TH_recover.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_reifyDecl1.hs b/tests/examples/ghc86/TH_reifyDecl1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/TH_reifyDecl1.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/ghc86/TH_reifyDecl2.hs b/tests/examples/ghc86/TH_reifyDecl2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_reifyInstances.hs b/tests/examples/ghc86/TH_reifyInstances.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_reifyMkName.hs b/tests/examples/ghc86/TH_reifyMkName.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_repE1.hs b/tests/examples/ghc86/TH_repE1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_repE2.hs b/tests/examples/ghc86/TH_repE2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_repE3.hs b/tests/examples/ghc86/TH_repE3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_repGuard.hs b/tests/examples/ghc86/TH_repGuard.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_repGuardOutput.hs b/tests/examples/ghc86/TH_repGuardOutput.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_repPatSig.hs b/tests/examples/ghc86/TH_repPatSig.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_repPatSigTVar.hs b/tests/examples/ghc86/TH_repPatSigTVar.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_repPrim.hs b/tests/examples/ghc86/TH_repPrim.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_repPrim2.hs b/tests/examples/ghc86/TH_repPrim2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_repPrimOutput.hs b/tests/examples/ghc86/TH_repPrimOutput.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_repPrimOutput2.hs b/tests/examples/ghc86/TH_repPrimOutput2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_scope.hs b/tests/examples/ghc86/TH_scope.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_sections.hs b/tests/examples/ghc86/TH_sections.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_spliceD2.hs b/tests/examples/ghc86/TH_spliceD2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_spliceDecl1.hs b/tests/examples/ghc86/TH_spliceDecl1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_spliceDecl2.hs b/tests/examples/ghc86/TH_spliceDecl2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_spliceDecl3.hs b/tests/examples/ghc86/TH_spliceDecl3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_spliceE1.hs b/tests/examples/ghc86/TH_spliceE1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_spliceE3.hs b/tests/examples/ghc86/TH_spliceE3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_spliceE4.hs b/tests/examples/ghc86/TH_spliceE4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_spliceE5_Lib.hs b/tests/examples/ghc86/TH_spliceE5_Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_spliceE5_prof_Lib.hs b/tests/examples/ghc86/TH_spliceE5_prof_Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_spliceE5_prof_ext_Lib.hs b/tests/examples/ghc86/TH_spliceE5_prof_ext_Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_spliceExpr1.hs b/tests/examples/ghc86/TH_spliceExpr1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_tf1.hs b/tests/examples/ghc86/TH_tf1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_tf3.hs b/tests/examples/ghc86/TH_tf3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_unresolvedInfix.hs b/tests/examples/ghc86/TH_unresolvedInfix.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TH_unresolvedInfix2.hs b/tests/examples/ghc86/TH_unresolvedInfix2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TensorTests.hs b/tests/examples/ghc86/TensorTests.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/Test.hs b/tests/examples/ghc86/Test.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/Test12417.hs b/tests/examples/ghc86/Test12417.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/TupleN.hs b/tests/examples/ghc86/TupleN.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/UnicodeSyntax.hs b/tests/examples/ghc86/UnicodeSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/Webhook.hs b/tests/examples/ghc86/Webhook.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/deriving-via-compile.hs b/tests/examples/ghc86/deriving-via-compile.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/determ004.hs b/tests/examples/ghc86/determ004.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/dynamic-paper.hs b/tests/examples/ghc86/dynamic-paper.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/dynbrk005.hs b/tests/examples/ghc86/dynbrk005.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/ffi1.hs b/tests/examples/ghc86/ffi1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/ghci006.hs b/tests/examples/ghc86/ghci006.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/haddockA026.hs b/tests/examples/ghc86/haddockA026.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/haddockA027.hs b/tests/examples/ghc86/haddockA027.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/haddockA031.hs b/tests/examples/ghc86/haddockA031.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/haddockC026.hs b/tests/examples/ghc86/haddockC026.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/haddockC027.hs b/tests/examples/ghc86/haddockC027.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/haddockC031.hs b/tests/examples/ghc86/haddockC031.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/mdo.hs b/tests/examples/ghc86/mdo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/mkGADTVars.hs b/tests/examples/ghc86/mkGADTVars.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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/ghc86/overloadedrecflds_generics.hs b/tests/examples/ghc86/overloadedrecflds_generics.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/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-ghc86/BadTelescope.hs b/tests/examples/pre-ghc86/BadTelescope.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/BadTelescope.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeInType #-} + +module BadTelescope where + +import Data.Kind + +data SameKind :: k -> k -> * + +data X a k (b :: k) (c :: SameKind a b) diff --git a/tests/examples/pre-ghc86/BadTelescope2.hs b/tests/examples/pre-ghc86/BadTelescope2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/BadTelescope2.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeInType, ExplicitForAll #-} + +module BadTelescope2 where + +import Data.Kind +import Data.Proxy + +data SameKind :: k -> k -> * + +foo :: forall a k (b :: k). SameKind a b +foo = undefined + +bar :: forall a (c :: Proxy b) (d :: Proxy a). Proxy c -> SameKind b d +bar = undefined diff --git a/tests/examples/pre-ghc86/BadTelescope3.hs b/tests/examples/pre-ghc86/BadTelescope3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/BadTelescope3.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeInType, ExplicitForAll #-} + +module BadTelescope3 where + +import Data.Kind + +data SameKind :: k -> k -> * + +type S a k (b :: k) = SameKind a b diff --git a/tests/examples/pre-ghc86/BadTelescope4.hs b/tests/examples/pre-ghc86/BadTelescope4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/BadTelescope4.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE ExistentialQuantification, TypeInType #-} +module BadTelescope4 where + +import Data.Proxy +import Data.Kind + +data SameKind :: k -> k -> * + +data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +data Borked a (b :: k) = forall (c :: k). B (Proxy c) + -- this last one is OK. But there was a bug involving renaming + -- that failed here, so the test case remains. diff --git a/tests/examples/pre-ghc86/Dep3.hs b/tests/examples/pre-ghc86/Dep3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/Dep3.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-} + +module Dep3 where + +import Data.Kind +import GHC.Exts ( Constraint ) + +type Star1 = * + +data Id1 (a :: Star1) where + Id1 :: a -> Id1 a + +data Id1' :: Star1 -> * where + Id1' :: a -> Id1' a + +type family Star2 x where + Star2 x = * + +data Id2a (a :: Star2 Constraint) = Id2a a + + +data Id2 (a :: Star2 Constraint) where + Id2 :: a -> Id2 a + +data Id2' :: Star2 Constraint -> * where + Id2' :: a -> Id2' a diff --git a/tests/examples/pre-ghc86/KindEqualities2.hs b/tests/examples/pre-ghc86/KindEqualities2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/KindEqualities2.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll, + TemplateHaskell, UndecidableInstances, ScopedTypeVariables, + TypeInType #-} + +module KindEqualities2 where + +import Data.Kind +import GHC.Exts ( Any ) + +data Kind = Star | Arr Kind Kind + +data Ty :: Kind -> * where + TInt :: Ty Star + TBool :: Ty Star + TMaybe :: Ty (Arr Star Star) + TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2 + + +data TyRep (k :: Kind) (t :: Ty k) where + TyInt :: TyRep Star TInt + TyBool :: TyRep Star TBool + TyMaybe :: TyRep (Arr Star Star) TMaybe + TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b) + +type family IK (k :: Kind) +type instance IK Star = * +type instance IK (Arr k1 k2) = IK k1 -> IK k2 + +$(return []) -- necessary because the following instances depend on the + -- previous ones. + +type family I (t :: Ty k) :: IK k +type instance I TInt = Int +type instance I TBool = Bool +type instance I TMaybe = Maybe +type instance I (TApp a b) = (I a) (I b) + +zero :: forall (a :: Ty 'Star). TyRep Star a -> I a +zero TyInt = 0 +zero TyBool = False +zero (TyApp TyMaybe TyInt) = Nothing + +main = print $ zero (TyApp TyMaybe TyInt) diff --git a/tests/examples/pre-ghc86/LiftedConstructors.hs b/tests/examples/pre-ghc86/LiftedConstructors.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/LiftedConstructors.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DataKinds, TypeOperators, GADTs #-} + +give :: b -> Pattern '[b] a +give b = Pattern (const (Just $ oneT b)) + + +pfail :: Pattern '[] a +pfail = is (const False) + +(/\) :: Pattern vs1 a -> Pattern vs2 a -> Pattern (vs1 :++: vs2) a +(/\) = mk2 (\a -> Just (a,a)) + +data Pattern :: [*] -> * where + Nil :: Pattern '[] + Cons :: Maybe h -> Pattern t -> Pattern (h ': t) + +type Pos = '("vpos", V3 GLfloat) +type Tag = '("tagByte", V1 Word8) + +-- | Alias for the 'In' type from the 'Direction' kind, allows users to write +-- the 'BroadcastChan In a' type without enabling DataKinds. +type In = 'In +-- | Alias for the 'Out' type from the 'Direction' kind, allows users to write +-- the 'BroadcastChan Out a' type without enabling DataKinds. +type Out = 'Out diff --git a/tests/examples/pre-ghc86/RAE_T32a.hs b/tests/examples/pre-ghc86/RAE_T32a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/RAE_T32a.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds, + PolyKinds, TypeFamilies, GADTs, TypeInType #-} + +module RAE_T32a where + +import Data.Kind + +data family Sing (k :: *) :: k -> * + +data TyArr' (a :: *) (b :: *) :: * +type TyArr (a :: *) (b :: *) = TyArr' a b -> * +type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2 +data TyPi' (a :: *) (b :: TyArr a *) :: * +type TyPi (a :: *) (b :: TyArr a *) = TyPi' a b -> * +type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b +$(return []) + +data MkStar (p :: *) (x :: TyArr' p *) +type instance MkStar p @@ x = * +$(return []) + +data Sigma (p :: *) (r :: TyPi p (MkStar p)) :: * where + Sigma :: + forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a). + Sing * p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b -> Sigma p r +$(return []) + +data instance Sing Sigma (Sigma p r) x where + SSigma :: + forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a) + (sp :: Sing * p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) (sb :: Sing (r @@@ a) b). + Sing (Sing (r @@@ a) b) sb -> + Sing (Sigma p r) ('Sigma sp sr sa sb) + +-- I (RAE) believe this last definition is ill-typed. diff --git a/tests/examples/pre-ghc86/RAE_T32b.hs b/tests/examples/pre-ghc86/RAE_T32b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/RAE_T32b.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, DataKinds, PolyKinds, + RankNTypes, TypeOperators, TypeInType #-} + +module RAE_T32b where + +import Data.Kind + +data family Sing (k :: *) :: k -> * + +data TyArr (a :: *) (b :: *) :: * +type family (a :: TyArr k1 k2 -> *) @@ (b :: k1) :: k2 +$(return []) + +data Sigma (p :: *) (r :: TyArr p * -> *) :: * where + Sigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a). + Sing * p -> Sing (TyArr p * -> *) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r +$(return []) + +data instance Sing (Sigma p r) (x :: Sigma p r) :: * where + SSigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a) + (sp :: Sing * p) (sr :: Sing (TyArr p * -> *) r) (sa :: Sing p a) (sb :: Sing (r @@ a) b). + Sing (Sing (r @@ a) b) sb -> + Sing (Sigma p r) ('Sigma sp sr sa sb) diff --git a/tests/examples/pre-ghc86/Rae31.hs b/tests/examples/pre-ghc86/Rae31.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/Rae31.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds, + TypeFamilies, TypeInType #-} + +module A where + +import Data.Kind + +data family Sing (k :: *) :: k -> * +type Sing' (x :: k) = Sing k x +data TyFun' (a :: *) (b :: *) :: * +type TyFun (a :: *) (b :: *) = TyFun' a b -> * +type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2 +data TyPi' (a :: *) (b :: TyFun a *) :: * +type TyPi (a :: *) (b :: TyFun a *) = TyPi' a b -> * +type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b +$(return []) + +data A (a :: *) (b :: a) (c :: TyFun' a *) -- A :: forall a -> a -> a ~> * +type instance (@@) (A a b) c = * +$(return []) +data B (a :: *) (b :: TyFun' a *) -- B :: forall a -> a ~> * +type instance (@@) (B a) b = TyPi a (A a b) +$(return []) +data C (a :: *) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) *) diff --git a/tests/examples/pre-ghc86/RaeBlogPost.hs b/tests/examples/pre-ghc86/RaeBlogPost.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/RaeBlogPost.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies, + TypeInType #-} +{-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-} + +module RaeBlogPost where + +import Data.Kind + +-- a Proxy type with an explicit kind +data Proxy k (a :: k) = P +prox :: Proxy * Bool +prox = P + +prox2 :: Proxy Bool 'True +prox2 = P + +-- implicit kinds still work +data A +data B :: A -> * +data C :: B a -> * +data D :: C b -> * +data E :: D c -> * +-- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> * + +-- a kind-indexed GADT +data TypeRep (a :: k) where + TInt :: TypeRep Int + TMaybe :: TypeRep Maybe + TApp :: TypeRep a -> TypeRep b -> TypeRep (a b) + +zero :: TypeRep a -> a +zero TInt = 0 +zero (TApp TMaybe _) = Nothing + +data Nat = Zero | Succ Nat +type family a + b where + 'Zero + b = b + ('Succ a) + b = 'Succ (a + b) + +data Vec :: * -> Nat -> * where + Nil :: Vec a 'Zero + (:>) :: a -> Vec a n -> Vec a ('Succ n) +infixr 5 :> + +-- promoted GADT, and using + as a "kind family": +type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where + 'Nil ++ y = y + (h ':> t) ++ y = h ':> (t ++ y) + +-- datatype that mentions * +data U = Star (*) + | Bool Bool + +-- kind synonym +type Monadish = * -> * +class MonadTrans (t :: Monadish -> Monadish) where + lift :: Monad m => m a -> t m a +data Free :: Monadish where + Return :: a -> Free a + Bind :: Free a -> (a -> Free b) -> Free b + +-- yes, * really does have type *. +type Star = (* :: (* :: (* :: *))) diff --git a/tests/examples/pre-ghc86/RenamingStar.hs b/tests/examples/pre-ghc86/RenamingStar.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/RenamingStar.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeInType #-} + +module RenamingStar where + +data Foo :: * diff --git a/tests/examples/pre-ghc86/SlidingTypeSyn.hs b/tests/examples/pre-ghc86/SlidingTypeSyn.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/SlidingTypeSyn.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + + +type ( f :-> g) (r :: * -> *) ix = f r ix -> g r ix + +type ( f :--> g) b ix = f b ix -> g b ix + +type ((f :---> g)) b ix = f b ix -> g b ix diff --git a/tests/examples/pre-ghc86/T10134a.hs b/tests/examples/pre-ghc86/T10134a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/T10134a.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module T10134a where + +import GHC.TypeLits + +data Vec :: Nat -> * -> * where + Nil :: Vec 0 a + (:>) :: a -> Vec n a -> Vec (n + 1) a diff --git a/tests/examples/pre-ghc86/T10321.hs b/tests/examples/pre-ghc86/T10321.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/T10321.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module T10321 where + +import GHC.TypeLits + +data Vec :: Nat -> * -> * where + Nil :: Vec 0 a + (:>) :: a -> Vec n a -> Vec (n + 1) a + +infixr 5 :> diff --git a/tests/examples/pre-ghc86/T10689a.hs b/tests/examples/pre-ghc86/T10689a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/T10689a.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE TypeOperators + , DataKinds + , PolyKinds + , TypeFamilies + , GADTs + , UndecidableInstances + , RankNTypes + , ScopedTypeVariables + #-} + +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Werror #-} +{-# OPTIONS_GHC -O1 -fspec-constr #-} + +{- +ghc-stage2: panic! (the 'impossible' happened) + (GHC version 7.11.20150723 for x86_64-unknown-linux): + Template variable unbound in rewrite rule +-} + +module List (sFoldr1) where + +data Proxy t + +data family Sing (a :: k) + +data TyFun (a :: *) (b :: *) + +type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2 + +data instance Sing (f :: TyFun k1 k2 -> *) = + SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } + +type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) + +type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) +singFun2 :: Proxy f -> SingFunction2 f -> Sing f +singFun2 _ f = SLambda (\x -> SLambda (f x)) + +data (:$$) (j :: a) (i :: TyFun [a] [a]) +type instance Apply ((:$$) j) i = (:) j i + +data (:$) (l :: TyFun a (TyFun [a] [a] -> *)) +type instance Apply (:$) l = (:$$) l +data instance Sing (z :: [a]) + = z ~ '[] => + SNil + | forall (m :: a) + (n :: [a]). z ~ (:) m n => + SCons (Sing m) (Sing n) + +data ErrorSym0 (t1 :: TyFun k1 k2) + +type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh + +type Let1627448493Xs f_afe9 + x_afea + wild_1627448474_afeb + wild_1627448476_afec = + Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec +type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) + -> *) + (t_afdZ :: [a_afdP]) = + Foldr1 t_afdY t_afdZ +data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) + -> *) + (l_afe2 :: TyFun [a_afdP] a_afdP) +type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 + +data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP + -> *) + -> *) (TyFun [a_afdP] a_afdP -> *)) +type instance Apply Foldr1Sym0 l = Foldr1Sym1 l + +type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP + -> *) + -> *) + (a_afe6 :: [a_afdP]) :: a_afdP where + Foldr1 z_afe7 '[x_afe8] = x_afe8 + Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) + Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" + +sFoldr1 :: + forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) + (y :: [a_afdP]). + Sing x + -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) +sFoldr1 _ (SCons _sX SNil) = undefined +sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) + = let + lambda_afeC :: + forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. + Sing f_afe9 + -> Sing x_afea + -> Sing wild_1627448474_afeb + -> Sing wild_1627448476_afec + -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) + lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG + = let + sXs :: + Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) + sXs + = applySing + (applySing + (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) + wild_1627448476_afeG + in + applySing + (applySing f_afeD x_afeE) + (applySing + (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) + sXs) + in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 +sFoldr1 _ SNil = undefined diff --git a/tests/examples/pre-ghc86/T10934.hs b/tests/examples/pre-ghc86/T10934.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/T10934.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE + ScopedTypeVariables + , DataKinds + , GADTs + , RankNTypes + , TypeOperators + , PolyKinds -- Comment out PolyKinds and the bug goes away. + #-} +{-# OPTIONS_GHC -O #-} + -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it + +module KeyValue where + +data AccValidation err a = AccFailure err | AccSuccess a + +data KeyValueError = MissingValue + +type WithKeyValueError = AccValidation [KeyValueError] + +missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs +missing = rpure missingField + where + missingField :: forall x. (WithKeyValueError :. f) x + missingField = Compose $ AccFailure [MissingValue] + +data Rec :: (u -> *) -> [u] -> * where + RNil :: Rec f '[] + (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) + +newtype Compose (f :: l -> *) (g :: k -> l) (x :: k) + = Compose { getCompose :: f (g x) } + +type (:.) f g = Compose f g + +class RecApplicative rs where + rpure + :: (forall x. f x) + -> Rec f rs diff --git a/tests/examples/pre-ghc86/T11142.hs b/tests/examples/pre-ghc86/T11142.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/T11142.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeInType, RankNTypes #-} + +module T11142 where + +import Data.Kind + +data SameKind :: k -> k -> * + +foo :: forall b. (forall k (a :: k). SameKind a b) -> () +foo = undefined diff --git a/tests/examples/pre-ghc86/T3927b.hs b/tests/examples/pre-ghc86/T3927b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/T3927b.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T3927b where + +import Data.Proxy +import GHC.Exts + +data Message + +data SocketType = Dealer | Push | Pull + +data SocketOperation = Read | Write + +type family Restrict (a :: SocketOperation) (as :: [SocketOperation]) :: Constraint where + Restrict a (a ': as) = () + Restrict x (a ': as) = Restrict x as + Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!") + +type family Implements (t :: SocketType) :: [SocketOperation] where + Implements Dealer = ['Read, Write] + Implements Push = '[Write] + Implements Pull = '[ 'Read] + +data SockOp :: SocketType -> SocketOperation -> * where + SRead :: SockOp sock 'Read + SWrite :: SockOp sock Write + +data Socket :: SocketType -> * where + Socket :: proxy sock + -> (forall op . Restrict op (Implements sock) => SockOp sock op -> Operation op) + -> Socket sock + +type family Operation (op :: SocketOperation) :: * where + Operation 'Read = IO Message + Operation Write = Message -> IO () + +class Restrict 'Read (Implements t) => Readable t where + readSocket :: Socket t -> Operation 'Read + readSocket (Socket _ f) = f (SRead :: SockOp t 'Read) + +instance Readable Dealer + +type family Writable (t :: SocketType) :: Constraint where + Writable Dealer = () + Writable Push = () + +dealer :: Socket Dealer +dealer = Socket (Proxy :: Proxy Dealer) f + where + f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op + f SRead = undefined + f SWrite = undefined + +push :: Socket Push +push = Socket (Proxy :: Proxy Push) f + where + f :: Restrict op (Implements Push) => SockOp Push op -> Operation op + f SWrite = undefined + +pull :: Socket Pull +pull = Socket (Proxy :: Proxy Pull) f + where + f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op + f SRead = undefined + +foo :: IO Message +foo = readSocket dealer diff --git a/tests/examples/pre-ghc86/T9632.hs b/tests/examples/pre-ghc86/T9632.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/T9632.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeInType #-} + +module T9632 where + +import Data.Kind + +data B = T | F +data P :: B -> * + +type B' = B +data P' :: B' -> * diff --git a/tests/examples/pre-ghc86/TensorTests.hs b/tests/examples/pre-ghc86/TensorTests.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/TensorTests.hs @@ -0,0 +1,43 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/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-ghc86/Vect.hs b/tests/examples/pre-ghc86/Vect.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/Vect.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE ParallelArrays #-} +{-# OPTIONS_GHC -fvectorise #-} +{-# LANGUAGE UnboxedTuples #-} + +module Vect where + +-- import Data.Array.Parallel + + +{-# VECTORISe isFive = blah #-} +{-# NoVECTORISE isEq #-} + +{-# VECTORISE SCALAR type Int #-} +{-# VECTORISE type Char #-} +{-# VECTORISE type ( ) #-} +{-# VECTORISE type (# #) #-} + +{-# VECTORISE SCALAR type Integer = Int #-} +{-# VECTORISE type Bool = String #-} + +{-# Vectorise class Eq #-} + +blah = 5 + +data MyBool = MyTrue | MyFalse + +class Eq a => Cmp a where + cmp :: a -> a -> Bool + +-- FIXME: +-- instance Cmp Int where +-- cmp = (==) +-- isFive :: (Eq a, Num a) => a -> Bool +isFive :: Int -> Bool +isFive x = x == 5 + +isEq :: Eq a => a -> Bool +isEq x = x == x + + +fiveEq :: Int -> Bool +fiveEq x = isFive x && isEq x + +cmpArrs :: PArray Int -> PArray Int -> Bool +{-# NOINLINE cmpArrs #-} +cmpArrs v w = cmpArrs' (fromPArrayP v) (fromPArrayP w) + +cmpArrs' :: [:Int:] -> [:Int:] -> Bool +cmpArrs' xs ys = andP [:x == y | x <- xs | y <- ys:] + +isFives :: PArray Int -> Bool +{-# NOINLINE isFives #-} +isFives xs = isFives' (fromPArrayP xs) + +isFives' :: [:Int:] -> Bool +isFives' xs = andP (mapP isFive xs) + +isEqs :: PArray Int -> Bool +{-# NOINLINE isEqs #-} +isEqs xs = isEqs' (fromPArrayP xs) + +isEqs' :: [:Int:] -> Bool +isEqs' xs = undefined -- andP (mapP isEq xs) + +-- fudge for compiler + +fromPArrayP = undefined +andP = undefined +mapP = undefined +data PArray a = PArray a diff --git a/tests/examples/pre-ghc86/Webhook.hs b/tests/examples/pre-ghc86/Webhook.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/Webhook.hs @@ -0,0 +1,176 @@ +{-| +Module : Servant.GitHub.Webhook +Description : Easily write safe GitHub webhook handlers with Servant +Copyright : (c) Jacob Thomas Errington, 2016 +License : MIT +Maintainer : servant-github-webhook@mail.jerrington.me +Stability : experimental + +The GitHub webhook machinery will attach three headers to the HTTP requests +that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@. +The former two headers correspond with the 'GitHubEvent' and +'GitHubSignedReqBody''' routing combinators. This library ignores the +@X-Github-Delivery@ header; if you would like to access its value, then use the +builtin 'Header' combinator from Servant. + +Usage of the library is straightforward: protect routes with the 'GitHubEvent' +combinator to ensure that the route is only reached for specific +'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write +under that route with 'GitHubSignedReqBody'. It is advised to always include a +'GitHubSignedReqBody''', as this is the only way you can be sure that it is +GitHub who is sending the request, and not a malicious user. If you don't care +about the request body, then simply use Aeson\'s 'Object' type as the +deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and +ignore the @Object@ in the handler. + +The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in +order to extract the signing key. This is the same key that must be entered in +the configuration of the webhook on GitHub. See 'GitHubKey'' for more details. + +In order to support multiple keys on a per-route basis, the basic combinator +@GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this, +create a datatype, e.g. @KeyIndex@ whose constructors identify the different +keys you will be using. Generally, this means one constructor per repository. +Use the @DataKinds@ extension to promote this datatype to a kind, and write an +instance of 'Reflect' for each promoted constructor of your datatype. Finally, +create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is +the datatype you've built up. Thus, your function can determine which key to +retrieve. +-} + +{-# LANGUAGE CPP #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- GHC 8 seems to have improved its decidability check for type family +-- instances and class instances. In particular, without UndecidableInstances +-- enabled, the Demote' instance for lists, which we need, will not compile. +-- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol, +-- won't compile on GHC < 8 because the instance head is no smaller than the +-- instance head. +#if __GLASGOW_HASKELL__ < 800 +{-# LANGUAGE UndecidableInstances #-} +#endif + +module Servant.GitHub.Webhook +( -- * Servant combinators + GitHubSignedReqBody'' +, GitHubSignedReqBody' +, GitHubSignedReqBody +, GitHubEvent + + -- ** Security +, GitHubKey'(..) +, GitHubKey +, gitHubKey + + -- * Reexports + -- + -- | We reexport a few datatypes that are typically needed to use the + -- library. +, RepoWebhookEvent(..) +, KProxy(..) + + -- * Implementation details + + -- ** Type-level programming machinery +, Demote +, Demote' +, Reflect(..) + + -- ** Stringy stuff +, parseHeaderMaybe +, matchEvent + + -- * Examples + -- + -- $example1 + -- + -- $example2 +) where + +import Control.Monad.IO.Class ( liftIO ) +import Data.Aeson ( decode', encode ) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy ( fromStrict, toStrict ) +import qualified Data.ByteString.Base16 as B16 +import Data.HMAC ( hmac_sha1 ) +import Data.List ( intercalate ) +import Data.Maybe ( catMaybes, fromMaybe ) +import Data.Monoid ( (<>) ) +import Data.Proxy +import Data.String.Conversions ( cs ) +import qualified Data.Text.Encoding as E +import GHC.TypeLits +import GitHub.Data.Webhooks +import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Wai ( requestHeaders, strictRequestBody ) +import Servant +import Servant.API.ContentTypes ( AllCTUnrender(..) ) +import Servant.Server.Internal + + +-- | A clone of Servant's 'ReqBody' combinator, except that it will also +-- verify the signature provided by GitHub in the @X-Hub-Signature@ header by +-- computing the SHA1 HMAC of the request body and comparing. +-- +-- The use of this combinator will require that the router context contain an +-- appropriate 'GitHubKey'' entry. Specifically, the type parameter of +-- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the +-- index @key@ used here. Consequently, it will be necessary to use +-- 'serveWithContext' instead of 'serve'. +-- +-- Other routes are not tried upon the failure of this combinator, and a 401 +-- response is generated. +-- +-- Use of this datatype directly is discouraged, since the choice of the index +-- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use +-- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just +-- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for +-- the implementation of the 'HasServer' instance for the datatype. +data GitHubSignedReqBody'' + (proxy :: KProxy k) + (key :: k) + (list :: [*]) + (result :: *) where + +-- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first +-- type argument given just the second one. +-- +-- Use this type synonym if you are creating a webhook server to handle +-- webhooks from multiple repositories, with different secret keys. +type GitHubSignedReqBody' (key :: k) + = GitHubSignedReqBody'' ('KProxy :: KProxy k) key + +-- | A convenient alias for a trivial key index. +-- +-- USe this type synonym if you are creating a webhook server to handle only +-- webhooks from a single repository, or for mutliple repositories using the +-- same secret key. +type GitHubSignedReqBody = GitHubSignedReqBody' '() + +-- | A routing combinator that succeeds only for a webhook request that matches +-- one of the given 'RepoWebhookEvent' given in the type-level list @events@. +-- +-- If the list contains 'WebhookWildcardEvent', then all events will be +-- matched. +-- +-- The combinator will require that its associated handler take a +-- 'RepoWebhookEvent' parameter, and the matched event will be passed to the +-- handler. This allows the handler to determine which event triggered it from +-- the list. +-- +-- Other routes are tried if there is a mismatch. +data GitHubEvent (events :: [RepoWebhookEvent]) where + diff --git a/tests/examples/pre-ghc86/determ004.hs b/tests/examples/pre-ghc86/determ004.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/determ004.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE TypeOperators + , DataKinds + , PolyKinds + , TypeFamilies + , GADTs + , UndecidableInstances + , RankNTypes + , ScopedTypeVariables + #-} + +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Werror #-} +{-# OPTIONS_GHC -O1 -fspec-constr #-} + +{- + +With reversed order of allocated uniques the type variables would be in +wrong order: + +*** Core Lint errors : in result of SpecConstr *** +determ004.hs:88:12: warning: + [in body of lambda with binder m_azbFg :: a_afdP_azbON] + @ (a_afdP_azbON :: BOX) is out of scope +*** Offending Program *** + +... + +Rec { +$s$wsFoldr1_szbtK + :: forall (m_azbFg :: a_afdP_azbON) + (x_azbOM :: TyFun + a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *) + -> *) + (a_afdP_azbON :: BOX) + (ipv_szbwN :: a_afdP_azbON) + (ipv_szbwO :: [a_afdP_azbON]). + R:Sing[]z (ipv_szbwN : ipv_szbwO) + ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO) + -> Sing ipv_szbwO + -> Sing ipv_szbwN + -> (forall (t_azbNM :: a_afdP_azbON). + Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) + -> Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) +[LclId, + Arity=4, + Str=DmdType ] +$s$wsFoldr1_szbtK = + \ (@ (m_azbFg :: a_afdP_azbON)) + (@ (x_azbOM :: TyFun + a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *) + -> *)) + (@ (a_afdP_azbON :: BOX)) + (@ (ipv_szbwN :: a_afdP_azbON)) + (@ (ipv_szbwO :: [a_afdP_azbON])) + (sg_szbtL + :: R:Sing[]z (ipv_szbwN : ipv_szbwO) + ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO)) + (sc_szbtM :: Sing ipv_szbwO) + (sc_szbtN :: Sing ipv_szbwN) + (sc_szbtP + :: forall (t_azbNM :: a_afdP_azbON). + Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) -> + case (SCons + @ a_afdP_azbON + @ (ipv_szbwN : ipv_szbwO) + @ ipv_szbwO + @ ipv_szbwN + @~ (_N + :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO)) + sc_szbtN + sc_szbtM) + `cast` (sg_szbtL + ; TFCo:R:Sing[]z[0] _N _N + :: R:Sing[]z (ipv_szbwN : ipv_szbwO) + ~R# R:Sing[]z + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) + of wild_XD { + SNil dt_dzbxX -> + (lvl_szbwi @ a_afdP_azbON) + `cast` ((Sing + (Sym (TFCo:R:Foldr1[2] _N _N) + ; Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N <'[]>_N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) + (Sym dt_dzbxX))_N))_R + :: Sing (Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list") + ~R# Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); + SCons @ n_azbFh @ m_XzbGe dt_dzbxK _sX_azbOH + ds_dzbyu [Dmd=] -> + case ds_dzbyu + `cast` (TFCo:R:Sing[]z[0] _N _N + :: Sing n_azbFh ~R# R:Sing[]z n_azbFh) + of wild_Xo { + SNil dt_dzbxk -> + (lvl_szbw1 @ a_afdP_azbON @ m_XzbGe) + `cast` ((Sing + (Sym (TFCo:R:Foldr1[0] _N _N _N) + ; Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N <'[m_XzbGe]>_N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) + ((_N ': Sym dt_dzbxk)_N ; Sym dt_dzbxK))_N))_R + :: Sing m_XzbGe + ~R# Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); + SCons @ ipv_XzbxR @ ipv_XzbyV ipv_szbwM ipv_szbwL ipv_szbwK -> + case (sc_szbtP @ m_XzbGe _sX_azbOH) + `cast` (TFCo:R:Sing(->)f[0] + _N _N _N + :: Sing (Apply x_azbOM m_XzbGe) + ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe)) + of wild_X3X { SLambda ds_XzbBr [Dmd=] -> + (ds_XzbBr + @ (Foldr1 x_azbOM (ipv_XzbyV : ipv_XzbxR)) + (($wsFoldr1_szbuc + @ a_afdP_azbON + @ x_azbOM + @ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR) + sc_szbtP + ((SCons + @ a_afdP_azbON + @ (ipv_XzbyV : ipv_XzbxR) + @ ipv_XzbxR + @ ipv_XzbyV + @~ (_N + :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR)) + ipv_szbwL + ipv_szbwK) + `cast` (Sym (TFCo:R:Sing[]z[0] _N) (Sym + (TFCo:R:Apply[][]:$$i[0] + _N + _N + _N) + ; (Apply + (Sym + (TFCo:R:Applyk(->):$l[0] + _N + _N)) + _N)_N) + :: R:Sing[]z (ipv_XzbyV : ipv_XzbxR) + ~R# Sing (Apply (Apply (:$) ipv_XzbyV) ipv_XzbxR)))) + `cast` ((Sing + ((Apply + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N) + _N)_N + ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N + ((Apply + (TFCo:R:Applyk(->):$l[0] _N _N) + _N)_N + ; TFCo:R:Apply[][]:$$i[0] + _N _N _N) + _N))_R + :: Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR)) + ~R# Sing (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))))) + `cast` ((Sing + ((Apply + _N + (Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N _N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] + _N _N)) + (Sym + (TFCo:R:Apply[][]:$$i[0] + _N _N _N) + ; (Apply + (Sym + (TFCo:R:Applyk(->):$l[0] _N _N)) + _N)_N))_N))_N + ; Sym + (TFCo:R:Foldr1[1] + _N + _N + _N + _N + _N) + ; Sym + (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] + _N _N _N) + ; (Apply + (Sym + (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) + ((_N ': Sym ipv_szbwM)_N ; Sym dt_dzbxK))_N))_R + :: Sing + (Apply + (Apply x_azbOM m_XzbGe) + (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))) + ~R# Sing + (Apply + (Apply Foldr1Sym0 x_azbOM) + (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))) + } + } + } +... +-} + +module List (sFoldr1) where + +data Proxy t + +data family Sing (a :: k) + +data TyFun (a :: *) (b :: *) + +type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2 + +data instance Sing (f :: TyFun k1 k2 -> *) = + SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } + +type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) + +type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) +singFun2 :: Proxy f -> SingFunction2 f -> Sing f +singFun2 _ f = SLambda (\x -> SLambda (f x)) + +data (:$$) (j :: a) (i :: TyFun [a] [a]) +type instance Apply ((:$$) j) i = (:) j i + +data (:$) (l :: TyFun a (TyFun [a] [a] -> *)) +type instance Apply (:$) l = (:$$) l +data instance Sing (z :: [a]) + = z ~ '[] => + SNil + | forall (m :: a) + (n :: [a]). z ~ (:) m n => + SCons (Sing m) (Sing n) + +data ErrorSym0 (t1 :: TyFun k1 k2) + +type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh + +type Let1627448493Xs f_afe9 + x_afea + wild_1627448474_afeb + wild_1627448476_afec = + Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec +type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) + -> *) + (t_afdZ :: [a_afdP]) = + Foldr1 t_afdY t_afdZ +data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) + -> *) + (l_afe2 :: TyFun [a_afdP] a_afdP) +type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 + +data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP + -> *) + -> *) (TyFun [a_afdP] a_afdP -> *)) +type instance Apply Foldr1Sym0 l = Foldr1Sym1 l + +type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP + -> *) + -> *) + (a_afe6 :: [a_afdP]) :: a_afdP where + Foldr1 z_afe7 '[x_afe8] = x_afe8 + Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) + Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" + +sFoldr1 :: + forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) + (y :: [a_afdP]). + Sing x + -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) +sFoldr1 _ (SCons _sX SNil) = undefined +sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) + = let + lambda_afeC :: + forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. + Sing f_afe9 + -> Sing x_afea + -> Sing wild_1627448474_afeb + -> Sing wild_1627448476_afec + -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) + lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG + = let + sXs :: + Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) + sXs + = applySing + (applySing + (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) + wild_1627448476_afeG + in + applySing + (applySing f_afeD x_afeE) + (applySing + (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) + sXs) + in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 +sFoldr1 _ SNil = undefined diff --git a/tests/examples/pre-ghc86/dynamic-paper.hs b/tests/examples/pre-ghc86/dynamic-paper.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/dynamic-paper.hs @@ -0,0 +1,341 @@ +{- This is the code extracted from "A reflection on types", by Simon PJ, +Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -} + +{-# LANGUAGE RankNTypes, PolyKinds, TypeOperators, + ScopedTypeVariables, GADTs, FlexibleInstances, + UndecidableInstances, RebindableSyntax, + DataKinds, MagicHash, AutoDeriveTypeable, TypeInType #-} +{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-redundant-constraints #-} + +module Dynamic where + +import Data.Map ( Map ) +import qualified Data.Map as Map +import Unsafe.Coerce ( unsafeCoerce ) +import Control.Monad ( (<=<) ) +import Prelude hiding ( lookup, fromInteger, replicate ) +import qualified Prelude +import qualified Data.Typeable +import qualified Data.Data +import Data.Kind + +lookupMap = Map.lookup +insertMap = Map.insert + +-- let's ignore overloaded numbers +fromInteger :: Integer -> Int +fromInteger = Prelude.fromInteger + +insertStore = undefined +schema = undefined +withTypeable = undefined +throw# = undefined + +toDynamicST = undefined +fromDynamicST = undefined + +extendStore :: Typeable a => STRef s a -> a -> Store -> Store +lookupStore :: Typeable a => STRef s a -> Store -> Maybe a + +type Key = Int +data STRef s a = STR Key +type Store = Map Key Dynamic + +extendStore (STR k) v s = insertMap k (toDynamicST v) s +lookupStore (STR k) s = case lookupMap k s of + Just d -> fromDynamicST d + Nothing -> Nothing + +toDynamicST :: Typeable a => a -> Dynamic +fromDynamicST :: Typeable a => Dynamic -> Maybe a + +eval = undefined +data Term + +data DynamicSilly = DIntSilly Int + | DBoolSilly Bool + | DCharSilly Char + | DPairSilly DynamicSilly DynamicSilly + + +toDynInt :: Int -> DynamicSilly +toDynInt = DIntSilly + +fromDynInt :: DynamicSilly -> Maybe Int +fromDynInt (DIntSilly n) = Just n +fromDynInt _ = Nothing + +toDynPair :: DynamicSilly -> DynamicSilly -> DynamicSilly +toDynPair = DPairSilly + +dynFstSilly :: DynamicSilly -> Maybe DynamicSilly +dynFstSilly (DPairSilly x1 x2) = Just x1 +dynFstSilly _ = Nothing + +eval :: Term -> DynamicSilly + +eqT = undefined + +instance Typeable (->) +instance Typeable Maybe +instance Typeable Bool +instance Typeable Int +instance (Typeable a, Typeable b) => Typeable (a b) +instance Typeable (,) + +instance Eq TypeRepX + +data Dynamic where + Dyn :: TypeRep a -> a -> Dynamic + +toDynamic :: Typeable a => a -> Dynamic +toDynamic x = Dyn typeRep x + +eqTNoKind = undefined + +eqTNoKind :: TypeRep a -> TypeRep b -> Maybe (a :***: b) + -- Primitive; implemented by compiler + +data a :***: b where + ReflNoKind :: a :***: a + +fromDynamic :: forall d. Typeable d => Dynamic -> Maybe d +fromDynamic (Dyn (ra :: TypeRep a) (x :: a)) + = case eqT ra (typeRep :: TypeRep d) of + Nothing -> Nothing + Just Refl -> Just x + +fromDynamicMonad :: forall d. Typeable d => Dynamic -> Maybe d + +fromDynamicMonad (Dyn ra x) + = do Refl <- eqT ra (typeRep :: TypeRep d) + return x + +cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b +cast x = do Refl <- eqT (typeRep :: TypeRep a) + (typeRep :: TypeRep b) + return x + +gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b) +gcast x = do Refl <- eqT (typeRep :: TypeRep a) + (typeRep :: TypeRep b) + return x + +data SameKind :: k -> k -> * +type CheckAppResult = SameKind AppResult AppResultNoKind + -- not the most thorough check +foo :: AppResult x -> AppResultNoKind x +foo (App y z) = AppNoKind y z + +splitApp :: TypeRep a -> Maybe (AppResult a) +splitApp = undefined +splitAppNoKind = undefined +splitAppNoKind :: TypeRep a -> Maybe (AppResultNoKind a) + -- Primitive; implemented by compiler + +data AppResultNoKind t where + AppNoKind :: TypeRep a -> TypeRep b -> AppResultNoKind (a b) + +dynFstNoKind :: Dynamic -> Maybe Dynamic +dynFstNoKind (Dyn rpab x) + = do AppNoKind rpa rb <- splitAppNoKind rpab + AppNoKind rp ra <- splitAppNoKind rpa + Refl <- eqT rp (typeRep :: TypeRep (,)) + return (Dyn ra (fst x)) + +dynApply :: Dynamic -> Dynamic -> Maybe Dynamic +dynApply (Dyn rf f) (Dyn rx x) = do + App ra rt2 <- splitApp rf + App rtc rt1 <- splitApp ra + Refl <- eqT rtc (typeRep :: TypeRep (->)) + Refl <- eqT rt1 rx + return (Dyn rt2 (f x)) + +data TypeRepAbstract (a :: k) -- primitive, indexed by type and kind + +class Typeable (a :: k) where + typeRep :: TypeRep a + +data AppResult (t :: k) where + App :: forall k1 k (a :: k1 -> k) (b :: k1). + TypeRep a -> TypeRep b -> AppResult (a b) + +dynFst :: Dynamic -> Maybe Dynamic +dynFst (Dyn (rpab :: TypeRep pab) (x :: pab)) + + = do App (rpa :: TypeRep pa ) (rb :: TypeRep b) <- splitApp rpab + -- introduces kind |k2|, and types |pa :: k2 -> *|, |b :: k2| + + App (rp :: TypeRep p ) (ra :: TypeRep a) <- splitApp rpa + -- introduces kind |k1|, and types |p :: k1 -> k2 -> *|, |a :: k1| + + Refl <- eqT rp (typeRep :: TypeRep (,)) + -- introduces |p ~ (,)| and |(k1 -> k2 -> *) ~ (* -> * -> *)| + + return (Dyn ra (fst x)) + +eqT :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~: b) + +data (a :: k1) :~: (b :: k2) where + Refl :: forall k (a :: k). a :~: a + +castDance :: (Typeable a, Typeable b) => a -> Maybe b +castDance = castR typeRep typeRep + +withTypeable :: TypeRep a -> (Typeable a => r) -> r + +castR :: TypeRep a -> TypeRep b -> a -> Maybe b +castR ta tb = withTypeable ta (withTypeable tb castDance) + +cmpT = undefined +compareTypeRep = undefined + +data TypeRepX where + TypeRepX :: TypeRep a -> TypeRepX + +type TyMapLessTyped = Map TypeRepX Dynamic + +insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped +insertLessTyped x = Map.insert (TypeRepX (typeRep :: TypeRep a)) (toDynamic x) + +lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a +lookupLessTyped = fromDynamic <=< Map.lookup (TypeRepX (typeRep :: TypeRep a)) + +instance Ord TypeRepX where + compare (TypeRepX tr1) (TypeRepX tr2) = compareTypeRep tr1 tr2 + +compareTypeRep :: TypeRep a -> TypeRep b -> Ordering -- primitive + +data TyMap = Empty | Node Dynamic TyMap TyMap + +lookup :: TypeRep a -> TyMap -> Maybe a +lookup tr1 (Node (Dyn tr2 v) left right) = + case compareTypeRep tr1 tr2 of + LT -> lookup tr1 left + EQ -> castR tr2 tr1 v -- know this cast will succeed + GT -> lookup tr1 right +lookup tr1 Empty = Nothing + +cmpT :: TypeRep a -> TypeRep b -> OrderingT a b + -- definition is primitive + +data OrderingT a b where + LTT :: OrderingT a b + EQT :: OrderingT t t + GTT :: OrderingT a b + +data TypeRep (a :: k) where + TrApp :: TypeRep a -> TypeRep b -> TypeRep (a b) + TrTyCon :: TyCon -> TypeRep k -> TypeRep (a :: k) + +data TyCon = TyCon { tc_module :: Module, tc_name :: String } +data Module = Module { mod_pkg :: String, mod_name :: String } + +tcMaybe :: TyCon +tcMaybe = TyCon { tc_module = Module { mod_pkg = "base" + , mod_name = "Data.Maybe" } + , tc_name = "Maybe" } + +rt = undefined + +delta1 :: Dynamic -> Dynamic +delta1 dn = case fromDynamic dn of + Just f -> f dn + Nothing -> dn +loop1 = delta1 (toDynamic delta1) + +data Rid = MkT (forall a. TypeRep a -> a -> a) +rt :: TypeRep Rid +delta :: forall a. TypeRep a -> a -> a +delta ra x = case (eqT ra rt) of + Just Refl -> case x of MkT y -> y rt x + Nothing -> x +loop = delta rt (MkT delta) + +throw# :: SomeException -> a + +data SomeException where + SomeException :: Exception e => e -> SomeException + +class (Typeable e, Show e) => Exception e where { } + +data Company +data Salary +incS :: Float -> Salary -> Salary +incS = undefined + +-- some impedance matching with SYB +instance Data.Data.Data Company +instance {-# INCOHERENT #-} Data.Typeable.Typeable a => Typeable a + +mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a +mkT f x = case (cast f) of + Just g -> g x + Nothing -> x + +data Expr a +frontEnd = undefined + +data DynExp where + DE :: TypeRep a -> Expr a -> DynExp + +frontEnd :: String -> DynExp + +data TyConOld + +typeOf = undefined +eqTOld = undefined +funTcOld = undefined :: TyConOld +splitTyConApp = undefined +mkTyCon3 = undefined +boolTcOld = undefined +tupleTc = undefined +mkTyConApp = undefined +instance Eq TypeRepOld +instance Eq TyConOld + +data TypeRepOld -- Abstract + +class TypeableOld a where + typeRepOld :: proxy a -> TypeRepOld + +data DynamicOld where + DynOld :: TypeRepOld -> a -> DynamicOld + +data Proxy a = Proxy + +fromDynamicOld :: forall d. TypeableOld d => DynamicOld -> Maybe d +fromDynamicOld (DynOld trx x) + | typeRepOld (Proxy :: Proxy d) == trx = Just (unsafeCoerce x) + | otherwise = Nothing + +dynApplyOld :: DynamicOld -> DynamicOld -> Maybe DynamicOld +dynApplyOld (DynOld trf f) (DynOld trx x) = + case splitTyConApp trf of + (tc, [t1,t2]) | tc == funTcOld && t1 == trx -> + Just (DynOld t2 ((unsafeCoerce f) x)) + _ -> Nothing + +data DynamicClosed where + DynClosed :: TypeRepClosed a -> a -> DynamicClosed + +data TypeRepClosed (a :: *) where + TBool :: TypeRepClosed Bool + TFun :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a -> b) + TProd :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a, b) + + +lookupPil = undefined + +lookupPil :: Typeable a => [Dynamic] -> Maybe a + +data Dyn1 = Dyn1 Int + | DynFun (Dyn1 -> Dyn1) + | DynPair (Dyn1, Dyn1) + +data TypeEnum = IntType | FloatType | BoolType | DateType | StringType +data Schema = Object [Schema] | + Field TypeEnum | + Array Schema + +schema :: Typeable a => a -> Schema diff --git a/tests/examples/pre-ghc86/mkGADTVars.hs b/tests/examples/pre-ghc86/mkGADTVars.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/mkGADTVars.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs, TypeInType #-} + +module GADTVars where + +import Data.Kind +import Data.Proxy + +data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where + MkT :: T x1 * (Proxy (y :: x1), z) z diff --git a/tests/examples/pre-ghc86/overloadedrecflds_generics.hs b/tests/examples/pre-ghc86/overloadedrecflds_generics.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc86/overloadedrecflds_generics.hs @@ -0,0 +1,50 @@ +-- Test that DuplicateRecordFields doesn't affect the metadata +-- generated by GHC.Generics or Data.Data + +-- Based on a Stack Overflow post by bennofs +-- (http://stackoverflow.com/questions/24474581) +-- licensed under cc by-sa 3.0 + +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +import GHC.Generics +import Data.Data +import Data.Proxy + +type family FirstSelector (f :: * -> *) :: Meta +type instance FirstSelector (M1 D x f) = FirstSelector f +type instance FirstSelector (M1 C x f) = FirstSelector f +type instance FirstSelector (a :*: b) = FirstSelector a +type instance FirstSelector (M1 S s f) = s + +data SelectorProxy (s :: Meta) (f :: * -> *) a = SelectorProxy +type SelectorProxy' (s :: Meta) = SelectorProxy s Proxy () + +-- Extract the first selector name using GHC.Generics +firstSelectorName :: forall a. Selector (FirstSelector (Rep a)) + => Proxy a -> String +firstSelectorName _ = + selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a))) + +-- Extract the list of selector names for a constructor using Data.Data +selectorNames :: Data a => a -> [String] +selectorNames = constrFields . toConstr + +data T = MkT { foo :: Int } deriving (Data, Generic) +data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic) + +main = do -- This should yield "foo", not "$sel:foo:MkT" + print (firstSelectorName (Proxy :: Proxy T)) + -- Similarly this should yield "foo" + print (firstSelectorName (Proxy :: Proxy U)) + -- This should yield ["foo"] + print (selectorNames (MkT 3)) + -- And this should yield ["foo","bar"] + print (selectorNames (MkU 3 True)) diff --git a/tests/examples/vect/DiophantineVect.hs b/tests/examples/vect/DiophantineVect.hs new file mode 100644 --- /dev/null +++ b/tests/examples/vect/DiophantineVect.hs @@ -0,0 +1,40 @@ +{-# 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) +