diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +2020-03-26 v0.6.3 + * Support GHC 8.8.1, 8.8.2, 8.8.3, 8.10.1 2019-08-28 v0.6.2 * Support GHC 8.8.1 (release candidate) 2019-05-27 v0.6.1 diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,5 +1,5 @@ name: ghc-exactprint -version: 0.6.2 +version: 0.6.3 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 @@ -40,16 +40,22 @@ , GHC == 8.6.2 , GHC == 8.6.4 , GHC == 8.6.5 + , GHC == 8.8.1 + , GHC == 8.8.2 + , GHC == 8.8.3 + , GHC == 8.10.1 extra-source-files: ChangeLog src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs tests/examples/failing/*.hs - tests/examples/ghc710/*.hs tests/examples/ghc710-only/*.hs + tests/examples/ghc710/*.hs tests/examples/ghc80/*.hs + tests/examples/ghc810/*.hs tests/examples/ghc82/*.hs tests/examples/ghc84/*.hs tests/examples/ghc86/*.hs tests/examples/ghc88/*.hs + tests/examples/pre-ghc810/*.hs tests/examples/pre-ghc86/*.hs tests/examples/vect/*.hs tests/examples/transform/*.hs @@ -93,8 +99,12 @@ -- other-modules: -- other-extensions: - GHC-Options: -Wall - build-depends: base >=4.8 && <4.14 + if impl (ghc >= 8.0.1) + GHC-Options: -Wall -Wredundant-constraints + else + GHC-Options: -Wall + -- GHC-Options: -Weverything + build-depends: base >=4.8 && <4.16 , bytestring >= 0.10.6 , containers >= 0.5 , directory >= 1.2 @@ -113,22 +123,25 @@ build-depends: ghc-boot hs-source-dirs: src - if impl (ghc > 8.6.5) - hs-source-dirs: src-ghc88 + if impl (ghc > 8.8.3) + hs-source-dirs: src-ghc810 else - if impl (ghc > 8.4.4) - hs-source-dirs: src-ghc86 + if impl (ghc > 8.6.5) + hs-source-dirs: src-ghc88 else - if impl (ghc > 8.2.2) - hs-source-dirs: src-ghc84 + if impl (ghc > 8.4.4) + 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) @@ -142,34 +155,41 @@ else hs-source-dirs: tests - if impl (ghc > 8.6.5) - hs-source-dirs: src-ghc88 + if impl (ghc > 8.8.3) + hs-source-dirs: src-ghc810 else - if impl (ghc > 8.4.4) - hs-source-dirs: src-ghc86 + if impl (ghc > 8.6.5) + hs-source-dirs: src-ghc88 else - if impl (ghc > 8.2.2) - hs-source-dirs: src-ghc84 + if impl (ghc > 8.4.4) + 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 + , Test.CommonUtils , Test.Consistency , Test.NoAnnotations , Test.Transform - GHC-Options: -threaded -Wall + if impl (ghc >= 8.0.1) + GHC-Options: -threaded -Wall -Wredundant-constraints + else + GHC-Options: -threaded -Wall Default-language: Haskell2010 if impl (ghc < 7.10.2) buildable: False Build-depends: HUnit >= 1.2 - , base < 4.14 + , base < 4.16 , bytestring , containers >= 0.5 , Diff @@ -219,8 +239,10 @@ buildable: True else buildable: False - ghc-options: - -threaded -Wall + if impl (ghc >= 8.0.1) + GHC-Options: -threaded -Wall -Wredundant-constraints + else + GHC-Options: -threaded -Wall executable static main-is: Static.hs @@ -238,8 +260,10 @@ build-depends: ghc-boot else buildable: False - ghc-options: - -threaded -Wall + if impl (ghc >= 8.0.1) + GHC-Options: -threaded -Wall -Wredundant-constraints + else + GHC-Options: -threaded -Wall executable prepare-hackage main-is: PrepareHackage.hs @@ -261,4 +285,7 @@ build-depends: ghc-boot else buildable: False - GHC-Options: -threaded + if impl (ghc >= 8.0.1) + GHC-Options: -threaded -Wall -Wredundant-constraints + else + GHC-Options: -threaded -Wall diff --git a/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs new file mode 100644 --- /dev/null +++ b/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs @@ -0,0 +1,2952 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} + + +-- | '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 qualified SrcLoc 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, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast) => ast -> Annotated () +annotate = markLocated + +-- instance Annotate (GHC.SrcSpanLess ast) where +-- markAST s ast = undefined +instance (Data ast, Annotate ast) => Annotate (GHC.Located ast) where + markAST l (GHC.L _ ast) = markAST l ast + +-- --------------------------------------------------------------------- + +-- | Constructs a syntax tree which contains information about which +-- annotations are required by each element. +markLocated :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) + => 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 :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) + => Bool -> [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 :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) + => [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 + 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 isSym + then ifInContext (Set.fromList [PrefixOp,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 + doNormalRdrName + "*" -> 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) + case qualFlag of + GHC.QualifiedPre -- 'qualified' appears in prepositive position. + -> (unsetContext TopLevel $ mark GHC.AnnQualified) + _ -> return () + case mpkg of + Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> + markWithString GHC.AnnPackageName srcPkg + _ -> return () + + markLocated modname + + case qualFlag of + GHC.QualifiedPost -- 'qualified' appears in postpositive position. + -> (unsetContext TopLevel $ mark GHC.AnnQualified) + _ -> return () + + 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.KindSigD _ 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 + setContext (Set.singleton PrefixOp) $ 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 mtybndrs termbndrs lhs rhs) = do + markLocated ln + setContext (Set.singleton ExplicitNeverActive) $ markActivation l act + + case mtybndrs of + Nothing -> return () + Just bndrs -> do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + mark GHC.AnnForall + mapM_ markLocated termbndrs + mark GHC.AnnDot + + markLocated lhs + mark GHC.AnnEqual + markLocated rhs + inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi + markTrailingSemi +{- + = HsRule -- Source rule + { rd_ext :: XHsRule pass + -- ^ After renamer, free-vars from the LHS and RHS + , rd_name :: Located (SourceText,RuleName) + -- ^ Note [Pragma source text] in BasicTypes + , rd_act :: Activation + , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] + -- ^ Forall'd type vars + , rd_tmvs :: [LRuleBndr pass] + -- ^ Forall'd term vars, before typechecking; after typechecking + -- this includes all forall'd vars + , rd_lhs :: Located (HsExpr pass) + , rd_rhs :: Located (HsExpr pass) + } + +-} + + 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 +{- +newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } + +type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) + +type FamInstEqn pass rhs + = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) + + +-} + 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 GhcPs [GHC.LHsTypeArg GhcPs] (GHC.LHsType GHC.GhcPs) +markFamEqn :: GHC.FamEqn GhcPs (GHC.LHsType GHC.GhcPs) + -> Annotated () +markFamEqn (GHC.FamEqn _ ln bndrs pats fixity rhs) = do + markTyClassArgs bndrs fixity ln pats + mark GHC.AnnEqual + markLocated rhs +{- +data FamEqn pass pats rhs + = FamEqn + { feqn_ext :: XCFamEqn pass pats rhs + , feqn_tycon :: Located (IdP pass) + , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars + , feqn_pats :: pats + , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration + , feqn_rhs :: rhs + } +-} + +markFamEqn (GHC.XFamEqn _) = error "got XFamEqn" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where + + markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln bndrs 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 + + markTyClassArgs bndrs 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 unless (null cons) $ mark GHC.AnnEqual + markDataDefn l (GHC.HsDataDefn GHC.NoExtField nd (GHC.noLoc []) typ _mk cons mderivs) + markOptional GHC.AnnWhere + markTrailingSemi + + 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 + setContext (Set.singleton PrefixOp) $ 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 + setContext (Set.singleton PrefixOp) $ 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" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.StandaloneKindSig GHC.GhcPs) where + + markAST _ (GHC.StandaloneKindSig _ ln st) = do + mark GHC.AnnType + setContext (Set.singleton PrefixOp) $ markLocated ln + mark GHC.AnnDcolon + markLHsSigType st + markTrailingSemi + tellContext (Set.singleton FollowingLine) + + markAST _ (GHC.XStandaloneKindSig _) + = error "hit extension for StandaloneKindSig" + +-- -------------------------------------------------------------------- + +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 + inContext (Set.fromList [InTypeApp]) $ mark GHC.AnnAt + 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 _ fvf tvs typ) = do + mark GHC.AnnForall + mapM_ markLocated tvs + case fvf of + GHC.ForallInvis -> mark GHC.AnnDot + GHC.ForallVis -> mark GHC.AnnRarrow + markLocated typ + + markType _ (GHC.HsQualTy _ cxt typ) = do + markLocated cxt + markLocated typ + + markType _ (GHC.HsTyVar _ promoted name) = do + when (promoted == GHC.IsPromoted) $ 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.HsAppKindTy l t k) = do + setContext (Set.singleton PrefixOp) $ markLocated t + markTypeApp l + markLocated k + + 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 + markOptional GHC.AnnOpenP -- '(' + markLocated t + mark GHC.AnnDcolon -- '::' + markLocated k + markOptional 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.IsPromoted) $ 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.HsSplicedT{} -> error "HsSplicedT 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) + -- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated 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 _ pat ty) = do + markLocated pat + mark GHC.AnnDcolon + markLHsSigWcType ty + + markPat _ GHC.CoPat {} = + traceM "warning: CoPat introduced after renaming" + + -- markPat _ (GHC.XPat (GHC.L l p)) = markPat l p + 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 + markListWithLayout 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.HsUnboundVar {}) = do + ifInContext (Set.fromList [InfixOp]) + (do mark GHC.AnnBackquote + markWithString GHC.AnnVal "_" + mark GHC.AnnBackquote) + (markExternal l GHC.AnnVal "_") + + 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.AnnSemi + 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 _ e typ) = 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 _ (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 _ e ty) = do + markLocated e + markInstead GHC.AnnAt AnnTypeApp + markLHsWcType ty + + markExpr _ (GHC.HsWrap {}) = + traceM "warning: HsWrap 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 +{- + SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs + , tcdLName :: Located (IdP pass) -- ^ Type constructor + , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an + -- associated type these + -- include outer binders + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration + , tcdRhs :: LHsType pass } -- ^ RHS of type declaration + +-} + 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 Nothing 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 Nothing 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 Nothing 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" + +-- --------------------------------------------------------------------- + +markTypeApp :: GHC.SrcSpan -> Annotated () +markTypeApp loc = do + let l = GHC.srcSpanFirstCharacter loc + markExternal l GHC.AnnVal "@" + +-- --------------------------------------------------------------------- + +markTyClassArgs :: (Annotate a) + => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity + -- -> GHC.Located a -> [ast] -> Annotated () + -> GHC.Located a -> [GHC.LHsTypeArg GhcPs] -> Annotated () +markTyClassArgs mbndrs fixity ln tyVars = do + let + cvt (GHC.HsValArg val) = markLocated val + cvt (GHC.HsTypeArg loc typ) = do + markTypeApp loc + -- let l = GHC.srcSpanFirstCharacter loc + -- markExternal l GHC.AnnVal "@" + markLocated typ + cvt (GHC.HsArgPar _ss) = undefined + markTyClassWorker cvt mbndrs fixity ln tyVars + {- +type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) + +data HsArg tm ty + = HsValArg tm -- Argument is an ordinary expression (f arg) + | HsTypeArg ty -- Argument is a visible type application (f @ty) + | HsArgPar SrcSpan -- See Note [HsArgPar] +-} + +-- TODO:AZ: simplify +markTyClass :: (Data (GHC.SrcSpanLess ast), Annotate a, Annotate ast,GHC.HasSrcSpan ast) + => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity + -> GHC.Located a -> [ast] -> Annotated () +markTyClass = markTyClassWorker markLocated + +markTyClassWorker :: (Annotate a) + => (b -> Annotated ()) -> Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity + -- -> GHC.Located a -> [ast] -> Annotated () + -> GHC.Located a -> [b] -> Annotated () +markTyClassWorker markFn mbndrs fixity ln tyVars = do + let processBinders = + case mbndrs of + Nothing -> return () + Just bndrs -> do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + -- 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 + processBinders + setContext (Set.singleton PrefixOp) $ markLocated ln + -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars + setContext (Set.singleton PrefixOp) $ mapM_ markFn $ take 2 tyVars + when (length tyVars >= 2) $ do + markParens GHC.AnnCloseP + setContext (Set.singleton PrefixOp) $ mapM_ markFn $ drop 2 tyVars + markManyOptional GHC.AnnCloseP + else do + case tyVars of + (x:y:xs) -> do + markParens GHC.AnnOpenP + processBinders + markFn x + setContext (Set.singleton InfixOp) $ markLocated ln + markFn y + markParens GHC.AnnCloseP + mapM_ markFn 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 Nothing 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 +{- +type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) + +type FamInstEqn pass rhs + = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) + +type HsTyPats pass = [LHsTypeArg pass] + +-} + 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 mbndrs (GHC.HsQTvs _ bndrs) fixity typ) = do +-- mark GHC.AnnType +-- mark GHC.AnnInstance +-- markTyClass mbndrs 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.Located (GHC.Pat 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.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-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs --- a/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ b/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs @@ -819,8 +819,7 @@ -- --------------------------------------------------------------------- -markFamEqn :: (GHC.HasOccName (GHC.IdP pass), - Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2) +markFamEqn :: (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 @@ -2398,10 +2397,10 @@ = error "extension hit for TyClDecl" markAST _ (GHC.XTyClDecl _) = error "extension hit for TyClDecl" - + -- --------------------------------------------------------------------- -markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) +markTyClass :: (Annotate a, Annotate ast) => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated () markTyClass fixity ln tyVars = do -- There may be arbitrary parens around parts of the constructor diff --git a/src/Language/Haskell/GHC/ExactPrint/Delta.hs b/src/Language/Haskell/GHC/ExactPrint/Delta.hs --- a/src/Language/Haskell/GHC/ExactPrint/Delta.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Delta.hs @@ -449,7 +449,7 @@ getSrcSpan = asks curSrcSpan #if __GLASGOW_HASKELL__ > 806 -withSrcSpanDelta :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b +withSrcSpanDelta :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b withSrcSpanDelta (GHC.dL->GHC.L l a) = #else withSrcSpanDelta :: Data a => GHC.Located a -> Delta b -> Delta b diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs --- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs @@ -12,6 +12,7 @@ module Language.Haskell.GHC.ExactPrint.Parsers ( -- * Utility Parser + , ParseResult , withDynFlags , CppOptions(..) , defaultCppOptions @@ -58,13 +59,21 @@ import qualified ApiAnnotation as GHC import qualified DynFlags as GHC +#if __GLASGOW_HASKELL__ > 808 +import qualified ErrUtils as GHC +#endif import qualified FastString as GHC import qualified GHC as GHC hiding (parseModule) import qualified HeaderInfo as GHC import qualified Lexer as GHC import qualified MonadUtils as GHC +#if __GLASGOW_HASKELL__ <= 808 import qualified Outputable as GHC +#endif import qualified Parser as GHC +#if __GLASGOW_HASKELL__ > 808 +import qualified RdrHsSyn as GHC +#endif import qualified SrcLoc as GHC import qualified StringBuffer as GHC @@ -89,18 +98,20 @@ -> FilePath -> GHC.P w -> String - -> Either (GHC.SrcSpan, String) (Anns, w) + -> ParseResult w #else parseWith :: Annotate w => GHC.DynFlags -> FilePath -> GHC.P (GHC.Located w) -> String - -> Either (GHC.SrcSpan, String) (Anns, GHC.Located w) + -> ParseResult (GHC.Located w) #endif parseWith dflags fileName parser s = case runParser parser dflags fileName s of -#if __GLASGOW_HASKELL__ >= 804 +#if __GLASGOW_HASKELL__ > 808 + GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags) +#elif __GLASGOW_HASKELL__ >= 804 GHC.PFailed _ ss m -> Left (ss, GHC.showSDoc dflags m) #else GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m) @@ -108,6 +119,22 @@ GHC.POk (mkApiAnns -> apianns) pmod -> Right (as, pmod) where as = relativiseApiAnns pmod apianns + +#if __GLASGOW_HASKELL__ > 808 +parseWithECP :: (GHC.DisambECP w, Annotate (GHC.Body w GHC.GhcPs)) + => GHC.DynFlags + -> FilePath + -> GHC.P GHC.ECP + -> String + -> ParseResult (GHC.Located w) +parseWithECP dflags fileName parser s = + -- case runParser ff dflags fileName s of + case runParser (parser >>= \p -> GHC.runECP_P p) dflags fileName s of + GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags) + GHC.POk (mkApiAnns -> apianns) pmod -> Right (as, pmod) + where as = relativiseApiAnns pmod apianns +#endif + -- --------------------------------------------------------------------- runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a @@ -138,12 +165,21 @@ -- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 808 +type ParseResult a = Either GHC.ErrorMessages (Anns, a) +#else +type ParseResult a = Either (GHC.SrcSpan, String) (Anns, a) +#endif + type Parser a = GHC.DynFlags -> FilePath -> String - -> Either (GHC.SrcSpan, String) - (Anns, a) + -> ParseResult a parseExpr :: Parser (GHC.LHsExpr GhcPs) +#if __GLASGOW_HASKELL__ > 808 +parseExpr df fp = parseWithECP df fp GHC.parseExpression +#else parseExpr df fp = parseWith df fp GHC.parseExpression +#endif parseImport :: Parser (GHC.LImportDecl GhcPs) parseImport df fp = parseWith df fp GHC.parseImport @@ -176,8 +212,7 @@ -- @ -- -- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GhcPs') -parseModule - :: FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) +parseModule :: FilePath -> IO (ParseResult GHC.ParsedSource) parseModule = parseModuleWithCpp defaultCppOptions normalLayout @@ -189,32 +224,29 @@ parseModuleFromString :: FilePath -> String - -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) + -> IO (ParseResult GHC.ParsedSource) parseModuleFromString fp s = ghcWrapper $ do dflags <- initDynFlagsPure fp s return $ parseModuleFromStringInternal dflags fp s -- | Internal part of 'parseModuleFromString'. -parseModuleFromStringInternal - :: GHC.DynFlags - -> FilePath - -> String - -> Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource) +parseModuleFromStringInternal :: Parser GHC.ParsedSource parseModuleFromStringInternal dflags fileName str = let (str1, lp) = stripLinePragmas str res = case runParser GHC.parseModule dflags fileName str1 of -#if __GLASGOW_HASKELL__ >= 804 +#if __GLASGOW_HASKELL__ > 808 + GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags) +#elif __GLASGOW_HASKELL__ >= 804 GHC.PFailed _ ss m -> Left (ss, GHC.showSDoc dflags m) #else GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m) #endif - GHC.POk x pmod -> Right $ (mkApiAnns x, lp, dflags, pmod) + GHC.POk x pmod -> Right (mkApiAnns x, lp, dflags, pmod) in postParseTransform res normalLayout parseModuleWithOptions :: DeltaOptions -> FilePath - -> IO (Either (GHC.SrcSpan, String) - (Anns, GHC.ParsedSource)) + -> IO (ParseResult GHC.ParsedSource) parseModuleWithOptions opts fp = parseModuleWithCpp defaultCppOptions opts fp @@ -224,7 +256,7 @@ :: CppOptions -> DeltaOptions -> FilePath - -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) + -> IO (ParseResult GHC.ParsedSource) parseModuleWithCpp cpp opts fp = do res <- parseModuleApiAnnsWithCpp cpp fp return $ postParseTransform res opts @@ -239,7 +271,11 @@ -> FilePath -> IO ( Either +#if __GLASGOW_HASKELL__ > 808 + GHC.ErrorMessages +#else (GHC.SrcSpan, String) +#endif (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) ) parseModuleApiAnnsWithCpp cppOptions file = ghcWrapper $ do @@ -261,7 +297,11 @@ -> FilePath -> m ( Either +#if __GLASGOW_HASKELL__ > 808 + GHC.ErrorMessages +#else (GHC.SrcSpan, String) +#endif (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) ) parseModuleApiAnnsWithCppInternal cppOptions dflags file = do @@ -282,7 +322,9 @@ return (contents1,lp,dflags) return $ case parseFile dflags' file fileContents of -#if __GLASGOW_HASKELL__ >= 804 +#if __GLASGOW_HASKELL__ > 808 + GHC.PFailed pst -> Left (GHC.getErrorMessages pst dflags) +#elif __GLASGOW_HASKELL__ >= 804 GHC.PFailed _ ss m -> Left $ (ss, (GHC.showSDoc dflags m)) #else GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m)) diff --git a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs --- a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs @@ -26,11 +26,18 @@ import qualified MonadUtils as GHC import qualified SrcLoc as GHC import qualified StringBuffer as GHC +#if __GLASGOW_HASKELL__ > 808 +import qualified Fingerprint as GHC +import qualified ToolSettings as GHC +#endif import SrcLoc (mkSrcSpan, mkSrcLoc) import FastString (mkFastString) +#if __GLASGOW_HASKELL__ > 808 +#else import Control.Exception +#endif import Data.List hiding (find) import Data.Maybe #if __GLASGOW_HASKELL__ <= 800 @@ -121,7 +128,9 @@ #else $ map (tokComment . commentToAnnotation . fst) cppCommentToks #endif -#if __GLASGOW_HASKELL__ >= 804 +#if __GLASGOW_HASKELL__ > 808 + GHC.PFailed pst -> parseError flags2 pst +#elif __GLASGOW_HASKELL__ >= 804 GHC.PFailed _ sspan err -> parseError flags2 sspan err #else GHC.PFailed sspan err -> parseError flags2 sspan err @@ -180,7 +189,9 @@ let src = stripPreprocessorDirectives buf case GHC.lexTokenStream src startLoc flags of GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc src ts -#if __GLASGOW_HASKELL__ >= 804 +#if __GLASGOW_HASKELL__ > 808 + GHC.PFailed pst -> parseError flags pst +#elif __GLASGOW_HASKELL__ >= 804 GHC.PFailed _ sspan err -> parseError flags sspan err #else GHC.PFailed sspan err -> parseError flags sspan err @@ -249,12 +260,25 @@ mkInclude = ("-include" ++) +#if __GLASGOW_HASKELL__ > 808 addOptP :: String -> GHC.DynFlags -> GHC.DynFlags +addOptP f = alterToolSettings $ \s -> s + { GHC.toolSettings_opt_P = f : GHC.toolSettings_opt_P s + , GHC.toolSettings_opt_P_fingerprint = fingerprintStrings (f : GHC.toolSettings_opt_P s) + } +alterToolSettings :: (GHC.ToolSettings -> GHC.ToolSettings) -> GHC.DynFlags -> GHC.DynFlags +alterToolSettings f dynFlags = dynFlags { GHC.toolSettings = f (GHC.toolSettings dynFlags) } + +fingerprintStrings :: [String] -> GHC.Fingerprint +fingerprintStrings ss = GHC.fingerprintFingerprints $ map GHC.fingerprintString ss + +#else +addOptP :: String -> GHC.DynFlags -> GHC.DynFlags addOptP f = alterSettings (\s -> s { GHC.sOpt_P = f : GHC.sOpt_P s}) alterSettings :: (GHC.Settings -> GHC.Settings) -> GHC.DynFlags -> GHC.DynFlags alterSettings f dflags = dflags { GHC.settings = f (GHC.settings dflags) } - +#endif -- --------------------------------------------------------------------- -- | Get the preprocessor directives as comment tokens from the @@ -276,9 +300,18 @@ -- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 808 +parseError :: (GHC.MonadIO m) => GHC.DynFlags -> GHC.PState -> m b +parseError dflags pst = do + let + -- (warns,errs) = GHC.getMessages pst dflags + -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err) + GHC.throwErrors (GHC.getErrorMessages pst dflags) +#else parseError :: GHC.DynFlags -> GHC.SrcSpan -> GHC.MsgDoc -> m b parseError dflags sspan err = do throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err) +#endif -- --------------------------------------------------------------------- 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 @@ -314,7 +314,7 @@ -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ > 806 -withSrcSpanPretty :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b +withSrcSpanPretty :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b withSrcSpanPretty (GHC.dL->GHC.L l a) action = do #else withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b 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 @@ -281,7 +281,9 @@ -- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl' wrapSig :: GHC.LSig GhcPs -> GHC.LHsDecl GhcPs -#if __GLASGOW_HASKELL__ > 804 +#if __GLASGOW_HASKELL__ > 808 +wrapSig (GHC.L l s) = GHC.L l (GHC.SigD GHC.NoExtField s) +#elif __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) @@ -291,7 +293,9 @@ -- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl' wrapDecl :: GHC.LHsBind GhcPs -> GHC.LHsDecl GhcPs -#if __GLASGOW_HASKELL__ > 804 +#if __GLASGOW_HASKELL__ > 808 +wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD GHC.NoExtField s) +#elif __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) @@ -543,8 +547,10 @@ -- '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__ > 804 +#if __GLASGOW_HASKELL__ > 808 balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do +#elif __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 @@ -1145,8 +1151,10 @@ -- --------------------------------- lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs] -#if __GLASGOW_HASKELL__ > 804 +#if __GLASGOW_HASKELL__ > 808 lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do +#elif __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 @@ -1230,7 +1238,9 @@ => GHC.HsLocalBinds GhcPs -> [GHC.LHsDecl GhcPs] -> TransformT m (GHC.HsLocalBinds GhcPs) replaceDeclsValbinds _ [] = do -#if __GLASGOW_HASKELL__ > 804 +#if __GLASGOW_HASKELL__ > 808 + return (GHC.EmptyLocalBinds GHC.NoExtField) +#elif __GLASGOW_HASKELL__ > 804 return (GHC.EmptyLocalBinds GHC.noExt) #else return (GHC.EmptyLocalBinds) @@ -1244,7 +1254,9 @@ logTr "replaceDecls HsLocalBinds" let decs = GHC.listToBag $ concatMap decl2Bind new let sigs = concatMap decl2Sig new -#if __GLASGOW_HASKELL__ > 804 +#if __GLASGOW_HASKELL__ > 808 + return (GHC.HsValBinds GHC.NoExtField (GHC.ValBinds GHC.NoExtField decs sigs)) +#elif __GLASGOW_HASKELL__ > 804 return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs)) #else return (GHC.HsValBinds (GHC.ValBindsIn decs sigs)) @@ -1261,7 +1273,9 @@ newSigs = map decl2Sig new let decs = GHC.listToBag $ concat newBinds let sigs = concat newSigs -#if __GLASGOW_HASKELL__ > 804 +#if __GLASGOW_HASKELL__ > 808 + return (GHC.HsValBinds GHC.NoExtField (GHC.ValBinds GHC.NoExtField decs sigs)) +#elif __GLASGOW_HASKELL__ > 804 return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs)) #else return (GHC.HsValBinds (GHC.ValBindsIn decs sigs)) 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 @@ -43,6 +43,10 @@ , GhcRn , GhcTc +#if __GLASGOW_HASKELL__ > 804 + , noExt +#endif + -- * Internal Types , LayoutStartCol(..) , declFun @@ -190,6 +194,15 @@ type GhcTc = GHC.GhcTc #endif + +#if __GLASGOW_HASKELL__ > 808 +noExt :: GHC.NoExtField +noExt = GHC.NoExtField +#elif __GLASGOW_HASKELL__ > 804 +noExt :: GHC.NoExt +noExt = GHC.noExt +#endif + -- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise. #if __GLASGOW_HASKELL__ > 806 mkAnnKey :: (Constraints a) => a -> AnnKey @@ -390,6 +403,9 @@ GHC.DerivD _ d -> f (GHC.L l d) GHC.ValD _ d -> f (GHC.L l d) GHC.SigD _ d -> f (GHC.L l d) +#if __GLASGOW_HASKELL__ > 808 + GHC.KindSigD _ d -> f (GHC.L l d) +#endif GHC.DefD _ d -> f (GHC.L l d) GHC.ForD _ d -> f (GHC.L l d) GHC.WarningD _ d -> f (GHC.L l d) diff --git a/tests/PrepareHackage.hs b/tests/PrepareHackage.hs --- a/tests/PrepareHackage.hs +++ b/tests/PrepareHackage.hs @@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -- import Data.Char -import Data.Monoid +-- import Data.Monoid import System.Directory import System.FilePath.Posix -import System.IO +-- import System.IO import Test.CommonUtils import Turtle hiding (FilePath,(<.>)) import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified GHC.IO.Handle.Text as GHC +-- import qualified GHC.IO.Handle.Text as GHC import Test.HUnit @@ -75,15 +75,15 @@ -- --------------------------------------------------------------------- -- | The computation 'writeFile' @file str@ function writes the string @str@, -- to the file @file@. -writeFileUtf8 :: FilePath -> String -> IO () -writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> GHC.hPutStr hdl txt) +-- writeFileUtf8 :: FilePath -> String -> IO () +-- writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> GHC.hPutStr hdl txt) -- --------------------------------------------------------------------- -allCabalPackagesTest :: IO [Text] -allCabalPackagesTest - = return ["3d-graphics-examples","3dmodels","4Blocks","AAI","ABList"] - -- = return ["airship"] +-- allCabalPackagesTest :: IO [Text] +-- allCabalPackagesTest +-- = return ["3d-graphics-examples","3dmodels","4Blocks","AAI","ABList"] +-- -- = return ["airship"] allCabalPackages :: IO [Text] @@ -107,8 +107,8 @@ tabWidth :: Int tabWidth = 8 -nonBreakingSpace :: Char -nonBreakingSpace = '\xa0' +-- nonBreakingSpace :: Char +-- nonBreakingSpace = '\xa0' cleanupOneLine :: String -> String cleanupOneLine str = str' diff --git a/tests/Roundtrip.hs b/tests/Roundtrip.hs --- a/tests/Roundtrip.hs +++ b/tests/Roundtrip.hs @@ -143,7 +143,7 @@ writeError fp throwIO e case r1 of - Left (ParseFailure _ s) -> do + Left (ParseFailure s) -> do writeParseFail fp s exitFailure Right r -> do diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -28,12 +28,14 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88 +data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88 | GHC810 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion ghcVersion = -#if __GLASGOW_HASKELL__ > 806 +#if __GLASGOW_HASKELL__ > 808 + GHC810 +#elif __GLASGOW_HASKELL__ > 806 GHC88 #elif __GLASGOW_HASKELL__ > 804 GHC86 @@ -54,12 +56,13 @@ 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" ] - GHC88 -> [ "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88" ] + GHC84 -> ["pre-ghc86", "pre-ghc810", "ghc710", "ghc80", "ghc82", "ghc84", "vect" ] + GHC86 -> ["pre-ghc810", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86" ] + GHC88 -> ["pre-ghc810", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88" ] + GHC810 -> [ "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810" ] - -- GHC88 -> ["ghc88"] - -- GHC88 -> ["ghc88-copied"] + -- GHC810 -> ["ghc810"] + -- GHC810 -> ["ghc810-copied"] -- --------------------------------------------------------------------- @@ -199,48 +202,17 @@ tt' :: IO (Counts,Int) tt' = runTestText (putTextToHandle stdout True) $ TestList [ - - -- mkPrettyRoundtrip "ghc86" "dynamic-paper.hs" - -- mkPrettyRoundtrip "ghc86" "mdo.hs" - - -- mkParserTest "ghc88" "DumpParsedast.hs" - -- mkParserTest "ghc88-copied" "T15365.hs" - -- mkPrettyRoundtrip "ghc88-copied" "T15365.hs" - -- mkParserTest "ghc88-copied" "T4437.hs" - - -- mkParserTest "ghc88-copied" "TH_recover_warns.hs" - -- mkPrettyRoundtrip "ghc88-copied" "TH_recover_warns.hs" - - -- mkParserTest "ghc88-copied" "TH_recursiveDoImport.hs" - -- mkPrettyRoundtrip "ghc88-copied" "TH_recursiveDoImport.hs" - - -- mkParserTest "ghc88-copied" "dsrun010.hs" - -- mkPrettyRoundtrip "ghc88-copied" "dsrun010.hs" - - -- mkParserTest "ghc88" "Internal.hs" - -- mkParserTest "ghc88" "Main.hs" - mkParserTest "ghc88" "PersistUniqueTest.hs" - - -- --------------------------------------------------------------- - -- mkParserTest "ghc710" "Roles.hs" - -- --------------------------------------------------------------- - - - - - -- mkParserTest "ghc86" "deriving-via-compile.hs" - -- mkParserTest "ghc88" "ClassParens.hs" - - - -- mkParserTest "pre-ghc86" "TensorTests.hs" - -- , mkParserTest "pre-ghc86" "Webhook.hs" - -- , mkParserTest "ghc710" "RdrNames.hs" + -- mkParserTest "ghc80" "C.hs" + -- mkParserTest "ghc80" "T10267.hs" + -- , mkParserTest "ghc80" "T10946.hs" + -- mkParserTest "ghc82" "T13050.hs" + -- mkParserTest "ghc84" "arrowfail003.hs" + -- mkParserTest "ghc810" "T17296.hs" - -- mkPrettyRoundtrip "ghc86" "BinDU.hs" - -- , mkPrettyRoundtrip "ghc86" "Dial.hs" + mkPrettyRoundtrip "ghc810" "T16326_Compile1.hs" + -- mkPrettyRoundtrip "ghc810" "saks029.hs" - -- mkParserTest "ghc84" "Types.hs" - -- , mkPrettyRoundtrip "ghc80" "export-type.hs" + -- mkPrettyRoundtrip "ghc86" "dynamic-paper.hs" -- Needs GHC changes -- mkParserTest "failing" "CtorOp.hs" diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs --- a/tests/Test/Common.hs +++ b/tests/Test/Common.hs @@ -21,6 +21,9 @@ , genTest , noChange , mkDebugOutput +#if __GLASGOW_HASKELL__ > 808 + , showErrorMessages +#endif ) where @@ -34,13 +37,12 @@ import qualified ApiAnnotation as GHC import qualified DynFlags as GHC --- import qualified FastString as GHC +#if __GLASGOW_HASKELL__ > 808 +import qualified Bag as GHC +import qualified ErrUtils as GHC +#endif import qualified GHC as GHC hiding (parseModule) --- import qualified Lexer as GHC import qualified MonadUtils as GHC --- import qualified Parser as GHC --- import qualified SrcLoc as GHC --- import qualified StringBuffer as GHC #if __GLASGOW_HASKELL__ <= 710 #else @@ -79,7 +81,7 @@ , inconsistent :: Maybe [(GHC.SrcSpan, (GHC.AnnKeywordId, [GHC.SrcSpan]))] } -data ParseFailure = ParseFailure GHC.SrcSpan String +data ParseFailure = ParseFailure String data ReportType = Success @@ -115,7 +117,7 @@ writeHsPP = writeFile (basename <.> "hspp") writeIncons s = writeFile (basename <.> "incons") (showGhc s) in - TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id + TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id <$> tester basename writeFailure (debugTxt r) forM_ (inconsistent r) writeIncons @@ -137,7 +139,11 @@ let pristine = expected case res of - Left (ss, m) -> return . Left $ ParseFailure ss m +#if __GLASGOW_HASKELL__ > 808 + Left m -> return . Left $ ParseFailure (showErrorMessages m) +#else + Left (_ss, m) -> return . Left $ ParseFailure m +#endif Right (apianns, injectedComments, dflags, pmod) -> do (printed', anns, pmod') <- GHC.liftIO (runRoundTrip f apianns pmod injectedComments) #if __GLASGOW_HASKELL__ <= 710 @@ -221,3 +227,9 @@ [] -> return Nothing fs -> return (Just (snd $ head fs)) +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ > 808 +showErrorMessages :: GHC.ErrorMessages -> String +showErrorMessages m = show $ GHC.bagToList m +#endif diff --git a/tests/Test/NoAnnotations.hs b/tests/Test/NoAnnotations.hs --- a/tests/Test/NoAnnotations.hs +++ b/tests/Test/NoAnnotations.hs @@ -82,11 +82,19 @@ prettyRoundtripTest origFile = do res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile case res of - Left (ss, m) -> return . Left $ ParseFailure ss m +#if __GLASGOW_HASKELL__ > 808 + Left m -> return . Left $ ParseFailure (showErrorMessages m) +#else + Left (_ss, m) -> return . Left $ ParseFailure m +#endif Right (apianns, injectedComments, _dflags, parsed) -> do res2 <- GHC.liftIO (runPrettyRoundTrip origFile apianns parsed injectedComments) case res2 of - Left (ss, m) -> return . Left $ ParseFailure ss m +#if __GLASGOW_HASKELL__ > 808 + Left m -> return . Left $ ParseFailure (showErrorMessages m) +#else + Left (_ss, m) -> return . Left $ ParseFailure m +#endif Right (_anns', parsed') -> do let originalStructure = astStructure parsed [] @@ -110,7 +118,7 @@ runPrettyRoundTrip :: FilePath -> GHC.ApiAnns -> GHC.ParsedSource -> [Comment] - -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) + -> IO (ParseResult GHC.ParsedSource) runPrettyRoundTrip origFile !anns !parsedOrig _cs = do let !newAnns = addAnnotationsForPretty [] parsedOrig mempty let comments = case Map.lookup GHC.noSrcSpan (snd anns) of @@ -126,7 +134,7 @@ parseString :: FilePath -> String -> Anns -> GHC.ParsedSource - -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) + -> IO (ParseResult GHC.ParsedSource) parseString origFile src newAnns origParsed = do tmpDir <- getTemporaryDirectory let workDir = tmpDir "ghc-exactprint" "noannotations" diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -72,7 +72,7 @@ expected = basename <.> suffix writeFailure = writeFile (basename <.> "out") in - TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id + TestCase (do r <- either (\(ParseFailure s) -> error (s ++ basename)) id <$> genTest f basename expected writeFailure (debugTxt r) assertBool fp (status r == Success)) @@ -141,7 +141,7 @@ -- 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]) + let binds = (GHC.HsValBinds noExt (GHC.ValBinds noExt (GHC.listToBag $ [GHC.L ld decl]) [GHC.L ls sig])) #else let binds = (GHC.HsValBinds (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl]) @@ -157,7 +157,7 @@ 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)))) + return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L bindSpan binds)))) #endif replaceLocalBinds x = return x -- putStrLn $ "log:" ++ intercalate "\n" w @@ -205,8 +205,8 @@ -- 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) + let binds' = (GHC.HsValBinds noExt + (GHC.ValBinds noExt (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds) (GHC.L ls sig:sigs))) #else let binds' = (GHC.HsValBinds @@ -220,7 +220,7 @@ #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')))) + return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L lb binds')))) #endif replaceLocalBinds x = return x -- putStrLn $ "log:" ++ intercalate "\n" w @@ -326,7 +326,7 @@ #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)) + | cond ln = GHC.L ln (GHC.HsVar noExt (GHC.L ln newName)) #endif replaceHsVar x = x @@ -335,11 +335,11 @@ #if __GLASGOW_HASKELL__ > 806 replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs replacePat (GHC.dL->GHC.L ln (GHC.VarPat {})) - | cond ln = GHC.cL ln (GHC.VarPat GHC.noExt (GHC.cL ln newName)) + | cond ln = GHC.cL ln (GHC.VarPat noExt (GHC.cL ln newName)) #elif __GLASGOW_HASKELL__ > 804 replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs replacePat (GHC.L ln (GHC.VarPat {})) - | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName)) + | cond ln = GHC.L ln (GHC.VarPat noExt (GHC.L ln newName)) #elif __GLASGOW_HASKELL__ > 802 replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs replacePat (GHC.L ln (GHC.VarPat {})) @@ -364,7 +364,7 @@ -- #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)) +-- | cond ln = GHC.L ln (GHC.VarPat noExt (GHC.L ln newName)) -- #endif -- replacePat x = x @@ -414,7 +414,7 @@ #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) + in (GHC.HsLet noExt (GHC.L lb (GHC.HsValBinds x (GHC.ValBinds xv bagDecls' sigs))) expr) #endif replace x = x @@ -563,12 +563,14 @@ [d1,d2] <- hsDecls lp balanceComments d1 d2 -#if __GLASGOW_HASKELL__ <= 710 - let GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1 -#elif __GLASGOW_HASKELL__ <= 804 +#if __GLASGOW_HASKELL__ > 808 + let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1 +#elif __GLASGOW_HASKELL__ > 804 + let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1 +#elif __GLASGOW_HASKELL__ > 710 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 + let GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1 #endif balanceComments m1 m2 @@ -688,7 +690,7 @@ #elif __GLASGOW_HASKELL__ <= 804 return (GHC.HsLet (GHC.L l lb') expr) #else - return (GHC.HsLet GHC.noExt (GHC.L l lb') expr) + return (GHC.HsLet noExt (GHC.L l lb') expr) #endif go x = return x @@ -790,8 +792,8 @@ n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1")) n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) #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))) + v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1))) + v2 = GHC.L l2 (GHC.IEVar 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))) @@ -824,8 +826,8 @@ n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1")) n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) #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))) + v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1))) + v2 = GHC.L l2 (GHC.IEVar 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))) diff --git a/tests/examples/ghc810/T16326_Compile1.hs b/tests/examples/ghc810/T16326_Compile1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc810/T16326_Compile1.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnicodeSyntax #-} +module T16326_Compile1 where + +import Data.Kind + +type DApply a (b :: a -> Type) (f :: forall (x :: a) -> b x) (x :: a) = + f x + +type DComp a + (b :: a -> Type) + (c :: forall (x :: a). b x -> Type) + (f :: forall (x :: a). forall (y :: b x) -> c y) + (g :: forall (x :: a) -> b x) + (x :: a) = + f (g x) + +-- Ensure that ElimList has a CUSK, beuas it is +-- is used polymorphically its RHS (c.f. #16344) +type family ElimList (a :: Type) + (p :: [a] -> Type) + (s :: [a]) + (pNil :: p '[]) + (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)) + :: p s where + forall a p pNil (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)). + ElimList a p '[] pNil pCons = + pNil + forall a p x xs pNil (pCons :: forall (x :: a) (xs :: [a]) -> p xs -> p (x:xs)). + ElimList a p (x:xs) pNil pCons = + pCons x xs (ElimList a p xs pNil pCons) + +data Proxy' :: forall k -> k -> Type where + MkProxy' :: forall k (a :: k). Proxy' k a + +type family Proxy2' ∷ ∀ k → k → Type where + Proxy2' = Proxy' + diff --git a/tests/examples/ghc810/T17296.hs b/tests/examples/ghc810/T17296.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc810/T17296.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module T17296 where + +import Data.Foldable +import Data.Kind +import Language.Haskell.TH hiding (Type) +import System.IO + +data family Foo1 :: Type -> Type +data instance Foo1 Bool = Foo1Bool +data instance Foo1 (Maybe a) + +data family Foo2 :: k -> Type +data instance Foo2 Bool = Foo2Bool +data instance Foo2 (Maybe a) +data instance Foo2 :: Char -> Type +data instance Foo2 :: (Char -> Char) -> Type where + +data family Foo3 :: k +data instance Foo3 +data instance Foo3 Bool = Foo3Bool +data instance Foo3 (Maybe a) +data instance Foo3 :: Char -> Type +data instance Foo3 :: (Char -> Char) -> Type where + +$(do let test :: Name -> Q () + test n = do i <- reify n + runIO $ do hPutStrLn stderr $ pprint i + hPutStrLn stderr "" + hFlush stderr + + traverse_ test [''Foo1, ''Foo2, ''Foo3] + pure []) + diff --git a/tests/examples/ghc810/T3391.hs b/tests/examples/ghc810/T3391.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc810/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 #3391 + +module T3391 where + +data T = MkT + +$(return []) + +$(return []) + diff --git a/tests/examples/ghc810/TH_scope.hs b/tests/examples/ghc810/TH_scope.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc810/TH_scope.hs @@ -0,0 +1,10 @@ +-- Test for #2188 +{-# LANGUAGE TemplateHaskellQuotes #-} + +module TH_scope where + +f g = [d| f :: Int + f = g + g :: Int + g = 4 |] + diff --git a/tests/examples/ghc810/TH_unresolvedInfix.hs b/tests/examples/ghc810/TH_unresolvedInfix.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc810/TH_unresolvedInfix.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import TH_unresolvedInfix_Lib +import Language.Haskell.TH + +-------------------------------------------------------------------------------- +-- Expressions -- +-------------------------------------------------------------------------------- +exprs = [ +-------------- Completely-unresolved bindings + $( n +? (n *? n) ), + $( (n +? n) *? n ), + $( n +? (n +? n) ), + $( (n +? n) +? n ), + -- VarE version + $( uInfixE n plus2 (uInfixE n plus2 n) ), + $( uInfixE (uInfixE n plus2 n) plus2 n ), + $( uInfixE n plus3 (uInfixE n plus3 n) ), + $( uInfixE (uInfixE n plus3 n) plus3 n ), + +--------------- Completely-resolved bindings + $( n +! (n *! n) ), + $( (n +! n) *! n ), + $( n +! (n +! n) ), + $( (n +! n) +! n ), + +-------------- Mixed resolved/unresolved + $( (n +! n) *? (n +? n) ), + $( (n +? n) *? (n +! n) ), + $( (n +? n) *! (n +! n) ), + $( (n +? n) *! (n +? n) ), + +-------------- Parens + $( ((parensE ((n +? n) *? n)) +? n) *? n ), + $( (parensE (n +? n)) *? (parensE (n +? n)) ), + $( parensE ((n +? n) *? (n +? n)) ), + +-------------- Sections + $( infixE (Just $ n +? n) plus Nothing ) N, + -- see B.hs for the (non-compiling) other version of the above + $( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N + ] + +-------------------------------------------------------------------------------- +-- Patterns -- +-------------------------------------------------------------------------------- +patterns = [ +-------------- Completely-unresolved patterns + case N :+ (N :* N) of + [p1|unused|] -> True, + case N :+ (N :* N) of + [p2|unused|] -> True, + case (N :+ N) :+ N of + [p3|unused|] -> True, + case (N :+ N) :+ N of + [p4|unused|] -> True, +-------------- Completely-resolved patterns + case N :+ (N :* N) of + [p5|unused|] -> True, + case (N :+ N) :* N of + [p6|unused|] -> True, + case N :+ (N :+ N) of + [p7|unused|] -> True, + case (N :+ N) :+ N of + [p8|unused|] -> True, +-------------- Mixed resolved/unresolved + case ((N :+ N) :* N) :+ N of + [p9|unused|] -> True, + case N :+ (N :* (N :+ N)) of + [p10|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p11|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p12|unused|] -> True, +-------------- Parens + case (N :+ (N :* N)) :+ (N :* N) of + [p13|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p14|unused|] -> True, + case (N :+ (N :* N)) :+ N of + [p15|unused|] -> True + ] + +-------------------------------------------------------------------------------- +-- Types -- +-------------------------------------------------------------------------------- + +-------------- Completely-unresolved types +_t1 = 1 `Plus` (1 `Times` 1) :: $( int $+? (int $*? int) ) +_t2 = 1 `Plus` (1 `Times` 1) :: $( (int $+? int) $*? int ) +_t3 = (1 `Plus` 1) `Plus` 1 :: $( int $+? (int $+? int) ) +_t4 = (1 `Plus` 1) `Plus` 1 :: $( (int $+? int) $+? int ) +-------------- Completely-resolved types +_t5 = 1 `Plus` (1 `Times` 1) :: $( int $+! (int $*! int) ) +_t6 = (1 `Plus` 1) `Times` 1 :: $( (int $+! int) $*! int ) +_t7 = 1 `Plus` (1 `Plus` 1) :: $( int $+! (int $+! int) ) +_t8 = (1 `Plus` 1) `Plus` 1 :: $( (int $+! int) $+! int ) +-------------- Mixed resolved/unresolved +_t9 = ((1 `Plus` 1) `Times` 1) `Plus` 1 :: $( (int $+! int) $*? (int $+? int) ) +_t10 = 1 `Plus` (1 `Times` (1 `Plus` 1)) :: $( (int $+? int) $*? (int $+! int) ) +_t11 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+! int) ) +_t12 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+? int) ) +-------------- Parens +_t13 = (1 `Plus` (1 `Times` 1)) `Plus` (1 `Times` 1) :: $( ((parensT ((int $+? int) $*? int)) $+? int) $*? int ) +_t14 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (parensT (int $+? int)) $*? (parensT (int $+? int)) ) +_t15 = (1 `Plus` (1 `Times` 1)) `Plus` 1 :: $( parensT ((int $+? int) $*? (int $+? int)) ) + +main = do + mapM_ print exprs + mapM_ print patterns + -- check that there are no Parens or UInfixes in the output + runQ [|N :* N :+ N|] >>= print + runQ [|(N :* N) :+ N|] >>= print + runQ [p|N :* N :+ N|] >>= print + runQ [p|(N :* N) :+ N|] >>= print + runQ [t|Int * Int + Int|] >>= print + runQ [t|(Int * Int) + Int|] >>= print + + -- pretty-printing of unresolved infix expressions + let ne = ConE $ mkName "N" + np = ConP (mkName "N") [] + nt = ConT (mkName "Int") + plusE = ConE (mkName ":+") + plusP = (mkName ":+") + plusT = (mkName "+") + putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UInfixE ne plusE (UInfixE ne plusE ne))) + putStrLn $ pprint (ParensE ne) + putStrLn $ pprint (InfixP np plusP (UInfixP np plusP (UInfixP np plusP np))) + putStrLn $ pprint (ParensP np) + putStrLn $ pprint (InfixT nt plusT (UInfixT nt plusT (UInfixT nt plusT nt))) + putStrLn $ pprint (ParensT nt) + diff --git a/tests/examples/ghc810/TH_unresolvedInfix_Lib.hs b/tests/examples/ghc810/TH_unresolvedInfix_Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc810/TH_unresolvedInfix_Lib.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoStarIsType #-} + +module TH_unresolvedInfix_Lib where + +import Language.Haskell.TH +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Quote + +infixl 6 :+ +infixl 7 :* + +data Tree = N + | Tree :+ Tree + | Tree :* Tree + +-- custom instance, including redundant parentheses +instance Show Tree where + show N = "N" + show (a :+ b) = "(" ++ show a ++ " :+ " ++ show b ++ ")" + show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")" + +-- VarE versions +infixl 6 +: +infixl 7 *: +(+:) = (:+) +(*:) = (:*) + +n = conE (mkName "N") +plus = conE (mkName ":+") +times = conE (mkName ":*") + +a +? b = uInfixE a plus b +a *? b = uInfixE a times b +a +! b = infixApp a plus b +a *! b = infixApp a times b + +plus2 = varE (mkName "+:") +times2 = varE (mkName "*:") +plus3 = conE ('(:+)) + + +-------------------------------------------------------------------------------- +-- Patterns -- +-------------------------------------------------------------------------------- +-- The only way to test pattern splices is using QuasiQuotation +mkQQ pat = QuasiQuoter undefined (const pat) undefined undefined +p = conP (mkName "N") [] +plus' = mkName ":+" +times' = mkName ":*" + +a ^+? b = uInfixP a plus' b +a ^*? b = uInfixP a times' b +a ^+! b = infixP a plus' b +a ^*! b = infixP a times' b + +-------------- Completely-unresolved patterns +p1 = mkQQ ( p ^+? (p ^*? p) ) +p2 = mkQQ ( (p ^+? p) ^*? p ) +p3 = mkQQ ( p ^+? (p ^+? p) ) +p4 = mkQQ ( (p ^+? p) ^+? p ) +-------------- Completely-resolved patterns +p5 = mkQQ ( p ^+! (p ^*! p) ) +p6 = mkQQ ( (p ^+! p) ^*! p ) +p7 = mkQQ ( p ^+! (p ^+! p) ) +p8 = mkQQ ( (p ^+! p) ^+! p ) +-------------- Mixed resolved/unresolved +p9 = mkQQ ( (p ^+! p) ^*? (p ^+? p) ) +p10 = mkQQ ( (p ^+? p) ^*? (p ^+! p) ) +p11 = mkQQ ( (p ^+? p) ^*! (p ^+! p) ) +p12 = mkQQ ( (p ^+? p) ^*! (p ^+? p) ) +-------------- Parens +p13 = mkQQ ( ((parensP ((p ^+? p) ^*? p)) ^+? p) ^*? p ) +p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) ) +p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) ) + +-------------------------------------------------------------------------------- +-- Types -- +-------------------------------------------------------------------------------- + +infixl 6 + +infixl 7 * +data (+) a b = Plus a b +data (*) a b = Times a b + +int = conT (mkName "Int") +tyPlus = mkName "+" +tyTimes = mkName "*" + +a $+? b = uInfixT a tyPlus b +a $*? b = uInfixT a tyTimes b +a $+! b = infixT a tyPlus b +a $*! b = infixT a tyTimes b + diff --git a/tests/examples/ghc810/mod181.hs b/tests/examples/ghc810/mod181.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc810/mod181.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +-- If 'ImportQualifiedPost' is enabled 'qualified' can appear in +-- postpositive position. + +import Prelude qualified + +main = Prelude.undefined + diff --git a/tests/examples/ghc810/saks029.hs b/tests/examples/ghc810/saks029.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc810/saks029.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE PolyKinds, DataKinds, RankNTypes, TypeFamilies #-} + +module SAKS_029 where + +import Data.Kind +import Data.Proxy +import Data.Type.Bool + +type IfK :: forall j m n. forall (e :: Proxy (j :: Bool)) -> m -> n -> If j m n +type family IfK e f g where + IfK (_ :: Proxy True) f _ = f + IfK (_ :: Proxy False) _ g = g + diff --git a/tests/examples/ghc810/saks032.hs b/tests/examples/ghc810/saks032.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc810/saks032.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, RankNTypes #-} + +module SAKS_032 where + +import Data.Kind +import Data.Proxy + +type Const :: Type -> forall k. k -> Type +data Const a b = Const a + +type F :: Type -> Type -> forall k. k -> Type +type family F a b :: forall k. k -> Type where + F () () = Proxy + F a b = Const (a,b) + +type F1 :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type +type family F1 a b + +type F2 :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type +type family F2 a b :: forall r2. (r1, r2) -> Type + diff --git a/tests/examples/ghc84/arrowfail003.hs b/tests/examples/ghc84/arrowfail003.hs deleted file mode 100644 --- a/tests/examples/ghc84/arrowfail003.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE Arrows #-} --- Arrow commands where an expression is expected - -module ShouldFail where - -import Control.Arrow - -foo = returnA -< [] -bar = (|zeroArrow|) - diff --git a/tests/examples/pre-ghc810/arrowfail003.hs b/tests/examples/pre-ghc810/arrowfail003.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc810/arrowfail003.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Arrows #-} +-- Arrow commands where an expression is expected + +module ShouldFail where + +import Control.Arrow + +foo = returnA -< [] +bar = (|zeroArrow|) +