diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +2021-02-24 v0.6.4 + * Add support for GHC 9.0.1 2021-02-01 v0.6.3.4 * Use env var to get ghc libdir by @jneira 2020-11-11 v0.6.3.3 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.3.4 +version: 0.6.4 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 @@ -30,7 +30,6 @@ category: Development build-type: Simple tested-with: GHC == 7.10.3 - , GHC == 8.0.1 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.2 @@ -46,6 +45,7 @@ , GHC == 8.8.4 , GHC == 8.10.1 , GHC == 8.10.2 + , GHC == 9.0.1 extra-source-files: ChangeLog src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs tests/examples/failing/*.hs @@ -57,8 +57,10 @@ tests/examples/ghc84/*.hs tests/examples/ghc86/*.hs tests/examples/ghc88/*.hs + tests/examples/ghc90/*.hs tests/examples/pre-ghc810/*.hs tests/examples/pre-ghc86/*.hs + tests/examples/pre-ghc90/*.hs tests/examples/vect/*.hs tests/examples/transform/*.hs tests/examples/failing/*.hs.bad @@ -125,25 +127,28 @@ build-depends: ghc-boot hs-source-dirs: src - if impl (ghc > 8.8.4) - hs-source-dirs: src-ghc810 + if impl (ghc > 8.10.9) + hs-source-dirs: src-ghc90 else - if impl (ghc > 8.6.5) - hs-source-dirs: src-ghc88 + if impl (ghc > 8.8.4) + 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) @@ -157,25 +162,28 @@ else hs-source-dirs: tests - if impl (ghc > 8.8.4) - hs-source-dirs: src-ghc810 + if impl (ghc > 8.10.9) + hs-source-dirs: src-ghc90 else - if impl (ghc > 8.6.5) - hs-source-dirs: src-ghc88 + if impl (ghc > 8.8.4) + 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 diff --git a/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs --- a/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ b/src-ghc810/Language/Haskell/GHC/ExactPrint/Annotater.hs @@ -2781,13 +2781,11 @@ -- --------------------------------------------------------------------- instance Annotate (GHC.ConDecl GHC.GhcPs) where - markAST _ (GHC.ConDeclH98 _ ln _fa mqtvs mctx + markAST _ (GHC.ConDeclH98 _ ln (GHC.L _ fa) mqtvs mctx dets _) = do - case mqtvs of - [] -> return () - bndrs -> do + when fa $ do mark GHC.AnnForall - mapM_ markLocated bndrs + mapM_ markLocated mqtvs mark GHC.AnnDot case mctx of @@ -2885,10 +2883,9 @@ 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 + when forall $ mark GHC.AnnForall + mapM_ markLocated bndrs + when forall $ mark GHC.AnnDot -- --------------------------------------------------------------------- @@ -2922,10 +2919,10 @@ instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where - markAST _ (ls,rs) = do + markAST _ (ls,rs') = do mapM_ markLocated ls mark GHC.AnnRarrow - mapM_ markLocated rs + mapM_ markLocated rs' inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- diff --git a/src-ghc84/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc84/Language/Haskell/GHC/ExactPrint/Annotater.hs --- a/src-ghc84/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ b/src-ghc84/Language/Haskell/GHC/ExactPrint/Annotater.hs @@ -781,8 +781,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 @@ -2300,7 +2299,7 @@ -- --------------------------------------------------------------------- -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 @@ -2577,10 +2576,10 @@ instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where - markAST _ (ls,rs) = do + markAST _ (ls,rs') = do mapM_ markLocated ls mark GHC.AnnRarrow - mapM_ markLocated rs + mapM_ markLocated rs' inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- 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 @@ -2637,14 +2637,12 @@ -- --------------------------------------------------------------------- instance Annotate (GHC.ConDecl GHC.GhcPs) where - markAST _ (GHC.ConDeclH98 _ ln _fa mqtvs mctx + markAST _ (GHC.ConDeclH98 _ ln (GHC.L _ fa) mqtvs mctx dets _) = do - case mqtvs of - [] -> return () - bndrs -> do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot + when fa $ do + mark GHC.AnnForall + mapM_ markLocated mqtvs + mark GHC.AnnDot case mctx of Just ctx -> do @@ -2741,10 +2739,9 @@ 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 + when forall $ mark GHC.AnnForall + mapM_ markLocated bndrs + when forall $ mark GHC.AnnDot -- --------------------------------------------------------------------- @@ -2769,10 +2766,10 @@ instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where - markAST _ (ls,rs) = do + markAST _ (ls,rs') = do mapM_ markLocated ls mark GHC.AnnRarrow - mapM_ markLocated rs + mapM_ markLocated rs' inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- diff --git a/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs --- a/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs +++ b/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs @@ -2468,7 +2468,7 @@ -- --------------------------------------------------------------------- -markTyClassArgs :: (Annotate a, GHC.HasOccName a) +markTyClassArgs :: (Annotate a) => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity -- -> GHC.Located a -> [ast] -> Annotated () -> GHC.Located a -> [GHC.LHsTypeArg GhcPs] -> Annotated () @@ -2492,12 +2492,12 @@ -} -- TODO:AZ: simplify -markTyClass :: (Data (GHC.SrcSpanLess ast), Annotate a, GHC.HasOccName a, Annotate ast,GHC.HasSrcSpan ast) +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, GHC.HasOccName a) +markTyClassWorker :: (Annotate a) => (b -> Annotated ()) -> Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity -- -> GHC.Located a -> [ast] -> Annotated () -> GHC.Located a -> [b] -> Annotated () @@ -2776,14 +2776,12 @@ -- --------------------------------------------------------------------- instance Annotate (GHC.ConDecl GHC.GhcPs) where - markAST _ (GHC.ConDeclH98 _ ln _fa mqtvs mctx + markAST _ (GHC.ConDeclH98 _ ln (GHC.L _ fa) mqtvs mctx dets _) = do - case mqtvs of - [] -> return () - bndrs -> do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot + when fa $ do + mark GHC.AnnForall + mapM_ markLocated mqtvs + mark GHC.AnnDot case mctx of Just ctx -> do @@ -2880,10 +2878,9 @@ 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 + when forall $ mark GHC.AnnForall + mapM_ markLocated bndrs + when forall $ mark GHC.AnnDot -- --------------------------------------------------------------------- @@ -2908,10 +2905,10 @@ instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where - markAST _ (ls,rs) = do + markAST _ (ls,rs') = do mapM_ markLocated ls mark GHC.AnnRarrow - mapM_ markLocated rs + mapM_ markLocated rs' inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- diff --git a/src-ghc90/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc90/Language/Haskell/GHC/ExactPrint/Annotater.hs new file mode 100644 --- /dev/null +++ b/src-ghc90/Language/Haskell/GHC/ExactPrint/Annotater.hs @@ -0,0 +1,2813 @@ +{-# 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 GHC as GHC +import qualified GHC.Core.Class as GHC +import qualified GHC.Core.Coercion.Axiom as GHC +import qualified GHC.Data.Bag as GHC +import qualified GHC.Data.BooleanFormula as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Parser.Annotation as GHC +import qualified GHC.Types.Basic as GHC +import qualified GHC.Types.ForeignCall as GHC +import qualified GHC.Types.Name as GHC +import qualified GHC.Types.Name.Reader as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Types.Var as GHC +import qualified GHC.Utils.Outputable as GHC + +import Control.Monad.Identity +import Data.Data +import Data.Maybe + +import qualified Data.Set as Set + +import Debug.Trace + + +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} +-- --------------------------------------------------------------------- + +class Data ast => Annotate ast where + markAST :: GHC.SrcSpan -> ast -> Annotated () + +-- --------------------------------------------------------------------- + +-- | Construct a syntax tree which represent which KeywordIds must appear +-- where. +-- annotate :: (Annotate ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast) => ast -> Annotated () +annotate :: (Annotate ast) => GHC.Located 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 :: (Annotate ast) => GHC.Located ast -> Annotated () +markLocated ast = + case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of + Just d -> markLHsDecl d + Nothing -> withLocated ast markAST + +-- --------------------------------------------------------------------- + +-- |When adding missing annotations, do not put a preceding space in front of a list +markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () +markListNoPrecedingSpace intercal ls = + case ls of + [] -> return () + (l:ls') -> do + if intercal + then do + if null ls' + then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l + else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l + markListIntercalate ls' + else do + setContext (Set.singleton NoPrecedingSpace) $ markLocated l + mapM_ markLocated ls' + +-- --------------------------------------------------------------------- + + +-- |Mark a list, with the given keyword as a list item separator +markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () +markListIntercalate ls = markListIntercalateWithFun markLocated ls + +-- --------------------------------------------------------------------- + +markListWithContexts :: Annotate ast + => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () +markListWithContexts ctxInitial ctxRest ls = + case ls of + [] -> return () + [x] -> setContextLevel ctxInitial 2 $ markLocated x + (x:xs) -> do + setContextLevel ctxInitial 2 $ markLocated x + setContextLevel ctxRest 2 $ mapM_ markLocated xs + +-- --------------------------------------------------------------------- + +-- Context for only if just one, else first item, middle ones, and last one +markListWithContexts' :: Annotate ast + => ListContexts + -> [GHC.Located ast] -> Annotated () +markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = + case ls of + [] -> return () + [x] -> setContextLevel ctxOnly level $ markLocated x + (x:xs) -> do + setContextLevel ctxInitial level $ markLocated x + go xs + where + level = 2 + go [] = return () + go [x] = setContextLevel ctxLast level $ markLocated x + go (x:xs) = do + setContextLevel ctxMiddle level $ markLocated x + go xs + + +-- --------------------------------------------------------------------- + +markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () +markListWithLayout ls = + setLayoutFlag $ markList ls + +-- --------------------------------------------------------------------- + +markList :: Annotate ast => [GHC.Located ast] -> Annotated () +markList ls = + setContext (Set.singleton NoPrecedingSpace) + $ markListWithContexts' listContexts' ls + +markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () +markLocalBindsWithLayout binds = markHsLocalBinds binds + +-- --------------------------------------------------------------------- + +-- |This function is used to get around shortcomings in the GHC AST for 7.10.1 +markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () +markLocatedFromKw kw (GHC.L l a) = do + -- Note: l is needed so that the pretty printer can make something up + ss <- getSrcSpanForKw l kw + AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) + markLocated (GHC.L (GHC.RealSrcSpan ss' Nothing) a) + +-- --------------------------------------------------------------------- + +markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () +markMaybe Nothing = return () +markMaybe (Just ast) = markLocated ast + +-- --------------------------------------------------------------------- + +markTightPrefix :: Annotated () -> Annotated () +markTightPrefix action = setContext (Set.singleton InTypeApp) action + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + +prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.RealSrcSpan,Annotated ())] +prepareListAnnotation ls = map (\b -> (rs $ GHC.getLoc b,markLocated b)) ls + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsModule where + markAST _ (GHC.HsModule _lo 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 + + markOptional GHC.AnnComma + 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 () + 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.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 + 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 + +-- --------------------------------------------------------------------- + +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) + +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 + +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 + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +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) + } + +-} + +-- --------------------------------------------------------------------- + +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 +{- + = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) + | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass) +-} + markAST _ (GHC.RuleBndr _ ln) = markLocated ln + markAST _ (GHC.RuleBndrSig _ ln (GHC.HsPS _ ty)) = do + mark GHC.AnnOpenP -- "(" + markLocated ln + mark GHC.AnnDcolon + markLocated ty + mark GHC.AnnCloseP -- ")" + +-- --------------------------------------------------------------------- + +markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated () +markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty)) = do + markLocated ty + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +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 "#-}" + +-- --------------------------------------------------------------------- + +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 -- "]" + +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 + +-- --------------------------------------------------------------------- + +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. + } + + +-} + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.DefaultDecl GHC.GhcPs) where + + markAST _ (GHC.DefaultDecl _ typs) = do + mark GHC.AnnDefault + mark GHC.AnnOpenP -- '(' + markListIntercalate typs + mark GHC.AnnCloseP -- ')' + markTrailingSemi + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +-- 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 + } +-} + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +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 l (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 + if (s == GHC.SrcStrict) + then do + markExternal (GHC.srcSpanFirstCharacter l) GHC.AnnBang "!" + markTightPrefix $ markLocated n + else 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 + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +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) + +-- -------------------------------------------------------------------- + +markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated () +markLHsSigType (GHC.HsIB _ typ) = markLocated typ + +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 (Data flag) => Annotate (GHC.HsTyVarBndr flag GHC.GhcPs) where + markAST _l (GHC.UserTyVar _ f n) = do + markInferred f GHC.AnnOpenC Nothing -- '{' + markLocated n + markInferred f GHC.AnnCloseC Nothing -- '}' + + markAST _ (GHC.KindedTyVar _ f n ty) = do + markInferred f GHC.AnnOpenC (Just GHC.AnnOpenP) + markLocated n + mark GHC.AnnDcolon -- '::' + markLocated ty + markInferred f GHC.AnnCloseC (Just GHC.AnnCloseP) + +markInferred :: Typeable a + => a -> GHC.AnnKeywordId -> (Maybe GHC.AnnKeywordId) -> Annotated () +markInferred flag kw kw2 = + case (cast flag :: Maybe GHC.Specificity) of + (Just GHC.InferredSpec) -> mark kw + _ -> mapM_ mark kw2 + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsType GHC.GhcPs) where + markAST loc ty = do + markType loc ty + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) + inContext (Set.singleton InGadt) $ do + mark GHC.AnnRarrow + -- markOptional GHC.AnnLolly + where + + -- markType :: GHC.SrcSpan -> ast -> Annotated () + markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated () + markType _ (GHC.HsForAllTy _ tele typ) = do + mark GHC.AnnForall + case tele of + (GHC.HsForAllVis _ qtvs) -> do + mapM_ markLocated qtvs + mark GHC.AnnRarrow + (GHC.HsForAllInvis _ qtvs) -> do + mapM_ markLocated qtvs + mark GHC.AnnDot + 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 + markTightPrefix $ markLocated k + + markType _ (GHC.HsFunTy _ arrow t1 t2) = do + markLocated t1 + markArrow arrow + -- case arrow of + -- GHC.HsLinearArrow -> do + -- case u of + -- GHC.NormalSyntax -> do + -- mark GHC.AnnMult -- "%1" + -- mark GHC.AnnRarrow + -- GHC.UnicodeSyntax -> mark GHC.AnnLollyU + -- GHC.HsUnrestrictedArrow -> mark GHC.AnnRarrow -- a -> b + -- GHC.HsExplicitMult _ -> do + -- mark GHC.AnnMult -- "%1" + -- mark GHC.AnnRarrow + -- arr = case mult of + -- HsLinearArrow -> lollipop + -- HsUnrestrictedArrow -> arrow + -- HsExplicitMult p -> mulArrow (ppr p) +-- lollipop = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->") +-- mulArrow d = text "%" <> d <+> arrow + + + markLocated t2 + + 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 -> do + mark GHC.AnnTilde + markTightPrefix $ markLocated t + GHC.SrcStrict -> do + mark GHC.AnnBang + markTightPrefix $ markLocated t + GHC.NoSrcStrict -> 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 _ decoration _n b -> do + if (decoration == GHC.DollarSplice) + then do + mark GHC.AnnDollarDollar + markTightPrefix $ markLocated b + else markLocated b + + GHC.HsUntypedSplice _ decoration _n b -> do + if (decoration == GHC.DollarSplice) + then do + mark GHC.AnnDollar + markTightPrefix $ markLocated b + else markLocated b + + GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.FieldOcc GHC.GhcPs) where + markAST _ (GHC.FieldOcc _ rn) = do + markLocated rn + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +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 + markTightPrefix $ markLocated p + + markPat _ (GHC.AsPat _ ln p) = do + markLocated ln + mark GHC.AnnAt + markTightPrefix $ markLocated p + + markPat _ (GHC.ParPat _ p) = do + mark GHC.AnnOpenP + markLocated p + mark GHC.AnnCloseP + + markPat _ (GHC.BangPat _ p) = do + mark GHC.AnnBang + markTightPrefix $ 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.ConPat _ n dets) = do + markHsConPatDetails n dets + + 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 (GHC.HsPS _ ty)) = do + markLocated pat + mark GHC.AnnDcolon + markLocated ty + +-- --------------------------------------------------------------------- + +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 "##" + +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 + +{- +type HsConDeclDetails pass + = HsConDetails (HsScaled pass (LBangType pass)) (Located [LConDeclField pass]) +-} +markHsConDeclDetails :: + Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated () +markHsConDeclDetails isDeprecated inGadt lns dets = do + case dets of + GHC.PrefixCon args -> + if inGadt + then setContextLevel (Set.fromList [InGadt,PrefixOp]) 2 $ + mapM_ markScaled args + else setContextLevel (Set.singleton PrefixOp ) 2 $ + mapM_ markScaled args + GHC.RecCon fs -> do + mark GHC.AnnOpenC + if inGadt + then do + if isDeprecated + then setContextLevel (Set.fromList [InGadt]) 2 $ markLocated fs + else setContextLevel (Set.fromList [InGadt,InRecCon]) 2 $ markLocated fs + else do + if isDeprecated + then markLocated fs + else setContextLevel (Set.fromList [InRecCon]) 2 $ markLocated fs + GHC.InfixCon a1 a2 -> do + markScaled a1 + setContext (Set.singleton InfixOp) $ mapM_ markLocated lns + markScaled a2 + +-- --------------------------------------------------------------------- + +-- markScaled :: (GHC.HsScaled GHC.GhcPs (GHC.Located a)) -> Annotated () +markScaled :: (GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs)) -> Annotated () +markScaled a@(GHC.HsScaled _rr (GHC.L l _)) = markLocated (GHC.L l a) + +instance Annotate (GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs)) where + markAST _ (GHC.HsScaled arrow a) = do + markLocated a + inContext (Set.singleton InGadt) $ do + markArrow arrow + -- -- AZ:TODO: fix this, with the new syntax + -- case arrow of + -- GHC.HsUnrestrictedArrow -> mark GHC.AnnRarrow -- a -> b + -- GHC.HsLinearArrow -> mark GHC.AnnLollyU -- a #-> b + -- GHC.HsExplicitMult _ -> mark GHC.AnnLollyU -- a #-> b + -- markOptional GHC.AnnRarrow -- See https://gitlab.haskell.org/ghc/ghc/-/commit/7f418acf61e#note_304011 +-- --------------------------------------------------------------------- + +markArrow :: GHC.HsArrow GhcPs -> Annotated () +markArrow arrow = do + case arrow of + GHC.HsLinearArrow u -> do + case u of + GHC.NormalSyntax -> do + mark GHC.AnnPercentOne -- "%1" + mark GHC.AnnRarrow + GHC.UnicodeSyntax -> mark GHC.AnnLollyU + GHC.HsUnrestrictedArrow u -> + case u of + GHC.NormalSyntax -> mark GHC.AnnRarrow -- a -> b + GHC.UnicodeSyntax -> mark GHC.AnnRarrowU -- a ⊸ b + GHC.HsExplicitMult u t -> do + mark GHC.AnnPercent + setContextLevel (Set.fromList [NoPrecedingSpace, InTypeApp]) 2 $ markLocated t + case u of + GHC.NormalSyntax -> mark GHC.AnnRarrow -- -> + GHC.UnicodeSyntax -> mark GHC.AnnRarrowU -- ⊸ + +-- data HsArrow pass +-- = HsUnrestrictedArrow IsUnicodeSyntax +-- -- ^ a -> b or a → b +-- | HsLinearArrow IsUnicodeSyntax +-- -- ^ a %1 -> b or a %1 → b, or a ⊸ b +-- | HsExplicitMult IsUnicodeSyntax (LHsType pass) +-- -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`! + + +-- --------------------------------------------------------------------- + +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 InRecCon) $ do + -- mark GHC.AnnRarrow + 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 + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +-- 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 + +-- --------------------------------------------------------------------- + +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" + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +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 + 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 Nothing -> mark GHC.AnnDo + GHC.DoExpr (Just mn) -> + markWithString GHC.AnnDo ((GHC.moduleNameString mn) ++ ".do") + GHC.MDoExpr Nothing -> mark GHC.AnnMdo + GHC.MDoExpr (Just mn) -> + markWithString GHC.AnnMdo ((GHC.moduleNameString mn) ++ ".mdo") + _ -> 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.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.HsTick {}) = return () + markExpr _ (GHC.HsBinTick {}) = return () + markExpr _ (GHC.HsPragE _ prag e) = do + case prag of + (GHC.HsPragSCC _ src csFStr) -> 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 + + (GHC.HsPragTick _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4))) -> 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.HsAppType _ e ty) = do + markLocated e + markInstead GHC.AnnAt AnnTypeApp + markTightPrefix $ markLHsWcType ty + + -- markExpr _ (GHC.HsWrap {}) = + -- traceM "warning: HsWrap introduced after renaming" + + markExpr _ (GHC.HsConLikeOut{}) = + traceM "warning: HsConLikeOut introduced after type checking" + + -- markExpr _ x = + -- error $ "markExpr: not matched for " ++ showAnnData mempty 0 x + +-- --------------------------------------------------------------------- + +markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated () +markLHsWcType (GHC.HsWC _ ty) = do + markLocated ty + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +-- |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 + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsCmdTop GHC.GhcPs) where + markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd + +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 l (GHC.HsCmdLamCase _ matches) = do + mark GHC.AnnLam + mark GHC.AnnCase + 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 _ x = error $ "got HsCmd for:" ++ showAnnData mempty 0 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 fixity ln tyvars + mark GHC.AnnEqual + markLocated typ + markTrailingSemi + + markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity + (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do + if nd == GHC.DataType + then mark GHC.AnnData + else mark GHC.AnnNewtype + markMaybe mctyp + markLocated ctx + markTyClass fixity ln tyVars + case mk of + Nothing -> return () + Just k -> do + mark GHC.AnnDcolon + markLocated k + if isGadt cons + then mark GHC.AnnWhere + else unless (null cons) $ mark GHC.AnnEqual + -- markOptional GHC.AnnWhere + markOptional GHC.AnnOpenC + setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) + $ markListWithContexts' listContexts cons + markOptional GHC.AnnCloseC + setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs + markTrailingSemi + + -- ----------------------------------- + + markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds + sigs meths ats atdefs docs) = do + mark GHC.AnnClass + markLocated ctx + + markTyClass fixity ln tyVars + + unless (null fds) $ do + mark GHC.AnnVbar + markListIntercalateWithFunLevel markLocated 2 fds + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + -- AZ:TODO: we end up with both the tyVars and the following body of the + -- class defn in annSortKey for the class. This could cause problems when + -- changing things. + setContext (Set.singleton InClassDecl) $ + applyListAnnotationsLayout + (prepareListAnnotation sigs + ++ prepareListAnnotation (GHC.bagToList meths) + ++ prepareListAnnotation ats + ++ prepareListAnnotation atdefs + ++ prepareListAnnotation docs + ) + markOptional GHC.AnnCloseC -- '}' + markTrailingSemi +{- + | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs + tcdCtxt :: LHsContext pass, -- ^ Context... + tcdLName :: Located (IdP pass), -- ^ Name of the class + tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables + tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration + tcdFDs :: [Located (FunDep (Located (IdP pass)))], + -- ^ Functional deps + tcdSigs :: [LSig pass], -- ^ Methods' signatures + tcdMeths :: LHsBinds pass, -- ^ Default methods + tcdATs :: [LFamilyDecl pass], -- ^ Associated types; + tcdATDefs :: [LTyFamDefltEqn pass], + -- ^ Associated type defaults + tcdDocs :: [LDocDecl] -- ^ Haddock docs + } + +-} + +-- --------------------------------------------------------------------- + +markTypeApp :: GHC.SrcSpan -> Annotated () +markTypeApp loc = do + let l = GHC.srcSpanFirstCharacter loc + markExternal l GHC.AnnVal "@" + +-- --------------------------------------------------------------------- + +markTyClassArgs :: (Annotate a, Data flag) + => Maybe [GHC.LHsTyVarBndr flag GhcPs] -> GHC.LexicalFixity + -> 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 + markTightPrefix $ 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 :: (Annotate a, Annotate ast) + => GHC.LexicalFixity -> GHC.Located a + -> [GHC.Located ast] -> Annotated () +markTyClass = markTyClassWorker markLocated (Nothing :: Maybe [GHC.LHsTyVarBndr () GhcPs]) + +markTyClassWorker :: (Annotate a, Data flag) + => (b -> Annotated ()) -> Maybe [GHC.LHsTyVarBndr flag GhcPs] -> GHC.LexicalFixity + -> 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 () + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.FamilyDecl GHC.GhcPs) where + markAST _ (GHC.FamilyDecl _ info ln (GHC.HsQTvs _ tyvars) fixity rsig minj) = do + case info of + GHC.DataFamily -> mark GHC.AnnData + _ -> mark GHC.AnnType + + mark GHC.AnnFamily + + markTyClass fixity ln tyvars + case GHC.unLoc rsig of + GHC.NoSig _ -> return () + GHC.KindSig _ _ -> do + mark GHC.AnnDcolon + markLocated rsig + GHC.TyVarSig _ _ -> do + mark GHC.AnnEqual + markLocated rsig + 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 + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where + markAST _ (GHC.NoSig _) = return () + markAST _ (GHC.KindSig _ k) = markLocated k + markAST _ (GHC.TyVarSig _ ltv) = markLocated ltv + +-- --------------------------------------------------------------------- + +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 + +-- --------------------------------------------------------------------- + +-- 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 + +-- --------------------------------------------------------------------- + +-- 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 (GHC.L _ fa) mqtvs mctx + dets _) = do + when fa $ do + mark GHC.AnnForall + mapM_ markLocated mqtvs + mark GHC.AnnDot + + case mctx of + Just ctx -> do + setContext (Set.fromList [NoDarrow]) $ markLocated 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 + + markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) qvars mbCxt args typ _) = do + let + surroundParens + = case args of + GHC.PrefixCon [] -> null qvars && not (isJust mbCxt) + _ -> False + + -- null qvars && + -- mbCxt == Nothing && + setContext (Set.singleton PrefixOp) $ markListIntercalate lns + mark GHC.AnnDcolon + annotationsToComments [GHC.AnnOpenP] + if surroundParens + then mark GHC.AnnOpenP + else return () + markLocated (GHC.L l (ResTyGADTHook forall qvars)) + markMaybe mbCxt + markHsConDeclDetails False True lns args + markLocated typ + if surroundParens + then mark GHC.AnnCloseP + else markManyOptional GHC.AnnCloseP + markTrailingSemi + +-- --------------------------------------------------------------------- + +-- 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.Specificity 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 + -- markManyOptional GHC.AnnOpenP + when forall $ mark GHC.AnnForall + mapM_ markLocated bndrs + when forall $ mark GHC.AnnDot + -- markManyOptional GHC.AnnCloseP + +-- --------------------------------------------------------------------- + +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,rss) = do + mapM_ markLocated ls + mark GHC.AnnRarrow + mapM_ markLocated rss + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate GHC.CType where + markAST _ (GHC.CType src mh f) = do + -- markWithString GHC.AnnOpen src + markAnnOpen src "" + case mh of + Nothing -> return () + Just (GHC.Header srcH _h) -> + -- markWithString GHC.AnnHeader srcH + markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") + -- markWithString GHC.AnnVal (fst f) + markSourceText (fst f) (GHC.unpackFS $ snd f) + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +stringLiteralToString :: GHC.StringLiteral -> String +stringLiteralToString (GHC.StringLiteral st fs) = + case st of + GHC.NoSourceText -> GHC.unpackFS fs + GHC.SourceText src -> src + +-- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs b/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs --- a/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs +++ b/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs @@ -40,7 +40,9 @@ import Language.Haskell.GHC.ExactPrint.Types -#if __GLASGOW_HASKELL__ > 800 +#if __GLASGOW_HASKELL__ >= 900 +import qualified GHC.Types.Basic as GHC +#elif __GLASGOW_HASKELL__ > 800 import qualified BasicTypes as GHC #endif import qualified GHC as GHC @@ -118,7 +120,7 @@ MarkManyOptional :: GHC.AnnKeywordId -> next -> AnnotationF next MarkOffsetPrim :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next MarkOffsetPrimOptional :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) WithAST :: (Data a,Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Annotated b -> next -> AnnotationF next #else @@ -126,7 +128,7 @@ -> Annotated b -> next -> AnnotationF next #endif CountAnns :: GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next - WithSortKey :: [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next + WithSortKey :: [(AnnSpan, Annotated ())] -> next -> AnnotationF next SetLayoutFlag :: Rigidity -> Annotated () -> next -> AnnotationF next MarkAnnBeforeAnn :: GHC.AnnKeywordId -> GHC.AnnKeywordId -> next -> AnnotationF next @@ -149,7 +151,7 @@ UnsetContext :: AstContext -> Annotated () -> next -> AnnotationF next -- Query the context while in a child element IfInContext :: Set.Set AstContext -> Annotated () -> Annotated () -> next -> AnnotationF next - WithSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next + WithSortKeyContexts :: ListContexts -> [(AnnSpan, Annotated ())] -> next -> AnnotationF next -- TellContext :: Set.Set AstContext -> next -> AnnotationF next @@ -218,7 +220,7 @@ -- --------------------------------------------------------------------- -- |Main driver point for annotations. -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Annotated () -> Annotated () #else @@ -255,7 +257,7 @@ -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) withLocated :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> (GHC.SrcSpan -> a -> Annotated ()) @@ -314,7 +316,7 @@ -- Expects the kws to be ordered already -withSortKeyContextsHelper :: (Monad m) => (Annotated () -> m ()) -> ListContexts -> [(GHC.SrcSpan, Annotated ())] -> m () +withSortKeyContextsHelper :: (Monad m) => (Annotated () -> m ()) -> ListContexts -> [(AnnSpan, Annotated ())] -> m () withSortKeyContextsHelper interpret (LC ctxOnly ctxInitial ctxMiddle ctxLast) kws = do case kws of [] -> return () @@ -334,10 +336,10 @@ -- Managing lists which have been separated, e.g. Sigs and Binds -applyListAnnotations :: [(GHC.SrcSpan, Annotated ())] -> Annotated () +applyListAnnotations :: [(AnnSpan, Annotated ())] -> Annotated () applyListAnnotations ls = withSortKey ls -applyListAnnotationsContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Annotated () +applyListAnnotationsContexts :: ListContexts -> [(AnnSpan, Annotated ())] -> Annotated () applyListAnnotationsContexts ctxt ls = withSortKeyContexts ctxt ls #if __GLASGOW_HASKELL__ <= 710 @@ -345,7 +347,7 @@ lexicalSortLocated = sortBy (comparing GHC.getLoc) #endif -applyListAnnotationsLayout :: [(GHC.SrcSpan, Annotated ())] -> Annotated () +applyListAnnotationsLayout :: [(AnnSpan, Annotated ())] -> Annotated () applyListAnnotationsLayout ls = setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) $ withSortKeyContexts listContexts ls 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 @@ -141,6 +141,10 @@ import Language.Haskell.GHC.ExactPrint.Annotate import qualified GHC +#if __GLASGOW_HASKELL__ >= 900 +-- import qualified GHC.Parser.Annotation as GHC +-- import qualified GHC.Types.SrcLoc as GHC +#endif import qualified Data.Map as Map import qualified Data.Set as Set @@ -154,7 +158,7 @@ -- --------------------------------------------------------------------- -- | Transform concrete annotations into relative annotations which are -- more useful when transforming an AST. -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) relativiseApiAnns :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) => ast #else @@ -170,7 +174,7 @@ -- by e.g. CPP, and the parts stripped out of the original source are re-added -- as comments so they are not lost for round tripping. relativiseApiAnnsWithComments :: -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) => [Comment] -> ast @@ -185,7 +189,7 @@ relativiseApiAnnsWithOptions normalLayout relativiseApiAnnsWithOptions :: -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) => DeltaOptions -> [Comment] @@ -245,7 +249,7 @@ -- | Used locally to pass Keywords, delta pairs relevant to a specific -- subtree to the parent. , annKds :: ![(KeywordId, DeltaPos)] - , sortKeys :: !(Maybe [GHC.SrcSpan]) + , sortKeys :: !(Maybe [AnnSpan]) , dwCapturedSpan :: !(First AnnKey) } @@ -299,7 +303,7 @@ -- tell (mempty { dwAnns = Endo (Map.insertWith (<>) k v) }) tell (mempty { dwAnns = Endo (Map.insert k v) }) -tellSortKey :: [GHC.SrcSpan] -> Delta () +tellSortKey :: [AnnSpan] -> Delta () tellSortKey xs = tell (mempty { sortKeys = Just xs } ) tellCapturedSpan :: AnnKey -> Delta () @@ -344,7 +348,7 @@ (if r <= rigidity then setLayoutFlag else id) (deltaInterpret action) next go (MarkAnnBeforeAnn ann1 ann2 next) = deltaMarkAnnBeforeAnn ann1 ann2 >> next - go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt ss akwid >> next + go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt (rs ss) akwid >> next go (StoreOriginalSrcSpan _ key next) = storeOriginalSrcSpanDelta key >>= next go (GetSrcSpanForKw ss kw next) = getSrcSpanForKw ss kw >>= next #if __GLASGOW_HASKELL__ <= 710 @@ -363,7 +367,7 @@ go (IfInContext ctxt ifAction elseAction next) = ifInContextDelta ctxt ifAction elseAction >> next go (TellContext _ next) = next -withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Delta () +withSortKey :: [(AnnSpan, Annotated b)] -> Delta () withSortKey kws = let order = sortBy (comparing fst) kws in do @@ -371,7 +375,7 @@ mapM_ (deltaInterpret . snd) order -withSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Delta () +withSortKeyContexts :: ListContexts -> [(AnnSpan, Annotated ())] -> Delta () withSortKeyContexts ctxts kws = do tellSortKey (map fst order) withSortKeyContextsHelper deltaInterpret ctxts order @@ -426,7 +430,7 @@ doOne :: GHC.AnnKeywordId -> Delta [Comment] doOne kw = do (spans,_) <- getAndRemoveAnnotationDelta ss kw - return $ map (mkKWComment kw) spans + return $ map (mkKWComment kw . sr) spans -- TODO:AZ make sure these are sorted/merged properly when the invariant for -- allocateComments is re-established. newComments <- mapM doOne kws @@ -439,16 +443,20 @@ getSrcSpanForKw _ kw = do ga <- gets apAnns ss <- getSrcSpan - case GHC.getAnnotation ga ss kw of + case GHC.getAnnotation ga (rs ss) kw of [] -> return GHC.noSrcSpan +#if __GLASGOW_HASKELL__ >= 900 + (sp:_) -> return (GHC.RealSrcSpan sp Nothing) +#else (sp:_) -> return sp +#endif -- --------------------------------------------------------------------- getSrcSpan :: Delta GHC.SrcSpan getSrcSpan = asks curSrcSpan -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) withSrcSpanDelta :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b withSrcSpanDelta (GHC.dL->GHC.L l a) = #else @@ -488,10 +496,10 @@ setPriorEnd pe = modify (\s -> s { priorEndPosition = pe }) -setPriorEndAST :: GHC.SrcSpan -> Delta () +setPriorEndAST :: AnnSpan -> Delta () setPriorEndAST pe = do - setLayoutStart (snd (ss2pos pe)) - modify (\s -> s { priorEndPosition = ss2posEnd pe } ) + setLayoutStart (snd (ss2pos (sr pe))) + modify (\s -> s { priorEndPosition = ss2posEnd (sr pe) } ) setLayoutStart :: Int -> Delta () setLayoutStart p = do @@ -503,7 +511,7 @@ -- ------------------------------------- -peekAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan] +peekAnnotationDelta :: GHC.AnnKeywordId -> Delta [AnnSpan] peekAnnotationDelta an = do ga <- gets apAnns ss <- getSrcSpan @@ -512,41 +520,48 @@ #else let unicodeAnns = case unicodeEquivalent an of [] -> [] - [kw] -> GHC.getAnnotation ga ss kw - (kw:_) -> GHC.getAnnotation ga ss kw -- Keep exhaustiveness checker happy - return $ unicodeAnns ++ GHC.getAnnotation ga ss an + [kw] -> GHC.getAnnotation ga (rs ss) kw + (kw:_) -> GHC.getAnnotation ga (rs ss) kw -- Keep exhaustiveness checker happy + return $ unicodeAnns ++ GHC.getAnnotation ga (rs ss) an #endif -getAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId) +getAnnotationDelta :: GHC.AnnKeywordId -> Delta ([AnnSpan],GHC.AnnKeywordId) getAnnotationDelta an = do ss <- getSrcSpan getAndRemoveAnnotationDelta ss an -getAndRemoveAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId) +getAndRemoveAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([AnnSpan],GHC.AnnKeywordId) getAndRemoveAnnotationDelta sp an = do ga <- gets apAnns #if __GLASGOW_HASKELL__ <= 710 let (r,ga') = GHC.getAndRemoveAnnotation ga sp an kw = an #else - let (r,ga',kw) = case GHC.getAndRemoveAnnotation ga sp an of + let (r,ga',kw) = case GHC.getAndRemoveAnnotation ga (rs sp) an of ([],_) -> (ss,g,k) where k = GHC.unicodeAnn an - (ss,g) = GHC.getAndRemoveAnnotation ga sp k + (ss,g) = GHC.getAndRemoveAnnotation ga (rs sp) k (ss,g) -> (ss,g,an) #endif modify (\s -> s { apAnns = ga' }) return (r,kw) -getOneAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId) +getOneAnnotationDelta :: GHC.AnnKeywordId -> Delta ([AnnSpan],GHC.AnnKeywordId) getOneAnnotationDelta an = do ss <- getSrcSpan getAndRemoveOneAnnotationDelta ss an -getAndRemoveOneAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId) +getAndRemoveOneAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([AnnSpan],GHC.AnnKeywordId) getAndRemoveOneAnnotationDelta sp an = do +#if __GLASGOW_HASKELL__ >= 900 + ann <- gets apAnns + let anns = GHC.apiAnnItems ann + let cs = GHC.apiAnnComments ann -- TODO:AZ: what about apiAnnRogueComments? +#else (anns,cs) <- gets apAnns +#endif + #if __GLASGOW_HASKELL__ <= 710 let (r,ga',kw) = case Map.lookup (sp,an) anns of Nothing -> ([],(anns,cs),an) @@ -554,16 +569,21 @@ Just (s:ss) -> ([s],(Map.insert (sp,an) ss anns,cs),an) #else let getKw kw = - case Map.lookup (sp,kw) anns of + case Map.lookup (rs sp,kw) anns of Nothing -> ([],(anns,cs),kw) - Just [] -> ([], (Map.delete (sp,kw) anns,cs),kw) - Just (s:ss) -> ([s],(Map.insert (sp,kw) ss anns,cs),kw) + Just [] -> ([], (Map.delete (rs sp,kw) anns,cs),kw) + Just (s:ss) -> ([s],(Map.insert (rs sp,kw) ss anns,cs),kw) - let (r,ga',kw) = + let (r,(a',c'),kw) = case getKw an of ([],_,_) -> getKw (GHC.unicodeAnn an) v -> v +#if __GLASGOW_HASKELL__ >= 900 + let ga' = ann { GHC.apiAnnItems = a', GHC.apiAnnComments = c' } +#else + let ga' = (a',c') #endif +#endif modify (\s -> s { apAnns = ga' }) return (r,kw) @@ -577,7 +597,7 @@ getAnnKey :: DeltaOptions -> AnnKey getAnnKey DeltaOptions {curSrcSpan, annConName} - = AnnKey curSrcSpan annConName + = AnnKey (rs curSrcSpan) annConName -- ------------------------------------- @@ -587,7 +607,7 @@ -- ------------------------------------- -- | Enter a new AST element. Maintain SrcSpan stack -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b @@ -650,7 +670,7 @@ -- |Split the ordered list of comments into ones that occur prior to -- the give SrcSpan and the rest priorComment :: Pos -> Comment -> Bool -priorComment start c = (ss2pos . commentIdentifier $ c) < start +priorComment start c = (ss2pos . sr . commentIdentifier $ c) < start -- TODO:AZ: We scan the entire comment list here. It may be better to impose an -- invariant that the comments are sorted, and consume them as the pos @@ -661,7 +681,7 @@ -- --------------------------------------------------------------------- -addAnnotationWorker :: KeywordId -> GHC.SrcSpan -> Delta () +addAnnotationWorker :: KeywordId -> AnnSpan -> Delta () addAnnotationWorker ann pa = -- Zero-width source spans are injected by the GHC Lexer when it puts virtual -- '{', ';' and '}' tokens in for layout @@ -669,7 +689,7 @@ do pe <- getPriorEnd ss <- getSrcSpan - let p = ss2delta pe pa + let p = ss2delta pe (sr pa) case (ann,isGoodDelta p) of (G GHC.AnnComma,False) -> return () (G GHC.AnnSemi, False) -> return () @@ -677,7 +697,7 @@ (G GHC.AnnClose,False) -> return () _ -> do p' <- adjustDeltaForOffsetM p - commentAllocation (priorComment (ss2pos pa)) (mapM_ (uncurry addDeltaComment)) + commentAllocation (priorComment (ss2pos (sr pa))) (mapM_ (uncurry addDeltaComment)) #if __GLASGOW_HASKELL__ <= 710 addAnnDeltaPos (checkUnicode ann pa) p' #else @@ -750,8 +770,13 @@ where -- unpack a RealSrcSpan into ((start line, start col), (end line, end col)). -- The file name is ignored. +#if __GLASGOW_HASKELL__ >= 900 + unpack :: GHC.RealSrcSpan -> Maybe ((Int, Int), (Int, Int)) + unpack x = +#else unpack :: GHC.SrcSpan -> Maybe ((Int, Int), (Int, Int)) unpack (GHC.RealSrcSpan x) = +#endif Just ( (GHC.srcSpanStartLine x, GHC.srcSpanStartCol x) , (GHC.srcSpanEndLine x, GHC.srcSpanEndCol x) ) unpack _ = Nothing @@ -760,9 +785,9 @@ makeDeltaComment c = do let pa = commentIdentifier c pe <- getPriorEnd - let p = ss2delta pe pa + let p = ss2delta pe (sr pa) p' <- adjustDeltaForOffsetM p - setPriorEnd (ss2posEnd pa) + setPriorEnd (ss2posEnd (sr pa)) return (c, p') addDeltaComment :: Comment -> DeltaPos -> Delta () @@ -778,8 +803,8 @@ mb <- peekAnnotationDelta annBefore ma <- peekAnnotationDelta annAfter let - before = sort $ filter (\s -> GHC.isSubspanOf s ss) mb - after = sort $ filter (\s -> GHC.isSubspanOf s ss) ma + before = sort $ filter (\s -> GHC.isSubspanOf (sr s) ss) mb + after = sort $ filter (\s -> GHC.isSubspanOf (sr s) ss) ma case (before,after) of (b:_, a:_) -> when (b < a) $ addDeltaAnnotation annBefore _ -> return () @@ -803,7 +828,7 @@ addDeltaAnnotationLs ann off = do ss <- getSrcSpan ma <- peekAnnotationDelta ann - let ma' = filter (\s -> GHC.isSubspanOf s ss) ma + let ma' = filter (\s -> GHC.isSubspanOf (sr s) ss) ma case drop off ma' of [] -> return () `debug` ("addDeltaAnnotationLs:missed:(off,ann,ma)=" ++ showGhc (off,ss,ann)) @@ -827,7 +852,7 @@ ma <- peekAnnotationDelta ann let do_one ap' = addAnnotationWorker (G ann) ap' -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) - let filtered = sort $ filter (\s -> GHC.isSubspanOf s ss) ma + let filtered = sort $ filter (\s -> GHC.isSubspanOf (sr s) ss) ma mapM_ do_one filtered -- --------------------------------------------------------------------- @@ -857,17 +882,28 @@ let do_one ap' = if ann == AnnSemiSep then addAnnotationWorker ann ap' else addAnnotationWorker (G kw) ap' - mapM_ do_one (sort $ filter (\s -> not (GHC.isSubspanOf s ss)) ma) + mapM_ do_one (sort $ filter (\s -> not (GHC.isSubspanOf (sr s) ss)) ma) -- | Add a Delta annotation at the current position, and advance the -- position to the end of the annotation -addDeltaAnnotationExt :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta () +addDeltaAnnotationExt :: AnnSpan -> GHC.AnnKeywordId -> Delta () addDeltaAnnotationExt s ann = addAnnotationWorker (G ann) s addEofAnnotation :: Delta () +#if __GLASGOW_HASKELL__ >= 900 addEofAnnotation = do pe <- getPriorEnd - (ma,_kw) <- withSrcSpanDelta (GHC.noLoc () :: GHC.GenLocated GHC.SrcSpan ()) (getAnnotationDelta GHC.AnnEofPos) + ga <- gets apAnns + let Just pa = GHC.apiAnnEofPos ga + commentAllocation (const True) (mapM_ (uncurry addDeltaComment)) + let DP (r,c) = ss2delta pe (sr pa) + addAnnDeltaPos AnnEofPos (DP (r, c - 1)) + setPriorEndAST pa +#else +addEofAnnotation = do + pe <- getPriorEnd + (ma,_kw) <- withSrcSpanDelta (GHC.noLoc () :: GHC.GenLocated GHC.SrcSpan ()) + (getAnnotationDelta GHC.AnnEofPos) case ma of [] -> return () (pa:pss) -> do @@ -875,6 +911,7 @@ let DP (r,c) = ss2delta pe pa addAnnDeltaPos (G GHC.AnnEofPos) (DP (r, c - 1)) setPriorEndAST pa `warn` ("Trailing annotations after Eof: " ++ showGhc pss) +#endif -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs --- a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs @@ -26,6 +26,9 @@ -- warnings if new constructors are added. AnnComment _ -> mkErr kw AnnString _ -> mkErr kw +#if __GLASGOW_HASKELL__ >= 900 + (AnnEofPos ) -> mkErr kw +#endif #if __GLASGOW_HASKELL__ <= 710 AnnUnicode kw' -> keywordToString (G kw') #endif @@ -86,9 +89,17 @@ (G GHC.AnnLam ) -> "\\" (G GHC.AnnLarrow ) -> "<-" (G GHC.AnnLet ) -> "let" +#if __GLASGOW_HASKELL__ >= 900 + -- (G GHC.AnnLolly ) -> "#->" + (G GHC.AnnLollyU ) -> "⊸" +#endif (G GHC.AnnMdo ) -> "mdo" (G GHC.AnnMinus ) -> "-" (G GHC.AnnModule ) -> "module" +#if __GLASGOW_HASKELL__ >= 900 + (G GHC.AnnPercent ) -> "%" + (G GHC.AnnPercentOne) -> "%1" +#endif (G GHC.AnnNewtype ) -> "newtype" (G GHC.AnnOf ) -> "of" #if __GLASGOW_HASKELL__ >= 801 @@ -104,8 +115,10 @@ (G GHC.AnnOpenEQU ) -> "⟦" #endif (G GHC.AnnOpenP ) -> "(" +#if __GLASGOW_HASKELL__ < 900 (G GHC.AnnOpenPE ) -> "$(" (G GHC.AnnOpenPTE ) -> "$$(" +#endif (G GHC.AnnOpenS ) -> "[" (G GHC.AnnPattern ) -> "pattern" (G GHC.AnnProc ) -> "proc" @@ -136,9 +149,16 @@ (G GHC.AnnRarrowtail ) -> ">>-" (G GHC.AnnSimpleQuote ) -> "'" (G GHC.AnnThTyQuote ) -> "''" +#if __GLASGOW_HASKELL__ >= 900 + (G GHC.AnnDollar ) -> "$" + (G GHC.AnnDollarDollar ) -> "$$" +#else (G GHC.AnnThIdSplice ) -> "$" (G GHC.AnnThIdTySplice ) -> "$$" +#endif +#if __GLASGOW_HASKELL__ < 900 (G GHC.AnnEofPos ) -> "" +#endif #if __GLASGOW_HASKELL__ > 710 (G GHC.AnnDarrowU) -> "⇒" (G GHC.AnnDcolonU) -> "∷" 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 @@ -52,22 +52,37 @@ import Control.Exception (IOException, catch) import Control.Monad.RWS -#if __GLASGOW_HASKELL__ > 806 +#if __GLASGOW_HASKELL__ >= 900 +#elif __GLASGOW_HASKELL__ > 806 import Data.Data (Data) #endif import Data.Maybe (fromMaybe) + import GHC.Paths (libdir) import System.Environment (lookupEnv) -import qualified ApiAnnotation as GHC +import qualified GHC hiding (parseModule) +#if __GLASGOW_HASKELL__ >= 900 +import qualified Control.Monad.IO.Class as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Data.StringBuffer as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.Parser as GHC +import qualified GHC.Parser.Header as GHC +import qualified GHC.Parser.Lexer as GHC +import qualified GHC.Parser.PostProcess as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Utils.Error as GHC +#else +-- 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 GHC as GHC hiding (parseModule) import qualified HeaderInfo as GHC import qualified Lexer as GHC import qualified MonadUtils as GHC @@ -80,6 +95,7 @@ #endif import qualified SrcLoc as GHC import qualified StringBuffer as GHC +#endif #if __GLASGOW_HASKELL__ <= 710 import qualified OrdList as OL @@ -97,7 +113,7 @@ -- | Wrapper function which returns Annotations along with the parsed -- element. -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) parseWith :: (Data (GHC.SrcSpanLess w), Annotate w, GHC.HasSrcSpan w) => GHC.DynFlags -> FilePath @@ -165,7 +181,11 @@ -- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ >= 900 +parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located GHC.HsModule) +#else parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs)) +#endif parseFile = runParser GHC.parseModule -- --------------------------------------------------------------------- @@ -400,6 +420,17 @@ -- --------------------------------------------------------------------- mkApiAnns :: GHC.PState -> GHC.ApiAnns + +#if __GLASGOW_HASKELL__ >= 900 mkApiAnns pstate + = GHC.ApiAnns { + GHC.apiAnnItems = Map.fromListWith (++) $ GHC.annotations pstate, + GHC.apiAnnEofPos = GHC.eof_pos pstate, + GHC.apiAnnComments = Map.fromList (GHC.annotations_comments pstate), + GHC.apiAnnRogueComments = GHC.comment_q pstate + } +#else +mkApiAnns pstate = ( Map.fromListWith (++) . GHC.annotations $ pstate , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : GHC.annotations_comments pstate)) +#endif 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 @@ -14,25 +14,46 @@ , defaultCppOptions ) where +import qualified GHC as GHC hiding (parseModule) + +#if __GLASGOW_HASKELL__ >= 900 +import qualified Control.Monad.IO.Class as GHC +import qualified GHC.Data.Bag as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Data.StringBuffer as GHC +import qualified GHC.Driver.Phases as GHC +import qualified GHC.Driver.Pipeline as GHC +-- import qualified GHC.Driver.Session as GHC +import qualified GHC.Driver.Types as GHC +import qualified GHC.Fingerprint.Type as GHC +import qualified GHC.Utils.Fingerprint as GHC +import qualified GHC.Parser.Lexer as GHC +import qualified GHC.Settings as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Utils.Error as GHC +import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc) +import GHC.Data.FastString (mkFastString) +#else import qualified Bag as GHC import qualified DriverPhases as GHC import qualified DriverPipeline as GHC import qualified DynFlags as GHC import qualified ErrUtils as GHC import qualified FastString as GHC -import qualified GHC as GHC hiding (parseModule) import qualified HscTypes as GHC import qualified Lexer as GHC import qualified MonadUtils as GHC import qualified SrcLoc as GHC import qualified StringBuffer as GHC -#if __GLASGOW_HASKELL__ > 808 +import SrcLoc (mkSrcSpan, mkSrcLoc) +import FastString (mkFastString) +#endif + +#if (__GLASGOW_HASKELL__ > 808) && (__GLASGOW_HASKELL__ < 900) import qualified Fingerprint as GHC import qualified ToolSettings as GHC #endif -import SrcLoc (mkSrcSpan, mkSrcLoc) -import FastString (mkFastString) #if __GLASGOW_HASKELL__ > 808 #else @@ -82,14 +103,14 @@ size = length pragma mSrcLoc = mkSrcLoc (mkFastString "LINE") ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1)) - in (res, Just $ mkComment pragma ss) + in (res, Just $ mkComment pragma (rs ss)) -- Deal with shebang/cpp directives too -- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s) | "#!" `isPrefixOf` s = let mSrcLoc = mkSrcLoc (mkFastString "SHEBANG") ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s)) in - ("",Just $ mkComment s ss) + ("",Just $ mkComment s (rs ss)) | otherwise = (s, Nothing) getPragma :: String -> (String, String) @@ -123,7 +144,9 @@ let toks = GHC.addSourceToTokens startLoc source ts cppCommentToks = getCppTokens directiveToks nonDirectiveToks toks return $ filter goodComment -#if __GLASGOW_HASKELL__ > 800 +#if __GLASGOW_HASKELL__ >= 900 + $ map (tokComment . GHC.commentToAnnotation . toRealLocated . fst) cppCommentToks +#elif __GLASGOW_HASKELL__ > 800 $ map (tokComment . GHC.commentToAnnotation . fst) cppCommentToks #else $ map (tokComment . commentToAnnotation . fst) cppCommentToks @@ -140,6 +163,13 @@ goodComment (Comment "" _ _) = False goodComment _ = True + +#if __GLASGOW_HASKELL__ >= 900 +toRealLocated :: GHC.Located a -> GHC.RealLocated a +toRealLocated (GHC.L (GHC.RealSrcSpan s _) x) = GHC.L s x +toRealLocated (GHC.L _ x) = GHC.L badRealSrcSpan x +#endif + -- --------------------------------------------------------------------- -- | Combine the three sets of tokens to produce a single set that @@ -159,18 +189,18 @@ -> [(GHC.Located GHC.Token, String)] getCppTokens directiveToks origSrcToks postCppToks = toks where - locFn (GHC.L l1 _,_) (GHC.L l2 _,_) = compare l1 l2 + locFn (GHC.L l1 _,_) (GHC.L l2 _,_) = compare (rs l1) (rs l2) m1Toks = mergeBy locFn postCppToks directiveToks -- We must now find the set of tokens that are in origSrcToks, but -- not in m1Toks -- GHC.Token does not have Ord, can't use a set directly - origSpans = map (\(GHC.L l _,_) -> l) origSrcToks - m1Spans = map (\(GHC.L l _,_) -> l) m1Toks + origSpans = map (\(GHC.L l _,_) -> rs l) origSrcToks + m1Spans = map (\(GHC.L l _,_) -> rs l) m1Toks missingSpans = Set.fromList origSpans Set.\\ Set.fromList m1Spans - missingToks = filter (\(GHC.L l _,_) -> Set.member l missingSpans) origSrcToks + missingToks = filter (\(GHC.L l _,_) -> Set.member (rs l) missingSpans) origSrcToks missingAsComments = map mkCommentTok missingToks where 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 @@ -96,7 +96,7 @@ -- | Used locally to pass Keywords, delta pairs relevant to a specific -- subtree to the parent. , annKds :: ![(KeywordId, DeltaPos)] - , sortKeys :: !(Maybe [GHC.SrcSpan]) + , sortKeys :: !(Maybe [AnnSpan]) , dwCapturedSpan :: !(First AnnKey) , prLayoutContext :: !(ACS' AstContext) } @@ -199,7 +199,11 @@ addEofAnnotation :: Pretty () addEofAnnotation = do +#if __GLASGOW_HASKELL__ >= 900 + tellKd (AnnEofPos, DP (1,0)) +#else tellKd (G GHC.AnnEofPos, DP (1,0)) +#endif -- --------------------------------------------------------------------- @@ -228,6 +232,10 @@ (G GHC.AnnDcolon) -> tellKd (ann,DP (0,1)) (G GHC.AnnDeriving) -> tellKd (ann,DP (0,1)) (G GHC.AnnDo) -> tellKd (ann,DP (0,1)) +#if __GLASGOW_HASKELL__ >= 900 + (G GHC.AnnDollar) -> tellKd (ann,DP (0,1)) + (G GHC.AnnDollarDollar) -> tellKd (ann,DP (0,1)) +#endif (G GHC.AnnDotdot) -> tellKd (ann,DP (0,1)) (G GHC.AnnElse) -> tellKd (ann,DP (1,2)) (G GHC.AnnEqual) -> tellKd (ann,DP (0,1)) @@ -242,23 +250,38 @@ (G GHC.AnnInstance) -> tellKd (ann,DP (0,1)) (G GHC.AnnLam) -> tellKd (ann,DP (0,1)) (G GHC.AnnLet) -> tellKd (ann,DP (0,1)) +#if __GLASGOW_HASKELL__ >= 900 + -- (G GHC.AnnLolly) -> tellKd (ann,DP (0,1)) + (G GHC.AnnLollyU) -> tellKd (ann,DP (0,1)) + (G GHC.AnnPercentOne) -> tellKd (ann,DP (0,1)) + (G GHC.AnnPercent) -> tellKd (ann,DP (0,1)) +#endif (G GHC.AnnMinus) -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator (G GHC.AnnModule) -> tellKd (ann,DP (0,1)) (G GHC.AnnNewtype) -> tellKd (ann,DP (0,1)) (G GHC.AnnOf) -> tellKd (ann,DP (0,1)) (G GHC.AnnOpenC) -> tellKd (ann,DP (0,0)) + (G GHC.AnnOpenP) -> tellKd (ann,DP (0,1)) + (G GHC.AnnOpenS) -> tellKd (ann,DP (0,1)) +#if __GLASGOW_HASKELL__ < 900 (G GHC.AnnOpenPE) -> tellKd (ann,DP (0,1)) (G GHC.AnnOpenPTE) -> tellKd (ann,DP (0,1)) +#endif (G GHC.AnnQualified) -> tellKd (ann,DP (0,1)) (G GHC.AnnRarrow) -> tellKd (ann,DP (0,1)) +#if __GLASGOW_HASKELL__ > 710 + (G GHC.AnnRarrowU) -> tellKd (ann,DP (0,1)) +#endif (G GHC.AnnRole) -> tellKd (ann,DP (0,1)) (G GHC.AnnSafe) -> tellKd (ann,DP (0,1)) #if __GLASGOW_HASKELL__ >= 806 (G GHC.AnnStock) -> tellKd (ann,DP (0,1)) #endif (G GHC.AnnSimpleQuote) -> tellKd (ann,DP (0,1)) +#if __GLASGOW_HASKELL__ < 900 (G GHC.AnnThIdSplice) -> tellKd (ann,DP (0,1)) (G GHC.AnnThIdTySplice) -> tellKd (ann,DP (0,1)) +#endif (G GHC.AnnThTyQuote) -> tellKd (ann,DP (0,1)) (G GHC.AnnThen) -> tellKd (ann,DP (1,2)) (G GHC.AnnTilde) -> tellKd (ann,DP (0,1)) @@ -313,7 +336,7 @@ -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) withSrcSpanPretty :: (Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b withSrcSpanPretty (GHC.dL->GHC.L l a) action = do #else @@ -336,7 +359,7 @@ -- --------------------------------------------------------------------- -- | Enter a new AST element. Maintain SrcSpan stack -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b @@ -379,7 +402,8 @@ -- edp <- entryDpFor ctx t let ctx1 = debugP ("Pretty.withAST:edp:(ss,constr,edp)=" ++ showGhc (ss,showConstr (toConstr t),edp)) ctx - (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel]) ctx1 + -- (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel]) ctx1 + (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel,InTypeApp]) ctx1 then -- debugP ("Pretty.withAST:setNoPrecedingSpace") $ censor maskWriter (listen (setNoPrecedingSpace action)) @@ -415,7 +439,8 @@ def _ = debugP ("entryDpFor:(topLevel,listStart,inList,noAdvanceLine,ctx)=" ++ show (topLevel,listStart,inList,noAdvanceLine,ctx)) $ if noAdvanceLine - then return (DP (0,1)) + then (if inTypeApp then return (DP (0,0)) else return (DP (0,1))) + -- then (if inTypeApp then error "inTypeAp" else return (DP (0,1))) else if listStart then return (DP (1,2)) @@ -428,6 +453,7 @@ && not (inAcs (Set.singleton TopLevel) ctx) inList = inAcs (Set.singleton ListItem) ctx inLambda = inAcs (Set.singleton LambdaExpr) ctx + inTypeApp = inAcs (Set.singleton InTypeApp) ctx grhs :: GHC.GRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Pretty DeltaPos grhs _ = do @@ -463,7 +489,7 @@ getAnnKey :: PrettyOptions -> AnnKey getAnnKey PrettyOptions {curSrcSpan, annConName} - = AnnKey curSrcSpan annConName + = AnnKey (rs curSrcSpan) annConName -- --------------------------------------------------------------------- @@ -472,14 +498,14 @@ -- --------------------------------------------------------------------- -withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Pretty () +withSortKey :: [(AnnSpan, Annotated b)] -> Pretty () withSortKey kws = let order = sortBy (comparing fst) kws in do tellSortKey (map fst order) mapM_ (prettyInterpret . snd) order -withSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Pretty () +withSortKeyContexts :: ListContexts -> [(AnnSpan, Annotated ())] -> Pretty () withSortKeyContexts ctxts kws = let order = sortBy (comparing fst) kws in do @@ -619,7 +645,7 @@ tellKd :: (KeywordId, DeltaPos) -> Pretty () tellKd kd = tell (mempty { annKds = [kd] }) -tellSortKey :: [GHC.SrcSpan] -> Pretty () +tellSortKey :: [AnnSpan] -> Pretty () tellSortKey xs = tell (mempty { sortKeys = Just xs } ) tellContext :: Set.Set AstContext -> Pretty () diff --git a/src/Language/Haskell/GHC/ExactPrint/Print.hs b/src/Language/Haskell/GHC/ExactPrint/Print.hs --- a/src/Language/Haskell/GHC/ExactPrint/Print.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Print.hs @@ -74,7 +74,7 @@ data PrintOptions m a = PrintOptions { epAnn :: !Annotation -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) , epAstPrint :: forall ast . (Data ast, GHC.HasSrcSpan ast) => ast -> a -> m a #else , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a @@ -87,7 +87,7 @@ -- | Helper to create a 'PrintOptions' printOptions :: -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) (forall ast . (Data ast, GHC.HasSrcSpan ast) => ast -> a -> m a) #else (forall ast . Data ast => GHC.Located ast -> a -> m a) @@ -165,7 +165,11 @@ where go :: AnnotationF (EP w m a) -> EP w m a go (MarkEOF next) = +#if __GLASGOW_HASKELL__ >= 900 + printStringAtMaybeAnn AnnEofPos (Just "") >> next +#else printStringAtMaybeAnn (G GHC.AnnEofPos) (Just "") >> next +#endif go (MarkPrim kwid mstr next) = markPrim (G kwid) mstr >> next go (MarkPPOptional kwid mstr next) = @@ -240,7 +244,7 @@ _ -> return () #endif -withSortKey :: (Monad m, Monoid w) => [(GHC.SrcSpan, Annotated ())] -> EP w m () +withSortKey :: (Monad m, Monoid w) => [(AnnSpan, Annotated ())] -> EP w m () withSortKey xs = do Ann{..} <- asks epAnn let ordered = case annSortKey of @@ -253,7 +257,7 @@ ) mapM_ (printInterpret . snd) ordered -withSortKeyContexts :: (Monad m, Monoid w) => ListContexts -> [(GHC.SrcSpan, Annotated ())] -> EP w m () +withSortKeyContexts :: (Monad m, Monoid w) => ListContexts -> [(AnnSpan, Annotated ())] -> EP w m () withSortKeyContexts ctxts xs = do Ann{..} <- asks epAnn let ordered = case annSortKey of @@ -290,7 +294,7 @@ -- |First move to the given location, then call exactP -- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a -- exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w) -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w) => ast -> EP w m a -> EP w m a #else @@ -328,7 +332,7 @@ colOffset <- getLayoutOffset printWhitespace (undelta p cl colOffset) -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) getAndRemoveAnnotation :: (Monad m, Monoid w, Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> EP w m (Maybe Annotation) #else 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 @@ -97,9 +97,14 @@ import Control.Monad.RWS import qualified Control.Monad.Fail as Fail +import qualified GHC as GHC hiding (parseModule) +#if __GLASGOW_HASKELL__ >= 900 +import qualified GHC.Data.Bag as GHC +import qualified GHC.Data.FastString as GHC +#else import qualified Bag as GHC import qualified FastString as GHC -import qualified GHC as GHC hiding (parseModule) +#endif import qualified Data.Generics as SYB @@ -249,7 +254,7 @@ captureOrderAnnKey :: AnnKey -> [GHC.Located b] -> Anns -> Anns captureOrderAnnKey parentKey ls ans = ans' where - newList = map GHC.getLoc ls + newList = map (rs . GHC.getLoc) ls reList = Map.adjust (\an -> an {annSortKey = Just newList }) parentKey ans' = reList ans @@ -306,7 +311,7 @@ -- |Create a simple 'Annotation' without comments, and attach it to the first -- parameter. addSimpleAnnT :: (Constraints a,Monad m) -#if __GLASGOW_HASKELL__ >= 808 +#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) => a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m () #else => GHC.Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m () @@ -334,7 +339,7 @@ -- --------------------------------------------------------------------- -- |'Transform' monad version of 'getEntryDP' -#if __GLASGOW_HASKELL__ >= 808 +#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) getEntryDPT :: (Constraints a,Monad m) => a -> TransformT m DeltaPos #else getEntryDPT :: (Data a,Monad m) => GHC.Located a -> TransformT m DeltaPos @@ -346,7 +351,7 @@ -- --------------------------------------------------------------------- -- |'Transform' monad version of 'getEntryDP' -#if __GLASGOW_HASKELL__ >= 808 +#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) setEntryDPT :: (Constraints a,Monad m) => a -> DeltaPos -> TransformT m () #else setEntryDPT :: (Data a,Monad m) => GHC.Located a -> DeltaPos -> TransformT m () @@ -404,7 +409,7 @@ -- |Return the true entry 'DeltaPos' from the annotation for a given AST -- element. This is the 'DeltaPos' ignoring any comments. -#if __GLASGOW_HASKELL__ >= 808 +#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) getEntryDP :: (Constraints a) => Anns -> a -> DeltaPos #else getEntryDP :: (Data a) => Anns -> GHC.Located a -> DeltaPos @@ -418,7 +423,7 @@ -- |Set the true entry 'DeltaPos' from the annotation for a given AST -- element. This is the 'DeltaPos' ignoring any comments. -#if __GLASGOW_HASKELL__ >= 808 +#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) setEntryDP :: (Constraints a) => a -> DeltaPos -> Anns -> Anns #else setEntryDP :: (Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns @@ -547,7 +552,9 @@ -- '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__ > 808 +#if __GLASGOW_HASKELL__ >= 900 +balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _)) second = do +#elif __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 @@ -694,12 +701,21 @@ -- --------------------------------------------------------------------- instance HasDecls GHC.ParsedSource where +#if __GLASGOW_HASKELL__ >= 900 + hsDecls (GHC.L _ (GHC.HsModule _lo _mn _exps _imps decls _ _)) = return decls + replaceDecls m@(GHC.L l (GHC.HsModule lo mn exps imps _decls deps haddocks)) decls + = do + logTr "replaceDecls LHsModule" + modifyAnnsT (captureOrder m decls) + return (GHC.L l (GHC.HsModule lo mn exps imps decls deps haddocks)) +#else hsDecls (GHC.L _ (GHC.HsModule _mn _exps _imps decls _ _)) = return decls replaceDecls m@(GHC.L l (GHC.HsModule mn exps imps _decls deps haddocks)) decls = do logTr "replaceDecls LHsModule" modifyAnnsT (captureOrder m decls) return (GHC.L l (GHC.HsModule mn exps imps decls deps haddocks)) +#endif -- --------------------------------------------------------------------- @@ -989,7 +1005,9 @@ #else hsDecls (GHC.L _ (GHC.LastStmt e _)) = hsDecls e #endif -#if __GLASGOW_HASKELL__ > 804 +#if __GLASGOW_HASKELL__ >= 900 + hsDecls (GHC.L _ (GHC.BindStmt _ _pat e)) = hsDecls e +#elif __GLASGOW_HASKELL__ > 804 hsDecls (GHC.L _ (GHC.BindStmt _ _pat e _ _)) = hsDecls e #elif __GLASGOW_HASKELL__ > 710 hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _ _)) = hsDecls e @@ -1037,7 +1055,12 @@ e' <- replaceDecls e newDecls return (GHC.L l (GHC.LastStmt e' se)) #endif -#if __GLASGOW_HASKELL__ > 804 +#if __GLASGOW_HASKELL__ >= 900 + replaceDecls (GHC.L l (GHC.BindStmt x pat e)) newDecls + = do + e' <- replaceDecls e newDecls + return (GHC.L l (GHC.BindStmt x pat e')) +#elif __GLASGOW_HASKELL__ > 804 replaceDecls (GHC.L l (GHC.BindStmt x pat e a b)) newDecls = do e' <- replaceDecls e newDecls @@ -1151,7 +1174,9 @@ -- --------------------------------- lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs] -#if __GLASGOW_HASKELL__ > 808 +#if __GLASGOW_HASKELL__ >= 900 + lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _)) = do +#elif __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 @@ -1197,7 +1222,7 @@ Nothing -> do return decls Just keys -> do - let ds = map (\s -> (GHC.getLoc s,s)) decls + let ds = map (\s -> (rs $ GHC.getLoc s,s)) decls ordered = map snd $ orderByKey ds keys return ordered 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 @@ -23,10 +23,14 @@ , DeltaPos(..) , deltaRow, deltaColumn -- * AnnKey + , AnnSpan , AnnKey(..) , mkAnnKey , AnnConName(..) , annGetConstr +#if __GLASGOW_HASKELL__ >= 900 + , badRealSrcSpan +#endif -- * Other @@ -56,16 +60,23 @@ import Data.Data (Data, Typeable, toConstr,cast) -- import Data.Generics -import qualified DynFlags as GHC import qualified GHC +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Data.FastString as GHC +import GHC.Driver.Session as GHC +import GHC.Types.SrcLoc as GHC +import GHC.Utils.Outputable as GHC +#else +import qualified DynFlags as GHC import qualified Outputable as GHC +#endif import qualified Data.Map as Map import qualified Data.Set as Set -- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ >= 808 +#if (__GLASGOW_HASKELL__ >= 808) && (__GLASGOW_HASKELL__ < 900) type Constraints a = (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a) #else type Constraints a = (Data a) @@ -83,7 +94,7 @@ -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is -- the thing we use to decide where in the output stream the comment should -- go. - , commentIdentifier :: !GHC.SrcSpan -- ^ Needed to uniquely identify two comments with the same contents + , commentIdentifier :: !AnnSpan -- ^ Needed to uniquely identify two comments with the same contents , commentOrigin :: !(Maybe GHC.AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly. } deriving (Eq,Typeable,Data,Ord) @@ -133,7 +144,11 @@ -- The next three fields relate to interacing down into the AST , annsDP :: ![(KeywordId, DeltaPos)] -- ^ Annotations associated with this element. +#if __GLASGOW_HASKELL__ >= 900 + , annSortKey :: !(Maybe [GHC.RealSrcSpan]) +#else , annSortKey :: !(Maybe [GHC.SrcSpan]) +#endif -- ^ Captures the sort order of sub elements. This is needed when the -- sub-elements have been split (as in a HsLocalBind which holds separate -- binds and sigs) or for infix patterns where the order has been @@ -167,15 +182,27 @@ -- | For every @Located a@, use the @SrcSpan@ and constructor name of -- a as the key, to store the standard annotation. -- These are used to maintain context in the AP and EP monads -data AnnKey = AnnKey GHC.SrcSpan AnnConName +data AnnKey = AnnKey AnnSpan AnnConName deriving (Eq, Ord, Data) +-- | From GHC 9.0 the ParsedSource uses RealSrcSpan instead of SrcSpan. +-- Compatibility type +#if __GLASGOW_HASKELL__ >= 900 +type AnnSpan = GHC.RealSrcSpan +#else +type AnnSpan = GHC.SrcSpan +#endif + -- More compact Show instance instance Show AnnKey where show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn -#if __GLASGOW_HASKELL__ > 806 +#if __GLASGOW_HASKELL__ >= 900 +mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey +mkAnnKeyPrim (GHC.L (GHC.RealSrcSpan l _) a) = AnnKey l (annGetConstr a) +mkAnnKeyPrim (GHC.L _ a) = AnnKey badRealSrcSpan (annGetConstr a) +#elif __GLASGOW_HASKELL__ > 806 mkAnnKeyPrim :: (Constraints a) => a -> AnnKey mkAnnKeyPrim (GHC.dL->GHC.L l a) = AnnKey l (annGetConstr a) @@ -184,6 +211,14 @@ mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a) #endif + +#if __GLASGOW_HASKELL__ >= 900 +badRealSrcSpan :: GHC.RealSrcSpan +badRealSrcSpan = GHC.mkRealSrcSpan bad bad + where + bad = GHC.mkRealSrcLoc (GHC.fsLit "ghc-exactprint-nospan") 0 0 +#endif + #if __GLASGOW_HASKELL__ <= 802 type GhcPs = GHC.RdrName type GhcRn = GHC.Name @@ -204,7 +239,7 @@ #endif -- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise. -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) mkAnnKey :: (Constraints a) => a -> AnnKey #else mkAnnKey :: (Data a) => GHC.Located a -> AnnKey @@ -229,6 +264,9 @@ -- AST. data KeywordId = G GHC.AnnKeywordId -- ^ A normal keyword | AnnSemiSep -- ^ A separating comma +#if __GLASGOW_HASKELL__ >= 900 + | AnnEofPos +#endif #if __GLASGOW_HASKELL__ >= 800 | AnnTypeApp -- ^ Visible type application annotation #endif @@ -245,6 +283,9 @@ instance Show KeywordId where show (G gc) = "(G " ++ show gc ++ ")" show AnnSemiSep = "AnnSemiSep" +#if __GLASGOW_HASKELL__ >= 900 + show AnnEofPos = "AnnEofPos" +#endif #if __GLASGOW_HASKELL__ >= 800 show AnnTypeApp = "AnnTypeApp" #endif @@ -369,6 +410,7 @@ | LeftMost -- Is this the leftmost operator in a chain of OpApps? | InTypeApp -- HsTyVar in a TYPEAPP context. Has AnnAt -- TODO:AZ: do we actually need this? + -- TODO:AZ this is actually tight prefix -- Next four used to identify current list context | CtxOnly diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs --- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs @@ -8,6 +8,7 @@ -- * Manipulating Positons ss2pos , ss2posEnd + , ss2range , undelta , isPointSrcSpan , pos2delta @@ -15,6 +16,7 @@ , addDP , spanLength , isGoodDelta + , rs, sr -- * Manipulating Comments , mkComment @@ -82,22 +84,35 @@ import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Lookup -import qualified Bag as GHC #if __GLASGOW_HASKELL__ <= 710 import qualified BooleanFormula as GHC #endif +import qualified GHC +#if __GLASGOW_HASKELL__ >= 900 +import qualified GHC.Data.Bag as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Types.Name as GHC +import qualified GHC.Types.Name.Set as GHC +import qualified GHC.Utils.Outputable as GHC +import qualified GHC.Types.Name.Reader as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Types.Var as GHC +import qualified GHC.Types.Name.Occurrence as OccName (OccName(..),occNameString,pprNameSpaceBrief) +#else +import qualified Bag as GHC import qualified DynFlags as GHC import qualified FastString as GHC -import qualified GHC import qualified Name as GHC import qualified NameSet as GHC import qualified Outputable as GHC import qualified RdrName as GHC import qualified SrcLoc as GHC import qualified Var as GHC - import qualified OccName(OccName(..),occNameString,pprNameSpaceBrief) +#endif + import Control.Arrow import qualified Data.Map as Map @@ -221,20 +236,39 @@ ss2posEnd :: GHC.SrcSpan -> Pos ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss) +ss2range :: GHC.SrcSpan -> (Pos,Pos) +ss2range ss = (ss2pos ss, ss2posEnd ss) + srcSpanEndColumn :: GHC.SrcSpan -> Int +#if __GLASGOW_HASKELL__ >= 900 +srcSpanEndColumn (GHC.RealSrcSpan s _) = GHC.srcSpanEndCol s +#else srcSpanEndColumn (GHC.RealSrcSpan s) = GHC.srcSpanEndCol s +#endif srcSpanEndColumn _ = 0 srcSpanStartColumn :: GHC.SrcSpan -> Int +#if __GLASGOW_HASKELL__ >= 900 +srcSpanStartColumn (GHC.RealSrcSpan s _) = GHC.srcSpanStartCol s +#else srcSpanStartColumn (GHC.RealSrcSpan s) = GHC.srcSpanStartCol s +#endif srcSpanStartColumn _ = 0 srcSpanEndLine :: GHC.SrcSpan -> Int +#if __GLASGOW_HASKELL__ >= 900 +srcSpanEndLine (GHC.RealSrcSpan s _) = GHC.srcSpanEndLine s +#else srcSpanEndLine (GHC.RealSrcSpan s) = GHC.srcSpanEndLine s +#endif srcSpanEndLine _ = 0 srcSpanStartLine :: GHC.SrcSpan -> Int +#if __GLASGOW_HASKELL__ >= 900 +srcSpanStartLine (GHC.RealSrcSpan s _) = GHC.srcSpanStartLine s +#else srcSpanStartLine (GHC.RealSrcSpan s) = GHC.srcSpanStartLine s +#endif srcSpanStartLine _ = 0 spanLength :: GHC.SrcSpan -> Int @@ -242,15 +276,15 @@ -- --------------------------------------------------------------------- -- | Checks whether a SrcSpan has zero length. -isPointSrcSpan :: GHC.SrcSpan -> Bool -isPointSrcSpan ss = spanLength ss == 0 - && srcSpanStartLine ss == srcSpanEndLine ss +isPointSrcSpan :: AnnSpan -> Bool +isPointSrcSpan ss = spanLength (sr ss) == 0 + && srcSpanStartLine (sr ss) == srcSpanEndLine (sr ss) -- --------------------------------------------------------------------- -- |Given a list of items and a list of keys, returns a list of items -- ordered by their position in the list of keys. -orderByKey :: [(GHC.SrcSpan,a)] -> [GHC.SrcSpan] -> [(GHC.SrcSpan,a)] +orderByKey :: (Eq o) => [(o,a)] -> [o] -> [(o,a)] orderByKey keys order -- AZ:TODO: if performance becomes a problem, consider a Map of the order -- SrcSpan to an index, and do a lookup instead of elemIndex. @@ -268,8 +302,13 @@ GHC.PArrComp -> True #endif +#if __GLASGOW_HASKELL__ >= 900 + GHC.DoExpr {} -> False + GHC.MDoExpr {} -> False +#else GHC.DoExpr -> False GHC.MDoExpr -> False +#endif GHC.ArrowExpr -> False GHC.GhciStmtCtxt -> False @@ -280,14 +319,31 @@ -- --------------------------------------------------------------------- isGadt :: [GHC.LConDecl name] -> Bool -isGadt [] = False -#if __GLASGOW_HASKELL__ <= 710 -isGadt (GHC.L _ GHC.ConDecl{GHC.con_res=GHC.ResTyGADT _ _}:_) = True +#if __GLASGOW_HASKELL__ >= 880 +isGadt [] = True #else +isGadt [] = False +#endif +#if __GLASGOW_HASKELL__ >= 900 isGadt ((GHC.L _ (GHC.ConDeclGADT{})):_) = True +isGadt ((GHC.L _ (GHC.XConDecl{})):_) = True +#elif __GLASGOW_HASKELL__ > 710 +isGadt ((GHC.L _ (GHC.ConDeclGADT{})):_) = True +#else +isGadt (GHC.L _ GHC.ConDecl{GHC.con_res=GHC.ResTyGADT _ _}:_) = True #endif isGadt _ = False +-- isGadt :: [GHC.LConDecl name] -> Bool +-- isGadt [] = False +-- #if __GLASGOW_HASKELL__ <= 710 +-- isGadt (GHC.L _ GHC.ConDecl{GHC.con_res=GHC.ResTyGADT _ _}:_) = True +-- #else +-- isGadt ((GHC.L _ (GHC.ConDeclGADT{})):_) = True +-- #endif +-- isGadt _ = False + + -- --------------------------------------------------------------------- -- Is a RdrName of type Exact? SYB query, so can be extended to other types too @@ -296,7 +352,30 @@ -- --------------------------------------------------------------------- +rs :: GHC.SrcSpan -> AnnSpan +#if __GLASGOW_HASKELL__ >= 900 +-- rs :: GHC.SrcSpan -> GHC.RealSrcSpan +rs (GHC.RealSrcSpan s _) = s +rs _ = badRealSrcSpan +#else +-- rs :: GHC.SrcSpan -> GHC.SrcSpan +rs = id +#endif + +#if __GLASGOW_HASKELL__ >= 900 +sr :: GHC.RealSrcSpan -> GHC.SrcSpan +sr s = GHC.RealSrcSpan s Nothing +#else +sr :: GHC.SrcSpan -> GHC.SrcSpan +sr = id +#endif +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 900 +ghcCommentText :: GHC.RealLocated GHC.AnnotationComment -> String +#else ghcCommentText :: GHC.Located GHC.AnnotationComment -> String +#endif ghcCommentText (GHC.L _ (GHC.AnnDocCommentNext s)) = s ghcCommentText (GHC.L _ (GHC.AnnDocCommentPrev s)) = s ghcCommentText (GHC.L _ (GHC.AnnDocCommentNamed s)) = s @@ -308,25 +387,58 @@ ghcCommentText (GHC.L _ (GHC.AnnLineComment s)) = s ghcCommentText (GHC.L _ (GHC.AnnBlockComment s)) = s +#if __GLASGOW_HASKELL__ >= 900 +tokComment :: GHC.RealLocated GHC.AnnotationComment -> Comment +tokComment t@(GHC.L lt _) = mkComment (ghcCommentText t) lt +#else tokComment :: GHC.Located GHC.AnnotationComment -> Comment tokComment t@(GHC.L lt _) = mkComment (ghcCommentText t) lt +#endif -mkComment :: String -> GHC.SrcSpan -> Comment +#if __GLASGOW_HASKELL__ >= 900 +mkComment :: String -> GHC.RealSrcSpan -> Comment mkComment c ss = Comment c ss Nothing +#else +mkComment :: String -> GHC.SrcSpan -> Comment +mkComment c ss = Comment c (rs ss) Nothing +#endif -- | Makes a comment which originates from a specific keyword. mkKWComment :: GHC.AnnKeywordId -> GHC.SrcSpan -> Comment -mkKWComment kw ss = Comment (keywordToString $ G kw) ss (Just kw) +mkKWComment kw ss = Comment (keywordToString $ G kw) (rs ss) (Just kw) comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos) comment2dp = first AnnComment +-- --------------------------------------------------------------------- +{- + +GHC 9.0 version + +data ApiAnns = + ApiAnns + { apiAnnItems :: Map.Map ApiAnnKey [RealSrcSpan], + apiAnnEofPos :: Maybe RealSrcSpan, + apiAnnComments :: Map.Map RealSrcSpan [RealLocated AnnotationComment], + apiAnnRogueComments :: [RealLocated AnnotationComment] + } + +-} + + extractComments :: GHC.ApiAnns -> [Comment] +#if __GLASGOW_HASKELL__ >= 900 +extractComments anns + -- cm has type :: Map SrcSpan [Located AnnotationComment] + = map tokComment $ GHC.sortRealLocated $ ((concat + $ Map.elems (GHC.apiAnnComments anns)) ++ GHC.apiAnnRogueComments anns) +#else extractComments (_,cm) -- cm has type :: Map SrcSpan [Located AnnotationComment] = map tokComment . GHC.sortLocated . concat $ Map.elems cm +#endif -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) getAnnotationEP :: (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a) => a -> Anns -> Maybe Annotation #else 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 | GHC810 +data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88 | GHC810 | GHC90 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion ghcVersion = -#if __GLASGOW_HASKELL__ > 808 +#if __GLASGOW_HASKELL__ >= 900 + GHC90 +#elif __GLASGOW_HASKELL__ > 808 GHC810 #elif __GLASGOW_HASKELL__ > 806 GHC88 @@ -53,16 +55,17 @@ testDirs :: [FilePath] testDirs = case ghcVersion of - GHC710 -> ["ghc710-only","ghc710", "vect"] - GHC80 -> [ "ghc710", "ghc80", "vect"] - GHC82 -> ["pre-ghc86", "ghc710", "ghc80", "ghc82", "vect"] - 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" ] + GHC710 -> ["ghc710-only", "ghc710", "vect"] + GHC80 -> [ "pre-ghc90", "ghc710", "ghc80", "vect"] + GHC82 -> ["pre-ghc86", "pre-ghc90", "ghc710", "ghc80", "ghc82", "vect"] + GHC84 -> ["pre-ghc86", "pre-ghc810", "pre-ghc90", "ghc710", "ghc80", "ghc82", "ghc84", "vect" ] + GHC86 -> ["pre-ghc810", "pre-ghc810", "pre-ghc90", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86" ] + GHC88 -> ["pre-ghc810", "pre-ghc810", "pre-ghc90", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88" ] + GHC810 -> [ "pre-ghc90", "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810" ] + GHC90 -> [ "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90"] - -- GHC810 -> ["ghc810"] - -- GHC810 -> ["ghc810-copied"] + -- GHC90 -> ["ghc90-copied"] + -- GHC90 -> ["ghc90"] -- --------------------------------------------------------------------- @@ -202,22 +205,55 @@ tt' :: IO (Counts,Int) tt' = runTestText (putTextToHandle stdout True) $ TestList [ - -- mkParserTest "ghc80" "C.hs" - -- mkParserTest "ghc80" "T10267.hs" - -- , mkParserTest "ghc80" "T10946.hs" - -- mkParserTest "ghc82" "T13050.hs" - -- mkParserTest "ghc84" "arrowfail003.hs" - -- mkParserTest "ghc810" "T17296.hs" + -- mkTestModChange changeRenameCase1 "RenameCase1.hs" - mkPrettyRoundtrip "ghc810" "T16326_Compile1.hs" - -- mkPrettyRoundtrip "ghc810" "saks029.hs" + -- mkParserTest "ghc710" "Associated.hs" - -- mkPrettyRoundtrip "ghc86" "dynamic-paper.hs" + -- mkParserTest "ghc710" "BracesSemiDataDecl.hs" + -- mkParserTest "ghc710" "GADTRecords.hs" + -- mkParserTest "ghc710" "RdrNames.hs" + -- mkParserTest "ghc710" "RdrNames1.hs" - -- Needs GHC changes - -- mkParserTest "failing" "CtorOp.hs" - -- mkParserTest "failing" "InfixOperator.hs" + -- mkParserTest "ghc80" "T11010.hs" + -- mkParserTest "ghc80" "Test10399.hs" + -- mkParserTest "ghc90" "Linear12.hs" + -- mkParserTest "ghc90" "T17544_kw.hs" + -- mkParserTest "ghc90" "FromManual.hs" + -- mkPrettyRoundtrip "ghc90" "FromManual.hs" + + -- mkParserTest "ghc90" "Linear1Rule.hs" + -- mkPrettyRoundtrip "ghc90" "Linear1Rule.hs" + + -- mkParserTest "ghc80" "Test11018.hs" + -- mkPrettyRoundtrip "ghc80" "Test11018.hs" + + -- mkParserTest "ghc86" "UnicodeSyntax.hs" + -- mkPrettyRoundtrip "ghc86" "UnicodeSyntax.hs" + + mkParserTest "ghc86" "empty-foralls.hs" + -- mkPrettyRoundtrip "ghc86" "empty-foralls.hs" + + -- mkParserTest "ghc710" "PatSynBind.hs" + -- mkPrettyRoundtrip "ghc710" "PatSynBind.hs" + + -- --------------------------------------------- + + -- mkParserTest "ghc86" "Webhook.hs" + + -- mkParserTest "ghc710" "TypeBrackets2.hs" + -- mkPrettyRoundtrip "ghc710" "TypeBrackets2.hs" + + -- mkParserTest "ghc710" "DataDecl.hs" + -- mkPrettyRoundtrip "ghc710" "DataDecl.hs" + + -- mkParserTest "ghc90" "BaseDescriptor.hs" + -- mkPrettyRoundtrip "ghc90" "BaseDescriptor.hs" + + -- mkParserTest "ghc90" "BaseDescriptors2.hs" + -- mkPrettyRoundtrip "ghc90" "BaseDescriptors2.hs" + + -- Needs GHC changes ] diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs --- a/tests/Test/Common.hs +++ b/tests/Test/Common.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Common ( RoundtripReport (..) , Report @@ -35,6 +36,14 @@ import Language.Haskell.GHC.ExactPrint.Types +#if __GLASGOW_HASKELL__ >= 900 +import qualified Control.Monad.IO.Class as GHC +import qualified GHC as GHC hiding (parseModule) +import qualified GHC.Data.Bag as GHC +import qualified GHC.Driver.Session as GHC +import qualified GHC.Utils.Error as GHC +import qualified GHC.Utils.Outputable as GHC +#else import qualified ApiAnnotation as GHC import qualified DynFlags as GHC #if __GLASGOW_HASKELL__ > 808 @@ -43,6 +52,7 @@ #endif import qualified GHC as GHC hiding (parseModule) import qualified MonadUtils as GHC +#endif #if __GLASGOW_HASKELL__ <= 710 #else @@ -78,7 +88,7 @@ { debugTxt :: String , status :: ReportType , cppStatus :: Maybe String -- Result of CPP if invoked - , inconsistent :: Maybe [(GHC.SrcSpan, (GHC.AnnKeywordId, [GHC.SrcSpan]))] + , inconsistent :: Maybe [(AnnSpan, (GHC.AnnKeywordId, [AnnSpan]))] } data ParseFailure = ParseFailure String @@ -184,7 +194,11 @@ runRoundTrip :: Changer +#if __GLASGOW_HASKELL__ >= 900 + -> GHC.ApiAnns -> GHC.Located GHC.HsModule +#else -> GHC.ApiAnns -> GHC.Located (GHC.HsModule GhcPs) +#endif -> [Comment] -> IO (String, Anns, GHC.ParsedSource) runRoundTrip f !anns !parsedOrig cs = do @@ -233,3 +247,16 @@ showErrorMessages :: GHC.ErrorMessages -> String showErrorMessages m = show $ GHC.bagToList m #endif + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 900 +instance GHC.Outputable GHC.ApiAnns where + ppr (GHC.ApiAnns items eof comments rogueComments) + = GHC.text "ApiAnns" GHC.<+> GHC.ppr items + GHC.<+> GHC.ppr eof + GHC.<+> GHC.ppr comments + GHC.<+> GHC.ppr rogueComments +#endif + +-- --------------------------------------------------------------------- diff --git a/tests/Test/CommonUtils.hs b/tests/Test/CommonUtils.hs --- a/tests/Test/CommonUtils.hs +++ b/tests/Test/CommonUtils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Test.CommonUtils ( findSrcFiles @@ -24,7 +25,11 @@ import Data.List hiding (find) import System.FilePath import System.FilePath.Find +#if __GLASGOW_HASKELL__ >= 900 +import qualified GHC.Data.StringBuffer as GHC +#else import qualified StringBuffer as GHC +#endif -- --------------------------------------------------------------------- diff --git a/tests/Test/Consistency.hs b/tests/Test/Consistency.hs --- a/tests/Test/Consistency.hs +++ b/tests/Test/Consistency.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Test.Consistency where import Data.Data @@ -6,18 +7,23 @@ import qualified Data.Set as Set import Data.Generics (everything, mkQ) -import Language.Haskell.GHC.ExactPrint.Utils (isPointSrcSpan) +import Language.Haskell.GHC.ExactPrint.Types (AnnSpan) +import Language.Haskell.GHC.ExactPrint.Utils (isPointSrcSpan, rs) -- import Debug.Trace -checkConsistency :: Data a => GHC.ApiAnns -> a -> [(SrcSpan, (AnnKeywordId, [SrcSpan]))] +checkConsistency :: Data a => GHC.ApiAnns -> a -> [(AnnSpan, (AnnKeywordId, [AnnSpan]))] checkConsistency anns ast = - let srcspans = Set.fromList $ getAllSrcSpans ast + let srcspans = Set.fromList $ map rs $ getAllSrcSpans ast cons (s, (_, vs)) = Set.member s srcspans || (all (isPointSrcSpan) vs) in filter (\s -> not (cons s)) (getAnnSrcSpans anns) -getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(AnnKeywordId,[SrcSpan]))] +getAnnSrcSpans :: ApiAnns -> [(AnnSpan,(AnnKeywordId,[AnnSpan]))] +#if __GLASGOW_HASKELL__ >= 900 +getAnnSrcSpans anns = map (\((ss,k),v) -> (ss,(k,v))) $ Map.toList (GHC.apiAnnItems anns) +#else getAnnSrcSpans (anns,_) = map (\((ss,k),v) -> (ss,(k,v))) $ Map.toList anns +#endif getAllSrcSpans :: (Data t) => t -> [SrcSpan] getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast diff --git a/tests/Test/NoAnnotations.hs b/tests/Test/NoAnnotations.hs --- a/tests/Test/NoAnnotations.hs +++ b/tests/Test/NoAnnotations.hs @@ -16,42 +16,53 @@ import qualified Data.ByteString as B import Language.Haskell.GHC.ExactPrint --- import Language.Haskell.GHC.ExactPrint.Annotate import Language.Haskell.GHC.ExactPrint.Parsers --- import Language.Haskell.GHC.ExactPrint.Pretty import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils +#if __GLASGOW_HASKELL__ >= 900 +import qualified Control.Monad.IO.Class as GHC +import qualified GHC as GHC hiding (parseModule) +import qualified GHC.Data.Bag as GHC +import qualified GHC.Data.FastString as GHC +-- import qualified GHC.Data.StringBuffer as GHC +-- import qualified GHC.Driver.Phases as GHC +-- import qualified GHC.Driver.Pipeline as GHC +-- import qualified GHC.Driver.Session as GHC +-- import qualified GHC.Driver.Types as GHC +-- import qualified GHC.Fingerprint.Type as GHC +-- import qualified GHC.Utils.Fingerprint as GHC +-- import qualified GHC.Parser.Lexer as GHC +-- import qualified GHC.Settings as GHC +import qualified GHC.Types.SrcLoc as GHC +-- import qualified GHC.Utils.Error as GHC +import qualified GHC.Utils.Outputable as GHC +import qualified GHC.Types.Name.Occurrence as OccName (occNameString) +import qualified GHC.Types.Var as GHC +import qualified GHC.Types.Name.Set as GHC +#else import qualified ApiAnnotation as GHC import qualified Bag as GHC --- import qualified DynFlags as GHC import qualified FastString as GHC import qualified GHC as GHC hiding (parseModule) --- import qualified Lexer as GHC import qualified MonadUtils as GHC --- import qualified Name as GHC import qualified NameSet as GHC --- import qualified OccName as GHC import qualified Outputable as GHC --- import qualified Parser as GHC --- import qualified RdrName as GHC import qualified SrcLoc as GHC --- import qualified StringBuffer as GHC import qualified Var as GHC import qualified OccName(occNameString) +#endif --- import qualified Data.Generics as SYB --- import qualified GHC.SYB.Utils as SYB + import System.Directory import System.FilePath --- import System.FilePath.Posix --- import System.IO + +#if __GLASGOW_HASKELL__ < 900 import qualified Data.Map as Map --- import Data.List --- import Data.Maybe +#endif import Test.Common @@ -121,9 +132,13 @@ -> IO (ParseResult GHC.ParsedSource) runPrettyRoundTrip origFile !anns !parsedOrig _cs = do let !newAnns = addAnnotationsForPretty [] parsedOrig mempty +#if __GLASGOW_HASKELL__ >= 900 + let comments = map tokComment $ GHC.sortRealLocated (GHC.apiAnnRogueComments anns) +#else let comments = case Map.lookup GHC.noSrcSpan (snd anns) of Nothing -> [] Just cl -> map tokComment $ GHC.sortLocated cl +#endif let pragmas = filter (\(Comment c _ _) -> isPrefixOf "{-#" c ) comments let pragmaStr = intercalate "\n" $ map commentContents pragmas @@ -177,6 +192,9 @@ `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon `extQ` overLit `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet +#if __GLASGOW_HASKELL__ >= 900 + `extQ` layoutInfo +#endif `extQ` fixity `ext2Q` located where generic :: Data a => a -> String @@ -218,6 +236,10 @@ #endif fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String + +#if __GLASGOW_HASKELL__ >= 900 + layoutInfo = const "{LayoutInfo: blanked }" :: GHC.LayoutInfo -> String +#endif located :: (Data b,Data loc) => GHC.GenLocated loc b -> String located (GHC.L ss a) = diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -7,21 +7,30 @@ import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Parsers +import Language.Haskell.GHC.ExactPrint.Utils +#if __GLASGOW_HASKELL__ >= 900 +import qualified GHC as GHC +import qualified GHC.Data.Bag as GHC +import qualified GHC.Data.FastString as GHC +import qualified GHC.Types.Name.Occurrence as GHC +import qualified GHC.Types.Name.Reader as GHC +import qualified GHC.Types.SrcLoc as GHC +#else import qualified Bag as GHC import qualified GHC as GHC import qualified OccName as GHC import qualified RdrName as GHC import qualified SrcLoc as GHC import qualified FastString as GHC +#endif import qualified Data.Generics as SYB --- import qualified GHC.SYB.Utils as SYB import System.FilePath import qualified Data.Map as Map -- import Data.List -import Data.Maybe +-- import Data.Maybe import Test.Common @@ -123,7 +132,7 @@ #endif newSpan <- uniqueSrcSpanT let - newAnnKey = AnnKey newSpan (CN "HsValBinds") + newAnnKey = AnnKey (rs newSpan) (CN "HsValBinds") addWhere mkds = case Map.lookup (mkAnnKey m) mkds of Nothing -> error "wtf" @@ -131,7 +140,7 @@ where ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))] , annCapturedSpan = Just newAnnKey - , annSortKey = Just [ls, ld] + , annSortKey = Just [rs ls, rs ld] } mkds2 = Map.insert (mkAnnKey m) ann1 mkds ann2 = annNone @@ -251,19 +260,28 @@ (p',(ans',_),_) = runTransform ans doTransform doTransform = doRmDecl p - doRmDecl (GHC.L l (GHC.HsModule mmn mexp imps decls mdepr haddock)) = do +#if __GLASGOW_HASKELL__ >= 900 + doRmDecl (GHC.L l (GHC.HsModule lo mmn mexp imps decls mdepr haddock)) = do +#else + doRmDecl (GHC.L l (GHC.HsModule mmn mexp imps decls mdepr haddock)) = do +#endif let -- declIndex = 2 -- zero based decls1 = take declIndex decls decls2 = drop (declIndex + 1) decls decls' = decls1 ++ decls2 - return (GHC.L l (GHC.HsModule mmn mexp imps decls' mdepr haddock)) +#if __GLASGOW_HASKELL__ >= 900 + return (GHC.L l (GHC.HsModule lo mmn mexp imps decls' mdepr haddock)) +#else + return (GHC.L l (GHC.HsModule mmn mexp imps decls' mdepr haddock)) +#endif -- error $ "doRmDecl:decls2=" ++ showGhc (length decls,decls1,decls2) -- --------------------------------------------------------------------- changeRenameCase1 :: Changer changeRenameCase1 ans parsed = return (ans,rename "bazLonger" [((3,15),(3,18))] parsed) +-- changeRenameCase1 ans parsed = return (ans,rename "bazLonger" [((3,15),(3,17))] parsed) changeRenameCase2 :: Changer changeRenameCase2 ans parsed = return (ans,rename "fooLonger" [((3,1),(3,4))] parsed) @@ -307,12 +325,7 @@ newName = GHC.mkRdrUnqual (GHC.mkVarOcc newNameStr) cond :: GHC.SrcSpan -> Bool - cond ln = ln `elem` srcSpans - where - srcSpans = map (\(start, end) -> GHC.mkSrcSpan (f start) (f end)) spans - fname = fromMaybe (GHC.mkFastString "f") (GHC.srcSpanFileName_maybe ln) - f = uncurry (GHC.mkSrcLoc fname) - + cond ln = ss2range ln `elem` spans replaceRdr :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName replaceRdr (GHC.L ln _) @@ -332,7 +345,7 @@ -#if __GLASGOW_HASKELL__ > 806 +#if (__GLASGOW_HASKELL__ > 806) && (__GLASGOW_HASKELL__ < 900) replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs replacePat (GHC.dL->GHC.L ln (GHC.VarPat {})) | cond ln = GHC.cL ln (GHC.VarPat noExt (GHC.cL ln newName)) @@ -378,11 +391,7 @@ where replace :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName replace (GHC.L ln _n) - | ln == (g (12,16) (12,17)) = GHC.L ln (GHC.mkRdrUnqual (GHC.mkVarOcc "p_2")) - where - g start end = GHC.mkSrcSpan (f start) (f end) - fname = fromMaybe (GHC.mkFastString "f") (GHC.srcSpanFileName_maybe ln) - f = uncurry (GHC.mkSrcLoc fname) + | ss2range ln == ((12,16),(12,17)) = GHC.L ln (GHC.mkRdrUnqual (GHC.mkVarOcc "p_2")) replace x = x -- --------------------------------------------------------------------- @@ -563,7 +572,9 @@ [d1,d2] <- hsDecls lp balanceComments d1 d2 -#if __GLASGOW_HASKELL__ > 808 +#if __GLASGOW_HASKELL__ >= 900 + let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _)) = d1 +#elif __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 diff --git a/tests/examples/failing/T17544_kw.hs b/tests/examples/failing/T17544_kw.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/T17544_kw.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS -haddock -ddump-parsed-ast #-} + +-- Haddock comments in this test case should all be rejected, but they are not. +-- +-- This is a known issue. Users should avoid writing comments in such +-- positions, as a future fix will disallow them. +-- +-- See Note [Register keyword location] in GHC.Parser.PostProcess.Haddock + +module + -- | Bad comment for the module + T17544_kw where + +data Foo -- | Bad comment for MkFoo + where MkFoo :: Foo + +newtype Bar -- | Bad comment for MkBar + where MkBar :: () -> Bar + +class Cls a + -- | Bad comment for clsmethod + where + clsmethod :: a + diff --git a/tests/examples/ghc710/Control.hs b/tests/examples/ghc710/Control.hs --- a/tests/examples/ghc710/Control.hs +++ b/tests/examples/ghc710/Control.hs @@ -53,7 +53,7 @@ #endif data ControlMessage = CMsgWakeup - | CMsgDie + | CMsgDie !Foo | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) {-# UNPACK #-} !Signal deriving (Eq, Show) diff --git a/tests/examples/ghc80/GADTContext.hs b/tests/examples/ghc80/GADTContext.hs deleted file mode 100644 --- a/tests/examples/ghc80/GADTContext.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - -data StackItem a where - Snum :: forall a. Fractional a => a -> StackItem a - Sop :: OpDesc -> StackItem a -deriving instance Show a => Show (StackItem a) - -type MPI = ?mpi_secret :: MPISecret - -mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) - -data MaybeDefault v where - SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v - SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v - -> a -> MaybeDefault [a]) - TestParens :: (forall v . (Eq v) => MaybeDefault v) - TestParens2 :: (forall v . ((Eq v)) => MaybeDefault v) - TestParens3 :: (forall v . (((Eq v)) => (MaybeDefault v))) - TestParens4 :: (forall v . (((Eq v)) => (MaybeDefault v -> MaybeDefault v))) - -data T a where - K1 :: forall a. Ord a => { x :: [a], y :: Int } -> T a - K2 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> T a - K3 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> (T a) - K4 :: (forall a. Ord a => { x :: [a], y :: Int } -> T a) - -[t| Map.Map T.Text $tc |] - -bar $( [p| x |] ) = x diff --git a/tests/examples/ghc80/T11010.hs b/tests/examples/ghc80/T11010.hs --- a/tests/examples/ghc80/T11010.hs +++ b/tests/examples/ghc80/T11010.hs @@ -1,9 +1,13 @@ {-# LANGUAGE PatternSynonyms, ExistentialQuantification, GADTSyntax #-} +{-# LANGUAGE TypeFamilies #-} module T11010 where data Expr a where Fun :: String -> (a -> b) -> (Expr a -> Expr b) + +ggFun :: String -> (a -> b) -> (Expr a -> Expr b) +ggFun = undefined pattern IntFun :: (a ~ Int) => String -> (a -> b) -> (Expr a -> Expr b) pattern IntFun str f x = Fun str f x diff --git a/tests/examples/ghc80/Test10399.hs b/tests/examples/ghc80/Test10399.hs deleted file mode 100644 --- a/tests/examples/ghc80/Test10399.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} -module Test10399 where - -type MPI = ?mpi_secret :: MPISecret - -mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) - -data MaybeDefault v where - SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v - SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v - -> a -> MaybeDefault [a]) - -[t| Map.Map T.Text $tc |] - -bar $( [p| x |] ) = x diff --git a/tests/examples/ghc86/empty-foralls.hs b/tests/examples/ghc86/empty-foralls.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc86/empty-foralls.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +-- Empty foralls are handled correctly in different situations. + +data D = forall. D Int + +data G where + G :: forall. Int -> G diff --git a/tests/examples/ghc88/Issue91.hs b/tests/examples/ghc88/Issue91.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc88/Issue91.hs @@ -0,0 +1,8 @@ +module Issue91 where + +-- Based on https://github.com/alanz/ghc-exactprint/issues/91 + +foo = case hi of + _ -> hi + _ -> hi + _ -> hi diff --git a/tests/examples/ghc88/empty-foralls2.hs b/tests/examples/ghc88/empty-foralls2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc88/empty-foralls2.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +-- Empty foralls are handled correctly in different situations. + +data D = forall. D Int + +data G where + G :: forall. Int -> G + +f :: forall. a -> a +f x = x + +type family T x where + forall. T x = x + +{-# RULES + "r" + forall. r a = () +#-} diff --git a/tests/examples/ghc90/Arity2.hs b/tests/examples/ghc90/Arity2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Arity2.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Arity2 where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint +-} + +--import GHC.Base + +data Id a = Id a + +(<$>) :: (a -> b) -> Id a -> Id b +(<$>) f (Id a) = Id (f a) + +(<*>) :: Id (a -> b) -> Id a -> Id b +(<*>) (Id a) (Id b) = Id (a b) + +data Q = Q () () +data S = S () + +-- Q only gets eta-expand once and then trapped +foo = Q <$> Id () <*> Id () + +-- This compiles fine +foo2 = S <$> Id () + +{- +[1 of 1] Compiling Arity2 ( linear-tests/Arity2.hs, linear-tests/Arity2.o ) + +linear-tests/Arity2.hs:21:7: error: + • Couldn't match type ‘() ⊸ Q’ with ‘() -> b’ + Expected type: Id (() -> b) + Actual type: Id (() ⊸ Q) + • In the first argument of ‘(<*>)’, namely ‘Q <$> Id ()’ + In the expression: Q <$> Id () <*> Id () + In an equation for ‘foo’: foo = Q <$> Id () <*> Id () + • Relevant bindings include + foo :: Id b (bound at linear-tests/Arity2.hs:21:1) + | +21 | foo = Q <$> Id () <*> Id () + | ^^^^^^^^^^^ +-} diff --git a/tests/examples/ghc90/ArrowLambdaCase.hs b/tests/examples/ghc90/ArrowLambdaCase.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/ArrowLambdaCase.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE Arrows, LambdaCase #-} +module Main (main) where + +import Control.Arrow + +main :: IO () +main = do + putStrLn $ foo (Just 42) + putStrLn $ foo (Just 500) + putStrLn $ foo Nothing + +foo :: ArrowChoice p => p (Maybe Int) String +foo = proc x -> + (| id (\case + Just x | x > 100 -> returnA -< "big " ++ show x + | otherwise -> returnA -< "small " ++ show x + Nothing -> returnA -< "none") + |) x + diff --git a/tests/examples/ghc90/BaseDescriptor.hs b/tests/examples/ghc90/BaseDescriptor.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/BaseDescriptor.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.ByteString.Mp4.Boxes.BaseDescriptor where + +import Data.ByteString.IsoBaseFileFormat.ReExports +import Data.ByteString.Mp4.Boxes.Expandable + +-- * Static base constructor + +-- | Abstract class of /descriptors/ as recognized by ISO/IEC 14496-1 (Systems). +-- A specifc descriptor is identified by the 'ClassTag'. +data Descriptor :: ClassTag n -> Type where + MkDescriptor ::BitRecord -> Descriptor tag + +-- TODO ok... this fixed the current problem in DecoderSpecificInfo .. but remove this instances ... or the above ... or ... I dunno + +data BitRecordOfDescriptor :: Extends (Descriptor c -> BitRecord) + +type instance + Apply BitRecordOfDescriptor ('MkDescriptor body :: Descriptor (tag :: ClassTag tagInd)) = + FieldU8 := tagInd + .+: From (StaticExpandableContent body) + +type family GetClassTag (c :: ClassTag n) :: Nat where + GetClassTag (c :: ClassTag n) = n + +-- | Base Descriptor Class Tags TODO rename to xxxTag +data ClassTag (tag :: Nat) where + ObjectDescr ::ClassTag 0x01 + InitialObjectDescr ::ClassTag 0x02 + ES_Descr ::ClassTag 0x03 + DecoderConfigDescr ::ClassTag 0x04 + DecSpecificInfo ::ClassTag 0x05 + SLConfigDescr ::ClassTag 0x06 + ContentIdentDescr ::ClassTag 0x07 + SupplContentIdentDescr ::ClassTag 0x08 + IPI_DescrPointer ::ClassTag 0x09 + IPMP_DescrPointer ::ClassTag 0x0A + IPMP_Descr ::ClassTag 0x0B + QoS_Descr ::ClassTag 0x0C + RegistrationDescr ::ClassTag 0x0D + ES_ID_Ref ::ClassTag 0x0F + MP4_IOD_ ::ClassTag 0x10 + MP4_OD_ ::ClassTag 0x11 + IPL_DescrPointerRef ::ClassTag 0x12 + ExtensionProfileLevelDescr ::ClassTag 0x13 + ProfileLevelIndicationIndexDescr ::ClassTag 0x14 + ContentClassificationDescr ::ClassTag 0x40 + KeyWordDescr ::ClassTag 0x41 + RatingDescr ::ClassTag 0x42 + LanguageDescr ::ClassTag 0x43 + ShortTextualDescr ::ClassTag 0x44 + ExpandedTextualDescr ::ClassTag 0x45 + ContentCreatorNameDescr ::ClassTag 0x46 + ContentCreationDateDescr ::ClassTag 0x47 + OCICreatorNameDescr ::ClassTag 0x48 + OCICreationDateDescr ::ClassTag 0x49 + SmpteCameraPositionDescr ::ClassTag 0x4A + SegmentDescr ::ClassTag 0x4B + MediaTimeDescr ::ClassTag 0x4C + IPMP_ToolsListDescr ::ClassTag 0x60 + IPMP_Tool ::ClassTag 0x61 + M4MuxTimingDescr ::ClassTag 0x62 + M4MuxCodeTableDescr ::ClassTag 0x63 + ExtSLConfigDescr ::ClassTag 0x64 + M4MuxBufferSizeDescr ::ClassTag 0x65 + M4MuxIdentDescr ::ClassTag 0x66 + DependencyPointer ::ClassTag 0x67 + DependencyMarker ::ClassTag 0x68 + M4MuxChannelDescr ::ClassTag 0x69 + ExtDescrTag :: (forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n) + OCIDescrTag :: (forall (n :: Nat) . (0x40 <= n, n <= 0x5F) => ClassTag n) diff --git a/tests/examples/ghc90/BaseDescriptor2.hs b/tests/examples/ghc90/BaseDescriptor2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/BaseDescriptor2.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +module BaseDescriptors2 where + +data ClassTag (tag :: Nat) where + ExtDescrTag :: (forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n) + +data ClassTag2 (tag :: Nat) where + ExtDescrTag2 :: forall (n :: Nat) . (0x6A <= n, n <= 0xFE) => ClassTag n diff --git a/tests/examples/ghc90/Branches.hs b/tests/examples/ghc90/Branches.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Branches.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +module GuardTup where + +data Q = Q () + +mkQ :: () -> Q +mkQ = Q + +foo smart + | smart = mkQ + | otherwise = Q + +fooIf smart = if smart then mkQ else Q diff --git a/tests/examples/ghc90/CSETest.hs b/tests/examples/ghc90/CSETest.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/CSETest.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UnicodeSyntax #-} +{- This test makes sure that if two expressions with conflicting types are + CSEd then appropiate things happen. -} +module CSETest where + +minimal :: a ⊸ a +minimal x = x + +maximal :: a -> a +maximal x = x + diff --git a/tests/examples/ghc90/Dollar2.hs b/tests/examples/ghc90/Dollar2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Dollar2.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Dollar2 where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint +-} + + +import GHC.Base + +data AB = A () | B () + +qux :: Bool +qux = True +{-# NOINLINE qux #-} + +foo = id $ ((if qux then A else B) $ ()) + +{- + +-} diff --git a/tests/examples/ghc90/DollarDefault.hs b/tests/examples/ghc90/DollarDefault.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/DollarDefault.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} +module DollarDefault where + +class C p where + cid :: p a a -> p a a + +instance C (->) where + cid = id + +foo = (cid $ id) $ () diff --git a/tests/examples/ghc90/DollarTest.hs b/tests/examples/ghc90/DollarTest.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/DollarTest.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UnicodeSyntax #-} +module Dollar where +{- +Check $ interacting with multiplicity polymorphism. +This caused Core Lint error previously. +-} + +import GHC.Base + +data Q a = Q a + +data QU = QU () + +test = QU $ () + +qux = Q $ () diff --git a/tests/examples/ghc90/ExplicitSpecificity4.hs b/tests/examples/ghc90/ExplicitSpecificity4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/ExplicitSpecificity4.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module ExplicitSpecificity4 where + +class C a where + f :: forall {z}. z -> a -> a + default f :: forall {z}. z -> a -> a + f _ x = x + + g :: forall z. z -> a -> a + g _ x = x diff --git a/tests/examples/ghc90/ExplicitSpecificityA1.hs b/tests/examples/ghc90/ExplicitSpecificityA1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/ExplicitSpecificityA1.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE RankNTypes + , PolyKinds + , GADTs + , TypeApplications + , PatternSynonyms + , ExistentialQuantification + , StandaloneKindSignatures + , DataKinds + , ExistentialQuantification +#-} + +module ExplicitSpecificityA1 where + +import Data.Proxy +import Data.Kind + +-- Type variables bound in RULES +{-# RULES "parametricity" forall (f :: forall {a}. a -> a). map f = id #-} + +-- Type signatures +foo1 :: a -> a +foo1 x = x + +foo2 :: forall a. a -> a +foo2 x = x + +foo3 :: forall {a}. a -> a +foo3 x = x + +foo4 :: forall a {b}. a -> b -> b +foo4 _ x = x + +foo5 :: forall {a} b. a -> b -> b +foo5 _ x = x + +bar1 :: () +bar1 = let { x1 = foo1 42 + ; x2 = foo2 @Int 42 + ; x3 = foo3 42 + ; x4 = foo4 @Bool True 42 + ; x5 = foo5 @Int True 42 + } + in () + +-- Data declarations +data T1 a = C1 a + +data T2 (a :: k) = C2 { f2 :: Proxy a } + +data T3 a where C3 :: forall k (a::k). Proxy a -> T3 a + +data T4 a where C4 :: forall {k} (a::k). Proxy a -> T4 a + +data T5 k (a :: k) where C5 :: forall k (a::k). Proxy a -> T5 k a + +data T6 k a where C6 :: forall {k} (a::k). Proxy a -> T6 k a + +bar2 :: () +bar2 = let { x1 = C1 @Int 42 + ; x2 = C2 @Type @Int Proxy + ; x3 = C3 @Type @Int Proxy + ; x4 = C4 @Int Proxy + ; x5 = C5 @Type @Int Proxy + ; x6 = C6 @Int Proxy + } + in () + +-- Pattern synonyms +data T7 a where C7 :: forall a b. a -> b -> T7 a + +data T8 a where C8 :: forall a {b}. a -> b -> T8 a + +pattern Pat1 :: forall a. () => forall b. a -> b -> T7 a +pattern Pat1 x y = C7 x y + +pattern Pat2 :: forall {a}. () => forall b. a -> b -> T7 a +pattern Pat2 x y = C7 x y + +pattern Pat3 :: forall a. () => forall b. a -> b -> T8 a +pattern Pat3 x y = C8 x y + +pattern Pat4 :: forall {a}. () => forall b. a -> b -> T8 a +pattern Pat4 x y = C8 x y + +pattern Pat5 :: forall {a}. () => forall {b}. a -> b -> T7 a +pattern Pat5 x y = C7 x y + +bar3 :: (T7 a) -> () +bar3 (Pat1 x y) = () +bar3 (Pat2 x y) = () + +bar4 :: (T8 a) -> () +bar4 (Pat3 x y) = () +bar4 (Pat4 x y) = () + +-- Existential variable quantification +data HList = HNil + | forall {a}. HCons a HList + +-- Type synonyms +type TySy = forall a {b}. Either a b + +-- Standalone kind signatures +type Foo :: forall a {b}. a -> b -> b +type Foo x y = y + +type Bar = Foo @Bool True 42 + diff --git a/tests/examples/ghc90/FromManual.hs b/tests/examples/ghc90/FromManual.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/FromManual.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UnicodeSyntax #-} + +module FromManual where + +data T1 a = MkT1 a + +construct :: a %1 -> MkT1 a +construct x = MkT1 x + +deconstruct :: MkT1 a %1 -> a +deconstruct (MkT1 x) = x -- must consume `x` exactly once + +data T2 a b c where + MkT2 :: a -> b %1 -> c %1 -> T2 a b -- Note unrestricted arrow in the first argument + +data T3 a b c where + MkT3 :: a -> b ⊸ c ⊸ T2 a b -- Note unrestricted arrow in the first argument + +g :: A %1 -> (A, B) +h :: A %1 -> B %1 -> C + +f :: A %1 -> C +f x = f' (g x) + where + f' :: (A, B) %1 -> C + f' (y, z) = h y z diff --git a/tests/examples/ghc90/Linear.hs b/tests/examples/ghc90/Linear.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Linear.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LinearTypes #-} +module Monad.Linear where + +import Prelude(Int, (+)) + +data T where T :: Int -> T +data TM a = TM a + +class Monad m where + return :: a #-> m a + (>>=) :: m a #-> (a #-> m b) #-> m b + +(>>) :: Monad m => m () #-> m b #-> m b +m1 >> m2 = m1 >>= \() -> m2 + +instance Monad TM where + return = TM + TM a >>= f = f a + +data Unrestricted a where + Unrestricted :: a -> Unrestricted a + +runTM :: TM (Unrestricted a) -> a +runTM (TM (Unrestricted a)) = a + +newT :: TM T +newT = return (T 0) + +increaseT :: T #-> TM T +increaseT (T i) = return (T (i+1)) + +extractT :: T #-> TM (T, Unrestricted Int) +extractT (T i) = return (T i, Unrestricted i) + +deleteT :: T #-> TM () +deleteT (T _) = return () + diff --git a/tests/examples/ghc90/Linear10.hs b/tests/examples/ghc90/Linear10.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Linear10.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE GADTs #-} +module Linear10 where + +data Unrestricted a where Unrestricted :: a -> Unrestricted a + +unrestrictedDup :: Unrestricted a ⊸ (a, a) +unrestrictedDup (Unrestricted a) = (a,a) + diff --git a/tests/examples/ghc90/Linear12.hs b/tests/examples/ghc90/Linear12.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Linear12.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE GADTs #-} +module Linear12 where + +type N a = a ⊸ () + +consume :: a ⊸ N a ⊸ () +consume x k = k x + +data N' a where N :: N a ⊸ N' a + +data M' a where M :: M a -> M' a + +consume' :: a ⊸ N' a ⊸ () +consume' x (N k) = k x + +data W = W (W ⊸ ()) + +wPlusTwo :: W ⊸ W +wPlusTwo n = W (\(W k) -> k n) + +data Nat = S Nat + +natPlusOne :: Nat ⊸ Nat +natPlusOne n = S n + +data D = D () + +mkD :: () ⊸ D +mkD x = D x + +data Odd = E Even +data Even = O Odd + +evenPlusOne :: Even ⊸ Odd +evenPlusOne e = E e + diff --git a/tests/examples/ghc90/Linear14.hs b/tests/examples/ghc90/Linear14.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Linear14.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear14 where + +-- Inference-related behaviour. Slightly sub-optimal still. + +bind1 :: (d ⊸ (a ⊸ b) ⊸ c) ⊸ d ⊸ (a⊸b) ⊸ c +bind1 b x f = b x (\a -> f a) + +newtype I a = I a + +bind2 :: (d ⊸ (a ⊸ b) ⊸ c) ⊸ d ⊸ (I a⊸b) ⊸ c +bind2 b x f = b x (\a -> f (I a)) + +bind3 :: (d ⊸ I (a ⊸ b) ⊸ c) ⊸ d ⊸ (a⊸b) ⊸ c +bind3 b x f = b x (I (\a -> f a)) + +bind4 :: (d ⊸ I ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c +bind4 b x f = b x (I (\g -> f g)) + +bind5 :: (d ⊸ ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c +bind5 b x f = b x (\g -> f (\a -> g a)) + +bind6 :: (d ⊸ I ((a ⊸ a') ⊸ b) ⊸ c) ⊸ d ⊸ ((a⊸a')⊸b) ⊸ c +bind6 b x f = b x (I (\g -> f (\a -> g a))) + diff --git a/tests/examples/ghc90/Linear15.hs b/tests/examples/ghc90/Linear15.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Linear15.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear15 where + +correctWhere :: Int ⊸ Int +correctWhere a = g a + where + f :: Int ⊸ Int + f x = x + + g :: Int ⊸ Int + g x = f x + diff --git a/tests/examples/ghc90/Linear16.hs b/tests/examples/ghc90/Linear16.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Linear16.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE RebindableSyntax #-} +module Linear16 where + +-- Rebindable do notation + +(>>=) :: a ⊸ (a ⊸ b) ⊸ b +(>>=) x f = f x + +-- `fail` is needed due to pattern matching on (); +-- ideally, it shouldn't be there. +fail :: a +fail = fail + +correctDo = do + x <- () + (y,z) <- ((),x) + () <- y + () <- z + () + diff --git a/tests/examples/ghc90/Linear1Rule.hs b/tests/examples/ghc90/Linear1Rule.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Linear1Rule.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +module Linear1Rule where + +-- Test the 1 <= p rule +f :: a %1 -> b +f = f + +-- f1 :: a %001 -> b +-- f1 = f1 + +g :: a %p -> b +g x = f x + diff --git a/tests/examples/ghc90/Linear3.hs b/tests/examples/ghc90/Linear3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Linear3.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear3 where + +correctApp1 :: (a⊸b) ⊸ a ⊸ b +correctApp1 f a = f a + +correctApp2 :: (a⊸a) -> a ⊸ a +correctApp2 f a = f (f a) + +correctApp3 :: Int ⊸ Int +correctApp3 x = f x + where + f :: Int ⊸ Int + f y = y + +correctApp4 :: Int ⊸ Int +correctApp4 x = f (f x) + where + f :: Int ⊸ Int + f y = y + +correctIf :: Bool ⊸ a ⊸ a +correctIf x n = + if x then n else n + diff --git a/tests/examples/ghc90/Linear4.hs b/tests/examples/ghc90/Linear4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Linear4.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LambdaCase, GADTs #-} +module Linear4 where + +correctCase :: Bool ⊸ a ⊸ a +correctCase x n = + case x of + True -> n + False -> n + diff --git a/tests/examples/ghc90/Linear6.hs b/tests/examples/ghc90/Linear6.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Linear6.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module Linear6 where + +correctEqn :: Bool ⊸ Int ⊸ Int +correctEqn True n = n +correctEqn False n = n + diff --git a/tests/examples/ghc90/Linear8.hs b/tests/examples/ghc90/Linear8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Linear8.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE LambdaCase #-} +module Linear8 where + +correctLCase :: Int ⊸ Bool -> Int +correctLCase n = \case + True -> n + False -> n + diff --git a/tests/examples/ghc90/LinearConstructors.hs b/tests/examples/ghc90/LinearConstructors.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/LinearConstructors.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE TupleSections #-} +module LinearConstructors where + +data T a b = MkT a b + +f1 :: a %1 -> b %1 -> T a b +f1 = MkT + +f2 :: a %1 -> b -> T a b +f2 = MkT + +f3 :: a -> b %1 -> T a b +f3 = MkT + +f4 :: a -> b -> T a b +f4 = MkT + +-- tuple sections +g1 :: a %1 -> b %1 -> (a, b, Int) +g1 = (,,0) + +g2 :: a %1 -> b -> (a, b, Int) +g2 = (,,0) + +g3 :: a -> b %1 -> (a, b, Int) +g3 = (,,0) + +g4 :: a -> b -> (a, b, Int) +g4 = (,,0) + diff --git a/tests/examples/ghc90/LinearEmptyCase.hs b/tests/examples/ghc90/LinearEmptyCase.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/LinearEmptyCase.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE EmptyCase, LinearTypes #-} + +module LinearEmptyCase where + +data Void + +f :: a %1 -> Void -> b +f x y = case y of {} + diff --git a/tests/examples/ghc90/LinearGuards.hs b/tests/examples/ghc90/LinearGuards.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/LinearGuards.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE LinearTypes #-} +module LinearGuards where + +f :: Bool -> a %1 -> a +f b a | b = a + | True = a + diff --git a/tests/examples/ghc90/LinearTH1.hs b/tests/examples/ghc90/LinearTH1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/LinearTH1.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LinearTypes, TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module LinearTH1 where + +x1 = [t|Int -> Int|] diff --git a/tests/examples/ghc90/LinearTH2.hs b/tests/examples/ghc90/LinearTH2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/LinearTH2.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE LinearTypes, TemplateHaskell, RankNTypes, NoMonomorphismRestriction #-} +module LinearTH2 where + +x1 = [t|forall p. Int %p -> Int|] diff --git a/tests/examples/ghc90/LinearTypeable.hs b/tests/examples/ghc90/LinearTypeable.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/LinearTypeable.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LinearTypes, TypeOperators #-} +module Main (main) where + +import Data.Typeable +import Data.Maybe + +x :: Maybe ((Int -> Int) :~: (Int #-> Int)) +x = eqT + +main = print (isJust x) + diff --git a/tests/examples/ghc90/Memoize.hs b/tests/examples/ghc90/Memoize.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Memoize.hs @@ -0,0 +1,23 @@ +module Feldspar.Memoize where + +import qualified Prelude + +import Feldspar + +-- | Accelerate the function @f@ using a lookup table. +-- The table will span all possible input values. +tabulate :: (Bits i, Integral i, Syntax a) + => (Data i -> a) -> Data i -> a +tabulate f i = tabulateLen (2 ^ bitSize i) f i + +-- | Accelerate the function @f@ by creating a lookup table of the results for the +-- @len@ first argument values +-- +-- Note. To really get a table the function must be closed after the +-- application to @i@ +-- +tabulateLen :: (Integral i, Syntax a) + => Data Length -> (Data i -> a) -> Data i -> a +-- tabulateLen len f i = sugar $ share (parallel len (desugar.f.i2n)) (!i2n i) +tabulateLen len f i = sugar $ share (parallel len (desugar.f.i2n)) (! i2n i) + diff --git a/tests/examples/ghc90/MultConstructor.hs b/tests/examples/ghc90/MultConstructor.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/MultConstructor.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE GADTSyntax, DataKinds, LinearTypes, KindSignatures, ExplicitForAll #-} +module MultConstructor where + +import GHC.Types + +data T p a where + MkT :: a %p -> T p a + +{- +this currently fails +g :: forall (b :: Type). T 'Many b %1 -> (b,b) +g (MkT x) = (x,x) +-} diff --git a/tests/examples/ghc90/OldList.hs b/tests/examples/ghc90/OldList.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/OldList.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude, ScopedTypeVariables, BangPatterns, RankNTypes #-} + +{- +This is a simplified version of Data.OldList module from base. +This caused an assertion failure in earlier version of linear +types implementation. +-} + +module Data.OldList where + +import GHC.Base + +sortBy :: forall a . (a -> a -> Ordering) -> [a] +sortBy cmp = [] + where + sequences (a:b:xs) + | a `cmp` b == GT = descending b [a] xs + | otherwise = ascending b (a:) xs + sequences xs = [xs] + +-- descending :: a -> [a] -> [a] -> [[a]] + descending a as (b:bs) + | a `cmp` b == GT = descending b (a:as) bs + descending a as bs = (a:as): sequences bs + + ascending :: a -> (forall i . [a] %i -> [a]) -> [a] -> [[a]] + ascending a as (b:bs) + | a `cmp` b /= GT = ascending b foo bs + where + foo :: [a] %k -> [a] + foo ys = as (a:ys) + ascending a as bs = let !x = as [a] + in x : sequences bs diff --git a/tests/examples/ghc90/Op.hs b/tests/examples/ghc90/Op.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Op.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Op where +{- +See Control.Arrow and Data.Functor.Contravariant +-} + +import GHC.Base + +class Or p where + or :: p a b -> p a b -> p a b + +instance Or (->) where + or x _ = x + + +foo = or Just (\x -> Just x) + +{- +This caused an error in the earlier version of linear types: + +linear-tests/Op.hs:18:16: error: + • Couldn't match expected type ‘a ⊸ Maybe a’ + with actual type ‘a0 -> Maybe a0’ + • The lambda expression ‘\ x -> Just x’ has one argument, + its type is ‘p0 a b0’, + it is specialized to ‘a ⊸ Maybe a’ + In the second argument of ‘or’, namely ‘(\ x -> Just x)’ + In the expression: or Just (\ x -> Just x) + • Relevant bindings include + foo :: a ⊸ Maybe a (bound at linear-tests/Op.hs:18:1) + | +18 | foo = or Just (\x -> Just x) + | ^^^^^^^^^^^^ +-} diff --git a/tests/examples/ghc90/ParserArrowLambdaCase.hs b/tests/examples/ghc90/ParserArrowLambdaCase.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/ParserArrowLambdaCase.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Arrows, LambdaCase #-} +module ParserArrowLambdaCase where + +import Control.Arrow + +foo :: () -> () +foo = proc () -> (| id (\case + () -> () >- returnA) |) () + diff --git a/tests/examples/ghc90/Pr110.hs b/tests/examples/ghc90/Pr110.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/Pr110.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LinearTypes #-} +module Pr110 where + +data Bloop = Bloop Bool + +g :: Bloop %1 -> Bool +g (Bloop x) = x + +h :: Bool %1 -> Bloop +h x = Bloop x + diff --git a/tests/examples/ghc90/T18023.hs b/tests/examples/ghc90/T18023.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/T18023.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +module T18023 where + +import Data.Kind +import Data.Proxy + +newtype N :: Type -> Type -> Type where + MkN :: forall b a. { unN :: Either a b } -> N a b + +toN :: Either Int Bool -> N Int Bool +toN = MkN @Bool @Int + +fromN :: N Int Bool -> Either Int Bool +fromN = unN @Bool @Int + +newtype P a = MkP { unP :: Proxy a } + +toPTrue :: Proxy True -> P True +toPTrue = MkP @True + +fromPTrue :: P True -> Proxy True +fromPTrue = unP @True + +newtype P2 a b = MkP2 { unP2 :: (Proxy a, Proxy b) } + +toP2True :: (Proxy True, Proxy True) -> P2 True True +toP2True = MkP2 @True @True + +fromP2True :: P2 True True -> (Proxy True, Proxy True) +fromP2True = unP2 @True @True + +type P3 :: forall {k}. k -> Type +newtype P3 a = MkP3 { unP3 :: Proxy a } + +toP3True :: Proxy True -> P3 True +toP3True = MkP3 @True + +fromP3True :: P3 True -> Proxy True +fromP3True = unP3 @True + diff --git a/tests/examples/ghc90/T18432.hs b/tests/examples/ghc90/T18432.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/T18432.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE QuantifiedConstraints #-} +module Bug where + +import Data.Proxy + +class C a where + m :: Proxy a + +f :: (forall {a}. C a) => Proxy Int +f = m + diff --git a/tests/examples/ghc90/T18522-dbg-ppr.hs b/tests/examples/ghc90/T18522-dbg-ppr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/T18522-dbg-ppr.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell, ExplicitForAll, PolyKinds #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import Language.Haskell.TH (runQ) +import GHC.Types.Basic +import GHC.ThToHs +import GHC.Driver.Session +import GHC.Core.TyCo.Ppr +import GHC.Utils.Outputable +import GHC.Tc.Module +import GHC.Tc.Utils.Zonk +import GHC.Utils.Error +import GHC.Driver.Types +import GHC +import qualified GHC.LanguageExtensions as LangExt + +import Data.Either (fromRight) +import Control.Monad.IO.Class (liftIO) +import System.Environment (getArgs) + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ do + initial_dflags <- getSessionDynFlags + setSessionDynFlags $ initial_dflags + `dopt_set` Opt_D_ppr_debug + `gopt_set` Opt_SuppressUniques + `gopt_set` Opt_SuppressModulePrefixes + `gopt_set` Opt_SuppressVarKinds + `xopt_set` LangExt.KindSignatures + `xopt_set` LangExt.PolyKinds + `xopt_set` LangExt.RankNTypes + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + liftIO $ do + th_t <- runQ [t| forall k {j}. + forall (a :: k) (b :: j) -> + () |] + let hs_t = fromRight (error "convertToHsType") $ + convertToHsType Generated noSrcSpan th_t + ((warnings, errors), mres) <- + tcRnType hsc_env SkolemiseFlexi True hs_t + case mres of + Nothing -> do + printBagOfErrors dflags warnings + printBagOfErrors dflags errors + Just (t, _) -> do + putStrLn $ showSDoc dflags (debugPprType t) + diff --git a/tests/examples/ghc90/TH_reifyLinear.hs b/tests/examples/ghc90/TH_reifyLinear.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/TH_reifyLinear.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE TemplateHaskell #-} +module TH_reifyLinear where + +import Language.Haskell.TH +import System.IO + +type T = Int #-> Int + +$( + do x <- reify ''T + runIO $ hPutStrLn stderr $ pprint x + return [] + ) + diff --git a/tests/examples/ghc90/TupSection.hs b/tests/examples/ghc90/TupSection.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/TupSection.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE TupleSections #-} +module TupSection where +{- +inplace/bin/ghc-stage1 -O2 -dcore-lint +-} + +myAp :: (a -> b) -> a -> b +myAp f x = f x + +foo = myAp (,()) () + +qux = ("go2",) $ () diff --git a/tests/examples/ghc90/anf.hs b/tests/examples/ghc90/anf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/anf.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE LinearTypes #-} +-- !! Data constructors with strict fields +-- This test should use -funbox-strict-fields + +module Main ( main ) where + +main = print (g (f t)) + +t = MkT 1 2 (3,4) (MkS 5 6) + +g (MkT x _ _ _) = x + +data T = MkT Int !Int !(Int,Int) !(S Int) + +data S a = MkS a a + + +{-# NOINLINE f #-} +f :: T -> T -- Takes apart the thing and puts it + -- back together differently +f (MkT x y (a,b) (MkS p q)) = MkT a b (p,q) (MkS x y) diff --git a/tests/examples/ghc90/qdocompile001.hs b/tests/examples/ghc90/qdocompile001.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/qdocompile001.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE QualifiedDo #-} + +import Prelude as P + +-- Test that the context of the do shows well in the renamer +-- output. +-- +-- The nested do in the renamer output must be qualified the +-- same as the outer P.do written in the source program. +-- +-- > ==================== Renamer ==================== +-- > Main.main +-- > = print +-- > $ P.do (x <- [1, 2] | +-- > y <- P.do y@1 <- [1, 2] -- qualified! +-- > [1, 2] +-- > y) +-- > return y +-- +main = + print $ P.do + x <- [1, 2] + y@1 <- [1, 2] + [1, 2] + P.return y + diff --git a/tests/examples/ghc90/qdocompile002.hs b/tests/examples/ghc90/qdocompile002.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/qdocompile002.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE QualifiedDo #-} + +import Prelude as P hiding (fail) + + +-- Tests that fail is not required with irrefutable patterns +main = + print $ P.do + x <- [1, 2] + (_, y) <- [(1, "a"), (2, "b")] + P.return (x, y) + diff --git a/tests/examples/ghc90/qdorun001.hs b/tests/examples/ghc90/qdorun001.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/qdorun001.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE QualifiedDo #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + putStrLn "The unqualified do still works." + print $ toList $ Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + Graded.return (x, y) + -- test Graded.fail + print $ toList $ Graded.do + 1 <- VCons 1 VNil + Graded.return 1 + diff --git a/tests/examples/ghc90/qdorun002.hs b/tests/examples/ghc90/qdorun002.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/qdorun002.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RecursiveDo #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + print $ take 6 $ concat $ toList $ Graded.do + rec + VCons (take 6 y) VNil + y <- VCons (1 : zipWith (+) y (0 : y)) VNil + Graded.return y + diff --git a/tests/examples/ghc90/qdorun003.hs b/tests/examples/ghc90/qdorun003.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/qdorun003.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE QualifiedDo #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + print $ toList $ Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + Graded.return (x, y) + -- Test Graded.join + print $ toList $ Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + VCons (y, x) VNil + diff --git a/tests/examples/ghc90/qdorun004.hs b/tests/examples/ghc90/qdorun004.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/qdorun004.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RecursiveDo #-} +import qualified Control.Monad.Fix as P +import Prelude (print, ($)) +import qualified Prelude as P + +return :: a -> [a] +return x = [x, x] + +-- Tests that QualifiedDo doesn't affect return +main = do + print $ P.do + x <- [1, 2] + return x + print $ P.mdo + x <- [1, 2] + return x + diff --git a/tests/examples/ghc90/qdorun005.hs b/tests/examples/ghc90/qdorun005.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/qdorun005.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RebindableSyntax #-} +import qualified Monad.Graded as Graded +import Vector +import Prelude (print, ($)) +import qualified Prelude as P + +xs >>= f = 'c' : P.concatMap f xs +(>>) = (P.>>) + +main = do + print $ toList $ Graded.do + x <- VCons 'a' (VCons 'b' VNil) + Graded.return x + print $ do + a <- ['a', 'b'] + P.return a + diff --git a/tests/examples/ghc90/qdorun006.hs b/tests/examples/ghc90/qdorun006.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/qdorun006.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TemplateHaskell #-} + +import qualified Monad.Graded as Graded +import Vector as Graded + + +main = do + print $ toList $([| Graded.do + x <- VCons 1 (VCons 2 VNil) + y <- VCons 1 (VCons 2 VNil) + Graded.return (x, y) |]) + print $ toList $([| Graded.mdo + z <- VCons (take 8 y) VNil + y <- VCons (1 : zipWith (+) y (0 : y)) VNil + Graded.return z |]) + diff --git a/tests/examples/ghc90/qdorun007.hs b/tests/examples/ghc90/qdorun007.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc90/qdorun007.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE QualifiedDo #-} +-- Tests that QualfiedDo works for a linear monad. + +import Monad.Linear as Linear + + +main = do + let r = runTM (Linear.do + t0 <- newT + t1 <- increaseT t0 + (t2, ur) <- extractT t1 + deleteT t2 + Linear.return ur) + print r + print r + diff --git a/tests/examples/pre-ghc90/GADTContext.hs b/tests/examples/pre-ghc90/GADTContext.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc90/GADTContext.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +data StackItem a where + Snum :: forall a. Fractional a => a -> StackItem a + Sop :: OpDesc -> StackItem a +deriving instance Show a => Show (StackItem a) + +type MPI = ?mpi_secret :: MPISecret + +mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) + +data MaybeDefault v where + SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v + SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v + -> a -> MaybeDefault [a]) + TestParens :: (forall v . (Eq v) => MaybeDefault v) + TestParens2 :: (forall v . ((Eq v)) => MaybeDefault v) + TestParens3 :: (forall v . (((Eq v)) => (MaybeDefault v))) + TestParens4 :: (forall v . (((Eq v)) => (MaybeDefault v -> MaybeDefault v))) + +data T a where + K1 :: forall a. Ord a => { x :: [a], y :: Int } -> T a + K2 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> T a + K3 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> (T a) + K4 :: (forall a. Ord a => { x :: [a], y :: Int } -> T a) + +[t| Map.Map T.Text $tc |] + +bar $( [p| x |] ) = x diff --git a/tests/examples/pre-ghc90/Test10399.hs b/tests/examples/pre-ghc90/Test10399.hs new file mode 100644 --- /dev/null +++ b/tests/examples/pre-ghc90/Test10399.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +module Test10399 where + +type MPI = ?mpi_secret :: MPISecret + +mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) + +data MaybeDefault v where + SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v + SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v + -> a -> MaybeDefault [a]) + +[t| Map.Map T.Text $tc |] + +bar $( [p| x |] ) = x