diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +2017-05-17 v0.5.4.0 + * Support GHC 8.2 (rc2) 2017-05-05 v0.5.3.1 * Fix bug roundtripping optional semicolons on if statements. 2017-02-07 v0.5.3.0 diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,5 +1,5 @@ name: ghc-exactprint -version: 0.5.3.1 +version: 0.5.4.0 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 7.10.2, this library provides a means to round trip any code that can @@ -17,7 +17,10 @@ * Print - converts an AST and its annotations to properly formatted source text. . + * Pretty - adds annotations to an AST (fragment) so that + the output can be parsed back to the same AST. . + . Note: requires GHC 7.10.2 or later license: BSD3 @@ -26,8 +29,9 @@ maintainer: alan.zimm@gmail.com category: Development build-type: Simple -tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2 +tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.1 extra-source-files: ChangeLog + src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs tests/examples/failing/*.hs tests/examples/ghc710/*.hs tests/examples/ghc710-only/*.hs @@ -56,22 +60,25 @@ library exposed-modules: Language.Haskell.GHC.ExactPrint , Language.Haskell.GHC.ExactPrint.Annotate + , Language.Haskell.GHC.ExactPrint.AnnotateTypes + , Language.Haskell.GHC.ExactPrint.Annotater , Language.Haskell.GHC.ExactPrint.Delta - , Language.Haskell.GHC.ExactPrint.GhcInterim , Language.Haskell.GHC.ExactPrint.Lookup + , Language.Haskell.GHC.ExactPrint.Parsers , Language.Haskell.GHC.ExactPrint.Preprocess , Language.Haskell.GHC.ExactPrint.Pretty , Language.Haskell.GHC.ExactPrint.Print , Language.Haskell.GHC.ExactPrint.Transform , Language.Haskell.GHC.ExactPrint.Types , Language.Haskell.GHC.ExactPrint.Utils - , Language.Haskell.GHC.ExactPrint.Parsers + if impl (ghc <= 8.0.2) + exposed-modules: Language.Haskell.GHC.ExactPrint.GhcInterim -- other-modules: -- other-extensions: GHC-Options: -Wall - build-depends: base >=4.7 && <5.0 + build-depends: base >=4.7 && <4.11 , bytestring >= 0.10.6 , containers >= 0.5 , directory >= 1.2 @@ -84,6 +91,15 @@ if impl (ghc >= 7.11) build-depends: ghc-boot hs-source-dirs: src + + if impl (ghc > 8.0.3) + hs-source-dirs: src-ghc82 + else + 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) buildable: False @@ -96,17 +112,25 @@ else hs-source-dirs: tests + if impl (ghc > 8.0.3) + hs-source-dirs: src-ghc82 + else + if impl (ghc > 7.10.3) + hs-source-dirs: src-ghc80 + else + hs-source-dirs: src-ghc710 + main-is: Test.hs other-modules: Test.Common , Test.Consistency , Test.NoAnnotations , Test.Transform - GHC-Options: -threaded + GHC-Options: -threaded -Wall Default-language: Haskell2010 if impl (ghc < 7.10.2) buildable: False Build-depends: HUnit >= 1.2 - , base < 5 + , base < 4.11 , bytestring , containers >= 0.5 , Diff @@ -152,7 +176,7 @@ else buildable: False ghc-options: - -threaded + -threaded -Wall executable static main-is: Static.hs @@ -171,7 +195,7 @@ else buildable: False ghc-options: - -threaded + -threaded -Wall executable prepare-hackage main-is: PrepareHackage.hs diff --git a/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs new file mode 100644 --- /dev/null +++ b/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs @@ -0,0 +1,2555 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook +-- | 'annotate' is a function which given a GHC AST fragment, constructs +-- a syntax tree which indicates which annotations belong to each specific +-- part of the fragment. +-- +-- "Delta" and "Print" provide two interpreters for this structure. You +-- should probably use those unless you know what you're doing! +-- +-- The functor 'AnnotationF' has a number of constructors which correspond +-- to different sitations which annotations can arise. It is hoped that in +-- future versions of GHC these can be simplified by making suitable +-- modifications to the AST. + +module Language.Haskell.GHC.ExactPrint.Annotater + ( + annotate + , AnnotationF(..) + , Annotated + , Annotate(..) + , withSortKeyContextsHelper + ) where + +import Language.Haskell.GHC.ExactPrint.AnnotateTypes +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils + +import qualified Bag as GHC +import qualified BasicTypes as GHC +import qualified BooleanFormula as GHC +import qualified Class as GHC +import qualified CoAxiom as GHC +import qualified FastString as GHC +import qualified ForeignCall as GHC +import qualified GHC as GHC +import qualified Name as GHC +import qualified RdrName as GHC +import qualified Outputable as GHC + +import Control.Monad.Identity +import Data.Data +import Data.Maybe + +import qualified Data.Set as Set + +import Debug.Trace + + +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} +-- --------------------------------------------------------------------- + +class Data ast => Annotate ast where + markAST :: GHC.SrcSpan -> ast -> Annotated () + + +-- --------------------------------------------------------------------- + +-- | Construct a syntax tree which represent which KeywordIds must appear +-- where. +annotate :: (Annotate ast) => GHC.Located ast -> Annotated () +annotate = markLocated + +-- --------------------------------------------------------------------- + +-- | Constructs a syntax tree which contains information about which +-- annotations are required by each element. +markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () +markLocated ast = + case cast ast :: Maybe (GHC.LHsDecl GHC.RdrName) 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.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.HsLocalBinds name -> Annotated () +markLocalBindsWithLayout binds = + markHsLocalBinds binds + +-- --------------------------------------------------------------------- + +-- |This function is used to get around shortcomings in the GHC AST for 7.10.1 +markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () +markLocatedFromKw kw (GHC.L l a) = do + -- Note: l is needed so that the pretty printer can make something up + ss <- getSrcSpanForKw l kw + AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) + markLocated (GHC.L ss' a) + +-- --------------------------------------------------------------------- + +markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () +markMaybe Nothing = return () +markMaybe (Just ast) = markLocated ast + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + +prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] +prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsModule GHC.RdrName) where + markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do + + case mmn of + Nothing -> return () + Just (GHC.L ln mn) -> do + mark GHC.AnnModule + markExternal ln GHC.AnnVal (GHC.moduleNameString mn) + + forM_ mdepr markLocated + forM_ mexp markLocated + + mark GHC.AnnWhere + + markOptional GHC.AnnOpenC -- Possible '{' + markManyOptional GHC.AnnSemi -- possible leading semis + setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps + + setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs + + markOptional GHC.AnnCloseC -- Possible '}' + + markEOF + +-- --------------------------------------------------------------------- + +instance Annotate GHC.WarningTxt where + markAST _ (GHC.WarningTxt (GHC.L ls txt) lss) = do + markExternal ls GHC.AnnOpen txt + mark GHC.AnnOpenS + markListIntercalate lss + mark GHC.AnnCloseS + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do + markExternal ls GHC.AnnOpen txt + mark GHC.AnnOpenS + markListIntercalate lss + mark GHC.AnnCloseS + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.SourceText,GHC.FastString) where + markAST l (src,_fs) = do + markExternal l GHC.AnnVal src + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LIE name] where + markAST _ ls = do + inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl + mark GHC.AnnOpenP -- '(' + -- Can't use markListIntercalate, there can be trailing commas, but only in imports. + markListIntercalateWithFunLevel markLocated 2 ls + + mark GHC.AnnCloseP -- ')' + +instance (GHC.DataId name,GHC.HasOccName name, Annotate name) + => Annotate (GHC.IE name) where + markAST _ ie = do + + case ie of + (GHC.IEVar ln) -> do + -- TODO: I am pretty sure this criterion is inadequate + if GHC.isDataOcc $ GHC.occName $ GHC.unLoc ln + then mark GHC.AnnPattern + else markOptional GHC.AnnPattern + setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln + + (GHC.IEThingAbs ln@(GHC.L _ n)) -> do + {- + At the moment (7.10.2) GHC does not cleanly represent an export of the form + "type Foo" + and it only captures the name "Foo". + + The Api Annotations workaround is to have the IEThingAbs SrcSpan + extend across both the "type" and "Foo", and then to capture the + individual item locations in an AnnType and AnnVal annotation. + + This need to be fixed for 7.12. + + -} + + if GHC.isTcOcc (GHC.occName n) && GHC.isSymOcc (GHC.occName n) + then do + mark GHC.AnnType + setContext (Set.singleton PrefixOp) $ markLocatedFromKw GHC.AnnVal ln + else setContext (Set.singleton PrefixOp) $ markLocated ln + + (GHC.IEThingWith ln ns) -> do + setContext (Set.singleton PrefixOp) $ markLocated ln + mark GHC.AnnOpenP + setContext (Set.singleton 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) + +-- --------------------------------------------------------------------- +{- +-- For details on above see note [Api annotations] in ApiAnnotation +data RdrName + = Unqual OccName + -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving (Data, Typeable) +-} + +isSymRdr :: GHC.RdrName -> Bool +isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." + +instance Annotate GHC.RdrName where + markAST l n = do + let + str = rdrName2String n + isSym = isSymRdr n + canParen = isSym && rdrName2String n /= "$" + doNormalRdrName = do + let str' = case str of + -- TODO: unicode support? + "forall" -> if spanLength l == 1 then "∀" else str + _ -> str + when (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n) $ inContext (Set.singleton InIE) $ mark GHC.AnnType + markOptional GHC.AnnType + + let + markParen :: GHC.AnnKeywordId -> Annotated () + markParen pa = do + if canParen + then ifInContext (Set.singleton PrefixOp) + (mark pa) -- '(' + (markOptional pa) + else if isSym + then ifInContext (Set.singleton PrefixOpDollar) + (mark pa) + (markOptional pa) + else markOptional pa + + 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 _ _ -> 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 + mark GHC.AnnOpenP -- '(' + mark GHC.AnnTildehsh + mark GHC.AnnCloseP + "*" -> do + markExternal l GHC.AnnVal str + "★" -> do -- Note: unicode star + markExternal l GHC.AnnVal str + ":" -> do + -- Note: The OccName for ":" has the following attributes (via occAttributes) + -- (d, Data DataSym Sym Val ) + -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon + doNormalRdrName + -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName + ('(':',':_) -> do + mark GHC.AnnOpenP + let cnt = length $ filter (==',') str + replicateM_ cnt (mark GHC.AnnCommaTuple) + mark GHC.AnnCloseP -- ')' + "~" -> do + mark GHC.AnnOpenP + mark GHC.AnnTilde + 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") + +-- --------------------------------------------------------------------- + +-- TODO: What is this used for? Not in ExactPrint +instance Annotate GHC.Name where + markAST l n = do + markExternal l GHC.AnnVal (showGhc n) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ImportDecl name) 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 "#-}" + when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc) + >> markWithString GHC.AnnClose "#-}") + when safeflag (mark GHC.AnnSafe) + when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) + case mpkg of + Nothing -> return () + Just pkg -> markWithString GHC.AnnPackageName (show (GHC.unpackFS pkg)) + + markLocated modname + + case GHC.ideclAs imp of + Nothing -> return () + Just mn -> do + mark GHC.AnnAs + markWithString GHC.AnnVal (GHC.moduleNameString 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.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.LHsDecl name -> Annotated () +markLHsDecl (GHC.L l decl) = + case decl of + GHC.TyClD d -> markLocated (GHC.L l d) + GHC.InstD d -> markLocated (GHC.L l d) + GHC.DerivD d -> markLocated (GHC.L l d) + GHC.ValD d -> markLocated (GHC.L l d) + GHC.SigD d -> markLocated (GHC.L l d) + GHC.DefD d -> markLocated (GHC.L l d) + GHC.ForD d -> markLocated (GHC.L l d) + GHC.WarningD d -> markLocated (GHC.L l d) + GHC.AnnD d -> markLocated (GHC.L l d) + GHC.RuleD d -> markLocated (GHC.L l d) + GHC.VectD d -> markLocated (GHC.L l d) + GHC.SpliceD d -> markLocated (GHC.L l d) + GHC.DocD d -> markLocated (GHC.L l d) + GHC.RoleAnnotD d -> markLocated (GHC.L l d) + GHC.QuasiQuoteD d -> markLocated (GHC.L l d) + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsDecl name) where + markAST l d = markLHsDecl (GHC.L l d) + +-- --------------------------------------------------------------------- + +instance (Annotate name) + => Annotate (GHC.RoleAnnotDecl name) where + markAST _ (GHC.RoleAnnotDecl ln mr) = do + mark GHC.AnnType + mark GHC.AnnRole + 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.SpliceDecl name) where + markAST _ (GHC.SpliceDecl e flag) = do + case flag of + GHC.ExplicitSplice -> mark GHC.AnnOpenPE + GHC.ImplicitSplice -> return () + + setContext (Set.singleton InSpliceDecl) $ markLocated e + + case flag of + GHC.ExplicitSplice -> mark GHC.AnnCloseP + GHC.ImplicitSplice -> return () + + markTrailingSemi + +{- +- data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y) +- ImplicitSplice -- <=> f x y, i.e. a naked +- top level expression +- +-} + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.VectDecl name) where + markAST _ (GHC.HsVect src ln e) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" + markLocated ln + mark GHC.AnnEqual + markLocated e + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsNoVect src ln) = do + markWithString GHC.AnnOpen src -- "{-# NOVECTORISE" + markLocated ln + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsVectTypeIn src _b ln mln) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR" + mark GHC.AnnType + markLocated ln + case mln of + Nothing -> return () + Just lnn -> do + mark GHC.AnnEqual + markLocated lnn + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ GHC.HsVectTypeOut {} = + traceM "warning: HsVectTypeOut appears after renaming" + + markAST _ (GHC.HsVectClassIn src ln) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" + mark GHC.AnnClass + markLocated ln + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ GHC.HsVectClassOut {} = + traceM "warning: HsVecClassOut appears after renaming" + markAST _ GHC.HsVectInstIn {} = + traceM "warning: HsVecInstsIn appears after renaming" + markAST _ GHC.HsVectInstOut {} = + traceM "warning: HsVecInstOut appears after renaming" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.RuleDecls name) where + markAST _ (GHC.HsRules src rules) = do + markWithString GHC.AnnOpen src + setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules + markWithString GHC.AnnClose "#-}" + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.RuleDecl name) where + markAST _ (GHC.HsRule ln act bndrs lhs _ rhs _) = do + markLocated ln + setContext (Set.singleton ExplicitNeverActive) $ markActivation act + + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + markLocated lhs + mark GHC.AnnEqual + markLocated rhs + inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi + markTrailingSemi + +-- --------------------------------------------------------------------- + +markActivation :: GHC.Activation -> Annotated () +markActivation act = do + case act of + GHC.ActiveBefore n -> do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + markWithString GHC.AnnVal (show n) + mark GHC.AnnCloseS -- ']' + GHC.ActiveAfter n -> do + mark GHC.AnnOpenS -- '[' + markWithString GHC.AnnVal (show n) + mark GHC.AnnCloseS -- ']' + GHC.NeverActive -> do + inContext (Set.singleton ExplicitNeverActive) $ do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + mark GHC.AnnCloseS -- ']' + _ -> return () + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.RuleBndr name) where + markAST _ (GHC.RuleBndr ln) = markLocated ln + markAST _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do + mark GHC.AnnOpenP -- "(" + markLocated ln + mark GHC.AnnDcolon + markLocated thing + mark GHC.AnnCloseP -- ")" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.AnnDecl name) where + markAST _ (GHC.HsAnnotation src prov e) = do + markWithString GHC.AnnOpen src + 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 name => Annotate (GHC.WarnDecls name) where + markAST _ (GHC.Warnings src warns) = do + markWithString GHC.AnnOpen src + mapM_ markLocated warns + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance (Annotate name) + => Annotate (GHC.WarnDecl name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ForeignDecl name) where + markAST _ (GHC.ForeignImport ln 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 + markExternal ls GHC.AnnVal (show src) + markLocated ln + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + + + markAST _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls src))) = do + mark GHC.AnnForeign + mark GHC.AnnExport + markLocated spec + markExternal ls GHC.AnnVal (show src) + setContext (Set.singleton PrefixOp) $ markLocated ln + mark GHC.AnnDcolon + markLocated typ + + +-- --------------------------------------------------------------------- + +instance (Annotate GHC.CExportSpec) where + markAST l (GHC.CExportStatic _ 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.DerivDecl name) where + + markAST _ (GHC.DerivDecl typ mov) = do + mark GHC.AnnDeriving + mark GHC.AnnInstance + markMaybe mov + markLocated typ + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.DefaultDecl name) where + + markAST _ (GHC.DefaultDecl typs) = do + mark GHC.AnnDefault + mark GHC.AnnOpenP -- '(' + markListIntercalate typs + mark GHC.AnnCloseP -- ')' + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.InstDecl name) 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 + markAST _ (GHC.NoOverlap src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlappable src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlapping src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlaps src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Incoherent src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ClsInstDecl name) where + + markAST _ (GHC.ClsInstDecl 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.TyFamInstDecl name) where + + markAST _ (GHC.TyFamInstDecl eqn _) = do + mark GHC.AnnType + inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional + markLocated eqn + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.DataFamInstDecl name) where + + markAST l (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _) + 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 + inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance + + markLocated ctx + + markTyClass ln pats + + if isGadt $ GHC.dd_cons defn + then mark GHC.AnnWhere + else mark GHC.AnnEqual + markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs) + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsBind name) where + markAST _ (GHC.FunBind _ _ (GHC.MG 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 lb) _typ _fvs _ticks) = do + markLocated lhs + case grhs of + (GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual -- empty guards + _ -> return () + markListIntercalateWithFunLevel markLocated 2 grhs + unless (GHC.isEmptyLocalBinds lb) $ mark GHC.AnnWhere + markOptional GHC.AnnWhere + + markLocalBindsWithLayout lb + markTrailingSemi + + markAST _ (GHC.VarBind _n rhse _) = + -- Note: this bind is introduced by the typechecker + markLocated rhse + + markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do + mark GHC.AnnPattern + case args of + GHC.InfixPatSyn la lb -> do + markLocated la + setContext (Set.singleton InfixOp) $ markLocated ln + markLocated lb + GHC.PrefixPatSyn ns -> do + markLocated ln + mapM_ markLocated ns + 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 + + -- Introduced after renaming. + markAST _ (GHC.AbsBinds _ _ _ _ _) = + traceM "warning: AbsBinds introduced after renaming" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.IPBind name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, + Annotate body) + => Annotate (GHC.Match name (GHC.Located body)) where + + markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do + let + get_infix Nothing = False + get_infix (Just (_,f)) = f + isFunBind = isJust + case (get_infix mln,pats) of + (True, a:b:xs) -> do + if null xs + then markOptional GHC.AnnOpenP + else mark GHC.AnnOpenP + markLocated a + case mln of + Nothing -> return () + Just (n,_) -> setContext (Set.singleton InfixOp) $ markLocated n + 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 + -- Nothing -> mark GHC.AnnFunId + Nothing -> markListNoPrecedingSpace False pats + Just (n,_) -> do + setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n + mapM_ markLocated pats + -- markListNoPrecedingSpace 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name, + Annotate name, Annotate body) + => Annotate (GHC.GRHS name (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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.Sig name) where + + markAST _ (GHC.TypeSig lns typ _) = do + setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + tellContext (Set.singleton FollowingLine) + + markAST _ (GHC.PatSynSig ln (_ef,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do + mark GHC.AnnPattern + markLocated ln + mark GHC.AnnDcolon + + -- Note: The 'forall' bndrs '.' may occur multiple times + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + when (GHC.getLoc ctx1 /= GHC.noSrcSpan) $ do + setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx1 + markOffset GHC.AnnDarrow 0 + when (GHC.getLoc ctx2 /= GHC.noSrcSpan) $ do + setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx2 + markOffset GHC.AnnDarrow 1 + markLocated typ + markTrailingSemi + + markAST _ (GHC.GenericSig ns typ) = do + mark GHC.AnnDefault + -- markListIntercalate ns + setContext (Set.singleton PrefixOp) $ markListIntercalate ns + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + + markAST _ (GHC.IdSig _) = + traceM "warning: Introduced after renaming" + + -- FixSig (FixitySig name) + markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do + let fixstr = case fdir of + GHC.InfixL -> "infixl" + GHC.InfixR -> "infixr" + GHC.InfixN -> "infix" + markWithString GHC.AnnInfix fixstr + markWithString GHC.AnnVal (show v) + setContext (Set.singleton InfixOp) $ markListIntercalate lns + markTrailingSemi + + -- InlineSig (Located name) InlinePragma + -- '{-# INLINE' activation qvar '#-}' + markAST _ (GHC.InlineSig ln inl) = do + markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE' + markActivation (GHC.inl_act inl) + setContext (Set.singleton PrefixOp) $ markLocated ln + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + markAST _ (GHC.SpecSig ln typs inl) = do + markWithString GHC.AnnOpen (GHC.inl_src inl) + markActivation (GHC.inl_act inl) + markLocated ln + mark GHC.AnnDcolon -- '::' + markListIntercalate typs + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + + -- '{-# SPECIALISE' 'instance' inst_type '#-}' + markAST _ (GHC.SpecInstSig src typ) = do + markWithString GHC.AnnOpen src + mark GHC.AnnInstance + markLocated typ + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + + + -- MinimalSig (BooleanFormula (Located name)) + markAST _l (GHC.MinimalSig src formula) = do + markWithString GHC.AnnOpen src + annotationsToCommentsBF formula [GHC.AnnOpenP,GHC.AnnCloseP,GHC.AnnComma,GHC.AnnVbar] + markAST _l formula + finalizeBF _l + markWithString GHC.AnnClose "#-}" + markTrailingSemi + +-- -------------------------------------------------------------------- + +-- In practice, due to the way the BooleanFormula is constructed in the parser, +-- we will get the following variants +-- a | b : Or [a,b] +-- a , b : And [a,b] +-- ( a ) : a +-- A bottom level Located RdrName is captured in a Var. This is the only part +-- with a location in it. +-- +-- So the best strategy might be to convert all the annotations into comments, +-- and then just print the names. DONE +instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where + -- markAST _ (GHC.Var x) = markLocated x + markAST _ (GHC.Var x) = setContext (Set.singleton PrefixOp) $ markLocated x + markAST l (GHC.Or ls) = mapM_ (markAST l) ls + markAST l (GHC.And ls) = mapM_ (markAST l) ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsTyVarBndr name) where + markAST _l (GHC.UserTyVar n) = do + markAST _l n + + markAST _ (GHC.KindedTyVar n ty) = do + mark GHC.AnnOpenP -- '(' + markLocated n + mark GHC.AnnDcolon -- '::' + markLocated ty + mark GHC.AnnCloseP -- '(' + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsType name) where + markAST loc ty = do + markType loc ty + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + where + + -- markType :: GHC.SrcSpan -> ast -> Annotated () + markType _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do + unless (null tvs) $ do + mark GHC.AnnForall + mapM_ markLocated tvs + mark GHC.AnnDot + + case mwc of + Nothing -> when (lc /= GHC.noSrcSpan) $ markLocated ctx + Just lwc -> do + let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildcardTy:ctxs) + markLocated (GHC.L lc sorted) + + markLocated typ + -- mark GHC.AnnCloseP -- ")" + + markType _l (GHC.HsTyVar name) = do + if GHC.isDataOcc $ GHC.occName name + then do + mark GHC.AnnSimpleQuote + markLocatedFromKw GHC.AnnName (GHC.L _l name) + else unsetContext Intercalate $ markAST _l name + + markType _ (GHC.HsAppTy t1 t2) = do + setContext (Set.singleton PrefixOp) $ markLocated t1 + markLocated t2 + + markType _ (GHC.HsFunTy t1 t2) = do + markLocated t1 + mark GHC.AnnRarrow + markLocated t2 + + markType _ (GHC.HsListTy t) = do + mark GHC.AnnOpenS -- '[' + markLocated t + mark GHC.AnnCloseS -- ']' + + markType _ (GHC.HsPArrTy t) = do + markWithString GHC.AnnOpen "[:" -- '[:' + markLocated t + markWithString GHC.AnnClose ":]" -- ':]' + + 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.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 (GHC.HsIPName n) t) = do + markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n)) + mark GHC.AnnDcolon + markLocated t + + markType _ (GHC.HsEqTy t1 t2) = do + markLocated t1 + mark GHC.AnnTilde + markLocated t2 + + markType _ (GHC.HsKindSig t k) = do + mark GHC.AnnOpenP -- '(' + markLocated t + mark GHC.AnnDcolon -- '::' + markLocated k + mark GHC.AnnCloseP -- ')' + + markType l (GHC.HsSpliceTy s _) = do + mark GHC.AnnOpenPE + markAST l s + mark GHC.AnnCloseP + + markType _ (GHC.HsDocTy t ds) = do + markLocated t + markLocated ds + + markType _ (GHC.HsBangTy b t) = do + case b of + (GHC.HsSrcBang ms (Just True) _) -> do + markWithString GHC.AnnOpen (fromMaybe "{-# UNPACK" ms) + markWithString GHC.AnnClose "#-}" + (GHC.HsSrcBang ms (Just False) _) -> do + markWithString GHC.AnnOpen (fromMaybe "{-# NOUNPACK" ms) + markWithString GHC.AnnClose "#-}" + _ -> return () + mark GHC.AnnBang + markLocated t + + markType _ (GHC.HsRecTy cons) = do + mark GHC.AnnOpenC -- '{' + markListIntercalate cons + mark GHC.AnnCloseC -- '}' + + -- HsCoreTy Type + markType _ (GHC.HsCoreTy _t) = + traceM "warning: HsCoreTy Introduced after renaming" + + markType _ (GHC.HsExplicitListTy _ ts) = do + 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 + + -- HsTyLit HsTyLit + markType l (GHC.HsTyLit lit) = do + case lit of + (GHC.HsNumTy s _) -> + markExternal l GHC.AnnVal s + (GHC.HsStrTy s _) -> + markExternal l GHC.AnnVal s + + -- HsWrapTy HsTyAnnotated (HsType name) + markType _ (GHC.HsWrapTy _ _) = + traceM "warning: HsWrapTyy Introduced after renaming" + + markType l GHC.HsWildcardTy = do + markExternal l GHC.AnnVal "_" + markType l (GHC.HsNamedWildcardTy n) = do + markExternal l GHC.AnnVal (showGhc n) + + markType l (GHC.HsQuasiQuoteTy n) = do + markAST l n + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsSplice name) where + markAST _ c = + case c of + GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do + -- TODO: We do not seem to have any way to distinguish between which of + -- the next two lines will emit output. If AnnThIdSplice is there, the + markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) + markLocated b + GHC.HsSplice _n b@(GHC.L _ (GHC.HsBracket _)) -> do + markLocated b + GHC.HsSplice _n b -> do + markLocated b + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsQuasiQuote name) where + markAST l (GHC.HsQuasiQuote n _pos fs) = do + markExternal l GHC.AnnVal + ("[" ++ showGhc n ++ "|" ++ GHC.unpackFS fs ++ "|]") + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => + Annotate (GHC.ConDeclField name) where + markAST _ (GHC.ConDeclField ns ty mdoc) = do +{- +data ConDeclField name -- Record fields have Haddoc docs on them + = ConDeclField { cd_fld_names :: [LFieldOcc name], + -- ^ See Note [ConDeclField names] + cd_fld_type :: LBangType name, + cd_fld_doc :: Maybe LHsDocString } + +-} + unsetContext Intercalate $ do + markListIntercalate ns + mark GHC.AnnDcolon + markLocated ty + markMaybe mdoc + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsDocString where + markAST l (GHC.HsDocString s) = do + markExternal l GHC.AnnVal (GHC.unpackFS s) + +-- --------------------------------------------------------------------- +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.Pat name) 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 n + markPat _ (GHC.LazyPat p) = do + mark GHC.AnnTilde + markLocated p + + markPat _ (GHC.AsPat ln p) = do + markLocated ln + mark GHC.AnnAt + markLocated p + + markPat _ (GHC.ParPat p) = do + mark GHC.AnnOpenP + markLocated p + mark GHC.AnnCloseP + + markPat _ (GHC.BangPat p) = do + mark GHC.AnnBang + markLocated p + + markPat _ (GHC.ListPat ps _ _) = do + mark GHC.AnnOpenS + markListIntercalateWithFunLevel markLocated 2 ps + mark GHC.AnnCloseS + + markPat _ (GHC.TuplePat pats b _) = do + if b == GHC.Boxed then mark GHC.AnnOpenP + else markWithString GHC.AnnOpen "(#" + markListIntercalateWithFunLevel markLocated 2 pats + if b == GHC.Boxed then mark GHC.AnnCloseP + else markWithString GHC.AnnClose "#)" + + markPat _ (GHC.PArrPat ps _) = do + markWithString GHC.AnnOpen "[:" + mapM_ markLocated ps + markWithString GHC.AnnClose ":]" + + markPat _ (GHC.ConPatIn n dets) = do + markHsConPatDetails n dets + + markPat _ GHC.ConPatOut {} = + traceM "warning: ConPatOut Introduced after renaming" + + -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type) + markPat _ (GHC.ViewPat e pat _) = do + markLocated e + mark GHC.AnnRarrow + markLocated pat + + -- SplicePat (HsSplice id) + markPat l (GHC.SplicePat s) = do + mark GHC.AnnOpenPE + markAST l s + mark GHC.AnnCloseP + + -- LitPat HsLit + markPat l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp) + + -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id) + markPat _ (GHC.NPat ol mn _) = do + -- markOptional GHC.AnnMinus + when (isJust mn) $ mark GHC.AnnMinus + markLocated ol + + -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id) + markPat _ (GHC.NPlusKPat ln ol _ _) = do + markLocated ln + markWithString GHC.AnnVal "+" -- "+" + markLocated ol + + + markPat _ (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do + markLocated pat + mark GHC.AnnDcolon + markLocated ty + + markPat _ GHC.SigPatOut {} = + traceM "warning: SigPatOut introduced after renaming" + + -- CoPat HsAnnotated (Pat id) Type + markPat _ GHC.CoPat {} = + traceM "warning: CoPat introduced after renaming" + + markPat l (GHC.QuasiQuotePat p) = markAST l p + +-- --------------------------------------------------------------------- +hsLit2String :: GHC.HsLit -> GHC.SourceText +hsLit2String lit = + case lit of + GHC.HsChar src _ -> src + -- It should be included here + -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 + GHC.HsCharPrim src _ -> src ++ "#" + GHC.HsString src _ -> src + GHC.HsStringPrim src _ -> src + GHC.HsInt src _ -> src + GHC.HsIntPrim src _ -> src + GHC.HsWordPrim src _ -> src + GHC.HsInt64Prim src _ -> src + GHC.HsWord64Prim src _ -> src + GHC.HsInteger src _ _ -> src + GHC.HsRat (GHC.FL src _) _ -> src + GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#" + GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##" + +markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.Located name -> GHC.HsConPatDetails name -> 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 + setContext (Set.singleton InfixOp) $ markLocated ln + markLocated a2 + +markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Bool -> Bool -> [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated () + +markHsConDeclDetails isDeprecated inGadt lns dets = do + case dets of + GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args + GHC.RecCon fs -> do + mark GHC.AnnOpenC + if inGadt + then do + if isDeprecated + then setContext (Set.fromList [InGadt]) $ markLocated fs + else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs + else do + if isDeprecated + then markLocated fs + else setContext (Set.fromList [InRecCon]) $ markLocated fs + GHC.InfixCon a1 a2 -> do + markLocated a1 + setContext (Set.singleton InfixOp) $ mapM_ markLocated lns + markLocated a2 + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LConDeclField name] where + markAST _ fs = do + markOptional GHC.AnnOpenC -- '{' + markListIntercalate fs + markOptional GHC.AnnDotdot + inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' + inContext (Set.singleton InGadt) $ do + mark GHC.AnnRarrow + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where + markAST l ol = + let str = case GHC.ol_val ol of + GHC.HsIntegral src _ -> src + GHC.HsFractional l2 -> GHC.fl_text l2 + GHC.HsIsString src _ -> src + in + markExternal l GHC.AnnVal str + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate arg) + => Annotate (GHC.HsWithBndrs name (GHC.Located arg)) where + markAST _ (GHC.HsWB thing _ _ _) = do + markLocated thing + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name + ,GHC.HasOccName name,Annotate body) + => Annotate (GHC.Stmt name (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.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 lb) = do + mark GHC.AnnLet + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + markLocalBindsWithLayout lb + markOptional GHC.AnnCloseC -- '}' + ifInContext (Set.singleton Intercalate) + (mark GHC.AnnComma) + (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) + markTrailingSemi + + markAST l (GHC.ParStmt pbs _ _) = do + -- Within a given parallel list comprehension,one of the sections to be done + -- in parallel. It is a normal list comprehension, so has a list of + -- ParStmtBlock, one for each part of the sub- list comprehension + + + ifInContext (Set.singleton Intercalate) + ( + + unsetContext Intercalate $ + markListWithContextsFunction + (LC (Set.singleton Intercalate) -- only + Set.empty -- first + Set.empty -- middle + (Set.singleton Intercalate) -- last + ) (markAST l) pbs + ) + ( + unsetContext Intercalate $ + markListWithContextsFunction + (LC Set.empty -- only + (Set.fromList [AddVbar]) -- first + (Set.fromList [AddVbar]) -- middle + Set.empty -- last + ) (markAST l) pbs + ) + markTrailingSemi + + markAST _ (GHC.TransStmt form stmts _b using by _ _ _) = do + setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts + case form of + GHC.ThenForm -> do + mark GHC.AnnThen + unsetContext Intercalate $ markLocated using + case by of + Just b -> do + mark GHC.AnnBy + unsetContext Intercalate $ markLocated b + Nothing -> return () + GHC.GroupForm -> do + mark GHC.AnnThen + mark GHC.AnnGroup + case by of + Just b -> mark GHC.AnnBy >> markLocated b + Nothing -> return () + mark GHC.AnnUsing + markLocated using + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + + markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do + mark GHC.AnnRec + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + mapM_ markLocated stmts + markOptional GHC.AnnCloseC + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + +-- --------------------------------------------------------------------- + +-- 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ParStmtBlock name name) where + markAST _ (GHC.ParStmtBlock stmts _ns _) = do + markListIntercalate stmts + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsLocalBinds name) where + markAST _ lb = markHsLocalBinds lb + +-- --------------------------------------------------------------------- + +markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.HsLocalBinds name -> Annotated () +markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = + applyListAnnotationsLayout + (prepareListAnnotation (GHC.bagToList binds) + ++ prepareListAnnotation sigs + ) +markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {}) + = traceM "warning: ValBindsOut introduced after renaming" + +markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout (reverse binds) +markHsLocalBinds GHC.EmptyLocalBinds = return () + +-- --------------------------------------------------------------------- + +markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, + Annotate body) + => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body) + -> Annotated () +markMatchGroup _ (GHC.MG matches _ _ _) + = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, + Annotate body) + => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsExpr name) 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 l (GHC.HsVar n) = unsetContext Intercalate $ markAST l n + + markExpr l (GHC.HsIPVar (GHC.HsIPName v)) = + markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v) + markExpr l (GHC.HsOverLit ov) = markAST l ov + markExpr l (GHC.HsLit lit) = markAST l lit + + markExpr _ (GHC.HsLam (GHC.MG [match] _ _ _)) = do + setContext (Set.singleton LambdaExpr) $ do + -- TODO: Change this, HsLam binds do not need obey layout rules. + -- And will only ever have a single match + markLocated match + markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match" + + markExpr l (GHC.HsLamCase _ match) = do + mark GHC.AnnLam + mark GHC.AnnCase + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + markMatchGroup l match + markOptional GHC.AnnCloseC + + markExpr _ (GHC.HsApp e1 e2) = do + -- markLocated e1 + setContext (Set.singleton PrefixOp) $ markLocated e1 + -- markLocated e2 + 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 l (GHC.HsCase e1 matches) = setRigidFlag $ do + mark GHC.AnnCase + setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 + mark GHC.AnnOf + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + setContext (Set.singleton CaseAlt) $ markMatchGroup l matches + markOptional GHC.AnnCloseC + + -- We set the layout for HsIf even though it need not obey layout rules as + -- when moving these expressions it's useful that they maintain "internal + -- integrity", that is to say the subparts remain indented relative to each + -- other. + markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do + -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do + mark GHC.AnnIf + markLocated e1 + markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen + mark GHC.AnnThen + setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 + markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse + mark GHC.AnnElse + setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 + + markExpr _ (GHC.HsMultiIf _ rhs) = do + mark GHC.AnnIf + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + -- mapM_ markLocated rhs + markListWithLayout rhs + markOptional GHC.AnnCloseC + + markExpr _ (GHC.HsLet 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 es _) = do + case cts of + GHC.DoExpr -> mark GHC.AnnDo + GHC.MDoExpr -> mark GHC.AnnMdo + _ -> return () + let (ostr,cstr) = + if isListComp cts + then case cts of + GHC.PArrComp -> ("[:",":]") + _ -> ("[", "]") + 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.ExplicitPArr _ es) = do + markWithString GHC.AnnOpen "[:" + markListIntercalate es + markWithString GHC.AnnClose ":]" + + 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 (GHC.HsRecFields fs _) _cons _ _) = 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 + markLocated typ + + markExpr _ (GHC.ExprWithTySigOut e typ) = do + markLocated e + mark GHC.AnnDcolon + markLocated 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.PArrSeq _ seqInfo) = do + markWithString GHC.AnnOpen "[:" -- '[:' + 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 + markWithString GHC.AnnClose ":]" -- ':]' + + markExpr _ (GHC.HsSCC src csFStr e) = do + markWithString GHC.AnnOpen src -- "{-# SCC" + markWithStringOptional GHC.AnnVal (GHC.unpackFS csFStr) + markWithString GHC.AnnValStr ("\"" ++ GHC.unpackFS csFStr ++ "\"") + markWithString GHC.AnnClose "#-}" + markLocated e + + markExpr _ (GHC.HsCoreAnn src csFStr e) = do + markWithString GHC.AnnOpen src -- "{-# CORE" + markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS 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 + markWithString GHC.AnnClose "|]" + -- Introduced after the renamer + markExpr _ (GHC.HsBracket (GHC.DecBrG _)) = + traceM "warning: DecBrG introduced after renamer" + markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do + -- This exists like this as the lexer collapses [e| and [| into the + -- same construtor + workOutString _l GHC.AnnOpen + (\ss -> if spanLength ss == 2 + then "[|" + else "[e|") + markLocated e + markWithString GHC.AnnClose "|]" + markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do + -- This exists like this as the lexer collapses [e|| and [|| into the + -- same construtor + workOutString _l GHC.AnnOpen + (\ss -> if spanLength ss == 3 + then "[||" + else "[e||") + markLocated e + markWithString GHC.AnnClose "||]" + markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do + markWithString GHC.AnnOpen "[t|" + markLocated e + markWithString GHC.AnnClose "|]" + markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do + markWithString GHC.AnnOpen "[p|" + markLocated e + markWithString GHC.AnnClose "|]" + + markExpr _ (GHC.HsRnBracketOut _ _) = + traceM "warning: HsRnBracketOut introduced after renamer" + markExpr _ (GHC.HsTcBracketOut _ _) = + traceM "warning: HsTcBracketOut introduced after renamer" + + markExpr _ (GHC.HsSpliceE isTyped e) = do + case e of + GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do + if isTyped + then do + mark GHC.AnnOpenPTE + markWithStringOptional GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) + else do + mark GHC.AnnOpenPE + markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) + markLocated b + mark GHC.AnnCloseP + GHC.HsSplice _n b -> do + if isTyped + then do + markOptional GHC.AnnThIdSplice + mark GHC.AnnOpenPTE + else mark GHC.AnnOpenPE + markLocated b + mark GHC.AnnCloseP + + markExpr l (GHC.HsQuasiQuoteE e) = do + markAST l e + + markExpr _ (GHC.HsProc p c) = do + mark GHC.AnnProc + markLocated p + mark GHC.AnnRarrow + markLocated c + + markExpr _ (GHC.HsStatic e) = do + mark GHC.AnnStatic + markLocated e + + markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do + -- isRightToLeft True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + if isRightToLeft + then do + markLocated e1 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail + else do + markLocated e2 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail + + if isRightToLeft + then markLocated e2 + else markLocated e1 + + markExpr _ (GHC.HsArrForm e _ cs) = do + markWithString GHC.AnnOpen "(|" + markLocated e + mapM_ markLocated cs + markWithString GHC.AnnClose "|)" + + markExpr _ (GHC.HsTick _ _) = return () + markExpr _ (GHC.HsBinTick _ _ _) = return () + + markExpr _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do + -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' + markWithString GHC.AnnOpen src + markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str)) -- STRING + markOffsetWithString GHC.AnnVal 1 (show v1) -- INTEGER + markOffset GHC.AnnColon 0 -- ':' + markOffsetWithString GHC.AnnVal 2 (show v2) -- INTEGER + mark GHC.AnnMinus -- '-' + markOffsetWithString GHC.AnnVal 3 (show v3) -- INTEGER + markOffset GHC.AnnColon 1 -- ':' + markOffsetWithString GHC.AnnVal 4 (show v4) -- INTEGER + markWithString GHC.AnnClose "#-}" + markLocated e + + markExpr l GHC.EWildPat = do + markExternal l GHC.AnnVal "_" + + markExpr _ (GHC.EAsPat ln e) = do + markLocated ln + mark GHC.AnnAt + markLocated e + + markExpr _ (GHC.EViewPat e1 e2) = do + markLocated e1 + mark GHC.AnnRarrow + markLocated e2 + + markExpr _ (GHC.ELazyPat e) = do + mark GHC.AnnTilde + markLocated e + + markExpr _ (GHC.HsType ty) = markLocated ty + + markExpr _ (GHC.HsWrap _ _) = + traceM "warning: HsWrap introduced after renaming" + markExpr _ (GHC.HsUnboundVar _) = + traceM "warning: HsUnboundVar introduced after renaming" + + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsLit where + markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) + +-- --------------------------------------------------------------------- + +-- |Used for declarations that need to be aligned together, e.g. in a +-- do or let .. in statement/expr +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.ExprLStmt name] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsTupArg name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsCmdTop name) where + markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsCmd name) 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 _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 + + -- TODO: This test assumes no auto-generated SrcSpans + let isPrefixOp = case cs of + [] -> True + (GHC.L h _:_) -> GHC.getLoc e < h + when isPrefixOp $ markWithString GHC.AnnOpen "(|" + -- 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 $ markWithString GHC.AnnClose "|)" + + markAST _ (GHC.HsCmdApp e1 e2) = do + markLocated e1 + markLocated e2 + + markAST l (GHC.HsCmdLam match) = do + setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match + + markAST _ (GHC.HsCmdPar e) = do + mark GHC.AnnOpenP + markLocated e + mark GHC.AnnCloseP -- ')' + + markAST l (GHC.HsCmdCase e1 matches) = do + mark GHC.AnnCase + markLocated e1 + mark GHC.AnnOf + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + markMatchGroup l matches + markOptional GHC.AnnCloseC + + markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do + mark GHC.AnnIf + markLocated e1 + markOffset GHC.AnnSemi 0 + mark GHC.AnnThen + markLocated e2 + markOffset GHC.AnnSemi 1 + mark GHC.AnnElse + markLocated e3 + + markAST _ (GHC.HsCmdLet binds e) = do + mark GHC.AnnLet + markOptional GHC.AnnOpenC + markLocalBindsWithLayout binds + markOptional GHC.AnnCloseC + mark GHC.AnnIn + markLocated e + + markAST _ (GHC.HsCmdDo es _) = do + mark GHC.AnnDo + markOptional GHC.AnnOpenC + markListWithLayout es + markOptional GHC.AnnCloseC + + markAST _ GHC.HsCmdCast {} = + traceM "warning: HsCmdCast introduced after renaming" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.TyClDecl name) where + + markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi + + markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) 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 ln tyvars + mark GHC.AnnEqual + markLocated typ + markTrailingSemi + + markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars) + (GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _) = do + if nd == GHC.DataType + then mark GHC.AnnData + else mark GHC.AnnNewtype + markMaybe mctyp + when (null (GHC.unLoc ctx)) $ markOptional GHC.AnnDarrow + markLocated ctx + markTyClass 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]) $ markMaybe mderivs + markTrailingSemi + + -- ----------------------------------- + + markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds + sigs meths ats atdefs docs _) = do + mark GHC.AnnClass + markLocated ctx + + markTyClass 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 + +-- --------------------------------------------------------------------- + +markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) + => GHC.Located a -> [GHC.Located ast] -> Annotated () +markTyClass ln tyVars = do + markManyOptional GHC.AnnOpenP + + let + parensNeeded = GHC.isSymOcc (GHC.occName $ GHC.unLoc ln) && length tyVars > 2 + lnFun = do + ifInContext (Set.singleton CtxMiddle) + (setContext (Set.singleton InfixOp) $ markLocated ln) + (markLocated ln) + listFun b = do + if parensNeeded + then ifInContext (Set.singleton (CtxPos 0)) + (markMany GHC.AnnOpenP) + (return ()) + else ifInContext (Set.singleton (CtxPos 0)) + (markManyOptional GHC.AnnOpenP) + (return ()) + + markLocated b + + if parensNeeded + then ifInContext (Set.singleton (CtxPos 2)) + (markMany GHC.AnnCloseP) + (return ()) + else ifInContext (Set.singleton (CtxPos 2)) + (markManyOptional GHC.AnnCloseP) + (return ()) + + prepareListFun ls = map (\b -> (GHC.getLoc b, listFun b )) ls + + unsetContext CtxMiddle $ + applyListAnnotationsContexts (LC (Set.fromList [CtxOnly,PrefixOp]) (Set.fromList [CtxFirst,PrefixOp]) + (Set.singleton CtxMiddle) (Set.singleton CtxLast)) + ([(GHC.getLoc ln,lnFun)] + ++ prepareListFun tyVars) + markManyOptional GHC.AnnCloseP + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.FamilyDecl name) where + markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do + case info of + GHC.DataFamily -> mark GHC.AnnData + _ -> mark GHC.AnnType + + mark GHC.AnnFamily + + markTyClass ln tyvars + case mkind of + Nothing -> return () + Just k -> do + mark GHC.AnnDcolon + markLocated k + case info of + GHC.ClosedTypeFamily eqns -> do + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- { + markListWithLayout eqns + markOptional GHC.AnnCloseC -- } + _ -> return () + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.TyFamInstEqn name) where + markAST _ (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do + markTyClass ln pats + -- let + -- fun = ifInContext (Set.singleton (CtxPos 0)) + -- (setContext (Set.singleton PrefixOp) $ markLocated ln) + -- (markLocated ln) + -- markOptional GHC.AnnOpenP + -- applyListAnnotationsContexts (LC Set.empty Set.empty Set.empty Set.empty) + -- ([(GHC.getLoc ln, fun)] + -- ++ prepareListAnnotationWithContext (Set.singleton PrefixOp) pats) + -- markOptional GHC.AnnCloseP + mark GHC.AnnEqual + markLocated typ + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.TyFamDefltEqn name) where + markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do + mark GHC.AnnType + mark GHC.AnnInstance + applyListAnnotations (prepareListAnnotation [ln] + ++ prepareListAnnotation bndrs + ) + mark GHC.AnnEqual + markLocated typ + +-- --------------------------------------------------------------------- + +-- 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 (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocCommentPrev (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocGroup _i (GHC.HsDocString fs)) -> GHC.unpackFS fs + in + markExternal l GHC.AnnVal str >> markTrailingSemi + +-- --------------------------------------------------------------------- + +markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated () +markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons mderivs) = do + markLocated ctx + markMaybe typ + markMaybe _mk + if isGadt cons + then markListWithLayout cons + else markListIntercalateWithFunLevel markLocated 2 cons + case mderivs of + Nothing -> return () + Just d -> setContext (Set.singleton Deriving) $ markLocated d + +-- --------------------------------------------------------------------- + +-- Note: GHC.HsContext name aliases to here too +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LHsType name] where + markAST l ts = do + inContext (Set.singleton Deriving) $ mark GHC.AnnDeriving + -- Mote: A single item in parens in a deriving clause is parsed as a + -- HsSigType, which is always a HsForAllTy. 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 + [_] -> markManyOptional pa + _ -> markMany pa + + parenIfNeeded'' pa = + ifInContext (Set.singleton Parens) + (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 (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.ConDecl name) where + markAST _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx + dets res _ depc_syntax) = do + case res of + GHC.ResTyH98 -> do + + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + unless (null $ GHC.unLoc ctx) $ do + setContext (Set.fromList [NoDarrow]) $ markLocated ctx + mark GHC.AnnDarrow + case dets of + GHC.InfixCon _ _ -> return () + _ -> setContext (Set.singleton PrefixOp) $ markListIntercalate lns + + markHsConDeclDetails False False lns dets + + GHC.ResTyGADT ls ty -> do + -- only print names if not infix + case dets of + GHC.InfixCon _ _ -> return () + _ -> markListIntercalate lns + + if depc_syntax + then do + markHsConDeclDetails True False lns dets + mark GHC.AnnCloseC + mark GHC.AnnDcolon + markManyOptional GHC.AnnOpenP + + else do + mark GHC.AnnDcolon + markLocated (GHC.L ls (ResTyGADTHook bndrs)) + markManyOptional GHC.AnnOpenP + unless (null $ GHC.unLoc ctx) $ do + markLocated ctx + markHsConDeclDetails False True lns dets + + markLocated ty + + markManyOptional GHC.AnnCloseP + + + case res of + GHC.ResTyH98 -> inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar + _ -> return () + markTrailingSemi + +-- ResTyGADT has a SrcSpan for the original sigtype, we need to create +-- a type for exactPC and annotatePC +data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name] + deriving (Typeable) +deriving instance (GHC.DataId name) => Data (ResTyGADTHook name) +deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name) + +instance (GHC.OutputableBndr name) => GHC.Outputable (ResTyGADTHook name) where + ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr bs + + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (ResTyGADTHook name) where + markAST _ (ResTyGADTHook bndrs) = do + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + +-- --------------------------------------------------------------------- + +instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.HsRecField name (GHC.LPat name)) 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 name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.HsRecField name (GHC.LHsExpr name)) 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 (GHC.DataId name,Annotate name) + => Annotate (GHC.FunDep (GHC.Located name)) where + + markAST _ (ls,rs) = do + mapM_ markLocated ls + mark GHC.AnnRarrow + mapM_ markLocated rs + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate GHC.CType where + markAST _ (GHC.CType src mh f) = do + markWithString GHC.AnnOpen src + case mh of + Nothing -> return () + Just (GHC.Header h) -> + markWithString GHC.AnnHeader ("\"" ++ GHC.unpackFS h ++ "\"") + markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS f ++ "\"") + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- diff --git a/src-ghc80/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc80/Language/Haskell/GHC/ExactPrint/Annotater.hs new file mode 100644 --- /dev/null +++ b/src-ghc80/Language/Haskell/GHC/ExactPrint/Annotater.hs @@ -0,0 +1,2750 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook +-- | 'annotate' is a function which given a GHC AST fragment, constructs +-- a syntax tree which indicates which annotations belong to each specific +-- part of the fragment. +-- +-- "Delta" and "Print" provide two interpreters for this structure. You +-- should probably use those unless you know what you're doing! +-- +-- The functor 'AnnotationF' has a number of constructors which correspond +-- to different sitations which annotations can arise. It is hoped that in +-- future versions of GHC these can be simplified by making suitable +-- modifications to the AST. + +module Language.Haskell.GHC.ExactPrint.Annotater + ( + annotate + , AnnotationF(..) + , Annotated + , Annotate(..) + , withSortKeyContextsHelper + ) where + + +import Language.Haskell.GHC.ExactPrint.AnnotateTypes +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils + +import qualified Bag as GHC +import qualified BasicTypes as GHC +import qualified BooleanFormula as GHC +import qualified Class as GHC +import qualified CoAxiom as GHC +import qualified FastString as GHC +import qualified ForeignCall as GHC +import qualified GHC as GHC +import qualified Name as GHC +import qualified RdrName as GHC +import qualified Outputable as GHC + +import Control.Monad.Identity +import Data.Data +import Data.Maybe + +import qualified Data.Set as Set + +import Debug.Trace + + +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} +-- --------------------------------------------------------------------- + +class Data ast => Annotate ast where + markAST :: GHC.SrcSpan -> ast -> Annotated () + +-- --------------------------------------------------------------------- + +-- | Construct a syntax tree which represent which KeywordIds must appear +-- where. +annotate :: (Annotate ast) => GHC.Located ast -> Annotated () +annotate = markLocated + +-- --------------------------------------------------------------------- + +-- | Constructs a syntax tree which contains information about which +-- annotations are required by each element. +markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () +markLocated ast = + case cast ast :: Maybe (GHC.LHsDecl GHC.RdrName) 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.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.HsLocalBinds name -> Annotated () +markLocalBindsWithLayout binds = + markHsLocalBinds binds + +-- --------------------------------------------------------------------- + +-- |This function is used to get around shortcomings in the GHC AST for 7.10.1 +markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () +markLocatedFromKw kw (GHC.L l a) = do + -- Note: l is needed so that the pretty printer can make something up + ss <- getSrcSpanForKw l kw + AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) + markLocated (GHC.L ss' a) + +-- --------------------------------------------------------------------- + +markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () +markMaybe Nothing = return () +markMaybe (Just ast) = markLocated ast + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + +prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] +prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsModule GHC.RdrName) where + markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do + + case mmn of + Nothing -> return () + Just (GHC.L ln mn) -> do + mark GHC.AnnModule + markExternal ln GHC.AnnVal (GHC.moduleNameString mn) + + forM_ mdepr markLocated + forM_ mexp markLocated + + mark GHC.AnnWhere + + markOptional GHC.AnnOpenC -- Possible '{' + markManyOptional GHC.AnnSemi -- possible leading semis + setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps + + setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs + + markOptional GHC.AnnCloseC -- Possible '}' + + markEOF + +-- --------------------------------------------------------------------- + +instance Annotate GHC.WarningTxt where + markAST _ (GHC.WarningTxt (GHC.L ls txt) lss) = do + markExternal ls GHC.AnnOpen txt + mark GHC.AnnOpenS + markListIntercalate lss + mark GHC.AnnCloseS + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do + markExternal ls GHC.AnnOpen txt + mark GHC.AnnOpenS + markListIntercalate lss + mark GHC.AnnCloseS + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance Annotate GHC.StringLiteral where + markAST l (GHC.StringLiteral src _) = do + markExternal l GHC.AnnVal src + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.SourceText,GHC.FastString) where + markAST l (src,_fs) = do + markExternal l GHC.AnnVal src + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LIE name] where + markAST _ ls = do + inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl + mark GHC.AnnOpenP -- '(' + -- Can't use markListIntercalate, there can be trailing commas, but only in imports. + markListIntercalateWithFunLevel markLocated 2 ls + + mark GHC.AnnCloseP -- ')' + +instance (GHC.DataId name,GHC.HasOccName name, Annotate name) + => Annotate (GHC.IE name) where + markAST _ ie = do + + case ie of + (GHC.IEVar ln) -> do + -- TODO: I am pretty sure this criterion is inadequate + if GHC.isDataOcc $ GHC.occName $ GHC.unLoc ln + then mark GHC.AnnPattern + else markOptional GHC.AnnPattern + setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln + + (GHC.IEThingAbs ln) -> do + setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln + + (GHC.IEThingWith ln wc ns _lfs) -> do + setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln + mark GHC.AnnOpenP + case wc of + GHC.NoIEWildcard -> unsetContext Intercalate $ setContext (Set.fromList [PrefixOp,InIE]) + $ markListIntercalate ns + GHC.IEWildcard n -> do + setContext (Set.fromList [PrefixOp,Intercalate,InIE]) $ mapM_ markLocated (take n ns) + mark GHC.AnnDotdot + case drop n ns of + [] -> return () + ns' -> do + mark GHC.AnnComma + setContext (Set.fromList [PrefixOp,InIE]) $ mapM_ markLocated ns' + mark GHC.AnnCloseP + + (GHC.IEThingAll ln) -> do + setContext (Set.fromList [PrefixOp,InIE]) $ 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) + +-- --------------------------------------------------------------------- + +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 + -- Horrible hack until GHC 8.2 with https://phabricator.haskell.org/D3016 + typeIESym = isSym && (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n) + && spanLength l - length str > 6 -- length of "type" + 2 parens + canParen = isSym && rdrName2String n /= "$" + && (not typeIESym) + doNormalRdrName = do + let str' = case str of + -- TODO: unicode support? + "forall" -> if spanLength l == 1 then "∀" else str + _ -> str + -- when (isSym && (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n)) $ inContext (Set.singleton InIE) $ mark GHC.AnnType + when (spanLength l - length str > 4) $ inContext (Set.singleton InIE) $ mark GHC.AnnType + let str'' = if typeIESym then "(" ++ str' ++ ")" + else str' + + let + markParen :: GHC.AnnKeywordId -> Annotated () + markParen pa = do + if canParen + then ifInContext (Set.singleton PrefixOp) + (mark pa) -- '(' + (markOptional pa) + else if isSym + then ifInContext (Set.singleton PrefixOpDollar) + (mark pa) + (markOptional pa) + else markOptional pa + + 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 + 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 + mark GHC.AnnOpenP -- '(' + mark GHC.AnnTildehsh + mark GHC.AnnCloseP + "*" -> do + markExternal l GHC.AnnVal str + "★" -> do -- Note: unicode star + markExternal l GHC.AnnVal str + ":" -> do + -- Note: The OccName for ":" has the following attributes (via occAttributes) + -- (d, Data DataSym Sym Val ) + -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon + doNormalRdrName + -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName + ('(':',':_) -> do + mark GHC.AnnOpenP + let cnt = length $ filter (==',') str + replicateM_ cnt (mark GHC.AnnCommaTuple) + mark GHC.AnnCloseP -- ')' + _ -> do + let isSym' = isSymRdr (GHC.nameRdrName n') + when isSym' $ mark GHC.AnnOpenP -- '(' + markWithString GHC.AnnVal str + when isSym $ mark GHC.AnnCloseP -- ')' + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") + +-- --------------------------------------------------------------------- + +-- TODO: What is this used for? Not in ExactPrint +instance Annotate GHC.Name where + markAST l n = do + markExternal l GHC.AnnVal (showGhc n) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ImportDecl name) 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 "#-}" + when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc) + >> markWithString GHC.AnnClose "#-}") + when safeflag (mark GHC.AnnSafe) + when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) + case mpkg of + Nothing -> return () + Just (GHC.StringLiteral srcPkg _) -> markWithString GHC.AnnPackageName srcPkg + + markLocated modname + + case GHC.ideclAs imp of + Nothing -> return () + Just mn -> do + mark GHC.AnnAs + markWithString GHC.AnnVal (GHC.moduleNameString 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.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.LHsDecl name -> Annotated () +markLHsDecl (GHC.L l decl) = + case decl of + GHC.TyClD d -> markLocated (GHC.L l d) + GHC.InstD d -> markLocated (GHC.L l d) + GHC.DerivD d -> markLocated (GHC.L l d) + GHC.ValD d -> markLocated (GHC.L l d) + GHC.SigD d -> markLocated (GHC.L l d) + GHC.DefD d -> markLocated (GHC.L l d) + GHC.ForD d -> markLocated (GHC.L l d) + GHC.WarningD d -> markLocated (GHC.L l d) + GHC.AnnD d -> markLocated (GHC.L l d) + GHC.RuleD d -> markLocated (GHC.L l d) + GHC.VectD 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsDecl name) where + markAST l d = markLHsDecl (GHC.L l d) + +-- --------------------------------------------------------------------- + +instance (Annotate name) + => Annotate (GHC.RoleAnnotDecl name) where + markAST _ (GHC.RoleAnnotDecl ln mr) = do + mark GHC.AnnType + mark GHC.AnnRole + 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.SpliceDecl name) where + markAST _ (GHC.SpliceDecl e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do + setContext (Set.singleton InSpliceDecl) $ markLocated e + markTrailingSemi + markAST _ (GHC.SpliceDecl e flag) = do + case flag of + GHC.ExplicitSplice -> mark GHC.AnnOpenPE + GHC.ImplicitSplice -> return () + + setContext (Set.singleton InSpliceDecl) $ markLocated e + + case flag of + GHC.ExplicitSplice -> mark GHC.AnnCloseP + GHC.ImplicitSplice -> return () + + markTrailingSemi + +{- +- data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y) +- ImplicitSplice -- <=> f x y, i.e. a naked +- top level expression +- +-} + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.VectDecl name) where + markAST _ (GHC.HsVect src ln e) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" + markLocated ln + mark GHC.AnnEqual + markLocated e + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsNoVect src ln) = do + markWithString GHC.AnnOpen src -- "{-# NOVECTORISE" + markLocated ln + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsVectTypeIn src _b ln mln) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR" + mark GHC.AnnType + markLocated ln + case mln of + Nothing -> return () + Just lnn -> do + mark GHC.AnnEqual + markLocated lnn + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ GHC.HsVectTypeOut {} = + traceM "warning: HsVectTypeOut appears after renaming" + + markAST _ (GHC.HsVectClassIn src ln) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" + mark GHC.AnnClass + markLocated ln + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ GHC.HsVectClassOut {} = + traceM "warning: HsVecClassOut appears after renaming" + markAST _ GHC.HsVectInstIn {} = + traceM "warning: HsVecInstsIn appears after renaming" + markAST _ GHC.HsVectInstOut {} = + traceM "warning: HsVecInstOut appears after renaming" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.RuleDecls name) where + markAST _ (GHC.HsRules src rules) = do + markWithString GHC.AnnOpen src + setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules + markWithString GHC.AnnClose "#-}" + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.RuleDecl name) where + markAST _ (GHC.HsRule ln act bndrs lhs _ rhs _) = do + markLocated ln + setContext (Set.singleton ExplicitNeverActive) $ markActivation act + + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + markLocated lhs + mark GHC.AnnEqual + markLocated rhs + inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi + markTrailingSemi + +-- --------------------------------------------------------------------- + +markActivation :: GHC.Activation -> Annotated () +markActivation act = do + case act of + GHC.ActiveBefore src _ -> do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + markWithString GHC.AnnVal src + mark GHC.AnnCloseS -- ']' + GHC.ActiveAfter src _ -> do + mark GHC.AnnOpenS -- '[' + markWithString GHC.AnnVal src + mark GHC.AnnCloseS -- ']' + GHC.NeverActive -> do + inContext (Set.singleton ExplicitNeverActive) $ do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + mark GHC.AnnCloseS -- ']' + _ -> return () + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.RuleBndr name) where + markAST _ (GHC.RuleBndr ln) = markLocated ln + markAST _ (GHC.RuleBndrSig ln st) = do + mark GHC.AnnOpenP -- "(" + markLocated ln + mark GHC.AnnDcolon + markLHsSigWcType st + mark GHC.AnnCloseP -- ")" + +-- --------------------------------------------------------------------- + +markLHsSigWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.LHsSigWcType name -> Annotated () +markLHsSigWcType (GHC.HsIB _ (GHC.HsWC _ mwc ty)) = do + case mwc of + Nothing -> markLocated ty + Just lwc -> do + applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")] + ++ prepareListAnnotation [ty] + ) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.AnnDecl name) where + markAST _ (GHC.HsAnnotation src prov e) = do + markWithString GHC.AnnOpen src + 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 name => Annotate (GHC.WarnDecls name) where + markAST _ (GHC.Warnings src warns) = do + markWithString GHC.AnnOpen src + mapM_ markLocated warns + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance (Annotate name) + => Annotate (GHC.WarnDecl name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ForeignDecl name) where + markAST _ (GHC.ForeignImport ln (GHC.HsIB _ typ) _ + (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do +{- + = ForeignImport + { fd_name :: Located name -- defines this name + , fd_sig_ty :: LHsSigType name -- sig_ty + , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty + , fd_fi :: ForeignImport } + +-} + mark GHC.AnnForeign + mark GHC.AnnImport + markLocated cconv + unless (ll == GHC.noSrcSpan) $ markLocated safety + if GHC.unLoc cconv == GHC.PrimCallConv + then markExternal ls GHC.AnnVal src +#if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1)) + else markExternal ls GHC.AnnVal src +#else + else markExternal ls GHC.AnnVal (show src) +#endif + 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 (show 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.DerivDecl name) where + + markAST _ (GHC.DerivDecl (GHC.HsIB _ typ) mov) = do + mark GHC.AnnDeriving + mark GHC.AnnInstance + markMaybe mov + markLocated typ + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.DefaultDecl name) where + + markAST _ (GHC.DefaultDecl typs) = do + mark GHC.AnnDefault + mark GHC.AnnOpenP -- '(' + markListIntercalate typs + mark GHC.AnnCloseP -- ')' + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.InstDecl name) 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 + markAST _ (GHC.NoOverlap src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlappable src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlapping src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlaps src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Incoherent src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ClsInstDecl name) where + + markAST _ (GHC.ClsInstDecl (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do + mark GHC.AnnInstance + markMaybe mov + markLocated poly + if null (GHC.bagToList binds) && null sigs && null tyfams && null datafams + then markOptional GHC.AnnWhere + else do + 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.TyFamInstDecl name) where + + markAST _ (GHC.TyFamInstDecl eqn _) = do + mark GHC.AnnType + inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional + markLocated eqn + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.DataFamInstDecl name) where + + markAST l (GHC.DataFamInstDecl ln (GHC.HsIB _ pats) + 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 + inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance + + markLocated ctx + + markTyClass ln pats + + case (GHC.dd_kindSig defn) of + Just s -> do + mark GHC.AnnDcolon + markLocated s + Nothing -> return () + if isGadt $ GHC.dd_cons defn + then mark GHC.AnnWhere + else mark GHC.AnnEqual + markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs) + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsBind name) 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)) _typ _fvs _ticks) = do + markLocated lhs + case grhs of + (GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual -- empty guards + _ -> return () + markListIntercalateWithFunLevel markLocated 2 grhs + + case lb of + GHC.EmptyLocalBinds -> return () + _ -> do + mark GHC.AnnWhere + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + markLocalBindsWithLayout lb + markOptional GHC.AnnCloseC -- '}' + markTrailingSemi + + markAST _ (GHC.VarBind _n rhse _) = + -- Note: this bind is introduced by the typechecker + markLocated rhse + + markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do + mark GHC.AnnPattern + case args of + GHC.InfixPatSyn la lb -> do + markLocated la + setContext (Set.singleton InfixOp) $ markLocated ln + markLocated lb + GHC.PrefixPatSyn ns -> do + markLocated ln + mapM_ markLocated ns + GHC.RecordPatSyn 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 + + -- Introduced after renaming. + markAST _ (GHC.AbsBinds _ _ _ _ _) = + traceM "warning: AbsBinds introduced after renaming" + + -- Introduced after renaming. + markAST _ GHC.AbsBindsSig{} = + traceM "warning: AbsBindsSig introduced after renaming" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.IPBind name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, + Annotate body) + => Annotate (GHC.Match name (GHC.Located body)) where + + markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs (GHC.L _ lb))) = do + let + get_infix GHC.NonFunBindMatch = False + get_infix (GHC.FunBindMatch _ f) = f + isFunBind GHC.NonFunBindMatch = False + isFunBind GHC.FunBindMatch{} = True + case (get_infix mln,pats) of + (True, a:b:xs) -> do + if null xs + then markOptional GHC.AnnOpenP + else mark GHC.AnnOpenP + markLocated a + case mln of + GHC.NonFunBindMatch -> return () + GHC.FunBindMatch n _ -> setContext (Set.singleton InfixOp) $ markLocated n + 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.NonFunBindMatch -> mark GHC.AnnFunId + GHC.NonFunBindMatch -> markListNoPrecedingSpace False pats + GHC.FunBindMatch n _ -> do + -- setContext (Set.singleton NoPrecedingSpace) $ markLocated n + setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n + mapM_ markLocated 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name, + Annotate name, Annotate body) + => Annotate (GHC.GRHS name (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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.Sig name) 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 ln (GHC.HsIB _ typ)) = do + mark GHC.AnnPattern + markLocated ln + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + + markAST _ (GHC.ClassOpSig isDefault ns (GHC.HsIB _ typ)) = do + when isDefault $ mark GHC.AnnDefault + -- markListIntercalate ns + setContext (Set.singleton PrefixOp) $ markListIntercalate ns + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + + markAST _ (GHC.IdSig _) = + traceM "warning: Introduced after renaming" + + -- FixSig (FixitySig name) + 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 + markWithString GHC.AnnVal src + setContext (Set.singleton InfixOp) $ markListIntercalate lns + markTrailingSemi + + -- InlineSig (Located name) InlinePragma + -- '{-# INLINE' activation qvar '#-}' + markAST _ (GHC.InlineSig ln inl) = do + markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE' + markActivation (GHC.inl_act inl) + setContext (Set.singleton PrefixOp) $ markLocated ln + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + markAST _ (GHC.SpecSig ln typs inl) = do +{- + | SpecSig (Located name) -- Specialise a function or datatype ... + [LHsSigType name] -- ... to these types + InlinePragma -- The pragma on SPECIALISE_INLINE form. + -- If it's just defaultInlinePragma, then we said + -- SPECIALISE, not SPECIALISE_INLINE + +-} + markWithString GHC.AnnOpen (GHC.inl_src inl) + markActivation (GHC.inl_act inl) + markLocated ln + mark GHC.AnnDcolon -- '::' + markListIntercalateWithFunLevel markLHsSigType 2 typs + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + + -- '{-# SPECIALISE' 'instance' inst_type '#-}' + markAST _ (GHC.SpecInstSig src typ) = do + markWithString GHC.AnnOpen src + mark GHC.AnnInstance + markLHsSigType typ + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + + + -- MinimalSig (BooleanFormula (Located name)) + markAST _l (GHC.MinimalSig src formula) = do + markWithString GHC.AnnOpen src + markLocated formula + markWithString GHC.AnnClose "#-}" + markTrailingSemi + +-- -------------------------------------------------------------------- + +markLHsSigType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.LHsSigType name -> Annotated () +markLHsSigType (GHC.HsIB _ typ) = markLocated typ + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LHsSigType name] 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. + case ls of + [] -> markManyOptional GHC.AnnOpenP + [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnOpenP + [_] -> markManyOptional GHC.AnnOpenP + _ -> markMany GHC.AnnOpenP + markListIntercalateWithFun markLHsSigType ls + case ls of + [] -> markManyOptional GHC.AnnCloseP + [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnCloseP + [_] -> markManyOptional GHC.AnnCloseP + _ -> markMany 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 l (GHC.Or ls) = mapM_ markLocated ls + 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsTyVarBndr name) where + markAST _l (GHC.UserTyVar n) = do + markLocated n + + markAST _ (GHC.KindedTyVar n ty) = do + mark GHC.AnnOpenP -- '(' + markLocated n + mark GHC.AnnDcolon -- '::' + markLocated ty + mark GHC.AnnCloseP -- '(' + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsType name) where + markAST loc ty = do + markType loc ty + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + where + + -- markType :: GHC.SrcSpan -> ast -> Annotated () + markType _ (GHC.HsForAllTy tvs typ) = do + mark GHC.AnnForall + mapM_ markLocated tvs + mark GHC.AnnDot + markLocated typ + + {- + = HsForAllTy -- See Note [HsType binders] + { hst_bndrs :: [LHsTyVarBndr name] -- Explicit, user-supplied 'forall a b c' + , hst_body :: LHsType name -- body type + } + + -} + + markType _ (GHC.HsQualTy cxt typ) = do + markLocated cxt + markLocated typ + {- + | HsQualTy -- See Note [HsType binders] + { hst_ctxt :: LHsContext name -- Context C => blah + , hst_body :: LHsType name } + -} + + markType _l (GHC.HsTyVar name) = do + -- TODO: Should the isExactName test move into the RdrName Annotate instanced? + if ((GHC.isDataOcc $ GHC.occName $ GHC.unLoc name) && ((not $ isExactName $ GHC.unLoc name))) + || (showGhc name == "()") + then do + mark GHC.AnnSimpleQuote + markLocatedFromKw GHC.AnnName name + else markLocated name + + markType _ (GHC.HsAppsTy ts) = do + mapM_ markLocated ts + + markType _ (GHC.HsAppTy t1 t2) = do + setContext (Set.singleton PrefixOp) $ markLocated t1 + markLocated t2 + + markType _ (GHC.HsFunTy t1 t2) = do + markLocated t1 + mark GHC.AnnRarrow + markLocated t2 + + markType _ (GHC.HsListTy t) = do + mark GHC.AnnOpenS -- '[' + markLocated t + mark GHC.AnnCloseS -- ']' + + markType _ (GHC.HsPArrTy t) = do + markWithString GHC.AnnOpen "[:" -- '[:' + markLocated t + markWithString GHC.AnnClose ":]" -- ':]' + + 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.HsOpTy t1 lo t2) = do + -- HsOpTy (LHsType name) (Located name) (LHsType name) + 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 (GHC.HsIPName n) t) = do + markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n)) + mark GHC.AnnDcolon + markLocated t + + markType _ (GHC.HsEqTy t1 t2) = do + markLocated t1 + mark GHC.AnnTilde + markLocated t2 + + markType _ (GHC.HsKindSig t k) = do + mark GHC.AnnOpenP -- '(' + markLocated t + mark GHC.AnnDcolon -- '::' + markLocated k + mark GHC.AnnCloseP -- ')' + + markType l (GHC.HsSpliceTy s _) = do + markAST l s + + markType _ (GHC.HsDocTy t ds) = do + markLocated t + markLocated ds + + markType _ (GHC.HsBangTy (GHC.HsSrcBang mt _up str) t) = do + case mt of + Nothing -> return () + Just src -> do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + case str of + GHC.SrcLazy -> mark GHC.AnnTilde + GHC.SrcStrict -> mark GHC.AnnBang + GHC.NoSrcStrict -> return () + + markLocated t + {- + | HsBangTy HsSrcBang (LHsType name) -- Bang-style type annotations + data HsSrcBang = + HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes + SrcUnpackedness + SrcStrictness + data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' + | SrcStrict -- ^ Strict, ie '!' + | NoSrcStrict -- ^ no strictness annotation + + data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified + | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified + | NoSrcUnpack -- ^ no unpack pragma + + -} + + markType _ (GHC.HsRecTy cons) = do + mark GHC.AnnOpenC -- '{' + markListIntercalate cons + mark GHC.AnnCloseC -- '}' + + -- HsCoreTy Type + markType _ (GHC.HsCoreTy _t) = + traceM "warning: HsCoreTy Introduced after renaming" + + markType _ (GHC.HsExplicitListTy _ ts) = do + 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 + + -- HsTyLit HsTyLit + markType l (GHC.HsTyLit lit) = do + case lit of + (GHC.HsNumTy s _) -> + markExternal l GHC.AnnVal s + (GHC.HsStrTy s _) -> + markExternal l GHC.AnnVal s + + -- HsWrapTy HsTyAnnotated (HsType name) + + markType l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do + markExternal l GHC.AnnVal "_" + + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsAppType name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsSplice name) where + markAST l c = + case c of + GHC.HsQuasiQuote _ n _pos fs -> do + markExternal l GHC.AnnVal + ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") + + GHC.HsTypedSplice _n (GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do + markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) + GHC.HsTypedSplice _n b -> do + mark GHC.AnnOpenPTE + markLocated b + mark GHC.AnnCloseP + + GHC.HsUntypedSplice _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do + ifInContext (Set.singleton InSpliceDecl) + (return ()) + (mark GHC.AnnOpenPE) + -- TODO: We do not seem to have any way to distinguish between which of + -- the next two lines will emit output. If AnnThIdSplice is there, the + -- markLocated b ends up with a negative offset so emits nothing. + markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) + markLocated b + ifInContext (Set.singleton InSpliceDecl) + (return ()) + (mark GHC.AnnCloseP) + GHC.HsUntypedSplice _n b -> do + -- TODO: when is this not optional? + markOptional GHC.AnnThIdSplice + ifInContext (Set.singleton InSpliceDecl) + (return ()) + (mark GHC.AnnOpenPE) + markLocated b + ifInContext (Set.singleton InSpliceDecl) + (return ()) + (mark GHC.AnnCloseP) +#if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1)) + GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" +#endif + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => + Annotate (GHC.ConDeclField name) where + markAST _ (GHC.ConDeclField ns ty mdoc) = do +{- +data ConDeclField name -- Record fields have Haddoc docs on them + = ConDeclField { cd_fld_names :: [LFieldOcc name], + -- ^ See Note [ConDeclField names] + cd_fld_type :: LBangType name, + cd_fld_doc :: Maybe LHsDocString } + +-} + unsetContext Intercalate $ do + markListIntercalate ns + mark GHC.AnnDcolon + markLocated ty + markMaybe mdoc + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name) + => Annotate (GHC.FieldOcc name) where + markAST _ (GHC.FieldOcc rn _) = do + markLocated rn + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsDocString where + markAST l (GHC.HsDocString s) = do + markExternal l GHC.AnnVal (GHC.unpackFS s) + +-- --------------------------------------------------------------------- +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.Pat name) where + markAST loc typ = do + markPat loc typ + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") + where + markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" + markPat l (GHC.VarPat n) = do + -- The parser inserts a placeholder value for a record pun rhs. This must be + -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is + -- resolved, particularly for pretty printing where annotations are added. + let pun_RDR = "pun-right-hand-side" + when (showGhc n /= pun_RDR) $ + unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) + markPat _ (GHC.LazyPat p) = do + mark GHC.AnnTilde + markLocated p + + markPat _ (GHC.AsPat ln p) = do + markLocated ln + mark GHC.AnnAt + markLocated p + + markPat _ (GHC.ParPat p) = do + mark GHC.AnnOpenP + markLocated p + mark GHC.AnnCloseP + + markPat _ (GHC.BangPat p) = do + mark GHC.AnnBang + markLocated p + + markPat _ (GHC.ListPat ps _ _) = do + mark GHC.AnnOpenS + markListIntercalateWithFunLevel markLocated 2 ps + mark GHC.AnnCloseS + + markPat _ (GHC.TuplePat pats b _) = do + if b == GHC.Boxed then mark GHC.AnnOpenP + else markWithString GHC.AnnOpen "(#" + markListIntercalateWithFunLevel markLocated 2 pats + if b == GHC.Boxed then mark GHC.AnnCloseP + else markWithString GHC.AnnClose "#)" + + markPat _ (GHC.PArrPat ps _) = do + markWithString GHC.AnnOpen "[:" + mapM_ markLocated ps + markWithString GHC.AnnClose ":]" + + markPat _ (GHC.ConPatIn n dets) = do + markHsConPatDetails n dets + + markPat _ GHC.ConPatOut {} = + traceM "warning: ConPatOut Introduced after renaming" + + -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type) + markPat _ (GHC.ViewPat e pat _) = do + markLocated e + mark GHC.AnnRarrow + markLocated pat + + -- SplicePat (HsSplice id) + markPat l (GHC.SplicePat s) = do + markAST l s + + -- LitPat HsLit + markPat l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp) + + -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id) + markPat _ (GHC.NPat ol mn _ _) = do + -- markOptional GHC.AnnMinus + when (isJust mn) $ mark GHC.AnnMinus + markLocated ol + + -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id) + markPat _ (GHC.NPlusKPat ln ol _ _ _ _) = do + markLocated ln + markWithString GHC.AnnVal "+" -- "+" + markLocated ol + + + markPat _ (GHC.SigPatIn pat ty) = do + markLocated pat + mark GHC.AnnDcolon + markLHsSigWcType ty + + markPat _ GHC.SigPatOut {} = + traceM "warning: SigPatOut introduced after renaming" + + -- CoPat HsAnnotated (Pat id) Type + markPat _ GHC.CoPat {} = + traceM "warning: CoPat introduced after renaming" + +-- --------------------------------------------------------------------- +hsLit2String :: GHC.HsLit -> GHC.SourceText +hsLit2String lit = + case lit of + GHC.HsChar src _ -> src + -- It should be included here + -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 + GHC.HsCharPrim src _ -> src ++ "#" + GHC.HsString src _ -> src + GHC.HsStringPrim src _ -> src + GHC.HsInt src _ -> src + GHC.HsIntPrim src _ -> src + GHC.HsWordPrim src _ -> src + GHC.HsInt64Prim src _ -> src + GHC.HsWord64Prim src _ -> src + GHC.HsInteger src _ _ -> src + GHC.HsRat (GHC.FL src _) _ -> src + GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#" + GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##" + +markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.Located name -> GHC.HsConPatDetails name -> 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 + setContext (Set.singleton InfixOp) $ markLocated ln + markLocated a2 + +markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Bool -> Bool -> [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated () + +markHsConDeclDetails isDeprecated inGadt lns dets = do + case dets of + GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args + GHC.RecCon fs -> do + mark GHC.AnnOpenC + if inGadt + then do + if isDeprecated + then setContext (Set.fromList [InGadt]) $ markLocated fs + else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs + else do + if isDeprecated + then markLocated fs + else setContext (Set.fromList [InRecCon]) $ markLocated fs + GHC.InfixCon a1 a2 -> do + markLocated a1 + setContext (Set.singleton InfixOp) $ mapM_ markLocated lns + markLocated a2 + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LConDeclField name] where + markAST _ fs = do + markOptional GHC.AnnOpenC -- '{' + markListIntercalate fs + markOptional GHC.AnnDotdot + inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' + inContext (Set.singleton InGadt) $ do + mark GHC.AnnRarrow + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where + markAST l ol = + let str = case GHC.ol_val ol of + GHC.HsIntegral src _ -> src + GHC.HsFractional l2 -> GHC.fl_text l2 + GHC.HsIsString src _ -> src + in + markExternal l GHC.AnnVal str + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate arg) + => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where + markAST _ (GHC.HsIB _ thing) = do + markLocated thing + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name + ,GHC.HasOccName name,Annotate body) + => Annotate (GHC.Stmt name (GHC.Located body)) where + + markAST _ (GHC.LastStmt body _ _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body + + markAST _ (GHC.BindStmt pat body _ _ _) = do + unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat + mark GHC.AnnLarrow + unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body + + ifInContext (Set.singleton Intercalate) + (mark GHC.AnnComma) + (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) + markTrailingSemi + + markAST _ GHC.ApplicativeStmt{} + = error "ApplicativeStmt should not appear in ParsedSource" + + markAST _ (GHC.BodyStmt body _ _ _) = do + unsetContext Intercalate $ markLocated body + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + + markAST _ (GHC.LetStmt (GHC.L _ lb)) = do + mark GHC.AnnLet + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + markLocalBindsWithLayout lb + markOptional GHC.AnnCloseC -- '}' + ifInContext (Set.singleton Intercalate) + (mark GHC.AnnComma) + (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) + markTrailingSemi + + markAST l (GHC.ParStmt pbs _ _ _) = do + -- Within a given parallel list comprehension,one of the sections to be done + -- in parallel. It is a normal list comprehension, so has a list of + -- ParStmtBlock, one for each part of the sub- list comprehension + + + ifInContext (Set.singleton Intercalate) + ( + + unsetContext Intercalate $ + markListWithContextsFunction + (LC (Set.singleton Intercalate) -- only + Set.empty -- first + Set.empty -- middle + (Set.singleton Intercalate) -- last + ) (markAST l) pbs + ) + ( + unsetContext Intercalate $ + markListWithContextsFunction + (LC Set.empty -- only + (Set.fromList [AddVbar]) -- first + (Set.fromList [AddVbar]) -- middle + Set.empty -- last + ) (markAST l) pbs + ) + markTrailingSemi + + markAST _ (GHC.TransStmt form stmts _b using by _ _ _ _) = do + setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts + case form of + GHC.ThenForm -> do + mark GHC.AnnThen + unsetContext Intercalate $ markLocated using + case by of + Just b -> do + mark GHC.AnnBy + unsetContext Intercalate $ markLocated b + Nothing -> return () + GHC.GroupForm -> do + mark GHC.AnnThen + mark GHC.AnnGroup + case by of + Just b -> mark GHC.AnnBy >> markLocated b + Nothing -> return () + mark GHC.AnnUsing + markLocated using + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + + markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _) = do + mark GHC.AnnRec + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + mapM_ markLocated stmts + markOptional GHC.AnnCloseC + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + +-- --------------------------------------------------------------------- + +-- 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ParStmtBlock name name) where + markAST _ (GHC.ParStmtBlock stmts _ns _) = do + markListIntercalate stmts + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsLocalBinds name) where + markAST _ lb = markHsLocalBinds lb + +-- --------------------------------------------------------------------- + +markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.HsLocalBinds name -> Annotated () +markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = + applyListAnnotationsLayout + (prepareListAnnotation (GHC.bagToList binds) + ++ prepareListAnnotation sigs + ) +markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {}) + = traceM "warning: ValBindsOut introduced after renaming" + +markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout (reverse binds) +markHsLocalBinds GHC.EmptyLocalBinds = return () + +-- --------------------------------------------------------------------- + +markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, + Annotate body) + => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body) + -> Annotated () +markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _) + = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, + Annotate body) + => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsExpr name) where + markAST loc expr = do + markExpr loc expr + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + -- TODO: If the AnnComma is not needed, revert to markAST + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + where + markExpr _ (GHC.HsVar n) = unsetContext Intercalate $ do + ifInContext (Set.singleton PrefixOp) + (setContext (Set.singleton PrefixOp) $ markLocated n) + (ifInContext (Set.singleton InfixOp) + (setContext (Set.singleton InfixOp) $ markLocated n) + (markLocated n) + ) + + markExpr l (GHC.HsRecFld f) = markAST l f + + markExpr l (GHC.HsOverLabel fs) + = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) + + markExpr l (GHC.HsIPVar (GHC.HsIPName v)) = + markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v) + markExpr l (GHC.HsOverLit ov) = markAST l ov + markExpr l (GHC.HsLit lit) = markAST l lit + + markExpr _ (GHC.HsLam (GHC.MG (GHC.L _ [match]) _ _ _)) = do + setContext (Set.singleton LambdaExpr) $ do + -- TODO: Change this, HsLam binds do not need obey layout rules. + -- And will only ever have a single match + markLocated match + markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match" + + markExpr l (GHC.HsLamCase _ match) = do + mark GHC.AnnLam + mark GHC.AnnCase + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + markMatchGroup l match + markOptional GHC.AnnCloseC + + markExpr _ (GHC.HsApp e1 e2) = do + -- markLocated e1 + setContext (Set.singleton PrefixOp) $ markLocated e1 + -- markLocated e2 + 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 l (GHC.HsCase e1 matches) = setRigidFlag $ do + mark GHC.AnnCase + setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 + mark GHC.AnnOf + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + setContext (Set.singleton CaseAlt) $ markMatchGroup l matches + markOptional GHC.AnnCloseC + + -- We set the layout for HsIf even though it need not obey layout rules as + -- when moving these expressions it's useful that they maintain "internal + -- integrity", that is to say the subparts remain indented relative to each + -- other. + markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do + -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do + mark GHC.AnnIf + markLocated e1 + markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen + mark GHC.AnnThen + setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 + markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse + mark GHC.AnnElse + setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 + + markExpr _ (GHC.HsMultiIf _ rhs) = do + mark GHC.AnnIf + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + -- mapM_ markLocated rhs + markListWithLayout rhs + markOptional GHC.AnnCloseC + + markExpr _ (GHC.HsLet (GHC.L _ binds) e) = do + setLayoutFlag (do -- Make sure the 'in' gets indented too + mark GHC.AnnLet + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + markLocalBindsWithLayout binds + markOptional GHC.AnnCloseC + mark GHC.AnnIn + markLocated e) + + -- ------------------------------- + + markExpr _ (GHC.HsDo cts (GHC.L _ es) _) = do + case cts of + GHC.DoExpr -> mark GHC.AnnDo + GHC.MDoExpr -> mark GHC.AnnMdo + _ -> return () + let (ostr,cstr) = + if isListComp cts + then case cts of + GHC.PArrComp -> ("[:",":]") + _ -> ("[", "]") + 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.ExplicitPArr _ es) = do + markWithString GHC.AnnOpen "[:" + markListIntercalate es + markWithString GHC.AnnClose ":]" + + 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 _cons _ _ _) = 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.ExprWithTySigOut e typ) = do + 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.PArrSeq _ seqInfo) = do + markWithString GHC.AnnOpen "[:" -- '[:' + 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 + markWithString GHC.AnnClose ":]" -- ':]' + + markExpr _ (GHC.HsSCC src csFStr e) = do + markWithString GHC.AnnOpen src -- "{-# SCC" + markWithStringOptional GHC.AnnVal (GHC.sl_st csFStr) + markWithString GHC.AnnValStr (GHC.sl_st csFStr) + markWithString GHC.AnnClose "#-}" + markLocated e + + markExpr _ (GHC.HsCoreAnn src csFStr e) = do + markWithString GHC.AnnOpen src -- "{-# CORE" + markWithString GHC.AnnVal (GHC.sl_st 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 + markWithString GHC.AnnClose "|]" + -- Introduced after the renamer + markExpr _ (GHC.HsBracket (GHC.DecBrG _)) = + traceM "warning: DecBrG introduced after renamer" + markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do + markWithString GHC.AnnOpen "[|" + markOptional GHC.AnnOpenE -- "[e|" + markLocated e + markWithString GHC.AnnClose "|]" + 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 + markWithString GHC.AnnClose "|]" + markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do + markWithString GHC.AnnOpen "[p|" + markLocated e + markWithString GHC.AnnClose "|]" + + markExpr _ (GHC.HsRnBracketOut _ _) = + traceM "warning: HsRnBracketOut introduced after renamer" + markExpr _ (GHC.HsTcBracketOut _ _) = + traceM "warning: HsTcBracketOut introduced after renamer" + + -- -------------------------------- + + -- markExpr l (GHC.HsSpliceE e@(GHC.HsUntypedSplice _ (GHC.L _ (GHC.HsSpliceE{})))) = do + -- mark GHC.AnnOpenPE + -- markAST l e + -- mark GHC.AnnCloseP + markExpr l (GHC.HsSpliceE e) = do + markOptional GHC.AnnOpenPE + markAST l e + markOptional GHC.AnnCloseP + + -- -------------------------------- + + markExpr _ (GHC.HsProc p c) = do + mark GHC.AnnProc + markLocated p + mark GHC.AnnRarrow + markLocated c + + markExpr _ (GHC.HsStatic e) = do + mark GHC.AnnStatic + markLocated e + + markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do + -- isRightToLeft True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + if isRightToLeft + then do + markLocated e1 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail + else do + markLocated e2 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail + + if isRightToLeft + then markLocated e2 + else markLocated e1 + + markExpr _ (GHC.HsArrForm e _ cs) = do + markWithString GHC.AnnOpen "(|" + markLocated e + mapM_ markLocated cs + markWithString GHC.AnnClose "|)" + + markExpr _ (GHC.HsTick _ _) = return () + markExpr _ (GHC.HsBinTick _ _ _) = return () + + markExpr _ (GHC.HsTickPragma src (str,_,_) ((v1,v2),(v3,v4)) e) = do + -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' + markWithString GHC.AnnOpen src + markOffsetWithString GHC.AnnVal 0 (GHC.sl_st str) -- STRING + markOffsetWithString GHC.AnnVal 1 v1 -- INTEGER + markOffset GHC.AnnColon 0 -- ':' + markOffsetWithString GHC.AnnVal 2 v2 -- INTEGER + mark GHC.AnnMinus -- '-' + markOffsetWithString GHC.AnnVal 3 v3 -- INTEGER + markOffset GHC.AnnColon 1 -- ':' + markOffsetWithString GHC.AnnVal 4 v4 -- INTEGER + markWithString GHC.AnnClose "#-}" + markLocated e + + markExpr l GHC.EWildPat = do + markExternal l GHC.AnnVal "_" + + markExpr _ (GHC.EAsPat ln e) = do + markLocated ln + mark GHC.AnnAt + markLocated e + + markExpr _ (GHC.EViewPat e1 e2) = do + markLocated e1 + mark GHC.AnnRarrow + markLocated e2 + + markExpr _ (GHC.ELazyPat e) = do + mark GHC.AnnTilde + markLocated e + + markExpr _ (GHC.HsAppType e ty) = do + markLocated e + mark GHC.AnnAt + markLHsWcType ty + markExpr _ (GHC.HsAppTypeOut _ _) = + traceM "warning: HsAppTypeOut introduced after renaming" + + markExpr _ (GHC.HsWrap _ _) = + traceM "warning: HsWrap introduced after renaming" + markExpr _ (GHC.HsUnboundVar _) = + traceM "warning: HsUnboundVar introduced after renaming" + + +-- --------------------------------------------------------------------- + +markLHsWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.LHsWcType name -> Annotated () +markLHsWcType (GHC.HsWC _ mwc ty) = do + case mwc of + Nothing -> markLocated ty + Just lwc -> do + -- let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildCardTy:[ty]) + -- markLocated (GHC.L lc sorted) + applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")] + ++ prepareListAnnotation [ty] + ) + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsLit where + markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsRecUpdField name) 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 +{- +type HsRecUpdField id = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id) + +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', +-- +-- For details on above see note [Api annotations] in ApiAnnotation +data HsRecField' id arg = HsRecField { + hsRecFieldLbl :: Located id, + hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning + hsRecPun :: Bool -- ^ Note [Punning] + } deriving (Data, Typeable) + +-} + +instance (GHC.DataId name) + => Annotate (GHC.AmbiguousFieldOcc name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.ExprLStmt name] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsTupArg name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsCmdTop name) where + markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.HsCmd name) 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 _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 + + -- TODO: This test assumes no auto-generated SrcSpans + let isPrefixOp = case cs of + [] -> True + (GHC.L h _:_) -> GHC.getLoc e < h + when isPrefixOp $ markWithString GHC.AnnOpen "(|" + -- 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 $ markWithString GHC.AnnClose "|)" + + markAST _ (GHC.HsCmdApp e1 e2) = do + markLocated e1 + markLocated e2 + + markAST l (GHC.HsCmdLam match) = do + setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match + + markAST _ (GHC.HsCmdPar e) = do + mark GHC.AnnOpenP + markLocated e + mark GHC.AnnCloseP -- ')' + + markAST l (GHC.HsCmdCase e1 matches) = do + mark GHC.AnnCase + markLocated e1 + mark GHC.AnnOf + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + markMatchGroup l matches + markOptional GHC.AnnCloseC + + markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do + mark GHC.AnnIf + markLocated e1 + markOffset GHC.AnnSemi 0 + mark GHC.AnnThen + markLocated e2 + markOffset GHC.AnnSemi 1 + mark GHC.AnnElse + markLocated e3 + + markAST _ (GHC.HsCmdLet (GHC.L _ binds) e) = do + mark GHC.AnnLet + markOptional GHC.AnnOpenC + markLocalBindsWithLayout binds + markOptional GHC.AnnCloseC + mark GHC.AnnIn + markLocated e + + markAST _ (GHC.HsCmdDo (GHC.L _ es) _) = do + mark GHC.AnnDo + markOptional GHC.AnnOpenC + markListWithLayout es + markOptional GHC.AnnCloseC + + + markAST _ (GHC.HsCmdWrap {}) = + traceM "warning: HsCmdWrap introduced after renaming" +{- + | HsCmdWrap HsWrapper + (HsCmd id) -- If cmd :: arg1 --> res + -- wrap :: arg1 "->" arg2 + -- Then (HsCmdWrap wrap cmd) :: arg2 --> res +-} + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.TyClDecl name) where + + markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi + + markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars _) 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 ln tyvars + mark GHC.AnnEqual + markLocated typ + markTrailingSemi + + markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars _) + (GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _ _) = do + if nd == GHC.DataType + then mark GHC.AnnData + else mark GHC.AnnNewtype + markMaybe mctyp + when (null (GHC.unLoc ctx)) $ markOptional GHC.AnnDarrow + markLocated ctx + markTyClass 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]) $ markMaybe mderivs + markTrailingSemi + + -- ----------------------------------- + + markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars _) fds + sigs meths ats atdefs docs _) = do + mark GHC.AnnClass + markLocated ctx + + markTyClass 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 + +-- --------------------------------------------------------------------- + +markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) + => GHC.Located a -> [GHC.Located ast] -> Annotated () +markTyClass ln tyVars = do + markManyOptional GHC.AnnOpenP + + let + parensNeeded = GHC.isSymOcc (GHC.occName $ GHC.unLoc ln) && length tyVars > 2 + lnFun = do + ifInContext (Set.singleton CtxMiddle) + (setContext (Set.singleton InfixOp) $ markLocated ln) + (markLocated ln) + listFun b = do + if parensNeeded + then ifInContext (Set.singleton (CtxPos 0)) + (markMany GHC.AnnOpenP) + (return ()) + else ifInContext (Set.singleton (CtxPos 0)) + (markManyOptional GHC.AnnOpenP) + (return ()) + + markLocated b + + if parensNeeded + then ifInContext (Set.singleton (CtxPos 2)) + (markMany GHC.AnnCloseP) + (return ()) + else ifInContext (Set.singleton (CtxPos 2)) + (markManyOptional GHC.AnnCloseP) + (return ()) + + prepareListFun ls = map (\b -> (GHC.getLoc b, listFun b )) ls + + unsetContext CtxMiddle $ + applyListAnnotationsContexts (LC (Set.fromList [CtxOnly,PrefixOp]) (Set.fromList [CtxFirst,PrefixOp]) + (Set.singleton CtxMiddle) (Set.singleton CtxLast)) + ([(GHC.getLoc ln,lnFun)] + ++ prepareListFun tyVars) + markManyOptional GHC.AnnCloseP + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.FamilyDecl name) where + markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars _) rsig minj) = do +{- +data FamilyDecl name = FamilyDecl + { fdInfo :: FamilyInfo name -- type/data, closed/open + , fdLName :: Located name -- type constructor + , fdTyVars :: LHsQTyVars name -- type variables + , fdResultSig :: LFamilyResultSig name -- result signature + , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann + } +-} + case info of + GHC.DataFamily -> mark GHC.AnnData + _ -> mark GHC.AnnType + + -- ifInContext (Set.singleton InClassDecl) (return ()) (mark GHC.AnnFamily) + mark GHC.AnnFamily + + markTyClass 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 (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.FamilyResultSig name) where + markAST _ (GHC.NoSig) = return () + markAST _ (GHC.KindSig k) = markLocated k + markAST _ (GHC.TyVarSig ltv) = markLocated ltv + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name) + => Annotate (GHC.InjectivityAnn name) where + markAST _ (GHC.InjectivityAnn ln lns) = do + markLocated ln + mark GHC.AnnRarrow + mapM_ markLocated lns + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.TyFamInstEqn name) where + markAST _ (GHC.TyFamEqn ln (GHC.HsIB _ pats) typ) = do + markTyClass ln pats + -- let + -- fun = ifInContext (Set.singleton (CtxPos 0)) + -- (setContext (Set.singleton PrefixOp) $ markLocated ln) + -- (markLocated ln) + -- markOptional GHC.AnnOpenP + -- applyListAnnotationsContexts (LC Set.empty Set.empty Set.empty Set.empty) + -- ([(GHC.getLoc ln, fun)] + -- ++ prepareListAnnotationWithContext (Set.singleton PrefixOp) pats) + -- markOptional GHC.AnnCloseP + mark GHC.AnnEqual + markLocated typ + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.TyFamDefltEqn name) where + markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs _) typ) = do + mark GHC.AnnType + mark GHC.AnnInstance + applyListAnnotations (prepareListAnnotation [ln] + ++ prepareListAnnotation bndrs + ) + mark GHC.AnnEqual + markLocated typ + +-- --------------------------------------------------------------------- + +-- 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 (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocCommentPrev (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocGroup _i (GHC.HsDocString fs)) -> GHC.unpackFS fs + in + markExternal l GHC.AnnVal str >> markTrailingSemi + +-- --------------------------------------------------------------------- + +markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated () +markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons mderivs) = do + markLocated ctx + markMaybe typ + if isGadt cons + then markListWithLayout cons + else markListIntercalateWithFunLevel markLocated 2 cons + case mderivs of + Nothing -> return () + Just d -> setContext (Set.singleton Deriving) $ markLocated d + +-- --------------------------------------------------------------------- + +-- Note: GHC.HsContext name aliases to here too +instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LHsType name] where + markAST l ts = do + -- Mote: A single item in parens in a deriving clause is parsed as a + -- HsSigType, which is always a HsForAllTy. 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 + [_] -> markManyOptional pa + _ -> markMany pa + + parenIfNeeded'' pa = + ifInContext (Set.singleton Parens) + (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 (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.ConDecl name) where + markAST _ (GHC.ConDeclH98 ln mqtvs mctx + dets _ ) = do +{- + | ConDeclH98 + { con_name :: Located name + + , con_qvars :: Maybe (LHsQTyVars name) + -- User-written forall (if any), and its implicit + -- kind variables + -- Non-Nothing needs -XExistentialQuantification + -- e.g. data T a = forall b. MkT b (b->a) + -- con_qvars = {b} + + , con_cxt :: Maybe (LHsContext name) + -- ^ User-written context (if any) + + , con_details :: HsConDeclDetails name + -- ^ Arguments + + , con_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + +-} + case mqtvs of + Nothing -> return () + Just (GHC.HsQTvs _ns bndrs _) -> do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + case mctx of + Just ctx -> do + setContext (Set.fromList [NoDarrow]) $ markLocated ctx + unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow + Nothing -> return () + + case dets of + GHC.InfixCon _ _ -> return () + _ -> setContext (Set.singleton PrefixOp) $ markLocated ln + + markHsConDeclDetails False False [ln] dets + + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar + markTrailingSemi + markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ) _) = do + setContext (Set.singleton PrefixOp) $ markListIntercalate lns + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + +-- ResTyGADT has a SrcSpan for the original sigtype, we need to create +-- a type for exactPC and annotatePC +data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name] + deriving (Typeable) +deriving instance (GHC.DataId name) => Data (ResTyGADTHook name) +deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name) + +instance (GHC.OutputableBndr name) => GHC.Outputable (ResTyGADTHook name) where + ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) + => Annotate (ResTyGADTHook name) where + markAST _ (ResTyGADTHook bndrs) = do + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + +-- --------------------------------------------------------------------- + +instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.HsRecField name (GHC.LPat name)) 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 name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) + => Annotate (GHC.HsRecField name (GHC.LHsExpr name)) 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 (GHC.DataId name,Annotate name) + => Annotate (GHC.FunDep (GHC.Located name)) where + + markAST _ (ls,rs) = do + mapM_ markLocated ls + mark GHC.AnnRarrow + mapM_ markLocated rs + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate GHC.CType where + markAST _ (GHC.CType src mh f) = do + markWithString GHC.AnnOpen src + case mh of + Nothing -> return () + Just (GHC.Header srcH _h) -> + markWithString GHC.AnnHeader srcH + markWithString GHC.AnnVal (fst f) + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- diff --git a/src-ghc82/Language/Haskell/GHC/ExactPrint/Annotater.hs b/src-ghc82/Language/Haskell/GHC/ExactPrint/Annotater.hs new file mode 100644 --- /dev/null +++ b/src-ghc82/Language/Haskell/GHC/ExactPrint/Annotater.hs @@ -0,0 +1,2660 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook +-- | 'annotate' is a function which given a GHC AST fragment, constructs +-- a syntax tree which indicates which annotations belong to each specific +-- part of the fragment. +-- +-- "Delta" and "Print" provide two interpreters for this structure. You +-- should probably use those unless you know what you're doing! +-- +-- The functor 'AnnotationF' has a number of constructors which correspond +-- to different sitations which annotations can arise. It is hoped that in +-- future versions of GHC these can be simplified by making suitable +-- modifications to the AST. + +module Language.Haskell.GHC.ExactPrint.Annotater + ( + annotate + , AnnotationF(..) + , Annotated + , Annotate(..) + , withSortKeyContextsHelper + ) where + + +import Language.Haskell.GHC.ExactPrint.AnnotateTypes +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils + +import qualified Bag as GHC +import qualified BasicTypes as GHC +import qualified BooleanFormula as GHC +import qualified Class as GHC +import qualified CoAxiom as GHC +import qualified FastString as GHC +import qualified ForeignCall as GHC +import qualified GHC as GHC +import qualified Name as GHC +import qualified RdrName as GHC +import qualified Outputable as GHC + +import Control.Monad.Identity +import Data.Data +import Data.Maybe + +import qualified Data.Set as Set + +import Debug.Trace + + +{-# ANN module "HLint: ignore Eta reduce" #-} +{-# ANN module "HLint: ignore Redundant do" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} +-- --------------------------------------------------------------------- + +class Data ast => Annotate ast where + markAST :: GHC.SrcSpan -> ast -> Annotated () + +-- --------------------------------------------------------------------- + +-- | Construct a syntax tree which represent which KeywordIds must appear +-- where. +annotate :: (Annotate ast) => GHC.Located ast -> Annotated () +annotate = markLocated + +-- --------------------------------------------------------------------- + +-- | Constructs a syntax tree which contains information about which +-- annotations are required by each element. +markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () +markLocated ast = + case cast ast :: Maybe (GHC.LHsDecl GHC.RdrName) 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.RdrName -> Annotated () +markLocalBindsWithLayout binds = markHsLocalBinds binds + +-- --------------------------------------------------------------------- + +-- |This function is used to get around shortcomings in the GHC AST for 7.10.1 +markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () +markLocatedFromKw kw (GHC.L l a) = do + -- Note: l is needed so that the pretty printer can make something up + ss <- getSrcSpanForKw l kw + AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) + markLocated (GHC.L ss' a) + +-- --------------------------------------------------------------------- + +markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () +markMaybe Nothing = return () +markMaybe (Just ast) = markLocated ast + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + +prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] +prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsModule GHC.RdrName) where + markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do + + case mmn of + Nothing -> return () + Just (GHC.L ln mn) -> do + mark GHC.AnnModule + markExternal ln GHC.AnnVal (GHC.moduleNameString mn) + + forM_ mdepr markLocated + forM_ mexp markLocated + + mark GHC.AnnWhere + + markOptional GHC.AnnOpenC -- Possible '{' + markManyOptional GHC.AnnSemi -- possible leading semis + setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps + + setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs + + markOptional GHC.AnnCloseC -- Possible '}' + + markEOF + +-- --------------------------------------------------------------------- + +instance Annotate GHC.WarningTxt where + markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do + markAnnOpen txt "{-# WARNING" + mark GHC.AnnOpenS + markListIntercalate lss + mark GHC.AnnCloseS + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do + -- markExternal ls GHC.AnnOpen txt + 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 (GHC.DataId name,GHC.HasOccName name,Annotate name) + => Annotate [GHC.LIE name] where + markAST _ ls = do + inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl + mark GHC.AnnOpenP -- '(' + -- Can't use markListIntercalate, there can be trailing commas, but only in imports. + markListIntercalateWithFunLevel markLocated 2 ls + + mark GHC.AnnCloseP -- ')' + +instance (GHC.DataId name,GHC.HasOccName name, Annotate name) + => Annotate (GHC.IE name) 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 + setContext (Set.singleton PrefixOp) $ mapM_ markLocated 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 (GHC.DataId name,GHC.HasOccName name, Annotate name) + => Annotate (GHC.IEWrappedName name) 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 +{- +data IEWrappedName name + = IEName (Located name) -- ^ no extra + | IEPattern (Located name) -- ^ pattern X + | IEType (Located name) -- ^ type (:+:) + deriving (Eq,Data) + +-} +-- --------------------------------------------------------------------- +{- +-- For details on above see note [Api annotations] in ApiAnnotation +data RdrName + = Unqual OccName + -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving (Data, Typeable) +-} + +isSymRdr :: GHC.RdrName -> Bool +isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." + +instance Annotate GHC.RdrName where + markAST l n = do + let + str = rdrName2String n + isSym = isSymRdr n + canParen = isSym && rdrName2String 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 canParen + then ifInContext (Set.singleton PrefixOp) + (mark pa) -- '(' + (markOptional pa) + else if isSym + then ifInContext (Set.singleton PrefixOpDollar) + (mark pa) + (markOptional pa) + else markOptional pa + + 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 + 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 + mark GHC.AnnOpenP -- '(' + mark GHC.AnnTildehsh + mark GHC.AnnCloseP + "*" -> do + markExternal l GHC.AnnVal str + "★" -> do -- Note: unicode star + markExternal l GHC.AnnVal str + ":" -> do + -- Note: The OccName for ":" has the following attributes (via occAttributes) + -- (d, Data DataSym Sym Val ) + -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon + doNormalRdrName + -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName + ('(':',':_) -> do + mark GHC.AnnOpenP + let cnt = length $ filter (==',') str + replicateM_ cnt (mark GHC.AnnCommaTuple) + mark GHC.AnnCloseP -- ')' + _ -> do + let isSym' = isSymRdr (GHC.nameRdrName n') + when isSym' $ mark GHC.AnnOpenP -- '(' + markWithString GHC.AnnVal str + when isSym $ mark GHC.AnnCloseP -- ')' + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") + +-- --------------------------------------------------------------------- + +-- TODO: What is this used for? Not in ExactPrint +instance Annotate GHC.Name where + markAST l n = do + markExternal l GHC.AnnVal (showGhc n) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.HasOccName name,Annotate name) + => Annotate (GHC.ImportDecl name) where + markAST _ imp@(GHC.ImportDecl msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do + + -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec + mark GHC.AnnImport + + -- "{-# SOURCE" and "#-}" + case msrc of + GHC.SourceText _txt -> do + markAnnOpen msrc "{-# SOURCE" + markWithString GHC.AnnClose "#-}" + GHC.NoSourceText -> return () + when safeflag (mark GHC.AnnSafe) + when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) + case mpkg of + Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> + markWithString GHC.AnnPackageName srcPkg + _ -> return () + + markLocated modname + + case GHC.ideclAs imp of + Nothing -> return () + Just mn -> do + mark GHC.AnnAs + markLocated mn + + case hiding of + Nothing -> return () + Just (isHiding,lie) -> do + if isHiding + then setContext (Set.singleton HasHiding) $ + markLocated lie + else markLocated lie + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance Annotate GHC.ModuleName where + markAST l mname = + markExternal l GHC.AnnVal (GHC.moduleNameString mname) + +-- --------------------------------------------------------------------- + +markLHsDecl :: GHC.LHsDecl GHC.RdrName -> Annotated () +markLHsDecl (GHC.L l decl) = + case decl of + GHC.TyClD d -> markLocated (GHC.L l d) + GHC.InstD d -> markLocated (GHC.L l d) + GHC.DerivD d -> markLocated (GHC.L l d) + GHC.ValD d -> markLocated (GHC.L l d) + GHC.SigD d -> markLocated (GHC.L l d) + GHC.DefD d -> markLocated (GHC.L l d) + GHC.ForD d -> markLocated (GHC.L l d) + GHC.WarningD d -> markLocated (GHC.L l d) + GHC.AnnD d -> markLocated (GHC.L l d) + GHC.RuleD d -> markLocated (GHC.L l d) + GHC.VectD 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.RdrName) where + markAST l d = markLHsDecl (GHC.L l d) + +-- --------------------------------------------------------------------- + +instance (Annotate name) + => Annotate (GHC.RoleAnnotDecl name) where + markAST _ (GHC.RoleAnnotDecl ln mr) = do + mark GHC.AnnType + mark GHC.AnnRole + 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.RdrName) 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.VectDecl GHC.RdrName) where + markAST _ (GHC.HsVect src ln e) = do + markAnnOpen src "{-# VECTORISE" + markLocated ln + mark GHC.AnnEqual + markLocated e + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsNoVect src ln) = do + markAnnOpen src "{-# NOVECTORISE" + markLocated ln + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsVectTypeIn src _b ln mln) = do + markAnnOpen src "{-# VECTORISE" -- or "{-# VECTORISE SCALAR" + mark GHC.AnnType + markLocated ln + case mln of + Nothing -> return () + Just lnn -> do + mark GHC.AnnEqual + markLocated lnn + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ GHC.HsVectTypeOut {} = + traceM "warning: HsVectTypeOut appears after renaming" + + markAST _ (GHC.HsVectClassIn src ln) = do + markAnnOpen src "{-# VECTORISE" + mark GHC.AnnClass + markLocated ln + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ GHC.HsVectClassOut {} = + traceM "warning: HsVecClassOut appears after renaming" + markAST _ GHC.HsVectInstIn {} = + traceM "warning: HsVecInstsIn appears after renaming" + markAST _ GHC.HsVectInstOut {} = + traceM "warning: HsVecInstOut appears after renaming" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.RuleDecls GHC.RdrName) where + markAST _ (GHC.HsRules src rules) = do + markAnnOpen src "{-# RULES" + setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules + markWithString GHC.AnnClose "#-}" + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.RuleDecl GHC.RdrName) where + markAST l (GHC.HsRule ln act bndrs lhs _ rhs _) = do + markLocated ln + setContext (Set.singleton ExplicitNeverActive) $ markActivation l act + + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + markLocated lhs + mark GHC.AnnEqual + markLocated rhs + inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi + markTrailingSemi + +-- --------------------------------------------------------------------- + +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.RdrName) where + markAST _ (GHC.RuleBndr ln) = markLocated ln + markAST _ (GHC.RuleBndrSig ln st) = do + mark GHC.AnnOpenP -- "(" + markLocated ln + mark GHC.AnnDcolon + markLHsSigWcType st + mark GHC.AnnCloseP -- ")" + +-- --------------------------------------------------------------------- + +markLHsSigWcType :: GHC.LHsSigWcType GHC.RdrName -> Annotated () +markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty _)) = do + markLocated ty + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.AnnDecl GHC.RdrName) 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 name => Annotate (GHC.WarnDecls name) where + markAST _ (GHC.Warnings src warns) = do + markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED + mapM_ markLocated warns + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance (Annotate name) + => Annotate (GHC.WarnDecl name) 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.RdrName) 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.RdrName) where + + markAST _ (GHC.DerivDecl typ ms mov) = do + mark GHC.AnnDeriving + markMaybe ms + mark GHC.AnnInstance + markMaybe mov + markLHsSigType typ + markTrailingSemi +{- +stand_alone_deriving :: { LDerivDecl RdrName } + : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type + {% do { let { err = text "in the stand-alone deriving instance" + <> colon <+> quotes (ppr $5) } + ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4)) + [mj AnnDeriving $1, mj AnnInstance $3] } } + +data DerivDecl name = DerivDecl + { deriv_type :: LHsSigType name + , deriv_strategy :: Maybe (Located DerivStrategy) + , deriv_overlap_mode :: Maybe (Located OverlapMode) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', + -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock', + -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + } +-} + +-- --------------------------------------------------------------------- + +instance Annotate GHC.DerivStrategy where + + markAST _ GHC.StockStrategy = mark GHC.AnnStock + markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass + markAST _ GHC.NewtypeStrategy = mark GHC.AnnNewtype + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.DefaultDecl GHC.RdrName) where + + markAST _ (GHC.DefaultDecl typs) = do + mark GHC.AnnDefault + mark GHC.AnnOpenP -- '(' + markListIntercalate typs + mark GHC.AnnCloseP -- ')' + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.InstDecl GHC.RdrName) 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.RdrName) 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.RdrName) where + + markAST _ (GHC.TyFamInstDecl eqn _) = do + mark GHC.AnnType + inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional + markLocated eqn + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.DataFamInstDecl GHC.RdrName) where + + markAST l (GHC.DataFamInstDecl ln (GHC.HsIB _ 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 + inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance + + markLocated ctx + + markTyClass fixity ln pats + + case (GHC.dd_kindSig defn) of + Just s -> do + mark GHC.AnnDcolon + markLocated s + Nothing -> return () + if isGadt $ GHC.dd_cons defn + then mark GHC.AnnWhere + else mark GHC.AnnEqual + markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs) + markTrailingSemi + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsBind GHC.RdrName) 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)) _typ _fvs _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 + + markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do + mark GHC.AnnPattern + case args of + GHC.InfixPatSyn la lb -> do + markLocated la + setContext (Set.singleton InfixOp) $ markLocated ln + markLocated lb + GHC.PrefixPatSyn ns -> do + markLocated ln + mapM_ markLocated ns + GHC.RecordPatSyn 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 + + -- Introduced after renaming. + markAST _ (GHC.AbsBinds _ _ _ _ _) = + traceM "warning: AbsBinds introduced after renaming" + + -- Introduced after renaming. + markAST _ GHC.AbsBindsSig{} = + traceM "warning: AbsBindsSig introduced after renaming" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.IPBind GHC.RdrName) 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.RdrName (GHC.Located body)) where + + markAST _ (GHC.Match mln pats _typ (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 _ -> do + setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ 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.RdrName (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.RdrName) where + + markAST _ (GHC.TypeSig lns st) = do + setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns + mark GHC.AnnDcolon + markLHsSigWcType st + markTrailingSemi + tellContext (Set.singleton FollowingLine) + + markAST _ (GHC.PatSynSig lns (GHC.HsIB _ typ _)) = do + mark GHC.AnnPattern + markListIntercalate lns + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + + markAST _ (GHC.ClassOpSig isDefault ns (GHC.HsIB _ typ _)) = do + when isDefault $ mark GHC.AnnDefault + setContext (Set.singleton PrefixOp) $ markListIntercalate ns + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + + markAST _ (GHC.IdSig _) = + traceM "warning: Introduced after renaming" + + markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity src v fdir))) = do + let fixstr = case fdir of + GHC.InfixL -> "infixl" + GHC.InfixR -> "infixr" + GHC.InfixN -> "infix" + markWithString GHC.AnnInfix fixstr + markSourceText src (show v) + setContext (Set.singleton InfixOp) $ markListIntercalate lns + markTrailingSemi + + markAST l (GHC.InlineSig ln inl) = do + markAnnOpen (GHC.inl_src inl) "{-# INLINE" + markActivation l (GHC.inl_act inl) + setContext (Set.singleton PrefixOp) $ markLocated ln + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + markAST l (GHC.SpecSig ln typs inl) = do + markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE + markActivation l (GHC.inl_act inl) + markLocated ln + mark GHC.AnnDcolon -- '::' + markListIntercalateWithFunLevel markLHsSigType 2 typs + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + + markAST _ (GHC.SpecInstSig src typ) = do + markAnnOpen src "{-# SPECIALISE" + mark GHC.AnnInstance + markLHsSigType typ + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + + + markAST _ (GHC.MinimalSig src formula) = do + markAnnOpen src "{-# MINIMAL" + markLocated formula + markWithString GHC.AnnClose "#-}" + markTrailingSemi + + markAST _ (GHC.SCCFunSig src ln ml) = do + markAnnOpen src "{-# SCC" + markLocated ln + markMaybe ml + markWithString GHC.AnnClose "#-}" + markTrailingSemi + + markAST _ (GHC.CompleteMatchSig src (GHC.L _ ns) mlns) = do + markAnnOpen src "{-# COMPLETE" + markListIntercalate ns + case mlns of + Nothing -> return () + Just _ -> do + mark GHC.AnnDcolon + markMaybe mlns + markWithString GHC.AnnClose "#-}" -- '#-}' + markTrailingSemi + +-- -------------------------------------------------------------------- + +markLHsSigType :: GHC.LHsSigType GHC.RdrName -> Annotated () +markLHsSigType (GHC.HsIB _ typ _) = markLocated typ + +instance Annotate [GHC.LHsSigType GHC.RdrName] 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. + case ls of + [] -> markManyOptional GHC.AnnOpenP + [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnOpenP + [_] -> markManyOptional GHC.AnnOpenP + _ -> markMany GHC.AnnOpenP + markListIntercalateWithFun markLHsSigType ls + case ls of + [] -> markManyOptional GHC.AnnCloseP + [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnCloseP + [_] -> markManyOptional GHC.AnnCloseP + _ -> markMany GHC.AnnCloseP + +-- -------------------------------------------------------------------- + +instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where + markAST _ (GHC.Var x) = do + setContext (Set.singleton PrefixOp) $ markLocated x + inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls + markAST _ (GHC.And ls) = do + markListIntercalateWithFunLevel markLocated 2 ls + inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + markAST _ (GHC.Parens x) = do + mark GHC.AnnOpenP -- '(' + markLocated x + mark GHC.AnnCloseP -- ')' + inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsTyVarBndr GHC.RdrName) where + markAST _l (GHC.UserTyVar n) = do + markLocated n + + markAST _ (GHC.KindedTyVar n ty) = do + mark GHC.AnnOpenP -- '(' + markLocated n + mark GHC.AnnDcolon -- '::' + markLocated ty + mark GHC.AnnCloseP -- '(' + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsType GHC.RdrName) where + markAST loc ty = do + markType loc ty + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + where + + -- markType :: GHC.SrcSpan -> ast -> Annotated () + markType _ (GHC.HsForAllTy tvs typ) = do + mark GHC.AnnForall + mapM_ markLocated tvs + mark GHC.AnnDot + markLocated typ + + markType _ (GHC.HsQualTy cxt typ) = do + markLocated cxt + markLocated typ + + markType _ (GHC.HsTyVar promoted name) = do + when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote + markLocated name + + markType _ (GHC.HsAppsTy ts) = do + mapM_ markLocated ts + inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar + + markType _ (GHC.HsAppTy t1 t2) = do + setContext (Set.singleton PrefixOp) $ markLocated t1 + markLocated t2 + + markType _ (GHC.HsFunTy t1 t2) = do + markLocated t1 + mark GHC.AnnRarrow + markLocated t2 + + markType _ (GHC.HsListTy t) = do + mark GHC.AnnOpenS -- '[' + markLocated t + mark GHC.AnnCloseS -- ']' + + markType _ (GHC.HsPArrTy t) = do + markWithString GHC.AnnOpen "[:" -- '[:' + markLocated t + markWithString GHC.AnnClose ":]" -- ':]' + + 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 _ (GHC.HsEqTy t1 t2) = do + markLocated t1 + mark GHC.AnnTilde + markLocated t2 + + markType _ (GHC.HsKindSig t k) = do + mark GHC.AnnOpenP -- '(' + markLocated t + mark GHC.AnnDcolon -- '::' + markLocated k + mark GHC.AnnCloseP -- ')' + + markType l (GHC.HsSpliceTy s _) = do + markAST l s + + markType _ (GHC.HsDocTy t ds) = do + markLocated t + markLocated ds + + markType _ (GHC.HsBangTy (GHC.HsSrcBang mt _up str) t) = do + case mt of + GHC.NoSourceText -> return () + GHC.SourceText src -> do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + case str of + GHC.SrcLazy -> mark GHC.AnnTilde + GHC.SrcStrict -> mark GHC.AnnBang + GHC.NoSrcStrict -> return () + + markLocated t + + markType _ (GHC.HsRecTy cons) = do + mark GHC.AnnOpenC -- '{' + markListIntercalate cons + mark GHC.AnnCloseC -- '}' + + markType _ (GHC.HsCoreTy _t) = + traceM "warning: HsCoreTy Introduced after renaming" + + markType _ (GHC.HsExplicitListTy promoted _ ts) = do + when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote + mark GHC.AnnOpenS -- "[" + markListIntercalate ts + mark GHC.AnnCloseS -- ']' + + markType _ (GHC.HsExplicitTupleTy _ ts) = do + mark GHC.AnnSimpleQuote + mark GHC.AnnOpenP + markListIntercalate ts + mark GHC.AnnCloseP + + markType l (GHC.HsTyLit lit) = do + case lit of + (GHC.HsNumTy s v) -> + markExternalSourceText l s (show v) + (GHC.HsStrTy s v) -> + markExternalSourceText l s (show v) + + markType l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do + markExternal l GHC.AnnVal "_" + + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsAppType GHC.RdrName) 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.RdrName) where + markAST l c = + case c of + GHC.HsQuasiQuote _ n _pos fs -> do + markExternal l GHC.AnnVal + -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 + ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") + + GHC.HsTypedSplice hasParens _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do + when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE + if (hasParens == GHC.HasDollar) + then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) + else markLocated b + when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP + + GHC.HsTypedSplice hasParens _n b -> do + when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE + markLocated b + when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP + + -- ------------------------------- + + GHC.HsUntypedSplice hasParens _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do + when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPE + if (hasParens == GHC.HasDollar) + then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) + else markLocated b + when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP + + GHC.HsUntypedSplice hasParens _n b -> do + case hasParens of + GHC.HasParens -> mark GHC.AnnOpenPE + GHC.HasDollar -> mark GHC.AnnThIdSplice + GHC.NoParens -> return () + markLocated b + when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP + + GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.ConDeclField GHC.RdrName) 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 (GHC.DataId name) + => Annotate (GHC.FieldOcc name) where + markAST _ (GHC.FieldOcc rn _) = do + markLocated rn + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsDocString where + markAST l (GHC.HsDocString s) = do + markExternal l GHC.AnnVal (GHC.unpackFS s) + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.Pat GHC.RdrName) where + markAST loc typ = do + markPat loc typ + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") + where + markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" + markPat l (GHC.VarPat n) = do + -- The parser inserts a placeholder value for a record pun rhs. This must be + -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is + -- resolved, particularly for pretty printing where annotations are added. + let pun_RDR = "pun-right-hand-side" + when (showGhc n /= pun_RDR) $ + unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) + markPat _ (GHC.LazyPat p) = do + mark GHC.AnnTilde + markLocated p + + markPat _ (GHC.AsPat ln p) = do + markLocated ln + mark GHC.AnnAt + markLocated p + + markPat _ (GHC.ParPat p) = do + mark GHC.AnnOpenP + markLocated p + mark GHC.AnnCloseP + + markPat _ (GHC.BangPat p) = do + mark GHC.AnnBang + markLocated p + + markPat _ (GHC.ListPat ps _ _) = do + mark GHC.AnnOpenS + markListIntercalateWithFunLevel markLocated 2 ps + mark GHC.AnnCloseS + + markPat _ (GHC.TuplePat pats b _) = do + if b == GHC.Boxed then mark GHC.AnnOpenP + else markWithString GHC.AnnOpen "(#" + markListIntercalateWithFunLevel markLocated 2 pats + if b == GHC.Boxed then mark GHC.AnnCloseP + else markWithString GHC.AnnClose "#)" + + markPat _ (GHC.SumPat pat alt arity _) = do + markWithString GHC.AnnOpen "(#" + replicateM_ (alt - 1) $ mark GHC.AnnVbar + markLocated pat + replicateM_ (arity - alt) $ mark GHC.AnnVbar + markWithString GHC.AnnClose "#)" + + markPat _ (GHC.PArrPat ps _) = do + markWithString GHC.AnnOpen "[:" + mapM_ markLocated ps + markWithString GHC.AnnClose ":]" + + markPat _ (GHC.ConPatIn n dets) = do + markHsConPatDetails n dets + + markPat _ GHC.ConPatOut {} = + traceM "warning: ConPatOut Introduced after renaming" + + markPat _ (GHC.ViewPat e pat _) = do + markLocated e + mark GHC.AnnRarrow + markLocated pat + + markPat l (GHC.SplicePat s) = do + markAST l s + + markPat l (GHC.LitPat lp) = markAST l lp + + markPat _ (GHC.NPat ol mn _ _) = do + when (isJust mn) $ mark GHC.AnnMinus + markLocated ol + + markPat _ (GHC.NPlusKPat ln ol _ _ _ _) = do + markLocated ln + markWithString GHC.AnnVal "+" -- "+" + markLocated ol + + + markPat _ (GHC.SigPatIn pat ty) = do + markLocated pat + mark GHC.AnnDcolon + markLHsSigWcType ty + + markPat _ GHC.SigPatOut {} = + traceM "warning: SigPatOut introduced after renaming" + + markPat _ GHC.CoPat {} = + traceM "warning: CoPat introduced after renaming" + +-- --------------------------------------------------------------------- + +hsLit2String :: GHC.HsLit -> 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 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 _) _ -> src + GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#" + GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##" + +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.RdrName -> Annotated () +markHsConPatDetails ln dets = do + case dets of + GHC.PrefixCon args -> do + setContext (Set.singleton PrefixOp) $ markLocated ln + mapM_ markLocated args + GHC.RecCon (GHC.HsRecFields fs dd) -> do + markLocated ln + mark GHC.AnnOpenC -- '{' + case dd of + Nothing -> markListIntercalateWithFunLevel markLocated 2 fs + Just _ -> do + setContext (Set.singleton Intercalate) $ mapM_ markLocated fs + mark GHC.AnnDotdot + mark GHC.AnnCloseC -- '}' + GHC.InfixCon a1 a2 -> do + markLocated a1 + unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln + markLocated a2 + +markHsConDeclDetails :: + Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.RdrName -> Annotated () + +markHsConDeclDetails isDeprecated inGadt lns dets = do + case dets of + GHC.PrefixCon args -> + setContext (Set.singleton PrefixOp) $ mapM_ markLocated args + GHC.RecCon fs -> do + mark GHC.AnnOpenC + if inGadt + then do + if isDeprecated + then setContext (Set.fromList [InGadt]) $ markLocated fs + else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs + else do + if isDeprecated + then markLocated fs + else setContext (Set.fromList [InRecCon]) $ markLocated fs + GHC.InfixCon a1 a2 -> do + markLocated a1 + setContext (Set.singleton InfixOp) $ mapM_ markLocated lns + markLocated a2 + +-- --------------------------------------------------------------------- + +instance Annotate [GHC.LConDeclField GHC.RdrName] where + markAST _ fs = do + markOptional GHC.AnnOpenC -- '{' + markListIntercalate fs + markOptional GHC.AnnDotdot + inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' + inContext (Set.singleton InGadt) $ do + mark GHC.AnnRarrow + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where + markAST l ol = + let str = case GHC.ol_val ol of + GHC.HsIntegral src _ -> src + GHC.HsFractional l2 -> GHC.SourceText $ GHC.fl_text l2 + GHC.HsIsString src _ -> src + in + markExternalSourceText l str "" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate arg) + => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where + markAST _ (GHC.HsIB _ thing _) = do + markLocated thing + +-- --------------------------------------------------------------------- + +instance (Annotate body) => Annotate (GHC.Stmt GHC.RdrName (GHC.Located body)) where + + markAST _ (GHC.LastStmt body _ _) + = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body + + markAST _ (GHC.BindStmt pat body _ _ _) = do + unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat + mark GHC.AnnLarrow + unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body + + ifInContext (Set.singleton Intercalate) + (mark GHC.AnnComma) + (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) + markTrailingSemi + + markAST _ GHC.ApplicativeStmt{} + = error "ApplicativeStmt should not appear in ParsedSource" + + markAST _ (GHC.BodyStmt body _ _ _) = do + unsetContext Intercalate $ markLocated body + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + + markAST _ (GHC.LetStmt (GHC.L _ lb)) = do + mark GHC.AnnLet + markOptional GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + markLocalBindsWithLayout lb + markOptional GHC.AnnCloseC -- '}' + ifInContext (Set.singleton Intercalate) + (mark GHC.AnnComma) + (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) + markTrailingSemi + + markAST l (GHC.ParStmt pbs _ _ _) = do + -- Within a given parallel list comprehension,one of the sections to be done + -- in parallel. It is a normal list comprehension, so has a list of + -- ParStmtBlock, one for each part of the sub- list comprehension + + + ifInContext (Set.singleton Intercalate) + ( + + unsetContext Intercalate $ + markListWithContextsFunction + (LC (Set.singleton Intercalate) -- only + Set.empty -- first + Set.empty -- middle + (Set.singleton Intercalate) -- last + ) (markAST l) pbs + ) + ( + unsetContext Intercalate $ + markListWithContextsFunction + (LC Set.empty -- only + (Set.fromList [AddVbar]) -- first + (Set.fromList [AddVbar]) -- middle + Set.empty -- last + ) (markAST l) pbs + ) + markTrailingSemi + + markAST _ (GHC.TransStmt form stmts _b using by _ _ _ _) = do + setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts + case form of + GHC.ThenForm -> do + mark GHC.AnnThen + unsetContext Intercalate $ markLocated using + case by of + Just b -> do + mark GHC.AnnBy + unsetContext Intercalate $ markLocated b + Nothing -> return () + GHC.GroupForm -> do + mark GHC.AnnThen + mark GHC.AnnGroup + case by of + Just b -> mark GHC.AnnBy >> markLocated b + Nothing -> return () + mark GHC.AnnUsing + markLocated using + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + + markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _) = do + mark GHC.AnnRec + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + mapM_ markLocated stmts + markOptional GHC.AnnCloseC + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + inContext (Set.singleton Intercalate) $ mark GHC.AnnComma + markTrailingSemi + +-- --------------------------------------------------------------------- + +-- 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.RdrName GHC.RdrName) where + markAST _ (GHC.ParStmtBlock stmts _ns _) = do + markListIntercalate stmts + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsLocalBinds GHC.RdrName) where + markAST _ lb = markHsLocalBinds lb + +-- --------------------------------------------------------------------- + +markHsLocalBinds :: GHC.HsLocalBinds GHC.RdrName -> Annotated () +markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = + applyListAnnotationsLayout + (prepareListAnnotation (GHC.bagToList binds) + ++ prepareListAnnotation sigs + ) +markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {}) + = traceM "warning: ValBindsOut introduced after renaming" + +markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout binds +markHsLocalBinds GHC.EmptyLocalBinds = return () + +-- --------------------------------------------------------------------- + +markMatchGroup :: (Annotate body) + => GHC.SrcSpan -> GHC.MatchGroup GHC.RdrName (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.RdrName (GHC.Located body))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsExpr GHC.RdrName) where + markAST loc expr = do + markExpr loc expr + inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar + -- TODO: If the AnnComma is not needed, revert to markAST + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + where + markExpr _ (GHC.HsVar n) = unsetContext Intercalate $ do + ifInContext (Set.singleton PrefixOp) + (setContext (Set.singleton PrefixOp) $ markLocated n) + (ifInContext (Set.singleton InfixOp) + (setContext (Set.singleton InfixOp) $ markLocated n) + (markLocated n) + ) + + markExpr l (GHC.HsRecFld f) = markAST l f + + markExpr l (GHC.HsOverLabel _ fs) + = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) + + + markExpr l (GHC.HsIPVar n@(GHC.HsIPName _v)) = + markAST l n + markExpr l (GHC.HsOverLit ov) = markAST l ov + markExpr l (GHC.HsLit lit) = markAST l lit + + markExpr _ (GHC.HsLam (GHC.MG (GHC.L _ [match]) _ _ _)) = do + setContext (Set.singleton LambdaExpr) $ do + -- TODO: Change this, HsLam binds do not need obey layout rules. + -- And will only ever have a single match + markLocated match + markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match" + + markExpr l (GHC.HsLamCase match) = do + mark GHC.AnnLam + mark GHC.AnnCase + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + markMatchGroup l match + markOptional GHC.AnnCloseC + + markExpr _ (GHC.HsApp e1 e2) = do + setContext (Set.singleton PrefixOp) $ markLocated e1 + setContext (Set.singleton PrefixOp) $ markLocated e2 + + markExpr _ (GHC.OpApp e1 e2 _ e3) = do + let + isInfix = case e2 of + -- TODO: generalise this. Is it a fixity thing? + GHC.L _ (GHC.HsVar _) -> True + _ -> False + + normal = + -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context + ifInContext (Set.singleton LeftMost) + (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) + (markLocated e1) + + if isInfix + then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 + else normal + + unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 + + if isInfix + then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 + else markLocated e3 + + markExpr _ (GHC.NegApp e _) = do + mark GHC.AnnMinus + markLocated e + + markExpr _ (GHC.HsPar e) = do + mark GHC.AnnOpenP -- '(' + markLocated e + mark GHC.AnnCloseP -- ')' + + markExpr _ (GHC.SectionL e1 e2) = do + markLocated e1 + setContext (Set.singleton InfixOp) $ markLocated e2 + + markExpr _ (GHC.SectionR e1 e2) = do + setContext (Set.singleton InfixOp) $ markLocated e1 + markLocated e2 + + markExpr _ (GHC.ExplicitTuple args b) = do + if b == GHC.Boxed then mark GHC.AnnOpenP + else markWithString GHC.AnnOpen "(#" + + setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args + + if b == GHC.Boxed then mark GHC.AnnCloseP + else markWithString GHC.AnnClose "#)" + + markExpr _ (GHC.ExplicitSum alt arity e _) = do + markWithString GHC.AnnOpen "(#" + replicateM_ (alt - 1) $ mark GHC.AnnVbar + markLocated e + replicateM_ (arity - alt) $ mark GHC.AnnVbar + markWithString GHC.AnnClose "#)" + + markExpr l (GHC.HsCase e1 matches) = setRigidFlag $ do + mark GHC.AnnCase + setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 + mark GHC.AnnOf + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + setContext (Set.singleton CaseAlt) $ markMatchGroup l matches + markOptional GHC.AnnCloseC + + -- We set the layout for HsIf even though it need not obey layout rules as + -- when moving these expressions it's useful that they maintain "internal + -- integrity", that is to say the subparts remain indented relative to each + -- other. + markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do + -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do + mark GHC.AnnIf + markLocated e1 + markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen + mark GHC.AnnThen + setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 + markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse + mark GHC.AnnElse + setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 + + markExpr _ (GHC.HsMultiIf _ rhs) = do + mark GHC.AnnIf + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + -- mapM_ markLocated rhs + markListWithLayout rhs + markOptional GHC.AnnCloseC + + markExpr _ (GHC.HsLet (GHC.L _ binds) e) = do + setLayoutFlag (do -- Make sure the 'in' gets indented too + mark GHC.AnnLet + markOptional GHC.AnnOpenC + markInside GHC.AnnSemi + markLocalBindsWithLayout binds + markOptional GHC.AnnCloseC + mark GHC.AnnIn + markLocated e) + + -- ------------------------------- + + markExpr _ (GHC.HsDo cts (GHC.L _ es) _) = do + case cts of + GHC.DoExpr -> mark GHC.AnnDo + GHC.MDoExpr -> mark GHC.AnnMdo + _ -> return () + let (ostr,cstr) = + if isListComp cts + then case cts of + GHC.PArrComp -> ("[:",":]") + _ -> ("[", "]") + 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.ExplicitPArr _ es) = do + markWithString GHC.AnnOpen "[:" + markListIntercalateWithFunLevel markLocated 2 es + markWithString GHC.AnnClose ":]" + + 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 _cons _ _ _) = 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.ExprWithTySigOut _e _typ) + = error "ExprWithTySigOut only occurs after renamer" + + 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.PArrSeq _ seqInfo) = do + markWithString GHC.AnnOpen "[:" -- '[:' + 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 + markWithString GHC.AnnClose ":]" -- ':]' + + markExpr _ (GHC.HsSCC src csFStr e) = do + markAnnOpen src "{-# SCC" + let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) + markWithStringOptional GHC.AnnVal txt + markWithString GHC.AnnValStr txt + markWithString GHC.AnnClose "#-}" + markLocated e + + markExpr _ (GHC.HsCoreAnn src csFStr e) = do + -- markWithString GHC.AnnOpen src -- "{-# CORE" + markAnnOpen src "{-# CORE" + -- markWithString GHC.AnnVal (GHC.sl_st csFStr) + markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) + markWithString GHC.AnnClose "#-}" + markLocated e + -- TODO: make monomorphic + markExpr l (GHC.HsBracket (GHC.VarBr True v)) = do + mark GHC.AnnSimpleQuote + setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) + markExpr l (GHC.HsBracket (GHC.VarBr False v)) = do + mark GHC.AnnThTyQuote + markLocatedFromKw GHC.AnnName (GHC.L l v) + markExpr _ (GHC.HsBracket (GHC.DecBrL ds)) = do + markWithString GHC.AnnOpen "[d|" + markOptional GHC.AnnOpenC + setContext (Set.singleton NoAdvanceLine) + $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds + markOptional GHC.AnnCloseC + mark GHC.AnnCloseQ -- "|]" + -- Introduced after the renamer + markExpr _ (GHC.HsBracket (GHC.DecBrG _)) = + traceM "warning: DecBrG introduced after renamer" + markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do + mark GHC.AnnOpenEQ -- "[|" + markOptional GHC.AnnOpenE -- "[e|" + markLocated e + mark GHC.AnnCloseQ -- "|]" + markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do + markWithString GHC.AnnOpen "[||" + markWithStringOptional GHC.AnnOpenE "[e||" + markLocated e + markWithString GHC.AnnClose "||]" + markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do + markWithString GHC.AnnOpen "[t|" + markLocated e + mark GHC.AnnCloseQ -- "|]" + markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do + markWithString GHC.AnnOpen "[p|" + markLocated e + mark GHC.AnnCloseQ -- "|]" + + markExpr _ (GHC.HsRnBracketOut _ _) = + traceM "warning: HsRnBracketOut introduced after renamer" + markExpr _ (GHC.HsTcBracketOut _ _) = + traceM "warning: HsTcBracketOut introduced after renamer" + + markExpr l (GHC.HsSpliceE e) = markAST l e + + markExpr _ (GHC.HsProc p c) = do + mark GHC.AnnProc + markLocated p + mark GHC.AnnRarrow + markLocated c + + markExpr _ (GHC.HsStatic _ e) = do + mark GHC.AnnStatic + markLocated e + + markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do + -- isRightToLeft True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + if isRightToLeft + then do + markLocated e1 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail + else do + markLocated e2 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail + + if isRightToLeft + then markLocated e2 + else markLocated e1 + + markExpr _ (GHC.HsArrForm e _ cs) = do + markWithString GHC.AnnOpen "(|" + markLocated e + mapM_ markLocated cs + markWithString GHC.AnnClose "|)" + + markExpr _ (GHC.HsTick _ _) = return () + markExpr _ (GHC.HsBinTick _ _ _) = return () + + markExpr _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do + -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' + markAnnOpen src "{-# GENERATED" + markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING + + let + markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) + markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s + + markOne 1 v1 s1 -- INTEGER + markOffset GHC.AnnColon 0 -- ':' + markOne 2 v2 s2 -- INTEGER + mark GHC.AnnMinus -- '-' + markOne 3 v3 s3 -- INTEGER + markOffset GHC.AnnColon 1 -- ':' + markOne 4 v4 s4 -- INTEGER + markWithString GHC.AnnClose "#-}" + markLocated e + + markExpr l GHC.EWildPat = do + ifInContext (Set.fromList [InfixOp]) + (do mark GHC.AnnBackquote + markWithString GHC.AnnVal "_" + mark GHC.AnnBackquote) + (markExternal l GHC.AnnVal "_") + + markExpr _ (GHC.EAsPat ln e) = do + markLocated ln + mark GHC.AnnAt + markLocated e + + markExpr _ (GHC.EViewPat e1 e2) = do + markLocated e1 + mark GHC.AnnRarrow + markLocated e2 + + markExpr _ (GHC.ELazyPat e) = do + mark GHC.AnnTilde + markLocated e + + markExpr _ (GHC.HsAppType e ty) = do + markLocated e + mark GHC.AnnAt + markLHsWcType ty + markExpr _ (GHC.HsAppTypeOut _ _) = + traceM "warning: HsAppTypeOut introduced after renaming" + + markExpr _ (GHC.HsWrap _ _) = + traceM "warning: HsWrap introduced after renaming" + markExpr _ (GHC.HsUnboundVar _) = + traceM "warning: HsUnboundVar introduced after renaming" + + markExpr _ (GHC.HsConLikeOut{}) = + traceM "warning: HsConLikeOut introduced after type checking" + + +-- --------------------------------------------------------------------- + +markLHsWcType :: GHC.LHsWcType GHC.RdrName -> Annotated () +markLHsWcType (GHC.HsWC _ ty) = do + markLocated ty + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsLit where + markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsRecUpdField GHC.RdrName) 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 (GHC.DataId name) + => Annotate (GHC.AmbiguousFieldOcc name) 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.RdrName] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsTupArg GHC.RdrName) 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.RdrName) where + markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd + +instance Annotate (GHC.HsCmd GHC.RdrName) where + markAST _ (GHC.HsCmdArrApp e1 e2 _ o isRightToLeft) = do + -- isRightToLeft True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + if isRightToLeft + then do + markLocated e1 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail + else do + markLocated e2 + case o of + GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail + GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail + + if isRightToLeft + then markLocated e2 + else markLocated e1 + + markAST _ (GHC.HsCmdArrForm e fixity _mf cs) = do + -- The AnnOpen should be marked for a prefix usage, not for a postfix one, + -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm + + let isPrefixOp = case fixity of + GHC.Infix -> False + GHC.Prefix -> True + when isPrefixOp $ mark GHC.AnnOpenB -- "(|" + + -- This may be an infix operation + applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) + (Set.singleton InfixOp) (Set.singleton InfixOp)) + (prepareListAnnotation [e] + ++ prepareListAnnotation cs) + when isPrefixOp $ mark GHC.AnnCloseB -- "|)" + + markAST _ (GHC.HsCmdApp e1 e2) = do + markLocated e1 + markLocated e2 + + markAST l (GHC.HsCmdLam match) = do + setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match + + markAST _ (GHC.HsCmdPar e) = do + mark GHC.AnnOpenP + markLocated e + mark GHC.AnnCloseP -- ')' + + markAST l (GHC.HsCmdCase e1 matches) = do + mark GHC.AnnCase + markLocated e1 + mark GHC.AnnOf + markOptional GHC.AnnOpenC + setContext (Set.singleton CaseAlt) $ do + markMatchGroup l matches + markOptional GHC.AnnCloseC + + markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do + mark GHC.AnnIf + markLocated e1 + markOffset GHC.AnnSemi 0 + mark GHC.AnnThen + markLocated e2 + markOffset GHC.AnnSemi 1 + mark GHC.AnnElse + markLocated e3 + + markAST _ (GHC.HsCmdLet (GHC.L _ binds) e) = do + mark GHC.AnnLet + markOptional GHC.AnnOpenC + markLocalBindsWithLayout binds + markOptional GHC.AnnCloseC + mark GHC.AnnIn + markLocated e + + markAST _ (GHC.HsCmdDo (GHC.L _ es) _) = do + mark GHC.AnnDo + markOptional GHC.AnnOpenC + markListWithLayout es + markOptional GHC.AnnCloseC + + + markAST _ (GHC.HsCmdWrap {}) = + traceM "warning: HsCmdWrap introduced after renaming" + +-- --------------------------------------------------------------------- + +instance Annotate [GHC.Located (GHC.StmtLR GHC.RdrName GHC.RdrName (GHC.LHsCmd GHC.RdrName))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.TyClDecl GHC.RdrName) where + + markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi + + markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars _) fixity typ _) = do + -- There may be arbitrary parens around parts of the constructor that are + -- infix. + -- Turn these into comments so that they feed into the right place automatically + -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] + mark GHC.AnnType + + markTyClass fixity ln tyvars + mark GHC.AnnEqual + markLocated typ + markTrailingSemi + + markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns 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 _ns 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 + +-- --------------------------------------------------------------------- + +markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) + => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated () +markTyClass fixity ln tyVars = do + let markParens = if fixity == GHC.Infix && length tyVars > 2 + then markMany + else markManyOptional + if fixity == GHC.Prefix + then do + markManyOptional GHC.AnnOpenP + setContext (Set.singleton PrefixOp) $ markLocated ln + setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ take 2 tyVars + when (length tyVars >= 2) $ do + markParens GHC.AnnCloseP + setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ drop 2 tyVars + markManyOptional GHC.AnnCloseP + else do + case tyVars of + (x:y:xs) -> do + markParens GHC.AnnOpenP + markLocated x + setContext (Set.singleton InfixOp) $ markLocated ln + markLocated y + markParens GHC.AnnCloseP + mapM_ markLocated xs + markManyOptional GHC.AnnCloseP + _ -> error $ "markTyClass: Infix op without operands" + +-- --------------------------------------------------------------------- + +instance Annotate [GHC.LHsDerivingClause GHC.RdrName] where + markAST _ ds = mapM_ markLocated ds + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsDerivingClause GHC.RdrName) where + markAST _ (GHC.HsDerivingClause mstrategy (GHC.L _ typs)) = do + let needsParens = case typs of + [(GHC.HsIB _ (GHC.L _ (GHC.HsTyVar _ _)) _)] -> False + _ -> True + mark GHC.AnnDeriving + markMaybe mstrategy + if needsParens then mark GHC.AnnOpenP + else markOptional GHC.AnnOpenP + markListIntercalateWithFunLevel markLHsSigType 2 typs + if needsParens then mark GHC.AnnCloseP + else markOptional GHC.AnnCloseP + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.FamilyDecl GHC.RdrName) 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.RdrName) where + markAST _ (GHC.NoSig) = return () + markAST _ (GHC.KindSig k) = markLocated k + markAST _ (GHC.TyVarSig ltv) = markLocated ltv + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name) + => Annotate (GHC.InjectivityAnn name) where + markAST _ (GHC.InjectivityAnn ln lns) = do + markLocated ln + mark GHC.AnnRarrow + mapM_ markLocated lns + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.TyFamInstEqn GHC.RdrName) where + markAST _ (GHC.TyFamEqn ln (GHC.HsIB _ pats _) fixity typ) = do + markTyClass fixity ln pats + mark GHC.AnnEqual + markLocated typ + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.TyFamDefltEqn GHC.RdrName) where + markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs _) fixity typ) = do + mark GHC.AnnType + mark GHC.AnnInstance + markTyClass fixity ln bndrs + mark GHC.AnnEqual + markLocated typ + +-- --------------------------------------------------------------------- + +-- 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 (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocCommentPrev (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs + (GHC.DocGroup _i (GHC.HsDocString fs)) -> GHC.unpackFS fs + in + markExternal l GHC.AnnVal str >> markTrailingSemi + +-- --------------------------------------------------------------------- + +markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.RdrName -> 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.RdrName] where + markAST l ts = do + -- Mote: A single item in parens in a deriving clause is parsed as a + -- HsSigType, which is always a HsForAllTy. 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 + [_] -> markManyOptional pa + _ -> markMany pa + + parenIfNeeded'' pa = + ifInContext (Set.singleton Parens) + (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.RdrName) where + markAST _ (GHC.ConDeclH98 ln mqtvs mctx + dets _ ) = do + case mqtvs of + Nothing -> return () + Just (GHC.HsQTvs _ns bndrs _) -> do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + case mctx of + Just ctx -> do + setContext (Set.fromList [NoDarrow]) $ markLocated ctx + unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow + Nothing -> return () + + case dets of + GHC.InfixCon _ _ -> return () + _ -> setContext (Set.singleton PrefixOp) $ markLocated ln + + markHsConDeclDetails False False [ln] dets + + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar + markTrailingSemi + markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ _) _) = do + setContext (Set.singleton PrefixOp) $ markListIntercalate lns + mark GHC.AnnDcolon + markLocated typ + markTrailingSemi + +-- ResTyGADT has a SrcSpan for the original sigtype, we need to create +-- a type for exactPC and annotatePC +data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name] + deriving (Typeable) +deriving instance (GHC.DataId name) => Data (ResTyGADTHook name) +deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name) + +instance (GHC.OutputableBndrId name) => GHC.Outputable (ResTyGADTHook name) where + ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" 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 GHC.RdrName) where + markAST _ (ResTyGADTHook bndrs) = do + unless (null bndrs) $ do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsRecField GHC.RdrName (GHC.LPat GHC.RdrName)) 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.RdrName (GHC.LHsExpr GHC.RdrName)) 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 (GHC.DataId name,Annotate name) + => Annotate (GHC.FunDep (GHC.Located name)) where + + markAST _ (ls,rs) = do + mapM_ markLocated ls + mark GHC.AnnRarrow + mapM_ markLocated rs + inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance Annotate GHC.CType where + markAST _ (GHC.CType src mh f) = do + -- markWithString GHC.AnnOpen src + markAnnOpen src "" + case mh of + Nothing -> return () + Just (GHC.Header srcH _h) -> + -- markWithString GHC.AnnHeader srcH + markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") + -- markWithString GHC.AnnVal (fst f) + markSourceText (fst f) (GHC.unpackFS $ snd f) + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +stringLiteralToString :: GHC.StringLiteral -> String +stringLiteralToString (GHC.StringLiteral st fs) = + case st of + GHC.NoSourceText -> GHC.unpackFS fs + GHC.SourceText src -> src diff --git a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs --- a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs @@ -29,3661 +29,8 @@ , Annotated , Annotate(..) , withSortKeyContextsHelper - ) where - -#if __GLASGOW_HASKELL__ <= 710 -import Data.Ord ( comparing ) -import Data.List ( sortBy ) -#endif - -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils - -import qualified Bag as GHC -import qualified BasicTypes as GHC -import qualified BooleanFormula as GHC -import qualified Class as GHC -import qualified CoAxiom as GHC -import qualified FastString as GHC -import qualified ForeignCall as GHC -import qualified GHC as GHC -#if __GLASGOW_HASKELL__ > 710 -import qualified Lexeme as GHC -#endif -import qualified Name as GHC -import qualified RdrName as GHC -import qualified Outputable as GHC - -import Control.Monad.Trans.Free -import Control.Monad.Free.TH (makeFreeCon) -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" #-} --- --------------------------------------------------------------------- - --- | ['MarkPrim'] The main constructor. Marks that a specific AnnKeywordId could --- appear with an optional String which is used when printing. --- ['MarkPPOptional'] Used to flag elements, such as optional braces, that are --- not used in the pretty printer. This functions identically to 'MarkPrim' --- for the other interpreters. --- ['MarkEOF'] --- Special constructor which marks the end of file marker. --- ['MarkExternal'] TODO --- ['MarkOutside'] A @AnnKeywordId@ which is precisely located but not inside the --- current context. This is usually used to reassociated located --- @RdrName@ which are more naturally associated with their parent than --- in their own annotation. --- ['MarkInside'] --- The dual of MarkOutside. If we wish to mark a non-separating comma --- or semi-colon then we must use this constructor. --- ['MarkMany'] Some syntax elements allow an arbritary number of puncuation marks --- without reflection in the AST. This construction greedily takes all of --- the specified @AnnKeywordId@. --- ['MarkOffsetPrim'] Some syntax elements have repeated @AnnKeywordId@ which are --- seperated by different @AnnKeywordId@. Thus using MarkMany is --- unsuitable and instead we provide an index to specify which specific --- instance to choose each time. --- ['WithAST'] TODO --- ['CountAnns'] Sometimes the AST does not reflect the concrete source code and the --- only way to tell what the concrete source was is to count a certain --- kind of @AnnKeywordId@. --- ['WithSortKey'] There are many places where the syntactic ordering of elements is --- thrown away by the AST. This constructor captures the original --- ordering and reflects any changes in ordered as specified by the --- @annSortKey@ field in @Annotation@. --- ['SetLayoutFlag'] It is important to know precisely where layout rules apply. This --- constructor wraps a computation to indicate that LayoutRules apply to --- the corresponding construct. --- ['StoreOriginalSrcSpan'] TODO --- ['GetSrcSpanFromKw'] TODO --- ['StoreString'] TODO --- ['AnnotationsToComments'] Used when the AST is sufficiently vague that there is no other --- option but to convert a fragment of source code into a comment. This --- means it is impossible to edit such a fragment but means that --- processing files with such fragments is still possible. -data AnnotationF next where - MarkPrim :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next - MarkPPOptional :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next - MarkEOF :: next -> AnnotationF next - MarkExternal :: GHC.SrcSpan -> GHC.AnnKeywordId -> String -> next -> AnnotationF next - MarkOutside :: GHC.AnnKeywordId -> KeywordId -> next -> AnnotationF next - MarkInside :: GHC.AnnKeywordId -> next -> AnnotationF next - MarkMany :: GHC.AnnKeywordId -> next -> AnnotationF next - MarkManyOptional :: GHC.AnnKeywordId -> next -> AnnotationF next - MarkOffsetPrim :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next - -- MarkOffsetPrimOptional :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next - WithAST :: Data a => GHC.Located a - -> Annotated b -> next -> AnnotationF next - CountAnns :: GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next - WithSortKey :: [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next - - SetLayoutFlag :: Rigidity -> Annotated () -> next -> AnnotationF next - MarkAnnBeforeAnn :: GHC.AnnKeywordId -> GHC.AnnKeywordId -> next -> AnnotationF next - - -- Required to work around deficiencies in the GHC AST - StoreOriginalSrcSpan :: GHC.SrcSpan -> AnnKey -> (AnnKey -> next) -> AnnotationF next - GetSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> (GHC.SrcSpan -> next) -> AnnotationF next -#if __GLASGOW_HASKELL__ <= 710 - StoreString :: String -> GHC.SrcSpan -> next -> AnnotationF next -#endif - AnnotationsToComments :: [GHC.AnnKeywordId] -> next -> AnnotationF next -#if __GLASGOW_HASKELL__ <= 710 - AnnotationsToCommentsBF :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> next -> AnnotationF next - FinalizeBF :: GHC.SrcSpan -> next -> AnnotationF next -#endif - - -- AZ experimenting with pretty printing - -- Set the context for child element - SetContextLevel :: Set.Set AstContext -> Int -> Annotated () -> next -> AnnotationF next - 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 - -- - TellContext :: Set.Set AstContext -> next -> AnnotationF next - -deriving instance Functor AnnotationF - -type Annotated = FreeT AnnotationF Identity - - --- --------------------------------------------------------------------- - -makeFreeCon 'MarkEOF -makeFreeCon 'MarkPrim -makeFreeCon 'MarkPPOptional -makeFreeCon 'MarkOutside -makeFreeCon 'MarkInside -makeFreeCon 'MarkExternal -makeFreeCon 'MarkMany -makeFreeCon 'MarkManyOptional -makeFreeCon 'MarkOffsetPrim --- makeFreeCon 'MarkOffsetPrimOptional -makeFreeCon 'CountAnns -makeFreeCon 'StoreOriginalSrcSpan -makeFreeCon 'GetSrcSpanForKw -#if __GLASGOW_HASKELL__ <= 710 -makeFreeCon 'StoreString -#endif -makeFreeCon 'AnnotationsToComments -#if __GLASGOW_HASKELL__ <= 710 -makeFreeCon 'AnnotationsToCommentsBF -makeFreeCon 'FinalizeBF -#endif -makeFreeCon 'WithSortKey -makeFreeCon 'SetContextLevel -makeFreeCon 'UnsetContext -makeFreeCon 'IfInContext -makeFreeCon 'WithSortKeyContexts -makeFreeCon 'TellContext -makeFreeCon 'MarkAnnBeforeAnn - --- --------------------------------------------------------------------- - -setContext :: Set.Set AstContext -> Annotated () -> Annotated () -setContext ctxt action = liftF (SetContextLevel ctxt 3 action ()) - -setLayoutFlag :: Annotated () -> Annotated () -setLayoutFlag action = liftF (SetLayoutFlag NormalLayout action ()) - -setRigidFlag :: Annotated () -> Annotated () -setRigidFlag action = liftF (SetLayoutFlag RigidLayout action ()) - --- | Construct a syntax tree which represent which KeywordIds must appear --- where. -annotate :: (Annotate ast) => GHC.Located ast -> Annotated () -annotate = markLocated - -inContext :: Set.Set AstContext -> Annotated () -> Annotated () -inContext ctxt action = liftF (IfInContext ctxt action (return ()) ()) - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -workOutString :: GHC.SrcSpan -> GHC.AnnKeywordId -> (GHC.SrcSpan -> String) -> Annotated () -workOutString l kw f = do - ss <- getSrcSpanForKw l kw - storeString (f ss) ss -#endif - --- --------------------------------------------------------------------- - --- |Main driver point for annotations. -withAST :: Data a => GHC.Located a -> Annotated () -> Annotated () -withAST lss action = liftF (WithAST lss action ()) - --- --------------------------------------------------------------------- --- Additional smart constructors - -mark :: GHC.AnnKeywordId -> Annotated () -mark kwid = markPrim kwid Nothing - -markOptional :: GHC.AnnKeywordId -> Annotated () -markOptional kwid = markPPOptional kwid Nothing - -markWithString :: GHC.AnnKeywordId -> String -> Annotated () -markWithString kwid s = markPrim kwid (Just s) - -markWithStringOptional :: GHC.AnnKeywordId -> String -> Annotated () -markWithStringOptional kwid s = markPPOptional kwid (Just s) - -markOffsetWithString :: GHC.AnnKeywordId -> Int -> String -> Annotated () -markOffsetWithString kwid n s = markOffsetPrim kwid n (Just s) - -markOffset :: GHC.AnnKeywordId -> Int -> Annotated () -markOffset kwid n = markOffsetPrim kwid n Nothing - --- markOffsetOptional :: GHC.AnnKeywordId -> Int -> Annotated () --- markOffsetOptional kwid n = markOffsetPrimOptional kwid n Nothing - -markTrailingSemi :: Annotated () -markTrailingSemi = markOutside GHC.AnnSemi AnnSemiSep - --- --------------------------------------------------------------------- - --- | 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.RdrName) of - Just d -> markLHsDecl d - Nothing -> withLocated ast markAST - -withLocated :: Data a - => GHC.Located a - -> (GHC.SrcSpan -> a -> Annotated ()) - -> Annotated () -withLocated a@(GHC.L l ast) action = - withAST a (action l ast) - --- --------------------------------------------------------------------- - --- |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 - -markListIntercalateWithFun :: (t -> Annotated ()) -> [t] -> Annotated () -markListIntercalateWithFun f ls = markListIntercalateWithFunLevel f 2 ls - -markListIntercalateWithFunLevel :: (t -> Annotated ()) -> Int -> [t] -> Annotated () -markListIntercalateWithFunLevel f level ls = markListIntercalateWithFunLevelCtx f level Intercalate ls - -markListIntercalateWithFunLevelCtx :: (t -> Annotated ()) -> Int -> AstContext -> [t] -> Annotated () -markListIntercalateWithFunLevelCtx f level ctx ls = go ls - where - go [] = return () - go [x] = f x - go (x:xs) = do - setContextLevel (Set.singleton ctx) level $ f x - go xs - --- --------------------------------------------------------------------- - -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 - - -markListWithContextsFunction :: - ListContexts - -> (t -> Annotated ()) - -> [t] -> Annotated () -markListWithContextsFunction (LC ctxOnly ctxInitial ctxMiddle ctxLast) f ls = - case ls of - [] -> return () - [x] -> setContextLevel ctxOnly level $ f x - (x:xs) -> do - setContextLevel ctxInitial level $ f x - go xs - where - level = 2 - go [] = return () - go [x] = setContextLevel ctxLast level $ f x - go (x:xs) = do - setContextLevel ctxMiddle level $ f x - go xs - --- --------------------------------------------------------------------- - - --- Expects the kws to be ordered already -withSortKeyContextsHelper :: (Monad m) => (Annotated () -> m ()) -> ListContexts -> [(GHC.SrcSpan, Annotated ())] -> m () -withSortKeyContextsHelper interpret (LC ctxOnly ctxInitial ctxMiddle ctxLast) kws = do - case kws of - [] -> return () - [x] -> interpret (setContextLevel (Set.insert (CtxPos 0) ctxOnly) level $ snd x) - (x:xs) -> do - interpret (setContextLevel (Set.insert (CtxPos 0) ctxInitial) level $ snd x) - go 1 xs - where - level = 2 - go _ [] = return () - go n [x] = interpret (setContextLevel (Set.insert (CtxPos n) ctxLast) level $ snd x) - go n (x:xs) = do - interpret (setContextLevel (Set.insert (CtxPos n) ctxMiddle) level $ snd x) - go (n+1) 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.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.HsLocalBinds name -> Annotated () -markLocalBindsWithLayout binds = - markHsLocalBinds binds - --- --------------------------------------------------------------------- - --- |This function is used to get around shortcomings in the GHC AST for 7.10.1 -markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () -markLocatedFromKw kw (GHC.L l a) = do - -- Note: l is needed so that the pretty printer can make something up - ss <- getSrcSpanForKw l kw - AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) - markLocated (GHC.L ss' a) - --- --------------------------------------------------------------------- - -markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () -markMaybe Nothing = return () -markMaybe (Just ast) = markLocated ast - --- --------------------------------------------------------------------- --- Managing lists which have been separated, e.g. Sigs and Binds - -prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] -prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls - --- prepareListAnnotationWithContext :: Annotate a => Set.Set AstContext --- -> [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] --- prepareListAnnotationWithContext ctx ls = map (\b -> (GHC.getLoc b,setContext ctx (markLocated b))) ls - -applyListAnnotations :: [(GHC.SrcSpan, Annotated ())] -> Annotated () -applyListAnnotations ls = withSortKey ls - -applyListAnnotationsContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Annotated () -applyListAnnotationsContexts ctxt ls = withSortKeyContexts ctxt ls - -#if __GLASGOW_HASKELL__ <= 710 -lexicalSortLocated :: [GHC.Located a] -> [GHC.Located a] -lexicalSortLocated = sortBy (comparing GHC.getLoc) -#endif - -applyListAnnotationsLayout :: [(GHC.SrcSpan, Annotated ())] -> Annotated () -applyListAnnotationsLayout ls = setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) - $ withSortKeyContexts listContexts ls - -listContexts :: ListContexts -listContexts = LC (Set.fromList [CtxOnly,ListStart]) - (Set.fromList [CtxFirst,ListStart,Intercalate]) - (Set.fromList [CtxMiddle,ListItem,Intercalate]) - (Set.fromList [CtxLast,ListItem]) - -listContexts' :: ListContexts -listContexts' = LC (Set.fromList [CtxOnly, ListStart]) - (Set.fromList [CtxFirst, ListStart]) - (Set.fromList [CtxMiddle,ListItem]) - (Set.fromList [CtxLast, ListItem]) - --- --------------------------------------------------------------------- - -class Data ast => Annotate ast where - markAST :: GHC.SrcSpan -> ast -> Annotated () - --- --------------------------------------------------------------------- - -instance Annotate (GHC.HsModule GHC.RdrName) where - markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do - - case mmn of - Nothing -> return () - Just (GHC.L ln mn) -> do - mark GHC.AnnModule - markExternal ln GHC.AnnVal (GHC.moduleNameString mn) - - forM_ mdepr markLocated - forM_ mexp markLocated - - mark GHC.AnnWhere - - markOptional GHC.AnnOpenC -- Possible '{' - markManyOptional GHC.AnnSemi -- possible leading semis - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps - - setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs - - markOptional GHC.AnnCloseC -- Possible '}' - - markEOF - --- --------------------------------------------------------------------- - -instance Annotate GHC.WarningTxt where - markAST _ (GHC.WarningTxt (GHC.L ls txt) lss) = do - markExternal ls GHC.AnnOpen txt - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do - markExternal ls GHC.AnnOpen txt - mark GHC.AnnOpenS - markListIntercalate lss - mark GHC.AnnCloseS - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 710 -instance Annotate GHC.StringLiteral where - markAST l (GHC.StringLiteral src _) = do - markExternal l GHC.AnnVal src - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -#endif - --- --------------------------------------------------------------------- - -instance Annotate (GHC.SourceText,GHC.FastString) where - markAST l (src,_fs) = do - markExternal l GHC.AnnVal src - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.HasOccName name,Annotate name) - => Annotate [GHC.LIE name] where - markAST _ ls = do - inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl - mark GHC.AnnOpenP -- '(' - -- Can't use markListIntercalate, there can be trailing commas, but only in imports. - markListIntercalateWithFunLevel markLocated 2 ls - - mark GHC.AnnCloseP -- ')' - -instance (GHC.DataId name,GHC.HasOccName name, Annotate name) - => Annotate (GHC.IE name) where - markAST _ ie = do - - case ie of - (GHC.IEVar ln) -> do - -- TODO: I am pretty sure this criterion is inadequate - if GHC.isDataOcc $ GHC.occName $ GHC.unLoc ln - then mark GHC.AnnPattern - else markOptional GHC.AnnPattern - setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln - - (GHC.IEThingAbs ln@(GHC.L _ n)) -> do - {- - At the moment (7.10.2) GHC does not cleanly represent an export of the form - "type Foo" - and it only captures the name "Foo". - - The Api Annotations workaround is to have the IEThingAbs SrcSpan - extend across both the "type" and "Foo", and then to capture the - individual item locations in an AnnType and AnnVal annotation. - - This need to be fixed for 7.12. - - -} - -#if __GLASGOW_HASKELL__ <= 710 - if GHC.isTcOcc (GHC.occName n) && GHC.isSymOcc (GHC.occName n) -#else - if ((GHC.isTcOcc $ GHC.occName n) && (GHC.isSymOcc $ GHC.occName n)) - && (not $ GHC.isLexConSym $ GHC.occNameFS $ GHC.occName n) -- rule out (:-$) etc -#endif - then do - mark GHC.AnnType - setContext (Set.singleton PrefixOp) $ markLocatedFromKw GHC.AnnVal ln - else setContext (Set.singleton PrefixOp) $ markLocated ln - -#if __GLASGOW_HASKELL__ <= 710 - (GHC.IEThingWith ln ns) -> do -#else - (GHC.IEThingWith ln wc ns _lfs) -> do -{- - | IEThingWith (Located name) - IEWildcard - [Located name] - [Located (FieldLbl name)] - -- ^ Class/Type plus some methods/constructors - -- and record fields; see Note [IEThingWith] - --} -#endif - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnOpenP -#if __GLASGOW_HASKELL__ <= 710 - setContext (Set.singleton PrefixOp) $ markListIntercalate ns -#else - 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 - setContext (Set.singleton PrefixOp) $ mapM_ markLocated ns' -#endif - 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) - --- --------------------------------------------------------------------- -{- --- For details on above see note [Api annotations] in ApiAnnotation -data RdrName - = Unqual OccName - -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. - -- Create such a 'RdrName' with 'mkRdrUnqual' - - | Qual ModuleName OccName - -- ^ A qualified name written by the user in - -- /source/ code. The module isn't necessarily - -- the module where the thing is defined; - -- just the one from which it is imported. - -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. - -- Create such a 'RdrName' with 'mkRdrQual' - - | Orig Module OccName - -- ^ An original name; the module is the /defining/ module. - -- This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where - -- we want to say \"Use Prelude.map dammit\". One of these - -- can be created with 'mkOrig' - - | Exact Name - -- ^ We know exactly the 'Name'. This is used: - -- - -- (1) When the parser parses built-in syntax like @[]@ - -- and @(,)@, but wants a 'RdrName' from it - -- - -- (2) By Template Haskell, when TH has generated a unique name - -- - -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' - deriving (Data, Typeable) --} - -isSymRdr :: GHC.RdrName -> Bool -isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." - -instance Annotate GHC.RdrName where - markAST l n = do - let - str = rdrName2String n - isSym = isSymRdr n - canParen = isSym && rdrName2String n /= "$" - doNormalRdrName = do - let str' = case str of - -- TODO: unicode support? - "forall" -> if spanLength l == 1 then "∀" else str - _ -> str - when (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n) $ inContext (Set.singleton InIE) $ mark GHC.AnnType - markOptional GHC.AnnType - let str'' = if isSym && (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n) - then -- Horrible hack until GHC 8.2 with https://phabricator.haskell.org/D3016 - if spanLength l - length str' > 6 -- length of "type" + 2 parens - then "(" ++ str' ++ ")" - else str' - else str' - - let - markParen :: GHC.AnnKeywordId -> Annotated () - markParen pa = do - if canParen - then ifInContext (Set.singleton PrefixOp) - (mark pa) -- '(' - (markOptional pa) - else if isSym - then ifInContext (Set.singleton PrefixOpDollar) - (mark pa) - (markOptional pa) - else markOptional pa - - 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 -#if __GLASGOW_HASKELL__ <= 710 - GHC.Orig _ _ -> markExternal l GHC.AnnVal str -#else - GHC.Orig _ _ -> if str == "~" - then doNormalRdrName - else markExternal l GHC.AnnVal str -#endif - GHC.Exact n' -> do - case str of - -- Special handling for Exact RdrNames, which are built-in Names - "[]" -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnCloseS -- ']' - "()" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnCloseP -- ')' - ('(':'#':_) -> do - markWithString GHC.AnnOpen "(#" -- '(#' - let cnt = length $ filter (==',') str - replicateM_ cnt (mark GHC.AnnCommaTuple) - markWithString GHC.AnnClose "#)"-- '#)' - "[::]" -> do - markWithString GHC.AnnOpen "[:" -- '[:' - markWithString GHC.AnnClose ":]" -- ':]' - "(->)" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnRarrow - mark GHC.AnnCloseP -- ')' - "~#" -> do - mark GHC.AnnOpenP -- '(' - mark GHC.AnnTildehsh - mark GHC.AnnCloseP - "*" -> do - markExternal l GHC.AnnVal str - "★" -> do -- Note: unicode star - markExternal l GHC.AnnVal str - ":" -> do - -- Note: The OccName for ":" has the following attributes (via occAttributes) - -- (d, Data DataSym Sym Val ) - -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon - doNormalRdrName - -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName - ('(':',':_) -> do - mark GHC.AnnOpenP - let cnt = length $ filter (==',') str - replicateM_ cnt (mark GHC.AnnCommaTuple) - mark GHC.AnnCloseP -- ')' -#if __GLASGOW_HASKELL__ <= 710 - "~" -> do - mark GHC.AnnOpenP - mark GHC.AnnTilde - mark GHC.AnnCloseP -#endif - _ -> 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") - --- --------------------------------------------------------------------- - --- TODO: What is this used for? Not in ExactPrint -instance Annotate GHC.Name where - markAST l n = do - markExternal l GHC.AnnVal (showGhc n) - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.ImportDecl name) 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 "#-}" - when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc) - >> markWithString GHC.AnnClose "#-}") - when safeflag (mark GHC.AnnSafe) - when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) - case mpkg of - Nothing -> return () -#if __GLASGOW_HASKELL__ <= 710 - Just pkg -> markWithString GHC.AnnPackageName (show (GHC.unpackFS pkg)) -#else - Just (GHC.StringLiteral srcPkg _) -> markWithString GHC.AnnPackageName srcPkg -#endif - - markLocated modname - - case GHC.ideclAs imp of - Nothing -> return () - Just mn -> do - mark GHC.AnnAs - markWithString GHC.AnnVal (GHC.moduleNameString 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.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.LHsDecl name -> Annotated () -markLHsDecl (GHC.L l decl) = - case decl of - GHC.TyClD d -> markLocated (GHC.L l d) - GHC.InstD d -> markLocated (GHC.L l d) - GHC.DerivD d -> markLocated (GHC.L l d) - GHC.ValD d -> markLocated (GHC.L l d) - GHC.SigD d -> markLocated (GHC.L l d) - GHC.DefD d -> markLocated (GHC.L l d) - GHC.ForD d -> markLocated (GHC.L l d) - GHC.WarningD d -> markLocated (GHC.L l d) - GHC.AnnD d -> markLocated (GHC.L l d) - GHC.RuleD d -> markLocated (GHC.L l d) - GHC.VectD 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) -#if __GLASGOW_HASKELL__ < 711 - GHC.QuasiQuoteD d -> markLocated (GHC.L l d) -#endif - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsDecl name) where - markAST l d = markLHsDecl (GHC.L l d) - --- --------------------------------------------------------------------- - -instance (Annotate name) - => Annotate (GHC.RoleAnnotDecl name) where - markAST _ (GHC.RoleAnnotDecl ln mr) = do - mark GHC.AnnType - mark GHC.AnnRole - 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.SpliceDecl name) where -#if __GLASGOW_HASKELL__ > 710 - markAST _ (GHC.SpliceDecl e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do - setContext (Set.singleton InSpliceDecl) $ markLocated e - markTrailingSemi -#endif - markAST _ (GHC.SpliceDecl e flag) = do - case flag of - GHC.ExplicitSplice -> mark GHC.AnnOpenPE - GHC.ImplicitSplice -> return () - - setContext (Set.singleton InSpliceDecl) $ markLocated e - - case flag of - GHC.ExplicitSplice -> mark GHC.AnnCloseP - GHC.ImplicitSplice -> return () - - markTrailingSemi - -{- -- data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y) -- ImplicitSplice -- <=> f x y, i.e. a naked -- top level expression -- --} - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.VectDecl name) where - markAST _ (GHC.HsVect src ln e) = do - markWithString GHC.AnnOpen src -- "{-# VECTORISE" - markLocated ln - mark GHC.AnnEqual - markLocated e - markWithString GHC.AnnClose "#-}" -- "#-}" - - markAST _ (GHC.HsNoVect src ln) = do - markWithString GHC.AnnOpen src -- "{-# NOVECTORISE" - markLocated ln - markWithString GHC.AnnClose "#-}" -- "#-}" - - markAST _ (GHC.HsVectTypeIn src _b ln mln) = do - markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR" - mark GHC.AnnType - markLocated ln - case mln of - Nothing -> return () - Just lnn -> do - mark GHC.AnnEqual - markLocated lnn - markWithString GHC.AnnClose "#-}" -- "#-}" - - markAST _ GHC.HsVectTypeOut {} = - traceM "warning: HsVectTypeOut appears after renaming" - - markAST _ (GHC.HsVectClassIn src ln) = do - markWithString GHC.AnnOpen src -- "{-# VECTORISE" - mark GHC.AnnClass - markLocated ln - markWithString GHC.AnnClose "#-}" -- "#-}" - - markAST _ GHC.HsVectClassOut {} = - traceM "warning: HsVecClassOut appears after renaming" - markAST _ GHC.HsVectInstIn {} = - traceM "warning: HsVecInstsIn appears after renaming" - markAST _ GHC.HsVectInstOut {} = - traceM "warning: HsVecInstOut appears after renaming" - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.RuleDecls name) where - markAST _ (GHC.HsRules src rules) = do - markWithString GHC.AnnOpen src - setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules - markWithString GHC.AnnClose "#-}" - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.RuleDecl name) where - markAST _ (GHC.HsRule ln act bndrs lhs _ rhs _) = do - markLocated ln - setContext (Set.singleton ExplicitNeverActive) $ markActivation act - - unless (null bndrs) $ do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - markLocated lhs - mark GHC.AnnEqual - markLocated rhs - inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi - markTrailingSemi - --- --------------------------------------------------------------------- - -markActivation :: GHC.Activation -> Annotated () -markActivation act = do -#if __GLASGOW_HASKELL__ <= 710 - case act of - GHC.ActiveBefore n -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - markWithString GHC.AnnVal (show n) - mark GHC.AnnCloseS -- ']' - GHC.ActiveAfter n -> do - mark GHC.AnnOpenS -- '[' - markWithString GHC.AnnVal (show n) - mark GHC.AnnCloseS -- ']' - GHC.NeverActive -> do - inContext (Set.singleton ExplicitNeverActive) $ do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - mark GHC.AnnCloseS -- ']' - _ -> return () -#else - case act of - GHC.ActiveBefore src _ -> do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - markWithString GHC.AnnVal src - mark GHC.AnnCloseS -- ']' - GHC.ActiveAfter src _ -> do - mark GHC.AnnOpenS -- '[' - markWithString GHC.AnnVal src - mark GHC.AnnCloseS -- ']' - GHC.NeverActive -> do - inContext (Set.singleton ExplicitNeverActive) $ do - mark GHC.AnnOpenS -- '[' - mark GHC.AnnTilde -- ~ - mark GHC.AnnCloseS -- ']' - _ -> return () -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.RuleBndr name) where - markAST _ (GHC.RuleBndr ln) = markLocated ln -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do - mark GHC.AnnOpenP -- "(" - markLocated ln - mark GHC.AnnDcolon - markLocated thing - mark GHC.AnnCloseP -- ")" -#else - markAST _ (GHC.RuleBndrSig ln st) = do - mark GHC.AnnOpenP -- "(" - markLocated ln - mark GHC.AnnDcolon - markLHsSigWcType st - mark GHC.AnnCloseP -- ")" -#endif --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 710 -markLHsSigWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.LHsSigWcType name -> Annotated () -markLHsSigWcType (GHC.HsIB _ (GHC.HsWC _ mwc ty)) = do - case mwc of - Nothing -> markLocated ty - Just lwc -> do - applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")] - ++ prepareListAnnotation [ty] - ) -#endif --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.AnnDecl name) where - markAST _ (GHC.HsAnnotation src prov e) = do - markWithString GHC.AnnOpen src - 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 name => Annotate (GHC.WarnDecls name) where - markAST _ (GHC.Warnings src warns) = do - markWithString GHC.AnnOpen src - mapM_ markLocated warns - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance (Annotate name) - => Annotate (GHC.WarnDecl name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.ForeignDecl name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.ForeignImport ln typ _ - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do -#else - markAST _ (GHC.ForeignImport ln (GHC.HsIB _ typ) _ - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do -{- - = ForeignImport - { fd_name :: Located name -- defines this name - , fd_sig_ty :: LHsSigType name -- sig_ty - , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty - , fd_fi :: ForeignImport } - --} -#endif - mark GHC.AnnForeign - mark GHC.AnnImport - markLocated cconv - unless (ll == GHC.noSrcSpan) $ markLocated safety -#if __GLASGOW_HASKELL__ <= 710 - markExternal ls GHC.AnnVal (show src) -#else - if GHC.unLoc cconv == GHC.PrimCallConv - then markExternal ls GHC.AnnVal src -#if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1)) - else markExternal ls GHC.AnnVal src -#else - else markExternal ls GHC.AnnVal (show src) -#endif -#endif - markLocated ln - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - -#if __GLASGOW_HASKELL__ <= 710 - markAST _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls src))) = do -#else - markAST _l (GHC.ForeignExport ln (GHC.HsIB _ typ) _ (GHC.CExport spec (GHC.L ls src))) = do -#endif - mark GHC.AnnForeign - mark GHC.AnnExport - markLocated spec - markExternal ls GHC.AnnVal (show src) - setContext (Set.singleton PrefixOp) $ markLocated ln - mark GHC.AnnDcolon - markLocated typ - - --- --------------------------------------------------------------------- - -instance (Annotate GHC.CExportSpec) where -#if __GLASGOW_HASKELL__ <= 710 - markAST l (GHC.CExportStatic _ cconv) = markAST l cconv -#else - markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv -#endif - --- --------------------------------------------------------------------- - -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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.DerivDecl name) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.DerivDecl typ mov) = do -#else - markAST _ (GHC.DerivDecl (GHC.HsIB _ typ) mov) = do -#endif - mark GHC.AnnDeriving - mark GHC.AnnInstance - markMaybe mov - markLocated typ - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.DefaultDecl name) where - - markAST _ (GHC.DefaultDecl typs) = do - mark GHC.AnnDefault - mark GHC.AnnOpenP -- '(' - markListIntercalate typs - mark GHC.AnnCloseP -- ')' - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.InstDecl name) 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 - markAST _ (GHC.NoOverlap src) = do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlappable src) = do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlapping src) = do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Overlaps src) = do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - - markAST _ (GHC.Incoherent src) = do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.ClsInstDecl name) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do -#else - markAST _ (GHC.ClsInstDecl (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do -#endif - 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.TyFamInstDecl name) where - - markAST _ (GHC.TyFamInstDecl eqn _) = do - mark GHC.AnnType - inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional - markLocated eqn - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.DataFamInstDecl name) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST l (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _) - defn@(GHC.HsDataDefn nd ctx typ _mk cons mderivs) _) = do -#else - markAST l (GHC.DataFamInstDecl ln (GHC.HsIB _ pats) - defn@(GHC.HsDataDefn nd ctx typ _mk cons mderivs) _) = do -#endif - case GHC.dd_ND defn of - GHC.NewType -> mark GHC.AnnNewtype - GHC.DataType -> mark GHC.AnnData - inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance - - markLocated ctx - - markTyClass ln pats - -#if __GLASGOW_HASKELL__ > 710 - case (GHC.dd_kindSig defn) of - Just s -> do - mark GHC.AnnDcolon - markLocated s - Nothing -> return () -#endif - if isGadt $ GHC.dd_cons defn - then mark GHC.AnnWhere - else mark GHC.AnnEqual - markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs) - markTrailingSemi - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsBind name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _) = do -#else - markAST _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _) = do -#endif - -- 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 - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs lb) _typ _fvs _ticks) = do -#else - markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs (GHC.L _ lb)) _typ _fvs _ticks) = do -#endif - markLocated lhs - case grhs of - (GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual -- empty guards - _ -> return () - markListIntercalateWithFunLevel markLocated 2 grhs - unless (GHC.isEmptyLocalBinds lb) $ mark GHC.AnnWhere - markOptional GHC.AnnWhere - - markLocalBindsWithLayout lb - markTrailingSemi - - markAST _ (GHC.VarBind _n rhse _) = - -- Note: this bind is introduced by the typechecker - markLocated rhse - - markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do - mark GHC.AnnPattern - case args of - GHC.InfixPatSyn la lb -> do - markLocated la - setContext (Set.singleton InfixOp) $ markLocated ln - markLocated lb - GHC.PrefixPatSyn ns -> do - markLocated ln - mapM_ markLocated ns -#if __GLASGOW_HASKELL__ > 710 - GHC.RecordPatSyn fs -> do - markLocated ln - mark GHC.AnnOpenC -- '{' - markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs - mark GHC.AnnCloseC -- '}' -#endif - 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 - - -- Introduced after renaming. - markAST _ (GHC.AbsBinds _ _ _ _ _) = - traceM "warning: AbsBinds introduced after renaming" - -#if __GLASGOW_HASKELL__ > 710 - -- Introduced after renaming. - markAST _ GHC.AbsBindsSig{} = - traceM "warning: AbsBindsSig introduced after renaming" -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.IPBind name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, - Annotate body) - => Annotate (GHC.Match name (GHC.Located body)) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do -#else - markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs (GHC.L _ lb))) = do -#endif - let -#if __GLASGOW_HASKELL__ <= 710 - get_infix Nothing = False - get_infix (Just (_,f)) = f -#else - get_infix GHC.NonFunBindMatch = False - get_infix (GHC.FunBindMatch _ f) = f -#endif -#if __GLASGOW_HASKELL__ <= 710 - isFunBind = isJust -#else - isFunBind GHC.NonFunBindMatch = False - isFunBind GHC.FunBindMatch{} = True -#endif - case (get_infix mln,pats) of - (True, a:b:xs) -> do - if null xs - then markOptional GHC.AnnOpenP - else mark GHC.AnnOpenP - markLocated a - case mln of -#if __GLASGOW_HASKELL__ <= 710 - Nothing -> return () - Just (n,_) -> setContext (Set.singleton InfixOp) $ markLocated n -#else - GHC.NonFunBindMatch -> return () - GHC.FunBindMatch n _ -> setContext (Set.singleton InfixOp) $ markLocated n -#endif - 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 -#if __GLASGOW_HASKELL__ <= 710 - case mln of - -- Nothing -> mark GHC.AnnFunId - Nothing -> markListNoPrecedingSpace False pats - Just (n,_) -> do - setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n - mapM_ markLocated pats - -- markListNoPrecedingSpace pats -#else - case mln of - -- GHC.NonFunBindMatch -> mark GHC.AnnFunId - GHC.NonFunBindMatch -> markListNoPrecedingSpace False pats - GHC.FunBindMatch n _ -> do - -- setContext (Set.singleton NoPrecedingSpace) $ markLocated n - setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n - mapM_ markLocated pats -#endif - - -- 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name, - Annotate name, Annotate body) - => Annotate (GHC.GRHS name (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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.Sig name) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.TypeSig lns typ _) = do -#else - markAST _ (GHC.TypeSig lns st) = do -#endif - setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns - mark GHC.AnnDcolon -#if __GLASGOW_HASKELL__ <= 710 - markLocated typ -#else - markLHsSigWcType st -#endif - markTrailingSemi - tellContext (Set.singleton FollowingLine) - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.PatSynSig ln (_ef,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do - mark GHC.AnnPattern - markLocated ln - mark GHC.AnnDcolon - - -- Note: The 'forall' bndrs '.' may occur multiple times - unless (null bndrs) $ do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - when (GHC.getLoc ctx1 /= GHC.noSrcSpan) $ do - setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx1 - markOffset GHC.AnnDarrow 0 - when (GHC.getLoc ctx2 /= GHC.noSrcSpan) $ do - setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx2 - markOffset GHC.AnnDarrow 1 - markLocated typ - markTrailingSemi -#else - markAST _ (GHC.PatSynSig ln (GHC.HsIB _ typ)) = do - mark GHC.AnnPattern - markLocated ln - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi -#endif - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.GenericSig ns typ) = do - mark GHC.AnnDefault -#else - markAST _ (GHC.ClassOpSig isDefault ns (GHC.HsIB _ typ)) = do - when isDefault $ mark GHC.AnnDefault -#endif - -- markListIntercalate ns - setContext (Set.singleton PrefixOp) $ markListIntercalate ns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - - markAST _ (GHC.IdSig _) = - traceM "warning: Introduced after renaming" - - -- FixSig (FixitySig name) -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do -#else - markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity src _v fdir))) = do -#endif - let fixstr = case fdir of - GHC.InfixL -> "infixl" - GHC.InfixR -> "infixr" - GHC.InfixN -> "infix" - markWithString GHC.AnnInfix fixstr -#if __GLASGOW_HASKELL__ <= 710 - markWithString GHC.AnnVal (show v) -#else - markWithString GHC.AnnVal src -#endif - setContext (Set.singleton InfixOp) $ markListIntercalate lns - markTrailingSemi - - -- InlineSig (Located name) InlinePragma - -- '{-# INLINE' activation qvar '#-}' - markAST _ (GHC.InlineSig ln inl) = do - markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE' - markActivation (GHC.inl_act inl) - setContext (Set.singleton PrefixOp) $ markLocated ln - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.SpecSig ln typs inl) = do -#else - markAST _ (GHC.SpecSig ln typs inl) = do -{- - | SpecSig (Located name) -- Specialise a function or datatype ... - [LHsSigType name] -- ... to these types - InlinePragma -- The pragma on SPECIALISE_INLINE form. - -- If it's just defaultInlinePragma, then we said - -- SPECIALISE, not SPECIALISE_INLINE - --} -#endif - markWithString GHC.AnnOpen (GHC.inl_src inl) - markActivation (GHC.inl_act inl) - markLocated ln - mark GHC.AnnDcolon -- '::' -#if __GLASGOW_HASKELL__ <= 710 - markListIntercalate typs -#else - markListIntercalateWithFunLevel markLHsSigType 2 typs -#endif - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - -- '{-# SPECIALISE' 'instance' inst_type '#-}' - markAST _ (GHC.SpecInstSig src typ) = do - markWithString GHC.AnnOpen src - mark GHC.AnnInstance -#if __GLASGOW_HASKELL__ <= 710 - markLocated typ -#else - markLHsSigType typ -#endif - markWithString GHC.AnnClose "#-}" -- '#-}' - markTrailingSemi - - - - -- MinimalSig (BooleanFormula (Located name)) - markAST _l (GHC.MinimalSig src formula) = do - markWithString GHC.AnnOpen src -#if __GLASGOW_HASKELL__ <= 710 - annotationsToCommentsBF formula [GHC.AnnOpenP,GHC.AnnCloseP,GHC.AnnComma,GHC.AnnVbar] - markAST _l formula - finalizeBF _l -#else - markLocated formula -#endif - markWithString GHC.AnnClose "#-}" - markTrailingSemi - --- -------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ > 710 -markLHsSigType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.LHsSigType name -> Annotated () -markLHsSigType (GHC.HsIB _ typ) = markLocated typ - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate [GHC.LHsSigType name] 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. - case ls of - [] -> markManyOptional GHC.AnnOpenP - [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnOpenP - [_] -> markManyOptional GHC.AnnOpenP - _ -> markMany GHC.AnnOpenP - markListIntercalateWithFun markLHsSigType ls - case ls of - [] -> markManyOptional GHC.AnnCloseP - [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnCloseP - [_] -> markManyOptional GHC.AnnCloseP - _ -> markMany GHC.AnnCloseP -#endif - --- -------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 --- In practice, due to the way the BooleanFormula is constructed in the parser, --- we will get the following variants --- a | b : Or [a,b] --- a , b : And [a,b] --- ( a ) : a --- A bottom level Located RdrName is captured in a Var. This is the only part --- with a location in it. --- --- So the best strategy might be to convert all the annotations into comments, --- and then just print the names. DONE -instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where - -- markAST _ (GHC.Var x) = markLocated x - markAST _ (GHC.Var x) = setContext (Set.singleton PrefixOp) $ markLocated x - markAST l (GHC.Or ls) = mapM_ (markAST l) ls - markAST l (GHC.And ls) = mapM_ (markAST l) ls -#else -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 l (GHC.Or ls) = mapM_ markLocated ls - 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 -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsTyVarBndr name) where - markAST _l (GHC.UserTyVar n) = do -#if __GLASGOW_HASKELL__ <= 710 - markAST _l n -#else - markLocated n -#endif - - markAST _ (GHC.KindedTyVar n ty) = do - mark GHC.AnnOpenP -- '(' - markLocated n - mark GHC.AnnDcolon -- '::' - markLocated ty - mark GHC.AnnCloseP -- '(' - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsType name) where - markAST loc ty = do - markType loc ty - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - where - - -- markType :: GHC.SrcSpan -> ast -> Annotated () -#if __GLASGOW_HASKELL__ <= 710 - markType _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do - unless (null tvs) $ do - mark GHC.AnnForall - mapM_ markLocated tvs - mark GHC.AnnDot - - case mwc of - Nothing -> when (lc /= GHC.noSrcSpan) $ markLocated ctx - Just lwc -> do - let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildcardTy:ctxs) - markLocated (GHC.L lc sorted) - - markLocated typ - -- mark GHC.AnnCloseP -- ")" -#else - markType _ (GHC.HsForAllTy tvs typ) = do - mark GHC.AnnForall - mapM_ markLocated tvs - mark GHC.AnnDot - markLocated typ - - {- - = HsForAllTy -- See Note [HsType binders] - { hst_bndrs :: [LHsTyVarBndr name] -- Explicit, user-supplied 'forall a b c' - , hst_body :: LHsType name -- body type - } - - -} -#endif - -#if __GLASGOW_HASKELL__ > 710 - markType _ (GHC.HsQualTy cxt typ) = do - markLocated cxt - markLocated typ - {- - | HsQualTy -- See Note [HsType binders] - { hst_ctxt :: LHsContext name -- Context C => blah - , hst_body :: LHsType name } - -} -#endif - - markType _l (GHC.HsTyVar name) = do -#if __GLASGOW_HASKELL__ <= 710 - if GHC.isDataOcc $ GHC.occName name - then do - mark GHC.AnnSimpleQuote - markLocatedFromKw GHC.AnnName (GHC.L _l name) - else unsetContext Intercalate $ markAST _l name -#else - -- TODO: Should the isExactName test move into the RdrName Annotate instanced? - if ((GHC.isDataOcc $ GHC.occName $ GHC.unLoc name) && ((not $ isExactName $ GHC.unLoc name))) - || (showGhc name == "()") - then do - mark GHC.AnnSimpleQuote - markLocatedFromKw GHC.AnnName name - else markLocated name -#endif - -#if __GLASGOW_HASKELL__ > 710 - markType _ (GHC.HsAppsTy ts) = do - mapM_ markLocated ts -#endif - - markType _ (GHC.HsAppTy t1 t2) = do - setContext (Set.singleton PrefixOp) $ markLocated t1 - markLocated t2 - - markType _ (GHC.HsFunTy t1 t2) = do - markLocated t1 - mark GHC.AnnRarrow - markLocated t2 - - markType _ (GHC.HsListTy t) = do - mark GHC.AnnOpenS -- '[' - markLocated t - mark GHC.AnnCloseS -- ']' - - markType _ (GHC.HsPArrTy t) = do - markWithString GHC.AnnOpen "[:" -- '[:' - markLocated t - markWithString GHC.AnnClose ":]" -- ':]' - - 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 "#)" -- '#)' - -#if __GLASGOW_HASKELL__ <= 710 - markType _ (GHC.HsOpTy t1 (_,lo) t2) = do -#else - markType _ (GHC.HsOpTy t1 lo t2) = do - -- HsOpTy (LHsType name) (Located name) (LHsType name) -#endif - 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 (GHC.HsIPName n) t) = do - markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n)) - mark GHC.AnnDcolon - markLocated t - - markType _ (GHC.HsEqTy t1 t2) = do - markLocated t1 - mark GHC.AnnTilde - markLocated t2 - - markType _ (GHC.HsKindSig t k) = do - mark GHC.AnnOpenP -- '(' - markLocated t - mark GHC.AnnDcolon -- '::' - markLocated k - mark GHC.AnnCloseP -- ')' - - markType l (GHC.HsSpliceTy s _) = do -#if __GLASGOW_HASKELL__ <= 710 - mark GHC.AnnOpenPE - markAST l s - mark GHC.AnnCloseP -#else - markAST l s -#endif - - markType _ (GHC.HsDocTy t ds) = do - markLocated t - markLocated ds - -#if __GLASGOW_HASKELL__ <= 710 - markType _ (GHC.HsBangTy b t) = do - case b of - (GHC.HsSrcBang ms (Just True) _) -> do - markWithString GHC.AnnOpen (fromMaybe "{-# UNPACK" ms) - markWithString GHC.AnnClose "#-}" - (GHC.HsSrcBang ms (Just False) _) -> do - markWithString GHC.AnnOpen (fromMaybe "{-# NOUNPACK" ms) - markWithString GHC.AnnClose "#-}" - _ -> return () - mark GHC.AnnBang - markLocated t -#else - markType _ (GHC.HsBangTy (GHC.HsSrcBang mt _up str) t) = do - case mt of - Nothing -> return () - Just src -> do - markWithString GHC.AnnOpen src - markWithString GHC.AnnClose "#-}" - case str of - GHC.SrcLazy -> mark GHC.AnnTilde - GHC.SrcStrict -> mark GHC.AnnBang - GHC.NoSrcStrict -> return () - - markLocated t - {- - | HsBangTy HsSrcBang (LHsType name) -- Bang-style type annotations - data HsSrcBang = - HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes - SrcUnpackedness - SrcStrictness - data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' - | SrcStrict -- ^ Strict, ie '!' - | NoSrcStrict -- ^ no strictness annotation - - data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified - | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified - | NoSrcUnpack -- ^ no unpack pragma - - -} -#endif - - markType _ (GHC.HsRecTy cons) = do - mark GHC.AnnOpenC -- '{' - markListIntercalate cons - mark GHC.AnnCloseC -- '}' - - -- HsCoreTy Type - markType _ (GHC.HsCoreTy _t) = - traceM "warning: HsCoreTy Introduced after renaming" - - markType _ (GHC.HsExplicitListTy _ ts) = do - 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 - - -- HsTyLit HsTyLit - markType l (GHC.HsTyLit lit) = do - case lit of - (GHC.HsNumTy s _) -> - markExternal l GHC.AnnVal s - (GHC.HsStrTy s _) -> - markExternal l GHC.AnnVal s - - -- HsWrapTy HsTyAnnotated (HsType name) -#if __GLASGOW_HASKELL__ <= 710 - markType _ (GHC.HsWrapTy _ _) = - traceM "warning: HsWrapTyy Introduced after renaming" -#endif - -#if __GLASGOW_HASKELL__ <= 710 - markType l GHC.HsWildcardTy = do - markExternal l GHC.AnnVal "_" - markType l (GHC.HsNamedWildcardTy n) = do - markExternal l GHC.AnnVal (showGhc n) -#else - markType l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do - markExternal l GHC.AnnVal "_" -#endif - -#if __GLASGOW_HASKELL__ <= 710 - markType l (GHC.HsQuasiQuoteTy n) = do - markAST l n -#endif - --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 710 -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsAppType name) 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 -#endif --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsSplice name) where -#if __GLASGOW_HASKELL__ > 710 - markAST l c = - case c of - GHC.HsQuasiQuote _ n _pos fs -> do - markExternal l GHC.AnnVal - ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") - - GHC.HsTypedSplice _n (GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do - markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) - GHC.HsTypedSplice _n b -> do - mark GHC.AnnOpenPTE - markLocated b - mark GHC.AnnCloseP - - GHC.HsUntypedSplice _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do - ifInContext (Set.singleton InSpliceDecl) - (return ()) - (mark GHC.AnnOpenPE) - -- TODO: We do not seem to have any way to distinguish between which of - -- the next two lines will emit output. If AnnThIdSplice is there, the - -- markLocated b ends up with a negative offset so emits nothing. - markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) - markLocated b - ifInContext (Set.singleton InSpliceDecl) - (return ()) - (mark GHC.AnnCloseP) - GHC.HsUntypedSplice _n b -> do - -- TODO: when is this not optional? - markOptional GHC.AnnThIdSplice - ifInContext (Set.singleton InSpliceDecl) - (return ()) - (mark GHC.AnnOpenPE) - markLocated b - ifInContext (Set.singleton InSpliceDecl) - (return ()) - (mark GHC.AnnCloseP) -#if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1)) - GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" -#endif -#else - markAST _ c = - case c of - GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do - -- TODO: We do not seem to have any way to distinguish between which of - -- the next two lines will emit output. If AnnThIdSplice is there, the - markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) - markLocated b - GHC.HsSplice _n b@(GHC.L _ (GHC.HsBracket _)) -> do - markLocated b - GHC.HsSplice _n b -> do - markLocated b -#endif - -#if __GLASGOW_HASKELL__ <= 710 -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsQuasiQuote name) where - markAST l (GHC.HsQuasiQuote n _pos fs) = do - markExternal l GHC.AnnVal - ("[" ++ showGhc n ++ "|" ++ GHC.unpackFS fs ++ "|]") -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => - Annotate (GHC.ConDeclField name) where - markAST _ (GHC.ConDeclField ns ty mdoc) = do -{- -data ConDeclField name -- Record fields have Haddoc docs on them - = ConDeclField { cd_fld_names :: [LFieldOcc name], - -- ^ See Note [ConDeclField names] - cd_fld_type :: LBangType name, - cd_fld_doc :: Maybe LHsDocString } - --} - unsetContext Intercalate $ do - markListIntercalate ns - mark GHC.AnnDcolon - markLocated ty - markMaybe mdoc - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ > 710 -instance (GHC.DataId name) - => Annotate (GHC.FieldOcc name) where - markAST _ (GHC.FieldOcc rn _) = do - markLocated rn - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -#endif - --- --------------------------------------------------------------------- - -instance Annotate GHC.HsDocString where - markAST l (GHC.HsDocString s) = do - markExternal l GHC.AnnVal (GHC.unpackFS s) - --- --------------------------------------------------------------------- -instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.Pat name) 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) $ -#if __GLASGOW_HASKELL__ <= 710 - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l n -#else - unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) -#endif - markPat _ (GHC.LazyPat p) = do - mark GHC.AnnTilde - markLocated p - - markPat _ (GHC.AsPat ln p) = do - markLocated ln - mark GHC.AnnAt - markLocated p - - markPat _ (GHC.ParPat p) = do - mark GHC.AnnOpenP - markLocated p - mark GHC.AnnCloseP - - markPat _ (GHC.BangPat p) = do - mark GHC.AnnBang - markLocated p - - markPat _ (GHC.ListPat ps _ _) = do - mark GHC.AnnOpenS - markListIntercalateWithFunLevel markLocated 2 ps - mark GHC.AnnCloseS - - markPat _ (GHC.TuplePat pats b _) = do - if b == GHC.Boxed then mark GHC.AnnOpenP - else markWithString GHC.AnnOpen "(#" - markListIntercalateWithFunLevel markLocated 2 pats - if b == GHC.Boxed then mark GHC.AnnCloseP - else markWithString GHC.AnnClose "#)" - - markPat _ (GHC.PArrPat ps _) = do - markWithString GHC.AnnOpen "[:" - mapM_ markLocated ps - markWithString GHC.AnnClose ":]" - - markPat _ (GHC.ConPatIn n dets) = do - markHsConPatDetails n dets - - markPat _ GHC.ConPatOut {} = - traceM "warning: ConPatOut Introduced after renaming" - - -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type) - markPat _ (GHC.ViewPat e pat _) = do - markLocated e - mark GHC.AnnRarrow - markLocated pat - - -- SplicePat (HsSplice id) - markPat l (GHC.SplicePat s) = do -#if __GLASGOW_HASKELL__ <= 710 - mark GHC.AnnOpenPE - markAST l s - mark GHC.AnnCloseP -#else - markAST l s -#endif - - -- LitPat HsLit - markPat l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp) - - -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id) -#if __GLASGOW_HASKELL__ <= 710 - markPat _ (GHC.NPat ol mn _) = do -#else - markPat _ (GHC.NPat ol mn _ _) = do -#endif - -- markOptional GHC.AnnMinus - when (isJust mn) $ mark GHC.AnnMinus - markLocated ol - - -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id) -#if __GLASGOW_HASKELL__ <= 710 - markPat _ (GHC.NPlusKPat ln ol _ _) = do -#else - markPat _ (GHC.NPlusKPat ln ol _ _ _ _) = do -#endif - markLocated ln - markWithString GHC.AnnVal "+" -- "+" - markLocated ol - - -#if __GLASGOW_HASKELL__ <= 710 - markPat _ (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do - markLocated pat - mark GHC.AnnDcolon - markLocated ty -#else - markPat _ (GHC.SigPatIn pat ty) = do - markLocated pat - mark GHC.AnnDcolon - markLHsSigWcType ty -#endif - - markPat _ GHC.SigPatOut {} = - traceM "warning: SigPatOut introduced after renaming" - - -- CoPat HsAnnotated (Pat id) Type - markPat _ GHC.CoPat {} = - traceM "warning: CoPat introduced after renaming" - -#if __GLASGOW_HASKELL__ <= 710 - markPat l (GHC.QuasiQuotePat p) = markAST l p -#endif - --- --------------------------------------------------------------------- -hsLit2String :: GHC.HsLit -> GHC.SourceText -hsLit2String lit = - case lit of - GHC.HsChar src _ -> src - -- It should be included here - -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 - GHC.HsCharPrim src _ -> src ++ "#" - GHC.HsString src _ -> src - GHC.HsStringPrim src _ -> src - GHC.HsInt src _ -> src - GHC.HsIntPrim src _ -> src - GHC.HsWordPrim src _ -> src - GHC.HsInt64Prim src _ -> src - GHC.HsWord64Prim src _ -> src - GHC.HsInteger src _ _ -> src - GHC.HsRat (GHC.FL src _) _ -> src - GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#" - GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##" - -markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.Located name -> GHC.HsConPatDetails name -> 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 - setContext (Set.singleton InfixOp) $ markLocated ln - markLocated a2 - -markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Bool -> Bool -> [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated () - -markHsConDeclDetails isDeprecated inGadt lns dets = do - case dets of - GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args - GHC.RecCon fs -> do - mark GHC.AnnOpenC - if inGadt - then do - if isDeprecated - then setContext (Set.fromList [InGadt]) $ markLocated fs - else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs - else do - if isDeprecated - then markLocated fs - else setContext (Set.fromList [InRecCon]) $ markLocated fs - GHC.InfixCon a1 a2 -> do - markLocated a1 - setContext (Set.singleton InfixOp) $ mapM_ markLocated lns - markLocated a2 - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate [GHC.LConDeclField name] where - markAST _ fs = do - markOptional GHC.AnnOpenC -- '{' - markListIntercalate fs - markOptional GHC.AnnDotdot - inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' - inContext (Set.singleton InGadt) $ do - mark GHC.AnnRarrow - --- --------------------------------------------------------------------- - -instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where - markAST l ol = - let str = case GHC.ol_val ol of - GHC.HsIntegral src _ -> src - GHC.HsFractional l2 -> GHC.fl_text l2 - GHC.HsIsString src _ -> src - in - markExternal l GHC.AnnVal str - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -instance (GHC.DataId name,Annotate arg) - => Annotate (GHC.HsWithBndrs name (GHC.Located arg)) where - markAST _ (GHC.HsWB thing _ _ _) = do - markLocated thing -#else -instance (GHC.DataId name,Annotate arg) - => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where - markAST _ (GHC.HsIB _ thing) = do - markLocated thing -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name - ,GHC.HasOccName name,Annotate body) - => Annotate (GHC.Stmt name (GHC.Located body)) where - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.LastStmt body _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body -#else - markAST _ (GHC.LastStmt body _ _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body -#endif - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.BindStmt pat body _ _) = do -#else - markAST _ (GHC.BindStmt pat body _ _ _) = do -#endif - 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 - -#if __GLASGOW_HASKELL__ > 710 - markAST _ GHC.ApplicativeStmt{} - = error "ApplicativeStmt should not appear in ParsedSource" -#endif - - markAST _ (GHC.BodyStmt body _ _ _) = do - unsetContext Intercalate $ markLocated body - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.LetStmt lb) = do -#else - markAST _ (GHC.LetStmt (GHC.L _ lb)) = do -#endif - 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 - -#if __GLASGOW_HASKELL__ <= 710 - markAST l (GHC.ParStmt pbs _ _) = do -#else - markAST l (GHC.ParStmt pbs _ _ _) = do -#endif - -- 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 - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.TransStmt form stmts _b using by _ _ _) = do -#else - markAST _ (GHC.TransStmt form stmts _b using by _ _ _ _) = do -#endif - 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 - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do -#else - markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _) = do -#endif - mark GHC.AnnRec - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - mapM_ markLocated stmts - markOptional GHC.AnnCloseC - inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar - inContext (Set.singleton Intercalate) $ mark GHC.AnnComma - markTrailingSemi - --- --------------------------------------------------------------------- - --- 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.ParStmtBlock name name) where - markAST _ (GHC.ParStmtBlock stmts _ns _) = do - markListIntercalate stmts - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsLocalBinds name) where - markAST _ lb = markHsLocalBinds lb - --- --------------------------------------------------------------------- - -markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.HsLocalBinds name -> Annotated () -markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = - applyListAnnotationsLayout - (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ) -markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {}) - = traceM "warning: ValBindsOut introduced after renaming" - -markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout (reverse binds) -markHsLocalBinds GHC.EmptyLocalBinds = return () - --- --------------------------------------------------------------------- - -markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, - Annotate body) - => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body) - -> Annotated () -#if __GLASGOW_HASKELL__ <= 710 -markMatchGroup _ (GHC.MG matches _ _ _) -#else -markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _) -#endif - = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, - Annotate body) - => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsExpr name) 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 -#if __GLASGOW_HASKELL__ <= 710 - markExpr l (GHC.HsVar n) = unsetContext Intercalate $ markAST l n -#else - 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) - ) -#endif - -#if __GLASGOW_HASKELL__ <= 710 -#else - markExpr l (GHC.HsRecFld f) = markAST l f - - markExpr l (GHC.HsOverLabel fs) - = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) -#endif - - markExpr l (GHC.HsIPVar (GHC.HsIPName v)) = - markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v) - markExpr l (GHC.HsOverLit ov) = markAST l ov - markExpr l (GHC.HsLit lit) = markAST l lit - -#if __GLASGOW_HASKELL__ <= 710 - markExpr _ (GHC.HsLam (GHC.MG [match] _ _ _)) = do -#else - markExpr _ (GHC.HsLam (GHC.MG (GHC.L _ [match]) _ _ _)) = do -#endif - setContext (Set.singleton LambdaExpr) $ do - -- TODO: Change this, HsLam binds do not need obey layout rules. - -- And will only ever have a single match - markLocated match - markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match" - - markExpr l (GHC.HsLamCase _ match) = do - mark GHC.AnnLam - mark GHC.AnnCase - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l match - markOptional GHC.AnnCloseC - - markExpr _ (GHC.HsApp e1 e2) = do - -- markLocated e1 - setContext (Set.singleton PrefixOp) $ markLocated e1 - -- markLocated e2 - 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 l (GHC.HsCase e1 matches) = setRigidFlag $ do - mark GHC.AnnCase - setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 - mark GHC.AnnOf - markOptional GHC.AnnOpenC - markInside GHC.AnnSemi - setContext (Set.singleton CaseAlt) $ markMatchGroup l matches - markOptional GHC.AnnCloseC - - -- We set the layout for HsIf even though it need not obey layout rules as - -- when moving these expressions it's useful that they maintain "internal - -- integrity", that is to say the subparts remain indented relative to each - -- other. - markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do - -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do - mark GHC.AnnIf - markLocated e1 - -- markOffsetOptional GHC.AnnSemi 0 - markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen - mark GHC.AnnThen - setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 - -- markOffsetOptional GHC.AnnSemi 1 - 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 - -#if __GLASGOW_HASKELL__ <= 710 - markExpr _ (GHC.HsLet binds e) = do -#else - markExpr _ (GHC.HsLet (GHC.L _ binds) e) = do -#endif - 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) - - -- ------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 - markExpr _ (GHC.HsDo cts es _) = do -#else - markExpr _ (GHC.HsDo cts (GHC.L _ es) _) = do -#endif - case cts of - GHC.DoExpr -> mark GHC.AnnDo - GHC.MDoExpr -> mark GHC.AnnMdo - _ -> return () - let (ostr,cstr) = - if isListComp cts - then case cts of - GHC.PArrComp -> ("[:",":]") - _ -> ("[", "]") - 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.ExplicitPArr _ es) = do - markWithString GHC.AnnOpen "[:" - mapM_ markLocated es - markWithString GHC.AnnClose ":]" - -#if __GLASGOW_HASKELL__ <= 710 - markExpr _ (GHC.RecordCon n _ (GHC.HsRecFields fs dd)) = do -#else - markExpr _ (GHC.RecordCon n _ _ (GHC.HsRecFields fs dd)) = do -#endif - 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 - -#if __GLASGOW_HASKELL__ <= 710 - markExpr _ (GHC.RecordUpd e (GHC.HsRecFields fs _) _cons _ _) = do -#else - markExpr _ (GHC.RecordUpd e fs _cons _ _ _) = do -#endif - markLocated e - mark GHC.AnnOpenC - markListIntercalate fs - mark GHC.AnnCloseC - -#if __GLASGOW_HASKELL__ <= 710 - markExpr _ (GHC.ExprWithTySig e typ _) = do -#else - markExpr _ (GHC.ExprWithTySig e typ) = do -#endif - setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e - mark GHC.AnnDcolon -#if __GLASGOW_HASKELL__ <= 710 - markLocated typ -#else - markLHsSigWcType typ -#endif - - markExpr _ (GHC.ExprWithTySigOut e typ) = do - markLocated e - mark GHC.AnnDcolon -#if __GLASGOW_HASKELL__ <= 710 - markLocated typ -#else - markLHsSigWcType typ -#endif - - 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.PArrSeq _ seqInfo) = do - markWithString GHC.AnnOpen "[:" -- '[:' - 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 - markWithString GHC.AnnClose ":]" -- ':]' - - markExpr _ (GHC.HsSCC src csFStr e) = do - markWithString GHC.AnnOpen src -- "{-# SCC" -#if __GLASGOW_HASKELL__ <= 710 - markWithStringOptional GHC.AnnVal (GHC.unpackFS csFStr) - markWithString GHC.AnnValStr ("\"" ++ GHC.unpackFS csFStr ++ "\"") -#else - markWithStringOptional GHC.AnnVal (GHC.sl_st csFStr) - markWithString GHC.AnnValStr (GHC.sl_st csFStr) -#endif - markWithString GHC.AnnClose "#-}" - markLocated e - - markExpr _ (GHC.HsCoreAnn src csFStr e) = do - markWithString GHC.AnnOpen src -- "{-# CORE" -#if __GLASGOW_HASKELL__ <= 710 - markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS csFStr ++ "\"") -#else - markWithString GHC.AnnVal (GHC.sl_st csFStr) -#endif - 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 - markWithString GHC.AnnClose "|]" - -- Introduced after the renamer - markExpr _ (GHC.HsBracket (GHC.DecBrG _)) = - traceM "warning: DecBrG introduced after renamer" - markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do -#if __GLASGOW_HASKELL__ <= 710 - -- This exists like this as the lexer collapses [e| and [| into the - -- same construtor - workOutString _l GHC.AnnOpen - (\ss -> if spanLength ss == 2 - then "[|" - else "[e|") -#else - markWithString GHC.AnnOpen "[|" - markOptional GHC.AnnOpenE -- "[e|" -#endif - markLocated e - markWithString GHC.AnnClose "|]" - markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do -#if __GLASGOW_HASKELL__ <= 710 - -- This exists like this as the lexer collapses [e|| and [|| into the - -- same construtor - workOutString _l GHC.AnnOpen - (\ss -> if spanLength ss == 3 - then "[||" - else "[e||") -#else - markWithString GHC.AnnOpen "[||" - markWithStringOptional GHC.AnnOpenE "[e||" -#endif - markLocated e - markWithString GHC.AnnClose "||]" - markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do - markWithString GHC.AnnOpen "[t|" - markLocated e - markWithString GHC.AnnClose "|]" - markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do - markWithString GHC.AnnOpen "[p|" - markLocated e - markWithString GHC.AnnClose "|]" - - markExpr _ (GHC.HsRnBracketOut _ _) = - traceM "warning: HsRnBracketOut introduced after renamer" - markExpr _ (GHC.HsTcBracketOut _ _) = - traceM "warning: HsTcBracketOut introduced after renamer" - -#if __GLASGOW_HASKELL__ > 710 - markExpr l (GHC.HsSpliceE e) = do - markOptional GHC.AnnOpenPE - markAST l e - markOptional GHC.AnnCloseP -#else - markExpr _ (GHC.HsSpliceE isTyped e) = do - case e of - GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do - if isTyped - then do - mark GHC.AnnOpenPTE - markWithStringOptional GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) - else do - mark GHC.AnnOpenPE - markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) - markLocated b - mark GHC.AnnCloseP - GHC.HsSplice _n b -> do - if isTyped - then do - markOptional GHC.AnnThIdSplice - mark GHC.AnnOpenPTE - else mark GHC.AnnOpenPE - markLocated b - mark GHC.AnnCloseP - - markExpr l (GHC.HsQuasiQuoteE e) = do - markAST l e -#endif - - markExpr _ (GHC.HsProc p c) = do - mark GHC.AnnProc - markLocated p - mark GHC.AnnRarrow - markLocated c - - markExpr _ (GHC.HsStatic e) = do - mark GHC.AnnStatic - markLocated e - - markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do - -- isRightToLeft True => right-to-left (f -< arg) - -- False => left-to-right (arg >- f) - if isRightToLeft - then do - markLocated e1 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail - else do - markLocated e2 - case o of - GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail - GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail - - if isRightToLeft - then markLocated e2 - else markLocated e1 - - markExpr _ (GHC.HsArrForm e _ cs) = do - markWithString GHC.AnnOpen "(|" - markLocated e - mapM_ markLocated cs - markWithString GHC.AnnClose "|)" - - markExpr _ (GHC.HsTick _ _) = return () - markExpr _ (GHC.HsBinTick _ _ _) = return () - -#if __GLASGOW_HASKELL__ <= 710 - markExpr _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do - -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - markWithString GHC.AnnOpen src - markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str)) -- STRING - markOffsetWithString GHC.AnnVal 1 (show v1) -- INTEGER - markOffset GHC.AnnColon 0 -- ':' - markOffsetWithString GHC.AnnVal 2 (show v2) -- INTEGER - mark GHC.AnnMinus -- '-' - markOffsetWithString GHC.AnnVal 3 (show v3) -- INTEGER - markOffset GHC.AnnColon 1 -- ':' - markOffsetWithString GHC.AnnVal 4 (show v4) -- INTEGER - markWithString GHC.AnnClose "#-}" - markLocated e -#else - markExpr _ (GHC.HsTickPragma src (str,_,_) ((v1,v2),(v3,v4)) e) = do - -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - markWithString GHC.AnnOpen src - markOffsetWithString GHC.AnnVal 0 (GHC.sl_st str) -- STRING - markOffsetWithString GHC.AnnVal 1 v1 -- INTEGER - markOffset GHC.AnnColon 0 -- ':' - markOffsetWithString GHC.AnnVal 2 v2 -- INTEGER - mark GHC.AnnMinus -- '-' - markOffsetWithString GHC.AnnVal 3 v3 -- INTEGER - markOffset GHC.AnnColon 1 -- ':' - markOffsetWithString GHC.AnnVal 4 v4 -- INTEGER - markWithString GHC.AnnClose "#-}" - markLocated e -#endif - - markExpr l GHC.EWildPat = do - markExternal l GHC.AnnVal "_" - - markExpr _ (GHC.EAsPat ln e) = do - markLocated ln - mark GHC.AnnAt - markLocated e - - markExpr _ (GHC.EViewPat e1 e2) = do - markLocated e1 - mark GHC.AnnRarrow - markLocated e2 - - markExpr _ (GHC.ELazyPat e) = do - mark GHC.AnnTilde - markLocated e - -#if __GLASGOW_HASKELL__ <= 710 - markExpr _ (GHC.HsType ty) = markLocated ty -#else - markExpr _ (GHC.HsAppType e ty) = do - markLocated e - mark GHC.AnnAt - markLHsWcType ty - markExpr _ (GHC.HsAppTypeOut _ _) = - traceM "warning: HsAppTypeOut introduced after renaming" -#endif - - markExpr _ (GHC.HsWrap _ _) = - traceM "warning: HsWrap introduced after renaming" - markExpr _ (GHC.HsUnboundVar _) = - traceM "warning: HsUnboundVar introduced after renaming" - - --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 710 -markLHsWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.LHsWcType name -> Annotated () -markLHsWcType (GHC.HsWC _ mwc ty) = do - case mwc of - Nothing -> markLocated ty - Just lwc -> do - -- let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildCardTy:[ty]) - -- markLocated (GHC.L lc sorted) - applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")] - ++ prepareListAnnotation [ty] - ) -#endif --- --------------------------------------------------------------------- - -instance Annotate GHC.HsLit where - markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) - --- --------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ > 710 -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsRecUpdField name) 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 -{- -type HsRecUpdField id = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id) - --- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', --- --- For details on above see note [Api annotations] in ApiAnnotation -data HsRecField' id arg = HsRecField { - hsRecFieldLbl :: Located id, - hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning - hsRecPun :: Bool -- ^ Note [Punning] - } deriving (Data, Typeable) - --} - -instance (GHC.DataId name) - => Annotate (GHC.AmbiguousFieldOcc name) where - markAST _ (GHC.Unambiguous n _) = markLocated n - markAST _ (GHC.Ambiguous n _) = markLocated n -#endif --- --------------------------------------------------------------------- - --- |Used for declarations that need to be aligned together, e.g. in a --- do or let .. in statement/expr -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate [GHC.ExprLStmt name] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsTupArg name) 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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsCmdTop name) where - markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.HsCmd name) 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 _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 - - -- TODO: This test assumes no auto-generated SrcSpans - let isPrefixOp = case cs of - [] -> True - (GHC.L h _:_) -> GHC.getLoc e < h - when isPrefixOp $ markWithString GHC.AnnOpen "(|" - -- 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 $ markWithString GHC.AnnClose "|)" - - markAST _ (GHC.HsCmdApp e1 e2) = do - markLocated e1 - markLocated e2 - - markAST l (GHC.HsCmdLam match) = do - setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match - - markAST _ (GHC.HsCmdPar e) = do - mark GHC.AnnOpenP - markLocated e - mark GHC.AnnCloseP -- ')' - - markAST l (GHC.HsCmdCase e1 matches) = do - mark GHC.AnnCase - markLocated e1 - mark GHC.AnnOf - markOptional GHC.AnnOpenC - setContext (Set.singleton CaseAlt) $ do - markMatchGroup l matches - markOptional GHC.AnnCloseC - - markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do - mark GHC.AnnIf - markLocated e1 - markOffset GHC.AnnSemi 0 - mark GHC.AnnThen - markLocated e2 - markOffset GHC.AnnSemi 1 - mark GHC.AnnElse - markLocated e3 - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsCmdLet binds e) = do -#else - markAST _ (GHC.HsCmdLet (GHC.L _ binds) e) = do -#endif - mark GHC.AnnLet - markOptional GHC.AnnOpenC - markLocalBindsWithLayout binds - markOptional GHC.AnnCloseC - mark GHC.AnnIn - markLocated e - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.HsCmdDo es _) = do -#else - markAST _ (GHC.HsCmdDo (GHC.L _ es) _) = do -#endif - mark GHC.AnnDo - markOptional GHC.AnnOpenC - markListWithLayout es - markOptional GHC.AnnCloseC - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ GHC.HsCmdCast {} = - traceM "warning: HsCmdCast introduced after renaming" -#endif - -#if __GLASGOW_HASKELL__ > 710 - markAST _ (GHC.HsCmdWrap {}) = - traceM "warning: HsCmdWrap introduced after renaming" -{- - | HsCmdWrap HsWrapper - (HsCmd id) -- If cmd :: arg1 --> res - -- wrap :: arg1 "->" arg2 - -- Then (HsCmdWrap wrap cmd) :: arg2 --> res --} -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where - markAST _ ls = mapM_ markLocated ls - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (GHC.TyClDecl name) where - - markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) typ _) = do -#else - markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars _) typ _) = do -#endif - -- 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 ln tyvars - mark GHC.AnnEqual - markLocated typ - markTrailingSemi - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars) - (GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _) = do -#else - markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars _) - (GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _ _) = do -#endif - if nd == GHC.DataType - then mark GHC.AnnData - else mark GHC.AnnNewtype - markMaybe mctyp - if null (GHC.unLoc ctx) - then markOptional GHC.AnnDarrow - else markLocated ctx - markTyClass 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]) $ markMaybe mderivs - markTrailingSemi - - -- ----------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds - sigs meths ats atdefs docs _) = do -#else - markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars _) fds - sigs meths ats atdefs docs _) = do -#endif - mark GHC.AnnClass - unless (null $ GHC.unLoc ctx) $ markLocated ctx - - markTyClass 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 - --- --------------------------------------------------------------------- - -markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) - => GHC.Located a -> [GHC.Located ast] -> Annotated () -markTyClass ln tyVars = do - markManyOptional GHC.AnnOpenP - - let - parensNeeded = GHC.isSymOcc (GHC.occName $ GHC.unLoc ln) && length tyVars > 2 - lnFun = do - ifInContext (Set.singleton CtxMiddle) - (setContext (Set.singleton InfixOp) $ markLocated ln) - (markLocated ln) - listFun b = do - if parensNeeded - then ifInContext (Set.singleton (CtxPos 0)) - (markMany GHC.AnnOpenP) - (return ()) - else ifInContext (Set.singleton (CtxPos 0)) - (markManyOptional GHC.AnnOpenP) - (return ()) - - markLocated b - - if parensNeeded - then ifInContext (Set.singleton (CtxPos 2)) - (markMany GHC.AnnCloseP) - (return ()) - else ifInContext (Set.singleton (CtxPos 2)) - (markManyOptional GHC.AnnCloseP) - (return ()) - - prepareListFun ls = map (\b -> (GHC.getLoc b, listFun b )) ls - - unsetContext CtxMiddle $ - applyListAnnotationsContexts (LC (Set.fromList [CtxOnly,PrefixOp]) (Set.fromList [CtxFirst,PrefixOp]) - (Set.singleton CtxMiddle) (Set.singleton CtxLast)) - ([(GHC.getLoc ln,lnFun)] - ++ prepareListFun tyVars) - markManyOptional GHC.AnnCloseP - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.FamilyDecl name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do -#else - markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars _) rsig minj) = do -{- -data FamilyDecl name = FamilyDecl - { fdInfo :: FamilyInfo name -- type/data, closed/open - , fdLName :: Located name -- type constructor - , fdTyVars :: LHsQTyVars name -- type variables - , fdResultSig :: LFamilyResultSig name -- result signature - , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann - } --} -#endif - case info of - GHC.DataFamily -> mark GHC.AnnData - _ -> mark GHC.AnnType - -#if __GLASGOW_HASKELL__ <= 710 - mark GHC.AnnFamily -#else - -- ifInContext (Set.singleton InClassDecl) (return ()) (mark GHC.AnnFamily) - mark GHC.AnnFamily -#endif - - markTyClass ln tyvars -#if __GLASGOW_HASKELL__ <= 710 - case mkind of - Nothing -> return () - Just k -> do - mark GHC.AnnDcolon - markLocated k -#else - 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 -#endif - case info of -#if __GLASGOW_HASKELL__ > 710 - 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 -- } -#else - GHC.ClosedTypeFamily eqns -> do - mark GHC.AnnWhere - markOptional GHC.AnnOpenC -- { - markListWithLayout eqns - markOptional GHC.AnnCloseC -- } -#endif - _ -> return () - markTrailingSemi - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 710 -#else -instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.FamilyResultSig name) where - markAST _ (GHC.NoSig) = return () - markAST _ (GHC.KindSig k) = markLocated k - markAST _ (GHC.TyVarSig ltv) = markLocated ltv -#endif - --- --------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ > 710 -instance (GHC.DataId name,Annotate name) - => Annotate (GHC.InjectivityAnn name) where - markAST _ (GHC.InjectivityAnn ln lns) = do - markLocated ln - mark GHC.AnnRarrow - mapM_ markLocated lns -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.TyFamInstEqn name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do -#else - markAST _ (GHC.TyFamEqn ln (GHC.HsIB _ pats) typ) = do -#endif - markTyClass ln pats - -- let - -- fun = ifInContext (Set.singleton (CtxPos 0)) - -- (setContext (Set.singleton PrefixOp) $ markLocated ln) - -- (markLocated ln) - -- markOptional GHC.AnnOpenP - -- applyListAnnotationsContexts (LC Set.empty Set.empty Set.empty Set.empty) - -- ([(GHC.getLoc ln, fun)] - -- ++ prepareListAnnotationWithContext (Set.singleton PrefixOp) pats) - -- markOptional GHC.AnnCloseP - mark GHC.AnnEqual - markLocated typ - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.TyFamDefltEqn name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do -#else - markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs _) typ) = do -#endif - mark GHC.AnnType - mark GHC.AnnInstance - applyListAnnotations (prepareListAnnotation [ln] - ++ prepareListAnnotation bndrs - ) - mark GHC.AnnEqual - markLocated typ - --- --------------------------------------------------------------------- - --- 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 (GHC.HsDocString fs)) -> GHC.unpackFS fs - (GHC.DocCommentPrev (GHC.HsDocString fs)) -> GHC.unpackFS fs - (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs - (GHC.DocGroup _i (GHC.HsDocString fs)) -> GHC.unpackFS fs - in - markExternal l GHC.AnnVal str >> markTrailingSemi - --- --------------------------------------------------------------------- - -markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated () -markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons mderivs) = do - markLocated ctx - markMaybe typ -#if __GLASGOW_HASKELL__ <= 710 - markMaybe _mk -#endif - if isGadt cons - then markListWithLayout cons - else markListIntercalateWithFunLevel markLocated 2 cons - case mderivs of - Nothing -> return () - Just d -> setContext (Set.singleton Deriving) $ markLocated d - --- --------------------------------------------------------------------- - --- Note: GHC.HsContext name aliases to here too -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate [GHC.LHsType name] where - markAST l ts = do -#if __GLASGOW_HASKELL__ <= 710 - inContext (Set.singleton Deriving) $ mark GHC.AnnDeriving -#endif - -- Mote: A single item in parens in a deriving clause is parsed as a - -- HsSigType, which is always a HsForAllTy. 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 - [_] -> markManyOptional pa - _ -> markMany pa - - parenIfNeeded'' pa = - ifInContext (Set.singleton Parens) - (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 (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.ConDecl name) where -#if __GLASGOW_HASKELL__ <= 710 - markAST _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx - dets res _ depc_syntax) = do - case res of - GHC.ResTyH98 -> do - - unless (null bndrs) $ do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - unless (null $ GHC.unLoc ctx) $ do - setContext (Set.fromList [NoDarrow]) $ markLocated ctx - mark GHC.AnnDarrow - case dets of - GHC.InfixCon _ _ -> return () - _ -> setContext (Set.singleton PrefixOp) $ markListIntercalate lns - - markHsConDeclDetails False False lns dets - - GHC.ResTyGADT ls ty -> do - -- only print names if not infix - case dets of - GHC.InfixCon _ _ -> return () - _ -> markListIntercalate lns - - if depc_syntax - then do - markHsConDeclDetails True False lns dets - mark GHC.AnnCloseC - mark GHC.AnnDcolon - markManyOptional GHC.AnnOpenP - - else do - mark GHC.AnnDcolon - markLocated (GHC.L ls (ResTyGADTHook bndrs)) - markManyOptional GHC.AnnOpenP - unless (null $ GHC.unLoc ctx) $ do - markLocated ctx - markHsConDeclDetails False True lns dets - - markLocated ty - - markManyOptional GHC.AnnCloseP - - - case res of - GHC.ResTyH98 -> inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar - _ -> return () - markTrailingSemi -#else - markAST _ (GHC.ConDeclH98 ln mqtvs mctx - dets _ ) = do -{- - | ConDeclH98 - { con_name :: Located name - - , con_qvars :: Maybe (LHsQTyVars name) - -- User-written forall (if any), and its implicit - -- kind variables - -- Non-Nothing needs -XExistentialQuantification - -- e.g. data T a = forall b. MkT b (b->a) - -- con_qvars = {b} - - , con_cxt :: Maybe (LHsContext name) - -- ^ User-written context (if any) - - , con_details :: HsConDeclDetails name - -- ^ Arguments - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - --} - case mqtvs of - Nothing -> return () - Just (GHC.HsQTvs _ns bndrs _) -> do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - - case mctx of - Just ctx -> do - setContext (Set.fromList [NoDarrow]) $ markLocated ctx - unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow - Nothing -> return () - - case dets of - GHC.InfixCon _ _ -> return () - _ -> setContext (Set.singleton PrefixOp) $ markLocated ln - - markHsConDeclDetails False False [ln] dets - - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar - markTrailingSemi - markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ) _) = do - setContext (Set.singleton PrefixOp) $ markListIntercalate lns - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi -#endif - --- ResTyGADT has a SrcSpan for the original sigtype, we need to create --- a type for exactPC and annotatePC -data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name] - deriving (Typeable) -deriving instance (GHC.DataId name) => Data (ResTyGADTHook name) -deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name) - -instance (GHC.OutputableBndr name) => GHC.Outputable (ResTyGADTHook name) where - ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr bs - - -#if __GLASGOW_HASKELL__ > 710 --- 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 "_" -#endif - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) - => Annotate (ResTyGADTHook name) where - markAST _ (ResTyGADTHook bndrs) = do - unless (null bndrs) $ do - mark GHC.AnnForall - mapM_ markLocated bndrs - mark GHC.AnnDot - --- --------------------------------------------------------------------- - -instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.HsRecField name (GHC.LPat name)) 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 name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) - => Annotate (GHC.HsRecField name (GHC.LHsExpr name)) 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 (GHC.DataId name,Annotate name) - => Annotate (GHC.FunDep (GHC.Located name)) where - - markAST _ (ls,rs) = do - mapM_ markLocated ls - mark GHC.AnnRarrow - mapM_ markLocated rs - inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma - --- --------------------------------------------------------------------- - -instance Annotate GHC.CType where - markAST _ (GHC.CType src mh f) = do - markWithString GHC.AnnOpen src - case mh of - Nothing -> return () -#if __GLASGOW_HASKELL__ <= 710 - Just (GHC.Header h) -> - markWithString GHC.AnnHeader ("\"" ++ GHC.unpackFS h ++ "\"") - markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS f ++ "\"") -#else - Just (GHC.Header srcH _h) -> - markWithString GHC.AnnHeader srcH - markWithString GHC.AnnVal (fst f) -#endif - markWithString GHC.AnnClose "#-}" - --- --------------------------------------------------------------------- + + ) where + + +import Language.Haskell.GHC.ExactPrint.Annotater diff --git a/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs b/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook +-- | '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.AnnotateTypes + -- ( + -- AnnotationF(..) + -- , Annotated + -- , Annotate(..) + + -- ) + where + +#if __GLASGOW_HASKELL__ <= 710 +import Data.Ord ( comparing ) +import Data.List ( sortBy ) +#endif + +import Language.Haskell.GHC.ExactPrint.Types +-- import Language.Haskell.GHC.ExactPrint.Utils + +-- import qualified Bag as GHC +#if __GLASGOW_HASKELL__ > 800 +import qualified BasicTypes as GHC +#endif +-- import qualified Class as GHC +-- import qualified CoAxiom as GHC +-- import qualified FastString as GHC +-- import qualified ForeignCall as GHC +import qualified GHC as GHC +#if __GLASGOW_HASKELL__ > 710 +-- import qualified Lexeme as GHC +#endif +-- import qualified Name as GHC +-- import qualified RdrName as GHC +#if __GLASGOW_HASKELL__ <= 710 +import qualified BooleanFormula as GHC +import qualified Outputable as GHC +#endif + +import Control.Monad.Trans.Free +import Control.Monad.Free.TH (makeFreeCon) +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" #-} +-- --------------------------------------------------------------------- + +-- | ['MarkPrim'] The main constructor. Marks that a specific AnnKeywordId could +-- appear with an optional String which is used when printing. +-- ['MarkPPOptional'] Used to flag elements, such as optional braces, that are +-- not used in the pretty printer. This functions identically to 'MarkPrim' +-- for the other interpreters. +-- ['MarkEOF'] +-- Special constructor which marks the end of file marker. +-- ['MarkExternal'] TODO +-- ['MarkOutside'] A @AnnKeywordId@ which is precisely located but not inside the +-- current context. This is usually used to reassociated located +-- @RdrName@ which are more naturally associated with their parent than +-- in their own annotation. +-- ['MarkInside'] +-- The dual of MarkOutside. If we wish to mark a non-separating comma +-- or semi-colon then we must use this constructor. +-- ['MarkMany'] Some syntax elements allow an arbritary number of puncuation marks +-- without reflection in the AST. This construction greedily takes all of +-- the specified @AnnKeywordId@. +-- ['MarkOffsetPrim'] Some syntax elements have repeated @AnnKeywordId@ which are +-- seperated by different @AnnKeywordId@. Thus using MarkMany is +-- unsuitable and instead we provide an index to specify which specific +-- instance to choose each time. +-- ['WithAST'] TODO +-- ['CountAnns'] Sometimes the AST does not reflect the concrete source code and the +-- only way to tell what the concrete source was is to count a certain +-- kind of @AnnKeywordId@. +-- ['WithSortKey'] There are many places where the syntactic ordering of elements is +-- thrown away by the AST. This constructor captures the original +-- ordering and reflects any changes in ordered as specified by the +-- @annSortKey@ field in @Annotation@. +-- ['SetLayoutFlag'] It is important to know precisely where layout rules apply. This +-- constructor wraps a computation to indicate that LayoutRules apply to +-- the corresponding construct. +-- ['StoreOriginalSrcSpan'] TODO +-- ['GetSrcSpanFromKw'] TODO +-- ['StoreString'] TODO +-- ['AnnotationsToComments'] Used when the AST is sufficiently vague that there is no other +-- option but to convert a fragment of source code into a comment. This +-- means it is impossible to edit such a fragment but means that +-- processing files with such fragments is still possible. +data AnnotationF next where + MarkPrim :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next + MarkPPOptional :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next + MarkEOF :: next -> AnnotationF next + MarkExternal :: GHC.SrcSpan -> GHC.AnnKeywordId -> String -> next -> AnnotationF next + MarkOutside :: GHC.AnnKeywordId -> KeywordId -> next -> AnnotationF next + MarkInside :: GHC.AnnKeywordId -> next -> AnnotationF next + MarkMany :: GHC.AnnKeywordId -> next -> AnnotationF next + MarkManyOptional :: GHC.AnnKeywordId -> next -> AnnotationF next + MarkOffsetPrim :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next + MarkOffsetPrimOptional :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next + WithAST :: Data a => GHC.Located a + -> Annotated b -> next -> AnnotationF next + CountAnns :: GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next + WithSortKey :: [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next + + SetLayoutFlag :: Rigidity -> Annotated () -> next -> AnnotationF next + MarkAnnBeforeAnn :: GHC.AnnKeywordId -> GHC.AnnKeywordId -> next -> AnnotationF next + + -- Required to work around deficiencies in the GHC AST + StoreOriginalSrcSpan :: GHC.SrcSpan -> AnnKey -> (AnnKey -> next) -> AnnotationF next + GetSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> (GHC.SrcSpan -> next) -> AnnotationF next +#if __GLASGOW_HASKELL__ <= 710 + StoreString :: String -> GHC.SrcSpan -> next -> AnnotationF next +#endif + AnnotationsToComments :: [GHC.AnnKeywordId] -> next -> AnnotationF next +#if __GLASGOW_HASKELL__ <= 710 + AnnotationsToCommentsBF :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> next -> AnnotationF next + FinalizeBF :: GHC.SrcSpan -> next -> AnnotationF next +#endif + + -- AZ experimenting with pretty printing + -- Set the context for child element + SetContextLevel :: Set.Set AstContext -> Int -> Annotated () -> next -> AnnotationF next + 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 + -- + TellContext :: Set.Set AstContext -> next -> AnnotationF next + +deriving instance Functor AnnotationF + +type Annotated = FreeT AnnotationF Identity + + +-- --------------------------------------------------------------------- + +makeFreeCon 'MarkEOF +makeFreeCon 'MarkPrim +makeFreeCon 'MarkPPOptional +makeFreeCon 'MarkOutside +makeFreeCon 'MarkInside +makeFreeCon 'MarkExternal +makeFreeCon 'MarkMany +makeFreeCon 'MarkManyOptional +makeFreeCon 'MarkOffsetPrim +makeFreeCon 'MarkOffsetPrimOptional +makeFreeCon 'CountAnns +makeFreeCon 'StoreOriginalSrcSpan +makeFreeCon 'GetSrcSpanForKw +#if __GLASGOW_HASKELL__ <= 710 +makeFreeCon 'StoreString +#endif +makeFreeCon 'AnnotationsToComments +#if __GLASGOW_HASKELL__ <= 710 +makeFreeCon 'AnnotationsToCommentsBF +makeFreeCon 'FinalizeBF +#endif +makeFreeCon 'WithSortKey +makeFreeCon 'SetContextLevel +makeFreeCon 'UnsetContext +makeFreeCon 'IfInContext +makeFreeCon 'WithSortKeyContexts +makeFreeCon 'TellContext +makeFreeCon 'MarkAnnBeforeAnn + +-- --------------------------------------------------------------------- + +setContext :: Set.Set AstContext -> Annotated () -> Annotated () +setContext ctxt action = liftF (SetContextLevel ctxt 3 action ()) + +setLayoutFlag :: Annotated () -> Annotated () +setLayoutFlag action = liftF (SetLayoutFlag NormalLayout action ()) + +setRigidFlag :: Annotated () -> Annotated () +setRigidFlag action = liftF (SetLayoutFlag RigidLayout action ()) + +inContext :: Set.Set AstContext -> Annotated () -> Annotated () +inContext ctxt action = liftF (IfInContext ctxt action (return ()) ()) + +-- --------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ <= 710 +workOutString :: GHC.SrcSpan -> GHC.AnnKeywordId -> (GHC.SrcSpan -> String) -> Annotated () +workOutString l kw f = do + ss <- getSrcSpanForKw l kw + storeString (f ss) ss +#endif + +-- --------------------------------------------------------------------- + +-- |Main driver point for annotations. +withAST :: Data a => GHC.Located a -> Annotated () -> Annotated () +withAST lss action = liftF (WithAST lss action ()) + +-- --------------------------------------------------------------------- +-- Additional smart constructors + +mark :: GHC.AnnKeywordId -> Annotated () +mark kwid = markPrim kwid Nothing + +markOptional :: GHC.AnnKeywordId -> Annotated () +markOptional kwid = markPPOptional kwid Nothing + +markWithString :: GHC.AnnKeywordId -> String -> Annotated () +markWithString kwid s = markPrim kwid (Just s) + +markWithStringOptional :: GHC.AnnKeywordId -> String -> Annotated () +markWithStringOptional kwid s = markPPOptional kwid (Just s) + +markOffsetWithString :: GHC.AnnKeywordId -> Int -> String -> Annotated () +markOffsetWithString kwid n s = markOffsetPrim kwid n (Just s) + +markOffset :: GHC.AnnKeywordId -> Int -> Annotated () +markOffset kwid n = markOffsetPrim kwid n Nothing + +markOffsetOptional :: GHC.AnnKeywordId -> Int -> Annotated () +markOffsetOptional kwid n = markOffsetPrimOptional kwid n Nothing + +markTrailingSemi :: Annotated () +markTrailingSemi = markOutside GHC.AnnSemi AnnSemiSep + +-- --------------------------------------------------------------------- + +withLocated :: Data a + => GHC.Located a + -> (GHC.SrcSpan -> a -> Annotated ()) + -> Annotated () +withLocated a@(GHC.L l ast) action = + withAST a (action l ast) + +-- --------------------------------------------------------------------- + + +markListIntercalateWithFun :: (t -> Annotated ()) -> [t] -> Annotated () +markListIntercalateWithFun f ls = markListIntercalateWithFunLevel f 2 ls + +markListIntercalateWithFunLevel :: (t -> Annotated ()) -> Int -> [t] -> Annotated () +markListIntercalateWithFunLevel f level ls = markListIntercalateWithFunLevelCtx f level Intercalate ls + +markListIntercalateWithFunLevelCtx :: (t -> Annotated ()) -> Int -> AstContext -> [t] -> Annotated () +markListIntercalateWithFunLevelCtx f level ctx ls = go ls + where + go [] = return () + go [x] = f x + go (x:xs) = do + setContextLevel (Set.singleton ctx) level $ f x + go xs + +-- --------------------------------------------------------------------- + +markListWithContextsFunction :: + ListContexts + -> (t -> Annotated ()) + -> [t] -> Annotated () +markListWithContextsFunction (LC ctxOnly ctxInitial ctxMiddle ctxLast) f ls = + case ls of + [] -> return () + [x] -> setContextLevel ctxOnly level $ f x + (x:xs) -> do + setContextLevel ctxInitial level $ f x + go xs + where + level = 2 + go [] = return () + go [x] = setContextLevel ctxLast level $ f x + go (x:xs) = do + setContextLevel ctxMiddle level $ f x + go xs + +-- --------------------------------------------------------------------- + + +-- Expects the kws to be ordered already +withSortKeyContextsHelper :: (Monad m) => (Annotated () -> m ()) -> ListContexts -> [(GHC.SrcSpan, Annotated ())] -> m () +withSortKeyContextsHelper interpret (LC ctxOnly ctxInitial ctxMiddle ctxLast) kws = do + case kws of + [] -> return () + [x] -> interpret (setContextLevel (Set.insert (CtxPos 0) ctxOnly) level $ snd x) + (x:xs) -> do + interpret (setContextLevel (Set.insert (CtxPos 0) ctxInitial) level $ snd x) + go 1 xs + where + level = 2 + go _ [] = return () + go n [x] = interpret (setContextLevel (Set.insert (CtxPos n) ctxLast) level $ snd x) + go n (x:xs) = do + interpret (setContextLevel (Set.insert (CtxPos n) ctxMiddle) level $ snd x) + go (n+1) xs + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + + +applyListAnnotations :: [(GHC.SrcSpan, Annotated ())] -> Annotated () +applyListAnnotations ls = withSortKey ls + +applyListAnnotationsContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Annotated () +applyListAnnotationsContexts ctxt ls = withSortKeyContexts ctxt ls + +#if __GLASGOW_HASKELL__ <= 710 +lexicalSortLocated :: [GHC.Located a] -> [GHC.Located a] +lexicalSortLocated = sortBy (comparing GHC.getLoc) +#endif + +applyListAnnotationsLayout :: [(GHC.SrcSpan, Annotated ())] -> Annotated () +applyListAnnotationsLayout ls = setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) + $ withSortKeyContexts listContexts ls + +listContexts :: ListContexts +listContexts = LC (Set.fromList [CtxOnly,ListStart]) + (Set.fromList [CtxFirst,ListStart,Intercalate]) + (Set.fromList [CtxMiddle,ListItem,Intercalate]) + (Set.fromList [CtxLast,ListItem]) + +listContexts' :: ListContexts +listContexts' = LC (Set.fromList [CtxOnly, ListStart]) + (Set.fromList [CtxFirst, ListStart]) + (Set.fromList [CtxMiddle,ListItem]) + (Set.fromList [CtxLast, ListItem]) + +-- --------------------------------------------------------------------- + + +#if __GLASGOW_HASKELL__ > 800 +markAnnOpen :: GHC.SourceText -> String -> Annotated () +markAnnOpen GHC.NoSourceText txt = markWithString GHC.AnnOpen txt +markAnnOpen (GHC.SourceText txt) _ = markWithString GHC.AnnOpen txt + +markSourceText :: GHC.SourceText -> String -> Annotated () +markSourceText GHC.NoSourceText txt = markWithString GHC.AnnVal txt +markSourceText (GHC.SourceText txt) _ = markWithString GHC.AnnVal txt + +markExternalSourceText :: GHC.SrcSpan -> GHC.SourceText -> String -> Annotated () +markExternalSourceText l GHC.NoSourceText txt = markExternal l GHC.AnnVal txt +markExternalSourceText l (GHC.SourceText txt) _ = markExternal l GHC.AnnVal txt + +sourceTextToString :: GHC.SourceText -> String -> String +sourceTextToString GHC.NoSourceText alt = alt +sourceTextToString (GHC.SourceText txt) _ = txt +#endif + +-- --------------------------------------------------------------------- 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 @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} -- | This module converts 'GHC.ApiAnns' into 'Anns' by traversing a --- structure created by the "Annotate" modue. +-- structure created by the "Annotate" module. -- -- == Structure of an Annotation -- @@ -11,18 +11,80 @@ -- -- == Layout Calculation -- --- Certain expressions such as do blocks and let bindings obey --- . We --- calculate the 'annEntryDelta' slightly differently when such rules --- apply. +-- In order to properly place syntax nodes and comments properly after +-- refactoring them (in such a way that the indentation level changes), their +-- position (encoded in the 'addEntryDelta' field) is not expressed as absolute +-- but relative to their context. As further motivation, consider the simple +-- let-into-where-block refactoring, from: -- --- 1. The first element which the layout rule applies to is given --- a 'annEntryDelta' as normal. --- 2. Further elements which must obey the rules are then given --- 'annEntryDelta's relative to the LHS of the first element. +-- @ +-- foo = do +-- let bar = do +-- x +-- -- comment +-- y +-- bar +-- @ -- +-- to +-- +-- @ +-- foo = do +-- bar +-- where +-- bar = do +-- x +-- -- comment +-- y +-- @ +-- +-- Notice how the column of @x@, @y@ and the comment change due to this +-- refactoring but certain relative positions (e.g. the comment starting at the +-- same column as @x@) remain unchanged. +-- +-- Now, what does "context" mean exactly? Here we reference the +-- "indentation level" as used in the haskell report (see chapter 2.7: +-- ): +-- 'addEntryDelta' is mostly relative to the current (inner-most) indentation +-- level. But in order to get better results, for the purpose of defining +-- relative positions a the offside-rule is modified slightly: Normally it +-- fires (only) at the first elements after where/let/do/of, introducing a new +-- indentation level. In addition, the rule here fires also at the "@let@" +-- keyword (when it is part of a "@let-in@" construct) and at the "@if@" keyword. +-- +-- The effect of this additional applications of the offside-rule is that any +-- elements (more or less directly) following the "@let@" ("@if@"") +-- keyword have a position relative to the "@let@" ("@if@") +-- keyword position, even when the regular offside-rule does apply not yet/not +-- anymore. This affects two concrete things: Comments directly following +-- "@let@"/"@if@", and the respective follow-up keywords: "@in@" or +-- "@then@"/"@else@". +-- +-- Due to this additional indentation level, it is possible to observe/obtain +-- negative delta-positions; consider: +-- +-- @ +-- foo = let x = 1 +-- in x +-- @ +-- +-- Here, the @in@ keyword has an 'annEntryDelta' of @DP (1, -4)@ as it appears +-- one line below the previous elements and 4 columns /left/ relative to the +-- start of the @let@ keyword. +-- +-- In general, the element that defines such an indentation level (i.e. the +-- first element after a where/let/do/of) will have an 'annEntryDelta' relative +-- to the previous inner-most indentation level; in other words: a new +-- indentation level becomes relevant only after the construct introducing the +-- element received its 'annEntryDelta' position. (Otherwise these elements +-- always would have a zero horizontal position - relative to itself.) +-- +-- (This affects comments, too: A comment preceding the first element of a +-- layout block will have a position relative to the outer block, not of the +-- newly introduced layout block.) +-- -- For example, in the following expression the statement corresponding to --- `baz` will be given a 'annEntryDelta' of @DP (1, 2)@ as it appears +-- @baz@ will be given a 'annEntryDelta' of @DP (1, 2)@ as it appears -- 1 line and 2 columns after the @do@ keyword. On the other hand, @bar@ -- will be given a 'annEntryDelta' of @DP (1,0)@ as it appears 1 line -- further than @baz@ but in the same column as the start of the layout @@ -43,7 +105,7 @@ -- -- === annTrueEntryDelta -- A very useful function is 'annTrueEntryDelta' which calculates the --- offset from the last synctactic element (ignoring comments). This is +-- offset from the last syntactic element (ignoring comments). This is -- different to 'annEntryDelta' which does not ignore comments. -- -- @@ -245,7 +307,7 @@ go (MarkMany akwid next) = addDeltaAnnotations akwid >> next go (MarkManyOptional akwid next) = addDeltaAnnotations akwid >> next go (MarkOffsetPrim akwid n _ next) = addDeltaAnnotationLs akwid n >> next - -- go (MarkOffsetPrimOptional akwid n _ next) = addDeltaAnnotationLs akwid n >> next + go (MarkOffsetPrimOptional akwid n _ next) = addDeltaAnnotationLs akwid n >> next go (WithAST lss prog next) = withAST lss (deltaInterpret prog) >> next go (CountAnns kwid next) = countAnnsDelta kwid >>= next go (SetLayoutFlag r action next) = do @@ -625,7 +687,14 @@ , (GHC.Annlarrowtail, GHC.AnnlarrowtailU) , (GHC.Annrarrowtail, GHC.AnnrarrowtailU) , (GHC.AnnLarrowtail, GHC.AnnLarrowtailU) - , (GHC.AnnRarrowtail, GHC.AnnRarrowtailU)] + , (GHC.AnnRarrowtail, GHC.AnnRarrowtailU) +#if __GLASGOW_HASKELL__ > 801 + , (GHC.AnnCloseB, GHC.AnnCloseBU) + , (GHC.AnnCloseQ, GHC.AnnCloseQU) + , (GHC.AnnOpenB, GHC.AnnOpenBU) + , (GHC.AnnOpenEQ, GHC.AnnOpenEQU) +#endif + ] #endif diff --git a/src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs b/src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs --- a/src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs +++ b/src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} -- functions from GHC copied here until they can be exported in the next version. + module Language.Haskell.GHC.ExactPrint.GhcInterim where import ApiAnnotation @@ -6,6 +8,8 @@ import SrcLoc -- --------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ > 800 +#else -- From Lexer.x commentToAnnotation :: Located Token -> Located AnnotationComment commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) @@ -13,7 +17,10 @@ commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s) commentToAnnotation (L l (ITdocSection n s)) = L l (AnnDocSection n s) commentToAnnotation (L l (ITdocOptions s)) = L l (AnnDocOptions s) +#if __GLASGOW_HASKELL__ < 801 commentToAnnotation (L l (ITdocOptionsOld s)) = L l (AnnDocOptionsOld s) +#endif commentToAnnotation (L l (ITlineComment s)) = L l (AnnLineComment s) commentToAnnotation (L l (ITblockComment s)) = L l (AnnBlockComment s) commentToAnnotation _ = error $ "commentToAnnotation called for non-comment:" -- ++ show x +#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 @@ -30,6 +30,9 @@ AnnUnicode kw' -> keywordToString (G kw') #endif AnnSemiSep -> ";" +#if __GLASGOW_HASKELL__ >= 801 + (G GHC.AnnAnyclass) -> "anyclass" +#endif (G GHC.AnnOpen ) -> mkErr kw (G GHC.AnnClose ) -> mkErr kw (G GHC.AnnVal ) -> mkErr kw @@ -46,8 +49,16 @@ (G GHC.AnnBy ) -> "by" (G GHC.AnnCase ) -> "case" (G GHC.AnnClass ) -> "class" +#if __GLASGOW_HASKELL__ >= 801 + (G GHC.AnnCloseB ) -> "|)" + (G GHC.AnnCloseBU ) -> "⦈" +#endif (G GHC.AnnCloseC ) -> "}" (G GHC.AnnCloseP ) -> ")" +#if __GLASGOW_HASKELL__ >= 801 + (G GHC.AnnCloseQ ) -> "|]" + (G GHC.AnnCloseQU ) -> "⟧" +#endif (G GHC.AnnCloseS ) -> "]" (G GHC.AnnColon ) -> ":" (G GHC.AnnComma ) -> "," @@ -80,10 +91,18 @@ (G GHC.AnnModule ) -> "module" (G GHC.AnnNewtype ) -> "newtype" (G GHC.AnnOf ) -> "of" +#if __GLASGOW_HASKELL__ >= 801 + (G GHC.AnnOpenB ) -> "(|" + (G GHC.AnnOpenBU ) -> "⦇" +#endif (G GHC.AnnOpenC ) -> "{" #if __GLASGOW_HASKELL__ > 710 (G GHC.AnnOpenE ) -> "[e|" #endif +#if __GLASGOW_HASKELL__ >= 801 + (G GHC.AnnOpenEQ ) -> "[|" + (G GHC.AnnOpenEQU ) -> "⟦" +#endif (G GHC.AnnOpenP ) -> "(" (G GHC.AnnOpenPE ) -> "$(" (G GHC.AnnOpenPTE ) -> "$$(" @@ -96,6 +115,10 @@ (G GHC.AnnRole ) -> "role" (G GHC.AnnSafe ) -> "safe" (G GHC.AnnSemi ) -> ";" +#if __GLASGOW_HASKELL__ >= 801 + (G GHC.AnnSignature) -> "signature" + (G GHC.AnnStock ) -> "stock" +#endif (G GHC.AnnStatic ) -> "static" (G GHC.AnnThen ) -> "then" (G GHC.AnnTilde ) -> "~" @@ -144,7 +167,8 @@ , (G GHC.AnnRarrow, "→") , (G GHC.AnnRarrowtail, "⤜") , (G GHC.Annlarrowtail, "⤙") - , (G GHC.Annrarrowtail, "⤚")] + , (G GHC.Annrarrowtail, "⤚") + ] {- From Lexer.x 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -- | This module provides support for CPP, interpreter directives and line @@ -32,7 +33,9 @@ import Control.Exception import Data.List hiding (find) import Data.Maybe +#if __GLASGOW_HASKELL__ <= 800 import Language.Haskell.GHC.ExactPrint.GhcInterim (commentToAnnotation) +#endif import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified Data.Set as Set @@ -113,7 +116,11 @@ let toks = GHC.addSourceToTokens startLoc source ts cppCommentToks = getCppTokens directiveToks nonDirectiveToks toks return $ filter goodComment +#if __GLASGOW_HASKELL__ > 800 + $ map (tokComment . GHC.commentToAnnotation . fst) cppCommentToks +#else $ map (tokComment . commentToAnnotation . fst) cppCommentToks +#endif GHC.PFailed sspan err -> parseError flags2 sspan err goodComment :: Comment -> Bool 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 @@ -38,8 +38,6 @@ import qualified Data.Map as Map 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" #-} @@ -161,7 +159,7 @@ go (MarkMany akwid next) = addPrettyAnnotation (G akwid) >> next go (MarkManyOptional _akwid next) = next go (MarkOffsetPrim akwid n _ next) = addPrettyAnnotationLs akwid n >> next - -- go (MarkOffsetPrimOptional _akwid _n _ next) = next + go (MarkOffsetPrimOptional _akwid _n _ next) = next go (WithAST lss prog next) = withAST lss (prettyInterpret prog) >> next go (CountAnns kwid next) = countAnnsPretty kwid >>= next go (WithSortKey kws next) = withSortKey kws >> next @@ -199,12 +197,13 @@ addPrettyAnnotation ann = do noPrec <- gets apNoPrecedingSpace ctx <- asks prContext - _ <- trace ("Pretty.addPrettyAnnotation:=" ++ showGhc (ann,noPrec,ctx)) $ asks prContext + _ <- debugP ("Pretty.addPrettyAnnotation:=" ++ showGhc (ann,noPrec,ctx)) $ asks prContext let dp = case ann of (G GHC.AnnAs) -> tellKd (ann,DP (0,1)) (G GHC.AnnAt) -> tellKd (ann,DP (0,1)) (G GHC.AnnBang) -> tellKd (ann,DP (0,1)) + (G GHC.AnnBackquote) -> tellKd (ann,DP (0,1)) (G GHC.AnnBy) -> tellKd (ann,DP (0,1)) (G GHC.AnnCase ) -> tellKd (ann,DP (0,1)) (G GHC.AnnClass) -> tellKd (ann,DP (0,1)) @@ -221,6 +220,7 @@ (G GHC.AnnGroup) -> tellKd (ann,DP (0,1)) (G GHC.AnnHiding) -> tellKd (ann,DP (0,1)) (G GHC.AnnImport) -> tellKd (ann,DP (0,1)) + (G GHC.AnnIf) -> tellKd (ann,DP (0,1)) (G GHC.AnnIn) -> tellKd (ann,DP (1,0)) (G GHC.AnnInstance) -> tellKd (ann,DP (0,1)) (G GHC.AnnLam) -> tellKd (ann,DP (0,1)) @@ -250,7 +250,8 @@ -- --------------------------------------------------------------------- addPrettyAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Pretty () -addPrettyAnnotationsOutside _akwid _kwid = return () +addPrettyAnnotationsOutside _akwid AnnSemiSep = return () +addPrettyAnnotationsOutside _akwid kwid = addPrettyAnnotation kwid -- --------------------------------------------------------------------- @@ -280,7 +281,7 @@ -- flags passed up from subelements of the AST. (_,w) <- listen (return () :: Pretty ()) - _ <- trace ("withSrcSpanPretty: prLayoutContext w=" ++ show (prLayoutContext w) ) (return ()) + _ <- debugP ("withSrcSpanPretty: prLayoutContext w=" ++ show (prLayoutContext w) ) (return ()) local (\s -> s { curSrcSpan = l , annConName = annGetConstr a @@ -321,20 +322,20 @@ #endif -- uncs <- getUnallocatedComments - -- ctx <- trace ("Pretty.withAST:cs:(ss,cs,uncs)=" ++ showGhc (ss,cs,uncs)) $ asks prContext + -- ctx <- debugP ("Pretty.withAST:cs:(ss,cs,uncs)=" ++ showGhc (ss,cs,uncs)) $ asks prContext ctx <- asks prContext noPrec <- gets apNoPrecedingSpace - edp <- trace ("Pretty.withAST:enter:(ss,constr,noPrec,ctx)=" ++ showGhc (ss,showConstr (toConstr t),noPrec,ctx)) $ entryDpFor ctx t + edp <- debugP ("Pretty.withAST:enter:(ss,constr,noPrec,ctx)=" ++ showGhc (ss,showConstr (toConstr t),noPrec,ctx)) $ entryDpFor ctx t -- edp <- entryDpFor ctx t - let ctx1 = trace ("Pretty.withAST:edp:(ss,constr,edp)=" ++ showGhc (ss,showConstr (toConstr t),edp)) ctx + 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 then - -- trace ("Pretty.withAST:setNoPrecedingSpace") $ + -- debugP ("Pretty.withAST:setNoPrecedingSpace") $ censor maskWriter (listen (setNoPrecedingSpace action)) else - -- trace ("Pretty.withAST:setNoPrecedingSpace") $ + -- debugP ("Pretty.withAST:setNoPrecedingSpace") $ censor maskWriter (listen action) let kds = annKds w @@ -363,7 +364,7 @@ def :: a -> Pretty DeltaPos def _ = - trace ("entryDpFor:(topLevel,listStart,inList,noAdvanceLine,ctx)=" ++ show (topLevel,listStart,inList,noAdvanceLine,ctx)) $ + debugP ("entryDpFor:(topLevel,listStart,inList,noAdvanceLine,ctx)=" ++ show (topLevel,listStart,inList,noAdvanceLine,ctx)) $ if noAdvanceLine then return (DP (0,1)) else @@ -396,11 +397,11 @@ then do modify (\s -> s { apNoPrecedingSpace = False }) - trace ("fromNoPrecedingSpace:def") def + debugP ("fromNoPrecedingSpace:def") def -- def else -- lay - trace ("fromNoPrecedingSpace:lay") lay + debugP ("fromNoPrecedingSpace:lay") lay -- --------------------------------------------------------------------- @@ -505,8 +506,8 @@ annotationsToCommentsBFPretty :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> Pretty () annotationsToCommentsBFPretty bf _kws = do -- cs <- gets apComments - cs <- trace ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) $ gets apComments - -- return$ trace ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) () + cs <- debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) $ gets apComments + -- return$ debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) () -- error ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) let kws = makeBooleanFormulaAnns bf 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 @@ -166,8 +166,8 @@ allAnns akwid >> next go (MarkOffsetPrim kwid _ mstr next) = printStringAtMaybeAnn (G kwid) mstr >> next - -- go (MarkOffsetPrimOptional kwid _ mstr next) = - -- printStringAtMaybeAnn (G kwid) mstr >> next + go (MarkOffsetPrimOptional kwid _ mstr next) = + printStringAtMaybeAnn (G kwid) mstr >> next go (WithAST lss action next) = exactPC lss (printInterpret action) >> next go (CountAnns kwid next) = 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 @@ -60,6 +60,7 @@ -- * For tests , debug + , debugP , debugM , warn , showGhc @@ -109,18 +110,30 @@ {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- --- |Global switch to enable debug tracing in ghc-exactprint +-- |Global switch to enable debug tracing in ghc-exactprint Delta / Print debugEnabledFlag :: Bool -- debugEnabledFlag = True debugEnabledFlag = False --- |Provide a version of trace the comes at the end of the line, so it can +-- |Global switch to enable debug tracing in ghc-exactprint Pretty +debugPEnabledFlag :: Bool +-- debugPEnabledFlag = True +debugPEnabledFlag = False + +-- |Provide a version of trace that comes at the end of the line, so it can -- easily be commented out when debugging different things. debug :: c -> String -> c debug c s = if debugEnabledFlag then trace s c else c +-- |Provide a version of trace for the Pretty module, which can be enabled +-- separately from 'debug' and 'debugM' +debugP :: String -> c -> c +debugP s c = if debugPEnabledFlag + then trace s c + else c + debugM :: Monad m => String -> m () debugM s = when debugEnabledFlag $ traceM s @@ -286,7 +299,9 @@ ghcCommentText (GHC.L _ (GHC.AnnDocCommentNamed s)) = s ghcCommentText (GHC.L _ (GHC.AnnDocSection _ s)) = s ghcCommentText (GHC.L _ (GHC.AnnDocOptions s)) = s +#if __GLASGOW_HASKELL__ < 801 ghcCommentText (GHC.L _ (GHC.AnnDocOptionsOld s)) = s +#endif ghcCommentText (GHC.L _ (GHC.AnnLineComment s)) = s ghcCommentText (GHC.L _ (GHC.AnnBlockComment s)) = s @@ -488,7 +503,7 @@ `extQ` string `extQ` fastString `extQ` srcSpan `extQ` bytestring `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon - `extQ` overLit + -- `extQ` overLit `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `extQ` fixity `ext2Q` located @@ -520,8 +535,8 @@ var = ("{Var: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Var -> String dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String - overLit :: GHC.HsOverLit GHC.RdrName -> String - overLit = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr + -- overLit :: GHC.HsOverLit GHC.RdrName -> String + -- overLit = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GHC.RdrName)) -> String bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList @@ -530,7 +545,11 @@ bagVar :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList +#if __GLASGOW_HASKELL__ > 800 + nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElemsStable +#else nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems +#endif fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -14,7 +14,7 @@ import System.Exit import Data.List - +import qualified Data.Set as Set import System.IO.Silently import Test.Common @@ -28,11 +28,13 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC710 | GHC80 deriving (Eq, Ord, Show) +data GHCVersion = GHC710 | GHC80 | GHC82 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion ghcVersion = -#if __GLASGOW_HASKELL__ >= 711 +#if __GLASGOW_HASKELL__ > 800 + GHC82 +#elif __GLASGOW_HASKELL__ >= 711 GHC80 #else GHC710 @@ -44,6 +46,10 @@ case ghcVersion of GHC710 -> ["ghc710-only","ghc710"] GHC80 -> ["ghc710", "ghc80"] + GHC82 -> ["ghc710", "ghc80", "ghc82"] + -- GHC82 -> ["ghc82-ghc-test"] + -- GHC82 -> ["ghc82-ghc-backups-rename"] + -- GHC82 -> ["ghc82"] -- --------------------------------------------------------------------- @@ -68,18 +74,43 @@ -- --------------------------------------------------------------------- findTests :: IO Test -findTests = testList "Round-trip tests" <$> mapM (findTestsDir mkParserTest) testDirs +findTests = testList "Round-trip tests" <$> mapM (findTestsDir id mkParserTest) testDirs findPrettyTests :: IO Test -findPrettyTests = testList "Default Annotations round-trip tests" <$> mapM (findTestsDir mkPrettyRoundtrip) testDirs +findPrettyTests = + testList "Default Annotations round-trip tests" + <$> mapM (findTestsDir filterPrettyRoundTrip mkPrettyRoundtrip) testDirs -findTestsDir :: (FilePath -> FilePath -> Test) -> FilePath -> IO Test -findTestsDir mkTestFn dir = do +-- | Filter out tests that are known to fail, for particular compilers +filterPrettyRoundTrip :: [FilePath] -> [FilePath] +filterPrettyRoundTrip fps = sort $ Set.toList $ Set.difference (Set.fromList fps) skipped +-- filterPrettyRoundTrip fps = error $ "filterPrettyRoundTrip:fps=" ++ show fps + where +#if __GLASGOW_HASKELL__ > 800 + -- GHC 8.2 + skipped = Set.empty +#elif __GLASGOW_HASKELL__ >= 711 + -- GHC 8.0 + skipped = Set.fromList + [ + -- testPrefix "ghc80" "MultiQuote.hs" + "MultiQuote.hs" + , "TestUtils.hs" + , "T10689a.hs" + , "Zwaluw.hs" + , "determ004.hs" + ] +#else + -- GHC 7.10 + skipped = Set.empty +#endif + +findTestsDir :: ([FilePath] -> [FilePath]) -> (FilePath -> FilePath -> Test) -> FilePath -> IO Test +findTestsDir filterFn mkTestFn dir = do let fp = testPrefix dir fs <- getDirectoryContents fp let testFiles = sort $ filter (".hs" `isSuffixOf`) fs - -- return $ testList dir (map (mkTestFn dir) testFiles) - return $ testList dir (map (\fn -> TestLabel fn (mkTestFn dir fn)) testFiles) + return $ testList dir (map (\fn -> TestLabel fn (mkTestFn dir fn)) $ filterFn testFiles) listTests :: IO () listTests = do @@ -99,7 +130,8 @@ prettyRoundTripTests <- findPrettyTests return $ TestList [ internalTests, roundTripTests, transformTests, failingTests, noAnnotationTests - -- , prettyRoundTripTests + , + prettyRoundTripTests ] -- Tests that will fail until https://phabricator.haskell.org/D907 lands in a @@ -109,10 +141,12 @@ [ -- Tests requiring future GHC modifications mkTestModBad "InfixOperator.hs" - , mkTestModBad "CtorOp.hs" -- Should be fixed in GHC 8.2 + , mkTestModBad "CtorOp.hs" -- Should be fixed in GHC 8.4 -#if __GLASGOW_HASKELL__ > 710 +#if __GLASGOW_HASKELL__ > 800 , mkTestModBad "overloadedlabelsrun04.hs" +#elif __GLASGOW_HASKELL__ > 710 + , mkTestModBad "overloadedlabelsrun04.hs" , mkTestModBad "TensorTests.hs" -- Should be fixed in GHC 8.2 , mkTestModBad "List2.hs" -- Should be fixed in GHC 8.2 #else @@ -148,24 +182,24 @@ tt' :: IO (Counts,Int) tt' = runTestText (putTextToHandle stdout True) $ TestList [ - mkParserTest "ghc80" "SemicolonIf.hs" - -- mkPrettyRoundtrip "ghc80" "StringSource.hs" - -- mkPrettyRoundtrip "ghc80" "records-prov-req.hs" - -- mkPrettyRoundtrip "ghc80" "records-poly-update.hs" - -- mkPrettyRoundtrip "ghc80" "poly-export-fail2.hs" + mkPrettyRoundtrip "ghc80" "Zwaluw.hs" -- mkPrettyRoundtrip "ghc80" "pmc007.hs" + -- mkPrettyRoundtrip "ghc80" "MultiQuote.hs" + -- mkPrettyRoundtrip "ghc80" "T10689a.hs" + -- mkPrettyRoundtrip "ghc710" "Ann01.hs" - -- mkParserTest "ghc80" "DatatypeContexts.hs" - -- mkParserTest "ghc80" "Families.hs" + , mkParserTest "ghc80" "Zwaluw.hs" + -- mkParserTest "ghc80" "SemicolonIf.hs" + -- mkParserTest "ghc80" "T10689a.hs" + -- mkParserTest "ghc80" "MonadT.hs" + -- mkParserTest "ghc710" "Ann01.hs" -- Needs GHC changes - -- , mkParserTest "failing" "CtorOp.hs" - -- mkParserTest "failing" "TensorTests.hs" - -- mkParserTest "failing" "List2.hs" + -- mkParserTest "failing" "CtorOp.hs" + -- mkParserTest "failing" "InfixOperator.hs" - -- mkParserTest "ghc710" "DroppedComma.hs" ] diff --git a/tests/Test/NoAnnotations.hs b/tests/Test/NoAnnotations.hs --- a/tests/Test/NoAnnotations.hs +++ b/tests/Test/NoAnnotations.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,7 +18,7 @@ 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.Pretty import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils @@ -201,7 +202,11 @@ bagVar :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList +#if __GLASGOW_HASKELL__ > 800 + nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElemsStable +#else nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems +#endif fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -696,8 +696,13 @@ [GHC.L li imp1,imp2] = GHC.hsmodImports p n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1")) n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) +#if __GLASGOW_HASKELL__ > 800 + v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1))) + v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2))) +#else v1 = GHC.L l1 (GHC.IEVar n1) v2 = GHC.L l2 (GHC.IEVar n2) +#endif impHiding = GHC.L l0 [v1,v2] imp1' = imp1 { GHC.ideclHiding = Just (True,impHiding)} p' = p { GHC.hsmodImports = [GHC.L li imp1',imp2]} @@ -722,8 +727,13 @@ Just (_,GHC.L lh ns) = GHC.ideclHiding imp1 n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1")) n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) +#if __GLASGOW_HASKELL__ > 800 + v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1))) + v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2))) +#else v1 = GHC.L l1 (GHC.IEVar n1) v2 = GHC.L l2 (GHC.IEVar n2) +#endif imp1' = imp1 { GHC.ideclHiding = Just (True,GHC.L lh (ns ++ [v1,v2]))} p' = p { GHC.hsmodImports = [GHC.L li imp1']} addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] diff --git a/tests/examples/ghc710/DiophantineVect.hs b/tests/examples/ghc710/DiophantineVect.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/DiophantineVect.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ParallelArrays #-} +{-# OPTIONS -fvectorise -XParallelListComp #-} +module DiophantineVect (solution3) where + +import Data.Array.Parallel +import Data.Array.Parallel.Prelude.Int as I + +import qualified Prelude as P + +solution3' + = let + pow x i = productP (replicateP i x) + primes = [: 2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73 :] + a `cutTo` b = sliceP 0 (lengthP b) a + sumpri xx = productP [: pow p x | p <- primes `cutTo` xx | x <- xx :] + distinct xx = productP [: x I.+ 1 | x <- xx :] + + series :: [:Int:] -> Int -> [:[:Int:]:] + series xs n + | n == 1 = [: [: 0 :] :] + | otherwise = [: [: x :] +:+ ps + | x <- xs + , ps <- series (I.enumFromToP 0 x) (n I.- 1) :] + + prob x y + = let xx = [: (sumpri m ,m) + | m <- series (I.enumFromToP 1 3) x + , distinct [: x I.* 2 | x <- m :] > y :] + i = minIndexP [: a | (a, b) <- xx :] + in xx !: i + in + prob 5 200 + +solution3 :: (Int, PArray Int) +{-# NOINLINE solution3 #-} +solution3 + = let (i, is) = solution3' + in + (i, toPArrayP is) + diff --git a/tests/examples/ghc710/ExplicitNamespaces.hs b/tests/examples/ghc710/ExplicitNamespaces.hs --- a/tests/examples/ghc710/ExplicitNamespaces.hs +++ b/tests/examples/ghc710/ExplicitNamespaces.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeOperators #-} diff --git a/tests/examples/ghc710/read018.hs b/tests/examples/ghc710/read018.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc710/read018.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DatatypeContexts #-} +-- !!! Checking that empty contexts are permitted. +module ShouldCompile where + +data () => Foo a = Foo a + +newtype () => Bar = Bar Int + +f :: () => Int -> Int +f = (+1) + + +class () => Fob a where + +instance () => Fob Int where +instance () => Fob Float + diff --git a/tests/examples/ghc80/MonadT.hs b/tests/examples/ghc80/MonadT.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/MonadT.hs @@ -0,0 +1,48 @@ +{-# OPTIONS -XRank2Types #-} + +module Control.Monatron.MonadT ( + MonadT(..), FMonadT(..), MMonadT(..), FComp(..), FunctorD(..), tmap, mtmap, + module Control.Monad +) where + +import Control.Monad + + +---------------------------------------------------------- +-- Class of monad transformers with +-- a lifting of first-order operations +---------------------------------------------------------- + +class MonadT t where + lift :: Monad m => m a -> t m a + treturn :: Monad m => a -> t m a + treturn = lift. return + tbind :: Monad m => t m a -> (a -> t m b) -> t m b + +newtype FunctorD f = FunctorD {fmapD :: forall a b . (a -> b) -> f a -> f b} + +functor :: Functor f => FunctorD f +functor = FunctorD fmap + +class MonadT t => FMonadT t where + tmap' :: FunctorD m -> FunctorD n -> (a -> b) -> (forall x. m x -> n x) -> t m a -> t n b + +tmap :: (FMonadT t, Functor m, Functor n) => (forall b. m b -> n b) -> t m a -> t n a +tmap = tmap' functor functor id + +mtmap :: FMonadT t => FunctorD f -> (a -> b) -> t f a -> t f b +mtmap fd f = tmap' fd fd f id + +class FMonadT t => MMonadT t where + flift :: Functor f => f a -> t f a --should coincide with lift! + monoidalT :: (Functor f, Functor g) => t f (t g a) -> t (FComp f g) a + +---------------------------------------- +-- Functor Composition +---------------------------------------- + +newtype (FComp f g) a = Comp {deComp :: (f (g a)) } + +instance (Functor f, Functor g) => Functor (FComp f g) where + fmap f (Comp fga) = Comp (fmap (fmap f) fga) + diff --git a/tests/examples/ghc80/Zwaluw.hs b/tests/examples/ghc80/Zwaluw.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc80/Zwaluw.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +module Web.Zwaluw ( + -- * Types + Router, (:-)(..), (<>), + + -- * Running routers + parse, unparse, + parse1, unparse1, + + -- * Constructing routers + -- | The @constrN@ functions are helper functions to lift constructors of + -- datatypes to routers. Their first argument is the constructor; their + -- second argument is a (partial) destructor. + constr0, constr1, constr2, + int, slash, lit + ) where + +import Prelude hiding ((.), id) +import Control.Monad +import Control.Category +import Control.Arrow (first) +import Data.Monoid + +infixr 8 <> +infixr 8 :- + +-- | Infix operator for 'mappend'. +(<>) :: Monoid m => m -> m -> m +(<>) = mappend + +data Router a b = Router + { ser :: b -> [(a, String)] + , prs :: String -> [(a -> b, String)] } + +data a :- b = a :- b deriving (Eq, Show) + +xmap :: (b -> a) -> (a -> b) -> Router r a -> Router r b +xmap f g (Router s p) = Router (s . f) ((fmap . liftM . first . fmap) g p) + +instance Category (Router) where + id = lit "" + Router sf pf . Router sg pg = Router + (\a -> do + (b, s) <- sf a + (c, s') <- sg b + return (c, s ++ s')) + (\s -> do + (f, s') <- pf s + (g, s'') <- pg s' + return (f . g, s'')) + +instance Monoid (Router a b) where + mempty = Router (const mzero) (const mzero) + Router sf pf `mappend` Router sg pg = Router + (\s -> sf s `mplus` sg s) + (\s -> pf s `mplus` pg s) + +parse :: Router () a -> String -> [a] +parse p = concatMap (\(a, s) -> if (s == "") then [a ()] else []) . prs p + +parse1 :: Router () (a :- ()) -> String -> [a] +parse1 p s = map (\(r :- ()) -> r) (parse p s) + +unparse :: Router () a -> a -> [String] +unparse p = map snd . ser p + +unparse1 :: Router () (a :- ()) -> a -> [String] +unparse1 p x = unparse p (x :- ()) + +maph :: (b -> a) -> (a -> b) -> Router i (a :- o) -> Router i (b :- o) +maph f g = xmap (\(h :- t) -> f h :- t) (\(h :- t) -> g h :- t) + +opt :: Eq a => a -> Router r (a :- r) -> Router r (a :- r) +opt a p = p <> push a + +nil :: Router r ([a] :- r) +nil = constr0 [] $ \x -> do [] <- x; Just () + +cons :: Router (a :- [a] :- r) ([a] :- r) +cons = constr2 (:) $ \x -> do a:as <- x; return (a, as) + +-- many :: Eq a => (forall r. Router r (a :- r)) -> Router r ([a] :- r) +-- many p = nil <> many1 p + +-- many1 :: Eq a => (forall r. Router r (a :- r)) -> Router r ([a] :- r) +-- many1 p = cons . p . many p + +satisfy :: (Char -> Bool) -> Router r (Char :- r) +satisfy p = Router + (\(c :- a) -> if (p c) then return (a, [c]) else mzero) + (\s -> case s of + [] -> mzero + (c:cs) -> if (p c) then return ((c :-), cs) else mzero) + +char :: Router r (Char :- r) +char = satisfy (const True) + +digitChar :: Router r (Char :- r) +digitChar = satisfy (\c -> c >= '0' && c <= '9') + +digit :: Router r (Int :- r) +digit = maph (head . show) (read . (:[])) digitChar + + +-- | Routes a constant string. +lit :: String -> Router r r +lit l = Router + (\b -> return (b, l)) + (\s -> let (s1, s2) = splitAt (length l) s in if s1 == l then return (id, s2) else mzero) + +-- | Routes a slash. +slash :: Router r r +slash = lit "/" + +-- | Routes any integer. +int :: Router r (Int :- r) +-- int = maph show read $ many1 digitChar +int = Router + (\(i :- a) -> return (a, show i)) + (\s -> let l = reads s in map (first (:-)) l) + + + +push :: Eq h => h -> Router r (h :- r) +push h = Router + (\(h' :- t) -> do guard (h == h'); return (t, "")) + (\s -> return ((h :-), s)) + +left :: Router (a :- r) (Either a b :- r) +left = constr1 Left $ \x -> do Left a <- x; return a + +right :: Router (b :- r) (Either a b :- r) +right = constr1 Right $ \x -> do Right b <- x; return b + +eitherP :: Router r (a :- r) -> Router r (b :- r) -> Router r (Either a b :- r) +eitherP l r = left . l <> right . r + +-- | For example: +-- +-- > nil :: Router r ([a] :- r) +-- > nil = constr0 [] $ \x -> do [] <- x; Just () +constr0 :: o -> (Maybe o -> Maybe ()) -> Router r (o :- r) +constr0 c d = Router + (\(a :- t) -> maybe mzero (\_ -> return (t, "")) (d (return a))) + (\s -> return ((c :-), s)) + +-- | For example: +-- +-- > left :: Router (a :- r) (Either a b :- r) +-- > left = constr1 Left $ \x -> do Left a <- x; return a +constr1 :: (a -> o) -> (Maybe o -> Maybe a) -> Router (a :- r) (o :- r) +constr1 c d = Router + (\(a :- t) -> maybe mzero (\a -> return (a :- t, "")) (d (return a))) + (\s -> return (\(a :- t) -> c a :- t, s)) + +-- | For example: +-- +-- > cons :: Router (a :- [a] :- r) ([a] :- r) +-- > cons = constr2 (:) $ \x -> do a:as <- x; return (a, as) +constr2 :: (a -> b -> o) -> (Maybe o -> Maybe (a, b)) -> + Router (a :- b :- r) (o :- r) +constr2 c d = Router + (\(a :- t) -> + maybe mzero (\(a, b) -> return (a :- b :- t, "")) (d (return a))) + (\s -> return (\(a :- b :- t) -> c a b :- t, s)) +